FORMAT (? ASMBL COM| FILEIO PASEMAIN SRC=EXTENS PASEXTENS LST EXTENS SRC EXTENS REL !"EXTENS COM.#$%&'(HOWTO RUN)*+HELLO PAS,LINK COM@-./01234LIB REL56789:;<=>?@ABCDLIB REL EFFIXED PAS~GHIJKLMNOPQRSTUVFIXCONSTPASWFIXTYPE PASXCLSOT SRCCMPCHK SRCCHKD SRCCVTSFP SRCDONE2 SRCDSKFIL SRC DYNALL SRC DIVD SRCDEFLT SRC ENTEXT SRCEXPFCT SRCERROR SRCEOFLN SRCURELOP SRC *+ÔP Z :!3 :!3 v!60! " !4* ~7-N#O O" !͖H!y|Error opening input file 0×1 "2!F#NO O! 6 #! 6  " ##" -(#/ʊ.,)* w#" !|File name too lon/-h(,/ʍ* w#6:-h(,/ʍ! -hp,/ʍ!6X !6!" -h/ʍ,*+"/-(_-W-O!~#( ~# ~( ###!|Bad slash optio{C(H(22/222/2 22/2" ^##w!A !K !_ !h|Disk erroError extending filDisk fulDirectory ful" 6# 6 #6#-(G-8:( jj:xA0"!wT] -8.(w#7!j.(!8*(,([(]( ?0:0!"*Nya8{0_ (# "!"*q:#6 7("*:7(+"~~O# ȱĉԍÉčÉ؉Ӡ͠ƠōǍԠſډƠӍ؉ȍ։¬͍؉ȉԠϠԠٍƱ։ÉſډӍȉ‰Šԍ։Ŭ͉Ӎ؉ȍ։Ĭ͍؉ȍ։ì͉ԍ؉ȍ։¬͍؉ȍȉȉŠŠҍljӠΠ̍։Ŭ͉Ԡō؉ȍ։Ĭ͍Ǎĉ‰ĠԍǍ։ͬĉō؉ȍ։ͬōЉȉԠҍЉ‰Ġҍ؉‰ԍ҉ƱԺӉԺӉҬƍԺFIXVAR PASYCALL SRCZ[CALL REL\CMAIN SRC]^_`abcdefghijklCMAIN SRCmnoEXAMPLE PASpqEXAMPLE COM rstuERADRV PASvRENERA1ASRCIwxyz{|}~RENERA1ARELRENDRV PASPEEK SRCPEEK RELCVTFLT SRCCHAIN SRCCONSOL SRChCOMHEXREL: o&T]))) w#6:/h/> ! 4* 6.#6S#6R#6C#" ~#. NO# O 6: 5 : = : 1  J9 $ J!~(: !" Z!3 ͖1! Z! ͖1! !"å *+D}ɯɯY!~#~6<(3$ ȲӍɉĬԍÉčÉ؉ӠԍȲɉĬԍĉĉӠΠŠō։Ŭ͉ԠĠˍ։ͬÉŠȠŠӍ؉ȍ։Ĭ͍։ͬ։čʼnĠƠοډΉԠԍԍغ̉ʼnԠ̠ōԉԉӠĠԠ΢ӉԧӠ̍Ԡ̠Ӯƺ̉҉ԠϠԠō؉ȍ؉ȍ؉ȍ؉ȍ։ì͉ҠӉҬƍԺӉҬƍԺӉԠҬƍԺӉ姬ҬƍԺӉ姬ҬƍԺӉҬƍԺӉҬƍԺӉ COM HEX LST REL ҬƍԺӉҬƍԺӉԺӉ+3>29͠v: : : : !":*:":ͥ!3 : !9N* * v222:2n: ͦ1 >2U:29͉!ͦ1>2U:͉!!="/:"1:"3:"5:!F:67*=*2:*2:*2:*2:"=::(F=2:*/:T*"/:::(3=2:*1:F*"1:::( =2:*3:F*"3:::( =2:*5:F*"5:3!F:5 >2U:29*=|( ͉!*5:5 1*9| :!!(* v:n:(1!9'6#!8:6!7:6 :! !8:6!7:6'!:(!":":Q,͜&##6#6ͥ>2U:292`::2n:2h:2i:*":N)<!(;6 #29;2L:2}:!":":!c<"-:6!-;"(:*:|(2D:!9;":'8((_ ( >2U:{ >2D: (x(*:s#":*:6!9;"j:*:|!r!8;6*:|(:}:m"*:*:| }Ĵ":9:!(-!c<"V:*V:~( #~#"V:͇!94*:#":!X:5!,;::(6+:L: :i: 29;::(6-:n:͉!:-; !9;~#( ( ( :,;+3?:h: :L: :,;-(,+((!(;+!::!:!:2:( > ^!=!9;%!:L:(-!(;O&!9;O&+3:9 :(:n: !(;+!!9;%!!:~6!:ă!: :2:::2::D:uGua,&)a, .::(]28:͵,27:*::(([:R0" :9 z(t*:":"::8:2:*:|Yn!*: ͝" :(ͅ" :(s"  .*:":*:{ozg":*:æ*: .{!:*:ͥ>{!:a:ãͥ>ͥ>!a:F6x!a:F6>!a:F6>n-Һ~ wͥ:b:V-w͋-jn-c- c- > w(n-c- c- > w02,:,8G:,:2:6Q~G:,:2,::b:w>2*:Å͞-æ .:9 ::!8:Y1*:*:0| } < }ͩ".}2:Q2G:ͥ>2F:*j:~'("_2E:#~( #~+-*/&i)‰i),;  !2g:{!!E:6!F:5 i)(+"j:!": !":>2F:2E: .5*::2g:{!!F:5:#:(:F:(!": !":#)*j:~G; #~; ͤ& x!(ͩ)(2K:xͤ&*j:~ *:"q:*j:~&i)Gͩ)x(! &i)2K:*:~! #~!( &*j:"j:*"j::]: (:: :K:(2:2]:$+::* ! :4+(-*9:'+( ::ͤ&*:~# ++~!i6*j:+"j:i! :5~2:i!":ͤ&*:^+V+}o|g":*9:^#V*:":i)( ; * 7" C" 2:2h: ?:2i: !96͊)2:͊)2:͊)2:n! ::(" -0ͅ)i)(*(';(#,(ͣ)OOi)((;( , 7"  O* ͖H0I" !:6 C  , U" *+ !":>=!:ͦ,͔+ *:͗,q#"Y::9:j:9Gʥ:a:ʥx͇x2;y2;:9!C:/<͇6;(O*  3å!;N#:9G#Ntå:929*  2[:͚G:[:͚O 80::!(;͇p#q#::͇p#q#:7:w*(:͇p#q#6 #"(:*(:z͇p#q#{͇p#q#:B:w#"(:G:9:x( |͉ *-:6#w#6"-::9: }||::(= ::Ø :!ͅ"7::9*:+":j"::8:2:*:":!96!9~6::::2:= !:Fw[:> ü :!o:6!:6! > !9~ ( > M[<{(> ͼ [<> ü !=/ > (:`:ͅ)( ; * i)ͩ)(i)( *$+::$ !:4!:4~!:w̓! = $:: !`:~/w/2:!B:6 :`:go = !:6!:̓!G!:̓!!`: 6x 6 Ϳ=ͅ)( * ; )  "i) ͩ)(*+(C:9()*:͗,= :8: ͦ,[:*:s#r!}:6*:":*:":*:":*:":!::8:ͦ,͔+i)( ; * )(.*$+ ,+(!*:͗, *:| [" & " ::80(i)(!:6::2a:::_!^#VYBbKf(08BKTgouafkz!2%+/8<Eb| y"  .$ *:":*:s#r::͗, Gͦ,::ʷ!":÷2}:*:| ͗"  .$ *:":!D:6 ,  .::8" 2:! :6*:":*:|ʷͣ"2 :÷ͥ:a:n!{! ,8wÝ~2*::b:w*͞-ú,Һ~0͋-ú͒-ú,82*:w,Gҷ:b:w!*:>Fw":b:w!*:6p:+:,0O"!*:w2+:ͥ:a:{!:*:{!:+:ã .5*ͥ:a:{!::ã,8wK:b:w!*:66 .5*::2,:ͥ:a:{!:*:{!:+:{!:,:ãͥ:a: .{!*::: *:{!{!n! n-8wò:b:w>!2*:ͥ:a:i):E: :G: =((*(:+++"(:P*-:+:g:w:~( :F: !N": !":|{! >>ͥ>2F: .*::: *:{!{!:#: !F:5 !": !":ͥ .*:*:":*:"::(:9 z(t÷!:4~!:w̓! .*:|·!:42`:÷::Z=" :2n:  .*:"e:!:6÷2}:*:| ͋" :9(>ͦ, ͗,(ʹ" *:":":*:s#r6+6͉&6#6#6#6#"9:6#6#6 ,((**9:'+(+" *9:~/2:͗+*j:~, , *9:+++V+^":"q:6! :4!":*9:n&":!B:6 ú*j:~ͩ)2:2K:2]:i8 (ʹ" ͦ,ͅ), i)C  ,*+(*:͗,Ĵ"c*:| " +":*9":###"9*=###"=͜&^#Vr+s##N#F#+ +T]+++x([:6#6#6>!:ͦ,͔+ͅ), i)'C  ,*ͅ), 7" !: C a,:a:28:͵,2B:27:!":ͅ)!#:6( ;(*(6͂,":àC a, ,(*ͅ), 7" !l:!9='+ !9~ " 2:4!9=͗+::* *C  ,*ͅ), 7" !:>.(#6 9!;>22X:2C:296:###"Y:!;"$:::2;͇::2;͇͇!;"$::[:!C:w*$::[:w#"$:*Y:p#!=/::= ^#V#::G> ~7͗,##=( ( ::2:!;=~ ^##))<^#V> :ͯ: : B[:::G>ͼ !:~(t >͡ t t !== ::G> ~7͗,N#F# ͜&#### ~2:#N#Fᰱ(:::9 [:z(> ͼ *S:":%,::*:|đ"!:6*S:":!o: !:6w!9=F!A=( !:6 !:6> 7N* 6!:t x !:w !:w t t x ͡ ͡ ͡ ::Gx x x :͏ xx x {͏ zÏ :~ ( #y2:!:~*6 !:6+!3 :: > ^!> ^!x O* O! y!29G:#:x7"*:#":~=w:U:(O:9(B! :~(3~B 2 :2933! :6!:+!!&+!*:#":i233!962U:29: :;>2U::: o&x o&O:(:9(:!=DM^#V #~# *==G*:|"*:^+V+}o|gp*:s+r* :#" :! :4~6*:+":*q:w#6"q:*:"q:~#"q:ͤ&*q:::?:)"=:)|2:}2:)|2:}2`:^#V#!"{:!=~͗,## ++6#6#*{:#"{:!>0)1*=0":*j:~(#"j:~ ( <>*j: .::(!2:::aͣ)$($%( .(#(_(08 :8 A8[8>ɯ$(%(.(#(_(ͣ)A8[80828088808:82\:08:8ͣ)A8G0> 2\:::2:##::::   !! ͇yHG!H! M ::ćyHG!H!::͵,O! !|>7{!*:":!:6 #|(a*l:"j: .*:|( (%".}2+:*j:~#(c-"j:Ϳ-*:|~c-}2b:*j:~#)(a"-"j:-Ϳ-*:|(!.}!a:ɯ2b:Ϳ-*:|(|~ }2b:7n-8͋-oh-c- .::( !":!::G xj-*j:~, #"l:U"!":*$+*j:~,>2#: >2#:#"j:::7j-*:0R|"": .::Y1::Y1>2:2:!":":!0":2#:2:::͵,2B:*j:~U";U"*U", #"j:U">2#:- !0-i)'ʗ/"ʗ/ */(~) "~*+(<*:͗,2: g"!:61 U!:~6 !:M:?":$+(-:: !0-!":i)(Y. **:DM*:!x0 L1*:| 1"*:}o|g8i`0L1*:*:}o|g0:: ::!":!:6Å"͔1>ȹ7!:p͔1ظ !:6(:9 7::7G::7O*9i2!g%P2*=i2!r%P2*:i2!%P2* :|(i2!%P2*{:i2!%P2*<}( i2!%P2*<}( i2!%P2*<}( i2!%P2!%P2!;=~^6 #6P2))<^#Vi2!%P2:+!:(:9(|DM>2H:2p:!2"V:>02:*V:^#V#"V:bk 8| DM!:4!p:::O0 ~(#6:9(:(:9(:n:(! !H:5 y0O:9(:(:9(:n:! ad arithmetic operatorBad argumentBad baseBad instructionBad labelBad numberBad symbolCan't backup in COM fileDisplacement too bigDummy redefinedDivision by 0Extra argumentExtra ELSEExtra ENDMACFile not foundToo many index registersMissing argumentMacro not definedMissing )MACRO symbolMultiple tagNot allowed in COM fileNo EQU labelNested INCLUDENo relocateNo MACRO labelNo expressionNo SET labelNo EXTOffset not zeroOut of rangeRedefinedSymbol not foundString too longSymbol t"2:ͺ(!:4*:^+V+"=:"?:͉&";:!"u:!"s:"w:i)(ʷ';ʷ'*ʷ'*j:+"j:*:| "÷'+":*u:#"u:*w:6#"y:*s:#"s:i)(7 #" G' G;(% (! (, *y:"w:N' *w:4*y:wm'*s:DM*u:*;:q#p#6#6#s#r!=##^#Vz r+s+V+^ ::2: &:: * d* d8(ɯ2:::j(*?:|ʂ(+"?:*=:~+"=: > /<2:͉&`i####::O=V(2:'## (^#~2:#":!:~ 2:'5*:~#":!:5(͉&`iN#F###^#V*:":!=##^#Vz'{_zw+s+V+^::o&)))m<*?:(*=:(::g::o(::g:`:os#r#::o&)))m<)":*j:~ͩ)~ͣ)i)ͩ)i)!=!f3":^#V#"&:!":":*:*&:|g}o"c:*:Oz)+)))##*:!: #":~#2:~2:)*c:0":"&:!=":*:|"+":*&:+*:N#Fyoxg#)))*:+~+ngDM+V+^{_zWs#r#^#V+!x(:w#++":*:^#Vr+s*j:~),(U"i):9͜&####[:~2::8:w#~2:::w#~2:::w!<6#6###:8:o&))<[:s#r#~#~r+s:8:!o))<^#V~#y2:O~!w#(((8( ((>?> >'>">*>#>+ɯ2b:2+:*j:"l:~(($Ϳ-*::"::8:2:Ϳ"!:6!/*:::> ::͵,2B:*j:~ (;, #"j:d.*:":!":!:~2:6*j:~#"j:+!0(-!0(*!0(/!1(& !91":>.! .!:6Oi)( i)x/!":"/*:Teo":zG!:6*j:~( ͩ)  #~.(F+~ * = ~ͣ)D(2.(.B(4O(:Q(6H(<"!":::G:A:_*j:"j:/30#0 *=00)G00*Q00*x2:y2A:2\:2020202020*j:*:Ͱ0)0!\:6o|g 00T])))))))!:~::w*:":Ͳ0g1Y1*:*:":x1Y1*:*:{ozgL1*:|/g}/oL1 *  *  ! :4 ! ! :9 :(:9( :(:9(:  ɇ$ A 8ABS 5ACI ADC ADD ADI ANA ANI B BIT @BSET C CALL CC CCD CCDR CCI CCIR CM CMA /CMC ?CMP CNC CNV CNZ COM 6CP CPE CPI CPO CV CZ D DAA 'DAD DADC JDADX DADY DATA 5DB DBS DBZ !DCR  DCX DI DJNZ DS #DSBC BDW "E EI ELSE %END ENDIF &ENDM +ENDMAC+ENTRY 2EQU EXAF EXT 3EXX H HLT vIF $IM0 FIM1 VIM2 ^IN INCLUD1IND INDR INI INIR INP @INR  INX IX ~IY ~JC JM JMP JMPR JNC JNV JNZ JP JPE JPO JR JRC 8JRNC 0JRNZ JRZ (JSW )JV JZ L (LBCD KLDA :LDAI WLDAR _LDAX LDD LDDR LDED [LDI LDIR LEAP LHLD *LIBFIL7LIST (LIXD *LIYD *LOAD SDED SSET SHLD "SIXD "SIYD "SLAR SP 0SPHL SPIX SPIY SRAR (SRLR 8SSPD sSTA 2STAI GSTAR OSTAX  STC 7SUB SUI VER 0X ~XCHG XRA XRI XTHL XTIX XTIY Y ~ ƠҬîîĉÉРҮЉȍԍΠ半򮍊κɉĬέ򮍊؉čɉ؉ĉ򮍊ЉΉ宍؉ȉРŠҮɉͬ҉ĠŠҠȠҮÉҠӠ̮Ԡ٠ΠҮډԲ+6+6+6:Wz2>G!:6 #=6!:9;:>G;= = =)>:#> G>w#O:(:9(:><2>=!&:(:9(|!&6 #6P#6a6 # :(:9()>:><2>G>=0 8 :Gy0(w#p#ȉȍĉÉԠŠɠȠҮ։̍ɉƦǠƠſÍډԲProgram Fileio; { this routine demonstrates how to use the Pascal/Z } { file conventions. This is not a complete program, just } { some demonstration declarations and statements } type numbers = file of real; var english: text; data: numbers; i,j: integer; datum: real; datum2: real; line: array[ 1..80 ] of char; begin reset( 'data.dat', data ); read( data:i, datum ); { get the ith datum } datum := datum + 3.14159; write( data:j, datum ); Pascal/Z run-time support interface . ; COPYRIGHT 1978 BY JEFF MOSKOW ; ; This is a collection of macros for use in constructing ; external modules from Pascal routines ; NAME EXTERN EXT FLTERR,HPERR,REFERR,STKERR,RNGERR,DIVERR,MLTERR EXT PERROR,STMTMSG,CRLF,STRERR EXT ILODV,ILODV1,ILODV2,ILOD1,ILOD11,ILOD12,ILOD2,ILOD21,ILOD22 EXT ISTOR,ISTOR1,ISTOR2,XADDR,YADDR,FSUB,FADD,ENTRSC,ENTER,EXITF EXT FPEQ,SEQUL,FPNEQ,SNE,FPLTE,SLE,ILE,FPLT,SLT,ILT EXT FPGTE,SGE,IGE,FPGT,SGT,IGT,FMULT,IMULLSPD {LXI M 0MACRO *MLIST -MOV @ MTLIST/MVI NAME 4NEG DNLIST 'NMLIST,NMTLIS.NOP NOT ORA ORG ORI OUT OUTD OUTDR OUTI OUTIR OUTP AP 0PCHL PCIX PCIY POP PROG 5PSW 0PUSH RAL RAR RC REL 5RES RET RETI MRETN ERLA RLAR RLC RLCR RLD oRM RNC RNV RNZ RP RPE RPO RRA RRAR RRC RRCR RRD gRST RV RZ S 0SBB SBCD CSBI ɉĬέ؉ĉ宍ԉ؍ԍȠ̠ϠԠӠŠҠΠàΠŠԍŠΠΠŠɠҮƠŠҠӠ̍ΠӠȠ٠ԮŠԠӠҮŠ̍ҠӠԠϠŠǠƠŠҠȠōΠӠĮȠ̠ϠԠӠàϠōǠƠŠҮԺȉȍɉȬƍĉÉԠϠǠƠҮĉ̉ԠŠ; { new jth datum } rewrite( 'data.dat', data ); { create a new file } for i := 1 to 40 do write( data, i - 3.14159 ); reset( 'book.txt', english ); while not eof( english ) do begin readln( english, line ); { correct for spelling errors and write to new file } end; end. ta.dat', data ); read( data:i, datum ); { get the ith datum } datum := datum + 3.14159; write( data:j, datum )T,QMULT,IDIVD,IMOD EXT ERROR,CSTS,CI,CO,CHKDE,CHKHL,PSTAT,CONSET,UNION,INN,LTEQ EXT GTEQ,INSECT,ORGAN,COMP,FUSS,FOUT,FXDCVT,CVTFLT,TOUT,TXTYP EXT FDIVD,STREQL,STRNQL,STRLEQ,STRLSS,STRGEQ,STRGRT,LAST EXT WRITELN,L109,L110,L111,L112,L115,L116,L117,L118,L120 EXT READLN,L121,L122,L123,L124,L125,L126,L127,L128,L129 EXT WRITE,L130,L131,L132,L133,L134,L135,L136,L0 EXT READ,L137,L98 EXT ABS EXT FPABS EXT SQR EXT FPSQR EXT EOLN EXT EOF EXT RESET EXT REWRITE EXT FTXTIN EXT CHAIN EXT NEW EXT MARK EXT RELEASE EXT TRUNC EXT ROUND EXT ARCTAN EXT COS EXT EXPFCT EXT LN EXT SQRT EXT SIN R: SET 0FFFFH C: SET 0FFFFH M: SET 0FFFFH A: SET 00000H S: SET 0FFFFH D: SET 0FFFFH E: SET 00000H F: SET 0FFFFH T: SET 00000H VALID: SET 00000H CR EQU 13 LF EQU 10 EOFMRK EQU 1AH BUFLEN EQU 80 MARGIN EQU 50 COMPILER EQU 0H MAXDRV EQU 16 CPM EQU 5 FINI: MACRO ENDMAC EXTR: macro intn,extn extn: equ intn entry extn,intn endmac EXTD: MACRO INTN,EXTN EXT EXTN INT ELSE MLOAD ILOD1,OFST ENDIF ENDIF ENDMAC ISTR: MACRO Q,SIZE,OFST MLOAD ISTOR,OFST IF R JC REFERR ENDIF ENDMAC LPOP: MACRO REG,DISTANCE IF DISTANCE PUSH H LXI H,DISTANCE+2 DAD S MOV E,M INX H MOV D,M PUSH D MOV D,H MOV E,L DCX H DCX H LXI B,DISTANCE LDDR POP D POP H POP B ELSE POP D ENDIF ENDMAC ADDR: MACRO Q TEMP SET 'Q'-'IY' IF 'Q'-'Y'*TEMP CALL XADDR ELSE CALL YADDR ENDIF ENDMAC MIDL: MACRO REG,LEVEL PUSH X MVI A,LEVEL MIDLER ENDIF ELSE Error Main programs may not be externals JC STKERR ENDIF ENDMAC EXIT: MACRO Q,SSIZ LXI H,SSIZ+8 JMP EXITF ENDMAC EQUL: MACRO Q,SIZE1,SIZE2 IF 'Q'-'S' IF SIZE1 IF SIZE1&8000H CALL FPEQ ELSE LXI B,SIZE1 CALL SEQUL ENDIF ENDIF ELSE LXI B,SIZE1*256+SIZE2 CALL STREQL ENDIF ENDMAC NEQL: MACRO Q,SIZE1,SIZE2 IF 'Q'-'S' IF SIZE1 IF SIZE1&8000H CALL FPNEQ ELSE LXI B,SIZE1 CALL SNE ENDIF ENDIF ELSE LXI B,SIZE1*256+SIZE2 CALL STRNQL ELSE LXI B,SIZE1 CALL SGE ENDIF ELSE CALL IGE ENDIF ELSE LXI B,SIZE1*256+SIZE2 CALL STRGEQ ENDIF ENDMAC GRET: MACRO Q,SIZE1,SIZE2 IF 'Q'-'S' IF SIZE1 IF SIZE1&8000H CALL FPGT ELSE LXI B,SIZE1 CALL SGT ENDIF ELSE CALL IGT ENDIF ELSE LXI B,SIZE1*256+SIZE2 CALL STRGRT ENDIF ENDMAC FDVD: MACRO Q,SIZE CALL FDIVD IF F JC DIVERR ENDIF ENDMAC MULT: MACRO Q,SIZE IF 0!SIZE&8000H CALL FMULT IF F JC MLTERR ENDIF ELSE IF M CALL IMULT ECPI 'C'&3FH JZ ERROR MVI C,7 CALL CO XRA A ENDIF ENDMAC RCHK: MACRO REG,LBND,HBND IF R LXI B,LBND IF 'REG'-'H' IF 'REG'-'S' PUSH H LXI H,HBND CALL CHKDE POP H ELSE MVI A,LBND CMP M JC STRERR XRA A ENDIF ELSE PUSH D LXI D,HBND CALL CHKHL POP D ENDIF ENDIF ENDMAC STMT: MACRO Q,NUMBER IF T+E VALID SET 0FFFFH EXX LXI B,NUMBER IF T IF 'M'-'Q' CALL PSTAT ENDIF ENDIF EXX ELSE IF VALID EXX MOV B,A MOV C,A EXX VALID SET 00000H N: equ EXTN ENDMAC SPSH: MACRO Q,SIZE IF SIZE IF SIZE&8000H LXI H,SIZE DAD S SPHL ELSE MVI A,SIZE CMP M JC STRERR MOV B,A INR B PSHLP: SET $ MOV D,M PUSH D INX S DCX H DJNZ PSHLP XRA A ENDIF ENDIF ENDMAC MLOAD: MACRO WHERE,VALUE IF VALUE IF VALUE&0FF00H LXI B,VALUE CALL WHERE!2 ELSE MVI C,VALUE CALL WHERE!1 ENDIF ELSE CALL WHERE ENDIF ENDMAC ILOD: MACRO Q,SIZE,OFST IF SIZE&8000H MLOAD ILODV,OFST ELSE IF SIZE-1 MLOAD ILOD2,OFST 1: SET $ MOV C,4(X) MOV B,5(X) PUSH B POP X CMP 1(X) JRNZ MIDL1 XRA A ENDMAC DSUB: MACRO Q,SIZE IF 0!SIZE&8000H CALL FSUB IF F JC FLTERR ENDIF ELSE XRA A DSBC Q D ENDIF ENDMAC DADD MACRO Q,SIZE IF 0!SIZE&8000H CALL FADD IF F JC FLTERR ENDIF ELSE IF 'Q'-'C' DAD Q D ELSE IF M&A XRA A DADC H JV MLTERR ELSE DAD H ENDIF ENDIF ENDIF ENDMAC ENTR: MACRO Q,LVL,VSIZ IF LVL-1 MVI B,LVL LXI D,1-VSIZ IF S CALL ENTRSC ELSE CALL ENT ENDIF ENDMAC LE: MACRO Q,SIZE1,SIZE2 IF 'Q'-'S' IF SIZE1 IF SIZE1&8000H CALL FPLTE ELSE LXI B,SIZE1 CALL SLE ENDIF ELSE CALL ILE ENDIF ELSE LXI B,SIZE1*256+SIZE2 CALL STRLEQ ENDIF ENDMAC LESS: MACRO Q,SIZE1,SIZE2 IF 'Q'-'S' IF SIZE1 IF SIZE1&8000H CALL FPLT ELSE LXI B,SIZE1 CALL SLT ENDIF ELSE CALL ILT ENDIF ELSE LXI B,SIZE1*256+SIZE2 CALL STRLSS ENDIF ENDMAC GE: MACRO Q,SIZE1,SIZE2 IF 'Q'-'S' IF SIZE1 IF SIZE1&8000H CALL FPGTE LSE CALL QMULT ENDIF ENDIF ENDMAC DIVD: MACRO CALL IDIVD IF M&D JC DIVERR ENDIF ENDMAC MMOD: MACRO CALL IMOD IF M JC DIVERR ENDIF ENDMAC NEGT: MACRO REG IF 'REG'-'H' IF 'REG'-'D' POP H POP D MVI A,80H XRA E MOV E,A PUSH D PUSH H ELSE MOV A,E CMA MOV E,A MOV A,REG CMA MOV REG,A INX REG ENDIF ELSE MOV A,L CMA MOV L,A MOV A,REG CMA MOV REG,A INX REG ENDIF XRA A ENDMAC CTRL: MACRO IF C CALL CSTS JRZ $+16 CALL CI ENDIF ENDIF ENDMAC GLBP MACRO Q,OFFSET,SIZE PUSH Y POP B DAD B MOV B,M DCX H MOV L,M MOV H,B LXI B,OFFSET DAD B IF SIZE-1 MOV B,M DCX H MOV L,M MOV H,B ELSE MOV L,M MOV H,A ENDIF ENDMAC CSET: MACRO Q,OFF1,OFF2 IF OFF1 LXI H,OFF1 CALL CONSET ELSE LXI H,-OFF2 DAD S SPHL MVI B,OFF2 CSETCL SET $ MOV M,A INX H DJNZ CSETCL ENDIF ENDMAC UNIN: MACRO Q,OFFSET,OFF1 LXI H,OFF1 LXI D,OFFSET CALL UNION ENDMAC MEMB: MACRO Q,OFFSET,OFF2 LXI D,OFF2 LXI H,OFFSET CALL INN ENDMAC INCL: MACRO Q,OFFSET,OFF1 LXI H,OFF1 LXI D,OFFSET CALL LTEQ ENDMAC SBST: MACRO Q,OFFSET,OFF1 LXI H,OFF1 LXI D,OFFSET CALL GTEQ ENDMAC INTR: MACRO Q,OFFSET,OFF1 LXI H,OFF1 LXI D,OFFSET CALL INSECT ENDMAC DIFF: MACRO Q,OFFSET,OFF1 LXI H,OFF1 LXI D,OFFSET CALL ORGAN ENDMAC MTCH: MACRO Q,OFFSET,OFF1 LXI H,OFF1 LXI D,OFFSET CALL COMP ENDMAC NOMT: MACRO Q,OFFSET,OFF1 LXI H,OFF1 LXI D,OFFSET CALL FUSS ENDMAC xcfp: m call cvtflt endif else lxi h,value call cvtflt endif endmac dsb1 macro reg xra a dsbc reg d endmac cmpi macro q,value cpi value endmac svln: macro mov a,m exx mov e,a xra a exx dcx h endmac gtln: macro reg,size exx mov a,e exx mov c,a xra a mov b,a lxi h,size dsub b dad s mvi m,cr endmac ; ; Pascal routines to become external modules ; (remember to include the ENTRY statements so that the linker can ; find your module) ; program extens; { this program does not demonstractte file I/O since that is } { demonstrated in the fileio routine } const tabtop = 52; tabtopp1 = tabtop+1; { notice expression of constants } { use this type to show i/o of enumeration types } type color = ( red, yellow, blue, green, orange, violet ); anstyp = string 20; var a,b: color; answer: anstyp; procedure systemok; external; { external routine to check the system } begin systemok; { verify the system EXTENS Page 1 1 program extens; 1 { this program does not demonstractte file I/O since that is } 1 { demonstrated in the fileio routine } 1 1 const tabtop = 52; 1 tabtopp1 = tabtop+1; { notice expression of constants } 1 { use this type to show i/o of enumeration types } 1 1 type color = ( red, yellow, blue, green, orange, violet ); 1 anstyp = string 20 orange: writeln( 'orange is made from yellow and red' ); 8 violet: writeln( 'violet is made from blue and red' ); 9 else: writeln( 'green is made from blue and yellow' ); 10 end; 10 write( 'Again? ' ); 11 readln( answer ); 12 until answer = 'NO'; 13 end. acro pop d pop h pop b xthl push d push h push b endmac cvtf: macro where,value if 'A'-'where' if 'B'-'where' if 'C'-'where' if 'D'-'where' if 'H'-'where' if value-4 mov a,l pop b pop d pop h mov h,a push h push d push b xra a call fout lxi h,13 dad s push h call fxdcvt else call fout endif else call cvtflt endif else xchg call cvtflt endif else pop b pop d pop h push d push b call cvtflt xcfp endif else pop h acro q,value cpi value endmac svln: macro mov a,m exx mov e,a xra a exx dcx h endmac gtln: macro reg,size exx mov a,e exx mov c,a xra a mov b,a lxi h,size dsub b dad s mvi m,cr endmac ; ; Pascal routines to become external modules ; (remember to include the ENTRY statements so that the linker can ; find your module) ; } repeat write( 'Enter a color (red, yellow, blue, green, orange, violet): ' ); readln( a ); { show a case statement with an else clause } case a of red, yellow, blue: writeln( a:1, ' is a primary color' ); orange: writeln( 'orange is made from yellow and red' ); violet: writeln( 'violet is made from blue and red' ); else: writeln( 'green is made from blue and yellow' ); end; write( 'Again? ' ); readln( answer ); until answer = 'NO'; end. ; 1 1 var a,b: color; 1 answer: anstyp; 1 1 procedure systemok; external; { external routine to check the system } 1 1 begin 1 systemok; { verify the system } 2 repeat 3 write( 'Enter a color (red, yellow, blue, green, orange, violet): ' ); 4 readln( a ); 5 { show a case statement with an else clause } 5 case a of 6 red, yellow, blue: writeln( a:1, ' is a primary color' ); 7 L151 DB "RED " DB "YELLOW " DB "BLUE " DB "GREEN " DB "ORANGE " DB "VIOLET " EXTD L158,SYSTEMOK L99 ENTR D,1,23 STMT D,1 CALL L158 STMT M,1 STMT D,2 L160 STMT D,3 JR L168 L167 DB ' :)teloiv ,egnaro ,neerg ,eulb ,wolley ,der( roloc a retnE',58 L168 LXI H,769 PUSH H LXI B,58 PUSH B LXI H,-58 DADD S SPHL XCHG LXI H,L167+0 LXI B,58 LDIR LXI B,62 CALL L111 STMT M,3 STMT D,4 PUSH IY LXI H,1024 PUSH H LXI H,L151+0 PUSH H LXI D,L225 XRA A STMT D,7 JR L239 L238 DB 'der dna wolley morf edam si egnaro',34 L239 LXI H,769 PUSH H LXI B,34 PUSH B LXI H,-34 DADD S SPHL XCHG LXI H,L238+0 LXI B,34 LDIR LXI B,38 CALL L109 STMT M,7 JMP L184 L224 CMPI D,5 JNZ L240 L241 XRA A STMT D,8 JR L255 L254 DB 'der dna eulb morf edam si teloiv',32 L255 LXI H,769 PUSH H LXI B,32 PUSH B LXI H,-32 DADD S SPHL XCHG LXI H,L254+0 LXI B,32 LDIR LXI B,36 CALL L109 STMT M,8 JMP LXI D,1812 PUSH D LXI B,1 CALL L110 STMT M,11 STMT D,12 CTRL LXI H,-21 DADD S SPHL XCHG PUSH IY POP H LXI B,-22 DADD B LXI B,21 LDIR JR L290 L289 DB 'ON',2 L290 LXI H,-3 DADD S SPHL XCHG LXI H,L289+0 LXI B,3 LDIR EQUL S,21,3 JNC L160 STMT D,13 FINI PRSd4H I1DIVERRTTU%(5a=URMLTERRTԠe$TdU%(I9IJSTKERRUTe5E$U%(CHAIN$5$h(DIVERRddDU%(HPERRdUHPMLTERReU%$(REFERRe$tU%(STKERRe5DD88STRERR,(T B6E@`EJ \ qA#;PFdh|hê!xFVuD50!0pCyq 70 0 Co1 f 0t9Mqo 9 l6 Gf2@p9LfnNG#{Ȓn2Oy@v0QtgrNC)t2CId2 GrwNál< c)l7gC 7#1 Et2L㢁l6O"! 2M!r3 C @s4 S)"@nPˬCr@" ` ^IA@ 7(b_/!``8ڰ ێrEb(D(j@ mfs4Uf 9|߮WBj0'Bruk0v 04iWEHi14@jjq:I`8b`s=&&8bbcn&P{jH);ꪑ 95 PUSH D LXI B,2 CALL L110 STMT M,4 STMT D,5 MOV H,A MOV L,0(IY) MOV A,L CMPI D,0 JRZ L185 CMPI D,1 JRZ L185 CMPI D,2 JNZ L183 L185 XRA A STMT D,6 LXI H,1025 PUSH H MOV H,A MOV L,0(IY) MOV H,L PUSH H INX S LXI H,L151+0 PUSH H JR L223 L222 DB 'roloc yramirp a si ',19 L223 LXI H,769 PUSH H LXI B,19 PUSH B LXI H,-19 DADD S SPHL XCHG LXI H,L222+0 LXI B,19 LDIR LXI B,28 CALL L109 STMT M,6 JMP L184 L183 CMPI D,4 JNZ L224 L184 L240 L257 XRA A STMT D,9 JR L265 L264 DB 'wolley dna eulb morf edam si neerg',34 L265 LXI H,769 PUSH H LXI B,34 PUSH B LXI H,-34 DADD S SPHL XCHG LXI H,L264+0 LXI B,34 LDIR LXI B,38 CALL L109 STMT M,9 L256 XRA A L184 STMT D,10 JR L274 L273 DB ' ?niagA',7 L274 LXI H,769 PUSH H LXI B,7 PUSH B LXI H,-7 DADD S SPHL XCHG LXI H,L273+0 LXI B,7 LDIR LXI B,11 CALL L111 STMT M,10 STMT D,11 PUSH IY POP H DCX H DCX H PUSH H倌l7Nq@p7MAe9n2NFca EA@ Ha< R(@ DR)8@ Dq $a ]O! 99{ګ` 0;'C)i;S9r7)g Sa@,;͆)@,2NBl7t7GB 3ruktv#4~D #CI\(n_@%_&4W@ G)n\1 &r#ycNFipD3H&!ܠ!v/XB`j3@ U ^ !aa 6Faa6fn0! Q y9|4";V0Kt$ a\`%x`Bd2Cq@e: BifLhi y @nPˬCa"` B@*+*+w!Z*w##w!( F##N# #^^#V!{!! !!! !!!XÙString too lonCall by reference precision erroIndex or value out of rangAttempted divide by zerMultiply overfloStack overflo -- statementFloating point overflow/underflo RED YELLOW BLUE GREEN ORANGE VIOLET !9!Z!9ZRc͋; :)teloiv ,egnaro ,neerg ,eulb ,wolley ,der( roloc a retnE:!:!9!z:>7 !!. gn}( (<!gn#ͺ<ͺ8$|#$| 1.ʙ-ʙ > կN¥T]F(###g8;g86+++ (ˆ#w+> ###g8(G+++ˆ ˎ#Np+y ++Nwy+!uRead beyond EO!PY9G!ݾ Afn( ~^(VfnůP^ ѯݾ¨z() ,F̔T  r+sFfn#8(|(0n({($8 $w+6 +$T( F( (fnpG$E ,#OG #8x8s(@$ (] (Y or in number, try again 9$ (-(+$$3$0:$3@.(7e(;E(708:8> ͵ DM#4 fnr+s+p+q@ H $3@-(+ $394 ~+.(:e(DE(@ (85ͦ #~0! 6+w+w+w+w ͯ Ͷ 66=O~- O+ +~0 G+~ (0 WxGxA(DG~ݦo (Gͦ  DG͔ !9͵ ͵ ! !  !  4 4 Ͷ 4P!9w !  ~ݮ w~<ݖ !7Z F e ###goͺ  ͒ ͒#Z F e ˆ###kgoͺ !9 PY FfnV go3| }~^(Vfn>Pf(zȯF+?̸ y Fng)))V^Ny (#͒( ͒F~+++N͒+G ͒++ݾ~p8 AO͒G ͒TRUEFALSEF~+++N ( +N͒y(G++G ͒V^!9 z(6-+goGRw+O'RRdR~+^#~ FNgi#9A N#+ ##`i###̓^(?"!5~< #5 #5'"x(  S_xDM!=()8 )0 0)+} E˸$}($0##0""L$q#s#r!(F!#6!*!!4 #4 #4!!%p g 6++w+(˞6# 6 #6#(8#AG0> :(*55*+Fx8 !X7w 8(.(w#e3!.roloc yramirp a si !!9!  †#der dna wolley morf edam si egnaro"!"!9!D"& !der dna eulb morf edam si teloiv ! !9! $ #wolley dna eulb morf edam si neerg"!"!9!"&  ?niagA!!9! 7 ++ (ʙ!9 ON!9!n͌xä 2-()$  8 07ɯ!9YX8FG+8  8 > >>(U (Q (M#(1_(-$(){8 [8:8a8A8 0WzW>( ($3 $fn~!9 G_~((BW>__{(+#ܯ>(#> + ٯgk9~fnw OfnF+ #88$ ( ( xOw+G #qF 6(!XfnqG6fnp+qG!D$ (- + $:0%08!͓{@:000⯸x/Gy/Oɯ e!X !T]jjZj_ZfnV^#ڥ###g++Fwx+0w+z  z F!uType error on inpuErr w !9w#+! +8 +#͢ +/8!-! w#!9~r r !9w >ݮ w !9w !(@! r ~( !  ~( !~ݖ (GO 8yr ! r yG(!4 +~"! 4 +~"!4 +~"! 4 +~"!  ͕ r ! r  ͯ ѯݾ !9#ɯ#ɯw~(4+ 6v +/5 5ɯݾ T! 9 REZG #~-   60 +A~8 ( W ͒ N͒++++!9ѯɯR0 >0w+ G fnN++͞| z /  X>+++######\8^ͨ++++ˎ˞˦30 ###+++go30 | }!uToo many open output file!uBad output file nam#}( ##|#(}#70!9G AN#+ #͓ }r+sPYO>xĿ0#fn##|###!Xd !,X/ R0 *H (#a8{0_ +++f###%(6XNAy%4`f!###̓"!5~< #5~< #5'"! 6!'!44~0#4 #4!!4 #4 #4! 6!!%66)~6<(3̓' " ^##w! ! ! !uDisk erroError in extending filDisk fulDirectory fulBad filename *^#~ 84 #6*6O  # *6#~P( 4^q5 #7~O#%~#? P~̓   76<+w_##~ >Y̓j%6#6̓x$^̓|R?|7R|7R?|Rb$ɯ7 HOW TO RUN PASCAL/Z To run the Pascal/Z compiler make sure that PAS2 is on the currently logged-in drive and type: PASCAL . where, is the file name of the text file with the extension .PAS is the letter naming the drive that the e Pascal listing should go. The currently logged-in drive is the default. A space in place of an option letter specifies the default. EXAMPLES A>PASCAL PRIMES This will compile the text file PRIMES.PAS on drive A. PRIMES.LST (the program listing) and PRIMES.SRC (the Z-80 macro-code) will be sent to drive A. B>PASCAL PRIMES.ABC L) is reached. (If there is a compilation error in the last group of lines then an 'E' is printed instead.) The compiler may be stopped at any time by typing CTRL-C. After compilation, a Pascal/Z program must be assembled and linked before it may be run. To run the assembler type: A> ASMBL ./opts where opts is either COM, REL or HEX to produce the appropriate file type. To run the lProgram Hello; {$i+ } { this program is to welcome a new Pascal/Z user } var i: 1..10; begin for i := 1 to 10 do writeln; writeln( 'Welcome to the land of Pascal/Z', chr( 7 ) ); writeln( 'Don''t forget to look at the file ''INFO.NEW''' ); writeln( 'to find out the latest and greatest about' ); writeln( 'Pascal/Z' ); for i := 1 to 10 do writeln; end. ~/w#~/+~w+ #~wɯ(#~+*^W#~!O:'8(: (:$8(:8'ڹ  * *ڹ !584 ' 'ڹ :!8 : (:$8( : (:$8(:  wA 8ABS 5ACI Y̓j%6#6̓x$^̓|R?|7R|7R?|Rb$ɯ7 source file is on. The currently logged-in drive is the default. is the letter naming the drive to which the Z-80 macro-code generated by the compiler should be sent. The currently logged-in drive is the default. is the letter naming the drive to which th This will compile the text file PRIMES.PAS on drive A. PRIMES.SRC will be sent to drive B, and PRIMES.LST will be sent to drive C. B>PASCAL PRIMES. A This will compile the text file PRIMES.PAS on drive B (the default). PRIMES.SRC will be sent to drive A. The listing file will be sent to drive B (the default). While compiling, the Pascal/Z compiler prints a '-' every time ten lines are compiled or a page boundary (a CTRL-inker type: A> LINK /N: .... .... /opts where is the name of the COM file to be generated and ..... are the names of the files to be linked together. opts are the options /E (exit) or /G (exit and execute). For a more detailed description of thhow to run these programs see the Pascal, ASMBL and LINK manuals shipped with your Pascal/Z compiler. 1k!rͨ͜<^ͮ0!b!6GH!K^͋(8ͤ0!=688@8:=( 8::8:ī8: : : 9*6*"rq0t 9q09:Ħ9ͷ:{!(̓ 9o:!( !K!":\!!*DM!lxʂÀ^!"!6͋(8ͤ0!=688@8:=(:& 8o 8:: : 8:& !r6H!ld!6# x !6!"!"![!:\(*~"L"N""P""R" ! 6ͺ"s+r+ s+=N*̈́0 !$.318 =2!j~#O !=7(O_ _#!~6(#O!#"͋(!ZH*~a8{0 8#"*+"*͋/ ͋L7(O ?!ɷ"!=͋(8A6/(6,(6$(.(:(08*:8A8"[0w#͋8(6!7ͤ6!67 !6#͋(8,(/(y00!7ͤ> 2:(:\/(!2{22!:( 22{!:( 2!*:\(!~(6!:2͋(6A 'C /D 7P G!]:2'ͷ 82  CS!:2  7!u:'ͷ 82  x(CS!H:2  *p"!: (*N"[p"N*L"[p"L:  K[!r+s+p+qͭ!:*5 :[!+5!:[p*!R!*[p"pY:'ͱ( Ͳ!:s8: T*[~R:\ l" *p"[p"[p"Kw:' !"@ !:!7:ĵ!::l(*R" [p"R*L" [p"L* "*p|(,!:* 5 :[p+5!::(*P"["P*LA :(Y\ Q .: !uÙ*60å !6Ϳ:m(:o :r Ϳ:m *:o(<:r0s 0kf !}~!~6:[2|:T2!"!u~7 #y# o&))N#F#^#V!~8 ![4_kb))!uɷ7N!lͼ6!}:n!}:oØ!}:rH*H͕H:tGu3:s[p{3z3:!uN#f0!372m ͕2nl2o(ͨCp͆2r8( 0Ȗ++^+V r#s*Sf^+Vr#s++++^+Vr#sfѷR[ s+r+[ps+r*^+V#RSSfa^##~+7*++++++~ͣ( ^+Vͳs+r~~w+y!* * `i:s!* =*=*u~+^K:*S++^+V*~(B *T]B*S++|^~"ͱ(BK^+VSw*:\( [~R8#*R8 R8l^q#Vpz Ͳ!f++++N+F+x^+V+N+F+^#V r+s Aux blocks Bad address Bad commr+s+r+6+s+r+s+r+s+r+6+s+r+s+r+s+r+!l:\!gl!"!"*+!V*:!C*:!@*:!:`!*++++++~(^+V:!II !6^~(,*P!I!((!Ó!(~6!d P~+OP++:|?}Y JPK P :(!ͼ!6 #6 #60(G!~ >04>82!7:nG*#"+*R8S*R0S:\( [~R8'*R8 R8lp!!O* 8*(*[p}z|zͱ"["L*|!:*5 :[+5!:G:sG[p(*|( !7 x[p"2=!6:] !7: ͍*Dl!Oͼ x d͍*">:F *[R8AR8|(3E}: *5 "!l[~R: ~#: yD: P : *5 P !d|: }OY zF {!Oͼ> F > Wc zS 80_:& !7Ϳ:m !37:o :r ":͜ !Uu!m6!o6>2r :(!!Ͳ! : !\ !Ϳ!?2l2sͨCpy02t!u6 #!u͕w#=!~ *P2|!65!|&>Cf'Gfl'Gfl''Gl͆''''G͕͆O͕G*++++"^+V#"!"[*|g}o"*Oz+)))##*R!u #^+V>*0""^~u +>"~^+V+Bz **^##^+VSS++++"O!u~#![*~+foR)))#*#~#ngDM#V#~_zWs+r+^+VR#!x(+w[p+s+r*^+Vr#sfV+"and character is a bad EXT chain Bad file name Bad input file Bad option Code below lowest address Can't findCan't open output file Code overwrites tables Common section Data section Entry point symbol redefined Error writing file Generate a HEX file Generate a COM file Generate a symbol table Hi =Load mode Lo =LIB Librarian mode LINK version 1m Module name isNo COM file in offset mode No GO in offset mode No output file Name too long OK?Offset Program section SaveStarting address redefined Second common larger Start =Start Program Too many commons Undefined common Undefined REL entry 0 HEXMAP.REL COMSYM2!""*+a{Y!~#~6<(3$ " TDU0LENGTHUS@%9b: L19Q";2USrN'"\ XV^°i+uW͠#$0n! j]jH e'#6>ܭP@i| "xV <@X p6~H6_ CE¯p`Df8hOӸB0"3l0nZ!7AB 0f|"*))m**J4d))")N e5E$UMQIFSTRGRTT`e5E$58MQI9E2:TS#MQIF:$ԕ#MQI1F:6 MQI9E2kͧ`di(v6?"`$ͧ`i0 %^r-+T "ru\ Հ]m+@ @`ͬ-+D!~?/[u_XۮW @p!`dD"$")FA2*rf$#FIb2 "$d8"$"FJ@r2b*e,( )cb2*d#(&*Fg@*2r*S4480L136S`M =N: Ḷ0:S@@`Ef ӻB_.  ڰ!jf *!~?/[uXL j@!..\8\-pvá`ru\ ՀPV4i] 9|ۮW@jBd]w+U6HۮW @ppWxoWۧW_r@ $;V">9Z@` ^##w!/ !9 !M !VDisk erroError extending filDisk fulDirectory ful"ͼ 6# 6 #6#*(G*8:( yy:xA0"!wT] *8.(w#7!y.(!8*(,([(]( ?0:0~O#!"*Nya8_ (# ">P !!"*q>ݕ#6 7("*}7(+"~P _d`+ CKH@W64 0 hGPZ,t 8T D3XMEIR: LcMEIRkr^hg7\rn\.\8\"ru\ Ձr@a˭pAHvۮW @pp_r@ $;VXr@/% B_.  ڰ3ܮVhҲ`"ru\XV 9u\ u@j˭p_/Hv 0r]` ڸpD/n\ @ 9|ۮW@j6 9|ۮW@j6 9ۮW @pp_r@/$;Vru\XVhڲ`˭pA`K;W]m+@ @`!~?/[uX3o`j@`˭p @ppX0j_rEbXvK@D%DlerYk/n\"X;V ڲګ""VZڭ@"ru\XVm~mX sܭVmmX 9|ۮW@jh[VB]m+ ]` ڸp[J_r@ $;V/\ 9u\, u@j˭pAHv 0r@ % B 00"h0]m+@ @`!2B.;Ͷ -h!..\8\,:IȩʊJhq*f(,ɪ` `ɩJSV dUd5H0:V#0k^/h!~?/[uXKtj@!.Å!~?/[u` ڰf ӓɺsxH}[uXv.<-+\sźfy3@XV^qYJЀ7F h#Dð tnEr4i^@ W/Zru\ Ճ4mrn\ Å!~?/[u` ڰn-3f K-rjij@`˭p_K;W]m+@ @`! J+TB@V]m+@ @`͡-$!0,!~?/[u_X3h jY`rjO`\j_V6(ۮW ;W]m+V+@j@`˭p_K;WUnV]m+@ @`@.V66]m+@ @`ͥ-`!."ͧ`-|!~?/[u` ڰf0Vr͵ 7=ۦgÕbD%DrY^D 0r@ % B 0̘CVTFLTdDdU%(0ENTRSCUDh̰ FADDTdDdHFLTERRdTHpFPEQTe5(( FSUBDHL118ӀDU%(ȐRNGERRTSd$5D0:TS0j\^h;w]m+@ @`g7\W@gB_. B_.|  ڰ[uXv.0# 9QIM2XQVU/12QU#055U1R2#$A1R3nPՕ deD5eHFXDCVTA#7N$٠tnn03[BRӛB ^m !/764C.QWJMӠuA ͩ± sfE#WN?@-+V+D!`^qYJڀۦB@0E7?ۦ`\ͳ *7?ۦ`FWn0T 6}D f7?ۦ`D f *?@+V+D ^qYNLsV+/6Հۥ땺fM{#+'7 h¡ -tlnJۦ]^~9D R![t n iHFWnQ ͵`ErqT n0"3nJۦ!}?ٴ ^ gm@P@n7/7$;Ls":ғfM{#+FWJL*gnp֯vm0%n+ݥ!`gn6gnp֯vm0%n+ݥ!\{ L+gn6gnp֯vm0%n+ݥ!\{L*Dgnp֯vm0%n+ݥ!bêvjiI3[BRLs":ғfM{#+nۦ]^~+ݥ&m3Mt3M0WJB1fM{#+Kϳa&ȩʊJhqJi(豟PJi)V(nL!}?ٵl.n+ܢpW/8ܬڲһFvn-p!^) h·Mtn1]^[Wtl\XV3M\rY(STS D#0ROUNDUS0: L#I=U9:.US +@7Z -h>zQ2B9:e{,ғȈFADDe$tU%)Օ d5eDdHCVTFLT̀Z!`{TfW(ͺ~X+u +@p\-{2P% 9=I6pQSTdDFLTIN5\9u  >_@+fP ģ000f?M*Vi0f@eQ@0áÐ| zܬMpDcA n s+9p@K, j!, fljiZ(?b6=FaLeX!*)(FL2*ʄfX(*Fb"bzٴ<`e`d0qk8ͮ #S68Ⰳqf0PPPPa@0 u@ fp03^GpYEd?2uCmW+uʯ'm,psWEfháLF h P b/ R=o,;0.f`$ c`ںEuzuEq!r(+"65F`9Hw^eP&7>ܭ!$/PWp*nG|2/Pna|]5x@*99|\- 3K$Bbr#_- ^aVG(3@m:D a `Wܭ0nH[~[V`qw %͢@c;6LFoPn n0` AqXaW@B3o8@5U,ͥc60^G.Kt d*אFmbpV7?.yͶ@nV7?^Gd\f0P D0 `lF aBfGh0t05ph9^O*hk#6k0 |@ Œ][MNi-:A|,v-W+tnҳ^~ٴ kb16 dcV0236zY  pCgé"öC 2FnMЊr9BI@i7A`r< &s EFOA*ʢJtep !M*z4e"'FO**zd&*$Fwbzz\e(")'FBrbz\e@))")FU򚢒j2fszRdZ,Zt 02*RSUS'QTTe5(0:QT0jhXV+U#! 5U1RpQUS TdTHFMULT0Z.n_V([Zw7O;/u u ӸDB_-(n[7* ;[!4.+U-+Ep h@ `$  a0B_-Xa#1=92`QT+5A2U-`I=QI%pQРDdDHFSUBDdDHFADD1De5T) zZVg-~\"h F%+[@ ~Le,(")FQ@2zb*4d-"!QTTeU%(FPERR+ۯ_@u!/rwLd(#&*")NUD4UMNGTEQT`T$tCOMPDeU580GTEQDDUORGAN3@X`͠ Z\ n]c]jK6jeqVuWY +Xl \ *ȡh_.K6 SAVREGUӠd44UH %9:INSECTUSSӣ =9MR:S@%9M R:bUSSӦ`hZ,vݥ& ER;,F~0H C͖#Nzh~uXl pG/Z9r",r j*8TU U5DHPSTAT9D 8\@ K&@6A@m,@ X!WAx1R>,02l$` I12UT$QaQeBp T4DX !-!2:Pc !-!2jD@ :rhHJ8JmptT26Qc"@ %12@TQSѓ4Th=1:FTXTIN L D#0:XSѣ=1::rS0:X Lc 0jr樨 _| `dF~YTDa 3H@`xʤ s 0x#H, >IV|ڐh*[2nQSc&5QIU28UQLc( Q%:2U'SU D0WRITEԒUS#,*,NQSTdDFLTIN5\9u  >_@+fP ģ000f?M*Vi0f@eQ@0áÐ| zܬMpDcA n s+9p@K, j!, fljiZ(?b6=FaLeX!*)(FL2*ʄfX(*Fb"bzz\Օє D5eD YQ2CVTSFPD5eDCVTLd5eE4e Dڡur]c+un O("p#?5X26YVw uqA,ftl7F7ahpy<d+Eg?M*G@Q0mW)bsC$s,(;Hv$St( ج\>C   ћ  jQ oI*Q 8QSdeEDTAQQ::S@AQQ:jt!-WX@j e@\4[@n.L@ cȉ*Ȇ1 8U TdDdH%Y:QU#%Yk\h^Vպ~Xrn]j!(n p)w7Ou, uQ"eX)|!}/* ;[ڬQDuA`H+ Àx{aFf v ErEkvhB3@B Z ` h# B(rnPe;JȦQ q b@˕uۧp`WpP`0h^Vպ~Xrn]j!@!7OX(Ud^fYR@!e  ڸa, ~@ nG@9/QͰ` P'eH‐" @f` !#GU^xB ng6A`rg6A˭,?fp, a COMPOPTDS(FPERRTDHROTRIGeU$4QӑLTDS(DONE2B ~YrU1~[ 9|PFNORMTԓ`Td$5AMPSUBTd$MPADDT5T)!L `UP04 an[(F+wi #" S8Z/Xf(K6!Xl pG/Zkh*HUS TTHE5U1R:<RSUS#E5U1RjJg!4BYX=!Tesм{l|Ϣx^W^wXzxD"[oea2>0P uMNQaհWғ&2STTTU D#(IMR: LIMRj~Yl^#`hb6h8 3@U4PX+W"X Xeg^錔T%DhCLSOTddOPNINE44QTԠTU%$( 0:QTԣ 0jP<,Xe o~/p#~ϋQF!iiꑐ 0:\ LLc]I%Q:ԒUS&M+67\0p 3j-##9mm #nZ/[f땺F.m\eb1p¯ AͶtB7G-I@KHv 7XVYX@~\94  >/Vbtnp Y \,[YpYfaC0=, ʎf\`+2YX ,(a~?۠X%np )[`t HPeCyH Àa@ !86mqw E#?A+na@4p # @}H6' nl譺+ ڭ~@|`X1"(s  f O @>,HE#I2+tn [tVa8 b 3mAW(m+n @zO)@6 mVY/?V tBG-˕YPn^g7ݥ ;xD 'f ͬA X 6YDm-b@n``\'@p J6D8ʹMXApEm[tV˭dGiH` % |0@7N#\ u]m0 nIVqm`<K1yä Y+g@!j1;b6UW@8 `4XlΈBYTOT$4ERRTMFeD((PUSHBDπe$$4SCANe$$4RBLOCKڀ@0\18YeaAfb1"']`4 p]`4 [ "]`4123e$Uu$IDF#@V+, iF#f V+̴s-O2[f`F#fXd\/+of0%|Ϡ'녒! 0o7 q@o8Myp:cI\!Lyp:cI 7MXCLSOTdDTUDX(MOVNAMTHPERRORE44SV ddM ::TSՓScM :j@ |_7 z+' _sFr+/+^7d@!*8%A'3@XAi V +r /GLe #$' A2jze0$FP"zSV TTDU(9QIMEXITFTTDU(ENTRSCTUDiHV(qZ/ݐlVDdinʤ :.PņFF*ʢzd('$"!F@@2B$PU T$ĴH eQ=RDERRSQT 1-=R:PU#1IJ:SQT,#F zB-efe\Ff82PE3@ "!F#jrDˬf@ 8D-Q"pe 3@ V#22(j`!ѢYP#AF4cFTB FTB]`4 hAh@"F ŇBB"d60if(DN hrVh.PuL(YP@ pK`dF#; 0D1 :1 Q?1 ZaCI 2Fr7px:MCI 3MR!kam?.pQ- n8^#p6?VQ_ b0#:@A=A! 2T#0@M1M.pӔ $4 >CSTS$4COD55E9@4٠Pݔ:͠ 4 am,L(F#$A=A! 2:T'S`T=A9=R:BSS=A9=Rj 3@<\- d?\- f"%FfPX8 FD""*d('$"!FH2B$d)")ђS dDTUDXA=A! PUSHBDS 1Q:NAUM! :S@ l4 pDxf@s6=Y @l 녺pX,Ej[W6XW+UɜTSW/Gy2&s{,*4F{twiHp,` eYaXXyWpi ^,͠ 9RWYɜUQe4e$TxSAVREG0\R(F#n˭8SS D#h0L128PT4UxI1N: L0:: L#5I.:ӑU㣠I1NjJlC.VD+9YʽRm ˕9 ll[,ȐHPERRTT4 =5A=BZERCHKTc  =5@:T#iI !.:"Tf 0/cN3>!0^U`e$DDI=QQJROTLEFQ㡠I=QQ2:UI=Q1:Q ?Ⰳ P 3 p]`4 [V+l~X84!0M3@ "!F #B1.pi4A&hb,<`CgLF#YlexDD gq"\(eb)үCk@x |D&@&)uBX *T^7v'S+Ґ|U>HRd#%^7d\!ʽ8ԑS U4UT MSGT`54H M9:TTUS# M:# M1:$# M9kBͣ` mY,ͩ`K62Y~n[09n\-Ktnݪ9J7 EbwKtqZ,֯t\A-+ nO+@-^<"ku tF\\A-+ nO+B-^<"ha8U TDdH%5=:RQU#@%5=k|U=Yg@/+,(s#WB=*Ǖ.uiI^\}0Y3DLOOK+ׂ +dE@`EX B4Y3 DeUARFPGTE TeDXA9F:8TcAR:QcA1R:*Qc`A9Fk<ͥ` `Fͥ`(`8ͥ``*ͥ``ͥ``ͥ`0`>2땺!tnG[7OV`:~V ܀#O7rp "tntn@a+,(A0`nRSTTC%1=ILOD12RS dC#%1=ILODVS`dEc(%MQ=JISTOR1TԌUDE(eJ:RS c %1=:S L%1=: S c %1=:@RS %1=X:DS@%MQ=J:fTԌc%MQ=H:VQ@eJjO#[V$+'8A&;$Gb\IVNpH³qO#[V$+' Cm^sV땂 # ³="dݥ&땢dݥ'땢dT D5HLASTN ܀#O7rp "tntn@a+,(A0`nRSTTC%1=ILOD12RS dC#%1=ILODVS`dEc(%MQ=JISTOR1TԌUDE(eJ:RS c %1=:S L%1=: S c %1=:@RS %1=(****************************************************************) (* *) (* Ithaca InterSystems' Pascal/Z Fixed-Point Package *) (* *) (* Written by Robert Bedichek August 1980 *) (* *) (****************************************************************) procedure setlength( var y: string0; x: integer ); external; function length( x: string255 ): integer; external; (* The next two external functions are in LIB.REL and are automatically *) (* linked in when theror' is set if there was *) (* an overflow. *) (* *) (* *) (* *) (************************************************************************) var carry: 0..1; i: integer; res: fixed; begin carry := 0; if a.sign = b.sign then (* Like signs, just add *) begin add.sign := a.sign; for i := 1 to bytes do add.digits[ i ] := addbyte( carry, a.digits[ i ], b.digits[ i ] ); fixederror := (carry = 1) end else (* Unlike sign i := 1 to bytes do res.digits[ i ] := subbyte( carry, 0, res.digits[ i ]) end; add := res end end; function sub( minuend, subtrahend: fixed ): fixed; (************************************************************************) (* The value of this function is the signed difference of the two *) (* value parameters. The global variable 'fixederror' is set if the *) (* is an overflow. *) (* *) (* *) (* *) (***************************************gns are like then we *) (* determine which is greater by subtracting and loking at the sign *) (* of the result. If the signs are unlike we return true if the first *) (* operand is positive, otherwise we return false. This is faster *) (* and it avoids the problem of arithmetic overflow. *) (************************************************************************) begin if a.sign = b.sign then begin a := sub( a, b ); greater := ( a.sign = plus ) end else i library is being linked in. They add and *) (* subtract two decimal digits packed into a byte using Z-80 decimal *) (* arithmetic. *) function addbyte( var carry: carrytyp; a, b: byte ):byte; external; function subbyte( var carry: carrytyp; a, b: byte ):byte; external; function add( a, b: fixed ): fixed; (************************************************************************) (* The value of this function is the signed sum of the two value *) (* parameters. The global variable 'fixeders, subract negative op from pos. *) begin fixederror := false; if a.sign = plus then for i := 1 to bytes do res.digits[ i ] := subbyte(carry, a.digits[ i ], b.digits[ i ]) else for i := 1 to bytes do res.digits[ i ] := subbyte(carry, b.digits[ i ], a.digits[ i ]); if carry = 0 then res.sign := plus else begin res.sign := minus; carry := 0; (* Take nines complement of the result by subtracting it from zero. *) for*********************************) begin (* Just reverse the sign of the subtrahend and add. *) if subtrahend.sign = plus then subtrahend.sign := minus else subtrahend.sign := plus; sub := add( minuend, subtrahend ) end; function greater( a,b: fixed ): boolean; (************************************************************************) (* This returns true if the first operand is greater than or equal to *) (* the second operand. *) (* Otherwise it returns false. If the sif a.sign = plus then greater := true else greater := false end; procedure shiftleft( var a: fixed ); (************************************************************************) (* This procedure shifts all of the packed decimal digits in the *) (* passed parameter left one position. A zero is shifted into the *) (* least significant position. The digit shifted out is lost. *) (* *) (* *) (* *) (************************************************************************) var i: integer; next: byte; begin for i := bytes downto 1 do begin if i > 1 then next := (a.digits[ i - 1 ] div 16) else next := 0; a.digits[ i ] := ((a.digits[ i ] * 16) + next) mod 256 end end; (* shiftleft *) procedure shiftright( var a: fixed ); (************************************************************************) (* This procedure shifts all of the packed decimal digits in the passed *) (* parameter right one position. A zero is shifted in************************************************************************) (* This function returns the product of the two passed value parameters.*) (* *) (* *) (* *) (* NOTE: the i is left out of multiplicand to make it unique in the *) (* first eight characters. *) (************************************************************************) const double = bytes * 2; var i, j, k: integer; next: byte; (* Used for shifting 'multpl' left *) multpl, (* Work array igits[ i ]; for i := bytes + 1 to double do multpl[ i ] := 0; for i := 1 to left + right do begin for j := 1 to (multiplier.digits[ 1 ] mod 16) do for k := 1 to double do result[ k ] := addbyte( carry, result[ k ], multpl[ k ] ); shiftright( multiplier ); (* Shift the double-size array 'multpl' left one position *) for j := double downto 1 do begin if j > 1 then next := (multpl[ j - 1 ] div 16) else next := 0; multpl[ j ] := ((multpl[ j ] * 16) +above the ones that we just moved *) (* into the function array then we have an overflow. *) for i := bytes + (right div 2) + 1 to double do if result[ i ] > 0 then fixederror := true end; (* mult *) function divd( dividend, divisor: fixed ): fixed; (************************************************************************) (* The value of this function is the quotient of the first paramter *) (* by the second. If the divisor is zero the function will return *) (* a zero and the 'fixederr.sign then divd.sign := plus else divd.sign := minus; dividend.sign := plus; divisor.sign := plus; result.sign := plus; (* Shift the divisor left until the most significant digit of the number is in the most significant nibble of the variable 'divisor'. *) shiftcount := 0; while (divisor.digits[ bytes ] div 16) = 0 do begin shiftleft( divisor ); shiftcount := shiftcount + 1 end; (* Do the same thing to the dividend that we did to the divito the most *) (* significant position. The digits shifted out is lost. *) (* *) (* *) (* *) (************************************************************************) var i: integer; next: byte; begin for i := 1 to bytes do begin if i < bytes then next := (a.digits[ i + 1 ] mod 16) * 16 else next := 0; a.digits[ i ] := (a.digits[ i ] div 16) + next end end; (* shiftright *) function mult( multiplier, multplicand: fixed): fixed; (for the multiplicand *) result: array[ 1..double ] of byte; carry: carrytyp; begin carry := 0; (* Result is positive if operands have like signs, otherwise negative. *) if multiplier.sign = multplicand.sign then mult.sign := plus else mult.sign := minus; for i := 1 to double do result[ i ] := 0; (* Put the multiplicand into the double-sized work array 'multpl'. *) (* And extend it in 'multpl' by filling it with zeros. *) for i := 1 to bytes do multpl[ i ] := multplicand.d next) mod 256 end end; (* Shift 'result' right one digit if 'right' is odd. *) if odd( right ) then for i := 1 to double do begin if i < double then next := (result[ i + 1 ] mod 16) * 16 else next := 0; result[ i ] := (result[ i ] div 16) + next end; (* Put the result in the return value and shift it while doing it. *) for i := 1 to bytes do mult.digits[ i ] := result[ i + (right div 2) ]; fixederror := false; (* If there are any non-zero digits ror' flag will be set. *) (* *) (* *) (* *) (************************************************************************) var zero: boolean; (* Gets set true if the divisor is zero *) i, j, shiftcount: integer; result: fixed; shift: integer; begin for i := 1 to bytes do result.digits[ i ] := 0; zero := true; for i := 1 to bytes do zero := zero and (divisor.digits[ i ] = 0); fixederror := zero; if not zero then begin if dividend.sign = divisosor. Shiftcount's value is the relative position of the divisor and the dividend. That is, shiftcount is the number of places that the divisor was shifted left minus the number of places the dividend was shifted left. *) while (dividend.digits[ bytes ] div 16) = 0 do begin shiftleft( dividend ); shiftcount := shiftcount - 1 end; for i := 1 to left + right do begin shiftleft( result ); (* Keep subtracting the divisor from the dividend until the dividend goes negative. *) repeat dividend := sub( dividend, divisor ); result.digits[ 1 ] := result.digits[ 1 ] + 1 until dividend.sign = minus; (* Add the divisor back to the dividend to make it positive again. *) dividend := add( dividend, divisor ); result.digits[ 1 ] := result.digits[ 1 ] - 1; shiftright( divisor ) end; (* Now that we've finished the divide, we must shift the result left or right to compensate for the preshifting of the divisor and the divide a real one. *) (* *) (* *) (* *) (* *) (* *) (************************************************************************) var multiplier: real; i: integer; result: real; begin fixederror := false; result := 0; multiplier := 1; for i := 1 to right - 1 do multiplier := multiplier / 10; for i := 1 to left + right do begin shiftright( a ); result := result + multiplier * (a.digits[ 1 ] mod 16); multiplier := multibegin fixederror := false; if a >= 0 then result.sign := plus else begin result.sign := minus; a := abs( a ) end; for i := 1 to bytes do result.digits[ i ] := 0; multiplier := 1; for i := 1 to left - 1 do multiplier := multiplier * 10; for i := 1 to left + right do begin if (result.digits[ bytes ] div 16) > 0 then fixederror := true; shiftleft( result ); result.digits[ 1 ] := result.digits[ 1 ]+(trunc( a/multiplier ) mod 10); (* *) (* *) (************************************************************************) var i, j: byte; result: fixstr; begin if trailing > right then trailing := right; (* Make the 'result' string have 'maxchars' spaces *) setlength( result, 0 ); for i := 1 to maxchars do append( result, ' ' ); result[ maxchars - right ] := '.'; (* Put the digits to the right of the dp into the string *) for i := maxchars downto maxchars - (right - 1) do begin right - 1) - i) mod 3) = 0) and (i < (maxchars - right - 1)) and (mode >= wcomma) then begin result[ j ] := ','; j := j - 1 end; result[ j ] := chr((a.digits[ 1 ] mod 16) + ord('0')); j := j - 1; shiftright( a ) end; (* Suppress leading zeros if mode is anything other than 'none' *) j := j + 1; if mode > none then while ((result[ j ] = '0') or (result[ j ] = ',')) and (j < maxchars - right - 1) do begin result[ nd that we did. *) shift := shiftcount - left + 1; if shift > 0 then for i := 1 to shift do begin if ((result.digits[ bytes ] div 16) > 0) then fixederror := true; shiftleft( result ) end else for i := -1 downto shift do shiftright( result ) end; divd.digits := result.digits end; (* divd *) function fixtoreal( a: fixed): real; (************************************************************************) (* This function converts a fixed point number toplier * 10 end; if a.sign = minus then result := -1 * result; fixtoreal := result end; (* fixtoreal *) function realtofix( a: real ): fixed; (************************************************************************) (* This function converts a real number to a fixed point number. *) (* *) (* *) (* *) (* *) (* *) (************************************************************************) var i: integer; multiplier: real; result: fixed; multiplier := multiplier / 10 end; realtofix := result end; (* realtofix *) function fixtostr( a: fixed; mode: modetyp; trailing: byte ): fixstr; (************************************************************************) (* This function returns a formatted string. The 'mode' parameter *) (* specifies which formatting operation is to take place. The *) (* 'trailing' parameter specifies the maximum number of digits to the *) (* right of the decimal point that are to appear. *) result[ i ] := chr((a.digits[ 1 ] mod 16) + ord('0')); shiftright( a ) end; (* Leave 'trailing' digits to the right of the decimal point *) for i := maxchars downto (maxchars - (right - trailing)) + 1 do result[ i ] := ' '; (* Put the digits to the left of the dp into the string *) j := maxchars - right - 1; for i := maxchars - right - 1 downto maxchars - left - right do begin (* Put a comma between every third digit if 'mode' tells us to *) if ((((maxchars - j ] := ' '; j := j + 1 end; (* Put a dollar sign in front of the most significant digit if *) (* 'mode' is 'wdollar' or 'wboth' *) j := j - 1; if (mode = wdollar) or (mode = wboth) then begin result[ j ] := '$'; j := j - 1 end; (* If the number being converted is negative put a minus sign in *) (* front of the dollar sign or (if there is no dollar sign) the most *) (* most significant digit. *) if a.sign = minus then result[ j ] := '-'; (* If we are supposed to suppress leading and trailing zeros *) (* (mode = supltzer), suppress the trailing ones here. *) if mode = supltzer then begin j := maxchars - ( right - trailing ); while result[ j ] = '0' do begin result[ j ] := ' '; j := j - 1 end end; fixtostr := result end; (* fixtostr *) function strtofix( a: fixstr ): fixed; (************************************************************************) (* This converts the passed string to fixed point. Al for i := 1 to length( a ) do if a[ i ] = '.' then righthalf := true else if a[ i ] = '-' then result.sign := minus else if (rightcount < right) and (a[ i ] <= '9') and (a[ i ] >= '0') then begin shiftleft( result ); result.digits[1] := result.digits[1] + ord(a[i]) - ord('0'); if righthalf then rightcount := rightcount + 1 end; for i := rightcount to right - 1 do shiftleft( result ); strtofix := result end; (* strtofix *) const left = 5; (* Number of digits to the left of the dp *) right = 5; (* " " " " " right " " " *) (* Number of bytes it takes to represent a fixed-point number *) bytes = (left + right + 1) div 2; (* Length of a fixed-point converted string *) maxchars = ((left * 4) div 3) + right + 3; LIB REL EFFIXED PAS~GHIJKLMNOPQRSTUVFIXCONST$$$type (* The next two types are neccessary for 'length' and 'setlength' *) string255 = string 255; string0 = string 0; signtyp = (plus, minus); carrytyp = 0..1; (* The basic unit of a fixed-point number -- takes 1 byte of storage *) byte = 0..255; modetyp = (none, suplzer, supltzer, wdollar, wcomma, wboth); (* This is the type around which this whole package is based. *) fixed = record sign: signtyp; digits: array[1..bytes] of byte end; (* This is a string type wvar (* This is set by the fixed point functions. It is set true if there *) (* was an overflow *) fixederror: boolean; (* This the carry flag. It is used by the fixed point functions. The *) (* user's code doesn't play with it. *) carry: carrytyp; l characters *) (* other than the minus sign (-), decimal point(.), and the decimal *) (* digits (0123456789) are skipped over and ignored. *) (* *) (* *) (* *) (************************************************************************) var rightcount, i: byte; righthalf: boolean; (* True when scanning digits to right of dp *) result: fixed; begin righthalf := false; rightcount := 0; for i := 1 to bytes do result.digits[ i ] := 0; result.sign := plus; ( result ); result.digits[1] := result.digits[1] + ord(a[i]) - ord('0'); if righthalf then rightcount := rightcount + 1 end; for i := rightcount to right - 1 do shiftleft( result ); strtofix := result end; (* strtofix *) hich can hold a fixed point number converted *) (* to ASCII. *) fixstr = string maxchars;  = 0..255; modetyp = (none, suplzer, supltzer, wdollar, wcomma, wboth); (* This is the type around which this whole package is based. *) fixed = record sign: signtyp; digits: array[1..bytes] of byte end; (* This is a string type w; General Purpose External Program Interface for Pascal/z ; Written by Robert Bedichek 1980 ; This is an external procedure for use with the Pascal/z compiler ; version 3.0 and newer. This procedure loads up most of the Z-80 ; registers and transfers control to a specified address. Control ; returns when the external program executes a return instruction. ; The registers are 'unloaded' and returned to the calling Pascal/z ; program. The first parameter is passed by reference. It is a record ; e registers for calling procedure. push h push ix push iy exx exaf push psw push h push d push b exx push d pop ix ; IX now has the go address. push b pop iy push iy ; Push the return address for the routine that we are calling onto the stack. lxi h,RetAddr push h ; Load the registers from the record pointed to by iy. mov a,0(iy) mov b,-1(iy) mov c,-2(iy) mov d,-3(iy) mov e,-4(iy) mov h,-5(iy) mov l,-6(iy) pcix ; Cross your toes and hold your breath.S D4CALL8Z,+urAW+Uj\,W +~sV~K7>w?N9?_7~_Ll\- 8; Pascal/Z run-time support interface ; COPYRIGHT 1978, 1979, 1980 BY JEFF MOSKOW ;MACROS USED BY THE COMPILER, ERROR STATEMENTS, AND START ROUTINE ; NAME MAIN ENTRY FLTERR,HPERR,REFERR,STKERR,RNGERR,DIVERR,MLTERR,L98 ENTRY PERROR,STMTMSG,CRLF,CHAIN$,STRERR,MAXOUT,MXOUT,MXOUT1,STRMSG EXT ILODV,ILODV1,ILODV2,ILOD1,ILOD11,ILOD12,ILOD2,ILOD21,ILOD22 EXT ISTOR,ISTOR1,ISTOR2,XADDR,YADDR,FSUB,FADD,ENTRSC,ENTER,EXITF EXT FPEQ,SEQUL,FPNEQ,SNE,FPLTE,SLE,ILE,FPLT,SLT,ILT EXT FPGTE,SGE,IGE,FTXTIN,CHAIN,NEW,MARK,RELEASE,TRUNC,ROUND,ARCTAN,COS EXT EXPFCT,LN,SQRT,SIN ; ; PASCAL RUN-TIME SUPPORT LIBRARY ; ; 2/15/79 ; ; INITIALIZE SOME RUN-TIME PARAMETERS TO THEIR CORRECT DEFAULT VALUES ; R: SET 0FFFFH ;DEFAULT FOR RANGE CHECKING IS YES C: SET 0FFFFH ; " " CTRL-C " " " M: SET 0FFFFH ; " " MATH " " " S: SET 0FFFFH ; " " STACK " " " D: SET 0FFFFH ; " " DIVIDE " " " E: SET 00000H ; " " EXTENDED ERROR MESSAcontaining the Z-80 registers: ; type registers = record ; a: 0..255; ; bc, de, hl: integer ; end; ; The second parameter is the address to which control is transfered after ; the registers are loaded. ; The Pascal external procedure delaration is: ; procedure call( var x: registers; start: integer ); external; name call entry call call pop h ; Return address for this procedure. pop d ; Go address. pop b ; Points to record containing register values. ; Save th RetAddr pop iy ; Alright, put 'em back. mov 0(iy),a mov -1(iy),b mov -2(iy),c mov -3(iy),d mov -4(iy),e mov -5(iy),h mov -6(iy),l ; restore the register that procedures above this one need. pop b pop d pop h pop psw exaf exx pop iy pop ix xra a ret PGT,SGT,IGT,FMULT,IMULT,QMULT,IDIVD,IMOD EXT ERROR,CSTS,CI,CO,CHKDE,CHKHL,PSTAT,CONSET,UNION,INN,LTEQ EXT GTEQ,INSECT,ORGAN,COMP,FUSS,FOUT,FXDCVT,CVTFLT,TOUT,TXTYP EXT FDIVD,STREQL,STRNQL,STRLEQ,STRLSS,STRGEQ,STRGRT,LAST ; ; ; PASCAL INSTRINSIC ROUTINE ENTRY POINTS ; EXT WRITELN,L109,L110,L111,L112,L115,L116,L117,L118,L120 EXT READLN,L121,L122,L123,L124,L125,L126,L127,L128,L129 EXT WRITE,L130,L131,L132,L133,L134,L135,L136,L0 EXT READ,L137,ABS,FPABS,SQR,FPSQR,EOLN,EOF,RESET,REWRITE EXT FGES IS OFF F: SET 0FFFFH ;DEFAULT FOR FLOATING POINT CHECKING IS ON. T: SET 00000H ; " " DEFAULT FOR TRACE OPTION IS OFF VALID: SET 00000H ;STATEMENT NUMBER ISN'T VALID ; ; ; PASCAL DEFAULTS ; MAXOUT EQU 4 ;NUMBER OF ALLOWABLE OUTPUT FILES MXOUT EQU MAXOUT*256 ;MAXOUT FOR TRANSPORT TO OTHER MODS MXOUT1 EQU MXOUT*2 ;FOR FILEXT MOD ONLY CR EQU 13 ;CARRIAGE RETURN LF EQU 10 ;LINE FEED EOFMRK EQU 1AH ; Enf of file marker. BUFLEN EQU 80 ;SIZE OF PASCAL'S CONSOLE BUFFER. TOPFRM EQU MAXOUT+MAXOUT+BUFLEN+3+1 ;SPACE FOR STACK FRAME #1 MARGIN EQU 50 ;STACK OVERFLOW MARGIN COMPILER EQU 0H ;TRUE IF ASSEMBLING THE COMPILER. MAXDRV EQU 16 ;MAXIMUM # OF DRIVES (USED BY FILNAM). CPM EQU 5 ;CP/M ENTRY ADDRESS. ; ; START: MVI C,25 ; CP/M CODE TO GET CURRENT DRIVE NUMBER. CALL CPM LHLD 6 ;GET POINTER TO TOP OF MEMORY. DCX H MOV M,A ;STORE DEFAULT DRIVE NUMBER. LXI B,0 ;CLEAR STATEMENT NUMBER LXI H,LAST ;Start of heap. EXX LHLD 6 ; 1 PAST LAST BYTE IN RAM. Lin command tail JRZ NOCOM MOV B,M ; B := NUMBER OF CHARACTERS. DCR B INX H ; POINT TO FIRST CHARACTER. INITLP INX H MOV C,M CALL TOUT ; STUFF CHARACTER INTO OUR BUFFER. DJNZ INITLP NOCOM MVI C,CR CALL TOUT ; Mark the end of buffer line. ; L99 is the label on the first line of code of the program translated ; by the Pascal/z compiler. JMP L99 ; FINI: MACRO ;;STARTING ADDR. OF PROGRAM JMP L0 END START ENDMAC ; EXTD: MACRO INTN,EXTN ;;TO LINK EXT.RTS. TO MAIN PROG. EXOAD: MACRO WHERE,VALUE ;;DO A MINIMUM LENGTH LOAD FOR ILOD1, ILOD2.... IF VALUE ;;CHECK FOR A NON-ZERO VALUE IF VALUE&0FF00H ;;CHECK FOR A VALUE > 255 LXI B,VALUE ;;LOAD THE VALUE CALL WHERE!2 ;;GO TO THE ROUTINE ELSE MVI C,VALUE ;;LOAD ONLY THE LOW BYTE CALL WHERE!1 ;;GO TO THE ROUTINE ENDIF ELSE CALL WHERE ;;GO TO THE ROUTINE AND LOAD A ZERO ENDIF ENDMAC ; ; ILOD: MACRO Q,SIZE,OFST ;;INDIRECT LOAD (FOR CALL BY REF VARS IF SIZE&8000H ;;NEGATIVE SIZE MLOAD ILODV,OFST ;POP: MACRO REG,DISTANCE ;;LONG POP IF DISTANCE ;;LONG POP PUSH H ;;SAVE HL LXI H,DISTANCE+2 ;;POINT TO ITEM TO POP DAD S MOV E,M ;;GET LOW BYTE INX H MOV D,M ;;GET HIGH BYTE PUSH D ;;SAVE THIS VALUE MOV D,H ;;COPY POINTER MOV E,L DCX H ;;POINT TO INTERMEDIATE BLOCK DCX H LXI B,DISTANCE ;;LENGTH OF INTERMEDIATE BLOCK LDDR ;;MOVE BLOCK UP 2 BYTES POP D ;;GET NEW DE VALUE POP H ;;RESTORE HL POP B ;;FIX STACK POINTER ELSE ;;SHORT POP POP D ENDIF ENDMAC ; LEAR ACCUMULATOR ENDMAC ;;YES, KEEP ON GOING ; ; DSUB: MACRO Q,SIZE IF 0!SIZE&8000H ;;CHECK FOR FLOATING POINT SUBTRACTION CALL FSUB IF F ;;CHECK FOR ERROR IF REQUIRED JC FLTERR ENDIF ELSE ;;SUBTRACT Q OR DE FROM HL XRA A ;;CLEAR CARRY DSBC Q D ;;SUBTRACT IT ENDIF ENDMAC ;;DONE ; ; DADD MACRO Q,SIZE IF 0!SIZE&8000H ;;CHECK FOR FLOATING POINT ADD CALL FADD IF F ;;CHECK FOR ERROR IF REQUIRED JC FLTERR ENDIF ELSE IF 'Q'-'C' ;;DADD C IS DAD H WITH CHECKING XI D,0-TOPFRM-1 ; AMOUNT OF SPACE TO RESERVE + 1. DAD D PUSH H PUSH H POP X POP Y SPHL ;MAKE SP DO THE SAME MVI B,MAXOUT*2+1 XRA A ;CLEAR FILE AREA ABOVE THE STACK CLRSTK: MOV M,A INX H DJNZ CLRSTK INX H MOV M,A ; PUT_CHAR_POINTER := 0 (BUFFER EMPTY). ;STICK STRING RESIDING AT COMMAND TAIL BUFFER (80H) IN TEXT BUFFER FOR ;CONSUMPTION BY PASCAL PROGRAM (THE COMPILER USES THIS). LXI H,80H ; ADDRESS OF TEXT BUFFER WITH REST OF COM LINE. CMP M ; 0 - number of characters T EXTN INTN: equ EXTN ENDMAC ; SPSH: MACRO Q,SIZE ;;PUSH A STRING IF SIZE ;;ZERO SIZE,FALL THROUGH IF SIZE&8000H ;;CHECK FOR NEG. SIZE LXI H,SIZE ;;NEG. SIZE.PUSH 'SIZE' BYTES OF JUNK DAD S SPHL ELSE MVI A,SIZE ;;POS. NON-ZERO SIZE CMP M ;;CHECK RANGE JC STRERR ;;STRING OVERFLOW MOV B,A ;;B IS COUNTER INR B ;;ALSO PUSHING LENGTH PSHLP: SET $ MOV D,M ;;D <- CHAR PUSH D INX S ;;ONLY ONE BYTE DCX H ;;NEXT CHAR DJNZ PSHLP XRA A ENDIF ENDIF ENDMAC ; ML;LOAD AND GO ELSE ;;VARIABLE SIZE IS KNOWN IF SIZE-1 ;;IF VARIABLE SIZE IS NOT 1 MLOAD ILOD2,OFST ;;LOAD AND GO ELSE ;;DO VARS WITH A SIZE OF 1 MLOAD ILOD1,OFST ;;LOAD AND GO ENDIF ENDIF ENDMAC ;;END OF ILOD ; ; ; ISTR: MACRO Q,SIZE,OFST ;;INDIRECT STORE A VARIABLE LENGTH INTEGER MLOAD ISTOR,OFST ;;LOAD AND GO IF R ;;RANGE CHECKING JC REFERR ;;CALL BY REF ERROR ENDIF ENDMAC ; ; ; LPOP -- POP A VALUE FROM THE MIDDLE OF THE STACK ; USED ONLY FOR SET ASSIGNMENTS ; L; ADDR: MACRO Q ;;CALCULATE ADDRESS USING SPECIFIED REG TEMP SET 'Q'-'IY' IF 'Q'-'Y'*TEMP ;;DEFAULT IS X-REG CALL XADDR ;;CALL ROUTINE TO DO IT ELSE CALL YADDR ;;OTHERWISE USE Y-REG ENDIF ENDMAC ; ; MIDL: MACRO REG,LEVEL ;;SET IX TO POINT TO A DIFFERENT LEVEL PUSH X ;;SAVE PRESENT IX MVI A,LEVEL MIDL1: SET $ ;;LOOP INDICATOR MOV C,4(X) ;;GET OLD IX MOV B,5(X) PUSH B ;;MOVE POINTER TO IX POP X CMP 1(X) ;;CHECK FOR RIGHT LEVEL JRNZ MIDL1 ;;NO...TRY AGAIN XRA A ;;CDAD Q D ;;ADD Q OR DE TO HL ELSE IF M ;;CHECK FOR ERROR CHECKING XRA A ;;CLEAR CARRY DADC H ;;ADD H TO ITSELF JV MLTERR ;;MULTIPLY OVERFLOW ELSE DAD H ;;H := H * 2; ENDIF ENDIF ENDIF ENDMAC ; ; ; ENTR: MACRO Q,LVL,VSIZ ;;ENTER A PROC/FCT ON LVL WITH VSIZ VARS IF LVL-1 ;;CHECK FOR INNER LEVELS MVI B,LVL ;;SAVE LEVEL NUMBER LXI D,1-VSIZ ;;SAVE VSIZ BYTES OF STACK IF S ;;DO STACK CHECKING CALL ENTRSC ;;ENTER WITH STACK CHEKING ELSE CALL ENTER ;;A SUBROUTNE WILL FINISH ENDIF ELSE ;;LEVEL 1 LXI H,1-VSIZ ;;SET UP STACK POINTER DAD S SPHL ;; LABEL TO JUMP TO FOR A CHAINED PROGRAM CHAIN$: EXX LXI H,LAST ;;INDICATE TOP OF HEAP EXX LXI H,-MARGIN ;;CHECK FOR A STACK OVERFLOW DAD S LXI D,LAST ;;DO STACK CHECKING FOR LEVEL 1 DSUB D ;;SUBTRACT DE FROM HL JC STKERR ;;OVERFLOW!! ENDIF ENDMAC ;;ALL ENTERED ; ; EXIT: MACRO Q,SSIZ ;;EXIT FROM A PROC/FCT LXI H,SSIZ+8 ;;GET NUMBER OF STACK BYTES JMP EXITF ;;FINISH UP IN A SUBROUTINTEST FOR STRUCTURED RELOP IF SIZE1&8000H ;;CHECK FOR FP OPERATION CALL FPEQ ;;YES, DO FP OP ELSE LXI B,SIZE1 CALL SEQUL ;;STRUCTURED RELOP ENDIF ENDIF ELSE LXI B,SIZE1*256+SIZE2 CALL STREQL ;;STRING RELOP ENDIF ENDMAC ; NEQL: MACRO Q,SIZE1,SIZE2 ;;NON-EQUALITY TEST IF 'Q'-'S' ;;TEST FOR STRING RELOP IF SIZE1 ;;TEST FOR STRUCTURED RELOP IF SIZE1&8000H ;;CHECK FOR FP OPERATION CALL FPNEQ ;;YES, DO FP OP ELSE LXI B,SIZE1 CALL SNE ;;STRUCTURED RELOP ENDIF ENDIFF 'Q'-'S' ;;TEST FOR STRING RELOP IF SIZE1 ;;TEST FOR STRUCTURED RELOP IF SIZE1&8000H ;;CHECK FOR FP OPERATION CALL FPLT ;;YES, DO FP OP ELSE LXI B,SIZE1 CALL SLT ;;STRUCTURED RELOP ENDIF ELSE CALL ILT ;;INTEGER TEST ENDIF ELSE LXI B,SIZE1*256+SIZE2 CALL STRLSS ;;STRING RELOP ENDIF ENDMAC ; GE: MACRO Q,SIZE1,SIZE2 ;;GREATER THAN OR EQUAL TO TEST IF 'Q'-'S' ;;TEST FOR STRING RELOP IF SIZE1 ;;TEST FOR STRUCTURED RELOP IF SIZE1&8000H ;;CHECK FOR FP OPERATION CALL ELSE LXI B,SIZE1*256+SIZE2 CALL STRGRT ;;STRING RELOP ENDIF ENDMAC ; FDVD: MACRO Q,SIZE ;;FLOATING POINT DIVISION CALL FDIVD IF F ;;CHECK FOR ERROR IF REQUIRED JC DIVERR ENDIF ENDMAC ; ; MULT: MACRO Q,SIZE ;;CALL MULTIPLY ROUTINE IF 0!SIZE&8000H ;;CHECK FOR FLOATING POINT OPERATION CALL FMULT IF F ;;CHECK FOR ERROR IF REQUIRED JC MLTERR ENDIF ELSE IF M ;;CHECK FOR OVERFLOW CALL IMULT ELSE ;;USE FAST ROUTINE CALL QMULT ENDIF ENDIF ENDMAC ; ; DIVTORE HIGH WORD PUSH H ;;RESTORE LOW WORD ELSE ;;DO DE PAIR MOV A,E CMA ;;COMPLEMENT LOW BYTE MOV E,A MOV A,REG CMA ;;COMPLEMENT HIGH BYTE MOV REG,A INX REG ;;AND INCREMENT ENDIF ELSE MOV A,L CMA ;;COMPLEMENT LOW BYTE MOV L,A MOV A,REG CMA ;;COMPLEMENT HIGH BYTE MOV REG,A INX REG ;;AND INCREMENT ENDIF XRA A ;;CLEAR ACCUMULATOR ENDMAC ; ; RUN-TIME CONTROL MACROS ; CTRL: MACRO ;;CHECK FOR A CTRL-C IF C ;;IF CTRL-C CHECKING IS ENABLED CALL CSTSE ENDMAC ; ; ; THIS ROUTINE IS USED TO DO A UNIT TIME CASE SELECTION WITH THE ; AID OF A JUMP TABLE CREATED BY THE COMPILER FOR THIS CASE STATMENT ; L98: DAD D ;CONVERT INDEX FROM BYTE COUNTER TO WORD COUNTER DAD D ;ADD IN ADDRESS OF THE ZEROETH TABLE ELEMENT MOV E,M ;GET LOW BYTE OF ADDRESS INX H MOV D,M ;GET HIGH BYTE OF ADDRESS XCHG ;STATEMENT ADDRESS -> HL PCHL ;EXECUTE THE STATEMENT ; EQUL: MACRO Q,SIZE1,SIZE2 ;;EQUALITY TEST IF 'Q'-'S' ;;TEST FOR STRING IF SIZE1 ;; ELSE LXI B,SIZE1*256+SIZE2 CALL STRNQL ;;STRING RELOP ENDIF ENDMAC ; LE: MACRO Q,SIZE1,SIZE2 ;;LESS THAN OR EQUAL TEST IF 'Q'-'S' ;;TEST FOR STRING RELOP IF SIZE1 ;;TEST FOR STRUCTURED RELOP IF SIZE1&8000H ;;CHECK FOR FP OPERATION CALL FPLTE ;;YES,DO FP OP ELSE LXI B,SIZE1 CALL SLE ;;STRUCTURED RELOP ENDIF ELSE CALL ILE ;;INTEGER TEST ENDIF ELSE LXI B,SIZE1*256+SIZE2 CALL STRLEQ ;;STRING RELOP ENDIF ENDMAC ; LESS: MACRO Q,SIZE1,SIZE2 ;;LESS THAN TEST I FPGTE ;;YES, DO FP OPERATION ELSE LXI B,SIZE1 CALL SGE ;;STRUCTURED RELOP ENDIF ELSE CALL IGE ;;INTEGER TEST ENDIF ELSE LXI B,SIZE1*256+SIZE2 CALL STRGEQ ;;STRING RELOP ENDIF ENDMAC ; GRET: MACRO Q,SIZE1,SIZE2 ;;GREATER THAN TEST IF 'Q'-'S' ;;TEST FOR STRING RELOP IF SIZE1 ;;TEST FOR STRUCTURED RELOP IF SIZE1&8000H ;;CHECK FOR FP OPERATION CALL FPGT ;;YES, DO FP OP ELSE LXI B,SIZE1 CALL SGT ;;STRUCTURED RELOP ENDIF ELSE CALL IGT ;;INTEGER TEST ENDIF D: MACRO ;;CALL DIVIDE ROUTINE CALL IDIVD IF M&D ;;CHECK FOR OVERFLOW JC DIVERR ENDIF ENDMAC ; ; MMOD: MACRO ;;CALL MOD ROUTINE CALL IMOD IF M ;;CHECK FOR OVERFLOW JC DIVERR ENDIF ENDMAC ; ; NEGT: MACRO REG ;;NEGATE SPECIFIED REGISTER PAIR IF 'REG'-'H' ;;DO DE PAIR OR FLOAT IF 'REG'-'D' ;;DO FLOAT NUMBER POP H ;;GET LOW WORD POP D ;;GET HIGH WORD MVI A,80H ;;SET HIGH BIT XRA E ;;TOGGLE HIGH BIT OF E MOV E,A ;;REPLACE HIGH WORD OF MANTISSA PUSH D ;;RES ;;CHECK FOR A CHARACTER TYPED JRZ $+16 ;;NO CHARACTER....CONTINUE CALL CI ;;GET THE CHARACTER CPI 'C'&3FH ;;IS IT A CTRL-C JZ ERROR ;;YES....ABORT!!! MVI C,7 ;;RING BELL CALL CO XRA A ;;CLEAR THE ACCUMULATOR BEFORE ENDIF ;;RETURNING ENDMAC ; ; RCHK: MACRO REG,LBND,HBND ;;RANGE CHECK MACRO IF R ;;ONLY CHECK IF CHECKING IS ENABLED LXI B,LBND ;;SAVE LOWER BOUND IF 'REG'-'H' ;;DO DE REGISTER PAIR OR A STRING CHECK IF 'REG'-'S' ;;DO DE PAIR PUSH H ;;SAVE POSSIBLE ADDRESS LXI H,HBND ;;SAVE UPPER BOUND CALL CHKDE ;;CHECK IT POP H ;;RESTORE POSSIBLE ADDRESS ELSE ;;DO STRING CHECK MVI A,LBND ;;MAXIMUM ACCEPTABLE STRING LENGTH CMP M JC STRERR ;;STRING TOO BIG! XRA A ;;CLEAR ACC ENDIF ELSE ;;DO HL PAIR PUSH D ;;SAVE DE REGISTER PAIR LXI D,HBND ;;SAVE UPPER BOUND CALL CHKHL ;;CHECK THE VALUE POP D ;;RESTORE DE ENDIF ENDIF ENDMAC ; ; STMT: MACRO Q,NUMBER ;;MACRO FOR TRACES AND.... IF T+E ;;....EXTENDED ERROR MESSAGES VALID S;GLOBAL PTRS. TO ONE OR TWO BYTE VARS. PUSH Y POP B ;GLOBAL VAR. POINTER DAD B ;POINTER ADDRESS MOV B,M DCX H MOV L,M MOV H,B ;VAR ADDR INTO HL LXI B,OFFSET DAD B IF SIZE-1 ;ONE OR TWO BYTES? MOV B,M ;TWO DCX H MOV L,M MOV H,B ELSE MOV L,M ;ONE BYTE MOV H,A ENDIF ENDMAC ; ; ERROR MESSAGES ; IF NOT COMPILER ;The compiler doesn't need these STRERR: LXI H,STRMSG ;STRING ERROR JR PERROR HPERR: LXI H,STKMSG ;HEAP OVERFLOW JR PERROR REFERR: LXI H,REFMSG ;eference precision erro','r'+80H RNGMSG DB 'Index or value out of rang','e'+80H ENDIF OUMSG DB 'Attempted divide by zer','o'+80H MLTMSG IF COMPILER DB 'Too many error','s'+80H ELSE DB 'Multiply overflo','w'+80H ENDIF STKMSG IF COMPILER DB 'Program too comple','x'+80H ELSE DB 'Stack overflo','w'+80H ENDIF FLTMSG DB 'Floating point overflow/underflo','w'+80H STMTMSG DB ' -- statement',' '+80H CRLF DB CR,LF+80H ; ; MACRO ROUTINES TO PROCESS SETS ; ; CSET IS A MACRO USED TO CONST-- START WITH A NULL SET INX H DJNZ CSETCL ENDIF ENDMAC UNIN: MACRO Q,OFFSET,OFF1 LXI H,OFF1 LXI D,OFFSET CALL UNION ENDMAC MEMB: MACRO Q,OFFSET,OFF2 LXI D,OFF2 LXI H,OFFSET CALL INN ENDMAC ; INCL: MACRO Q,OFFSET,OFF1 LXI H,OFF1 LXI D,OFFSET CALL LTEQ ENDMAC ; SBST: MACRO Q,OFFSET,OFF1 LXI H,OFF1 LXI D,OFFSET CALL GTEQ ENDMAC INTR: MACRO Q,OFFSET,OFF1 LXI H,OFF1 LXI D,OFFSET CALL INSECT ENDMAC DIFF: MACRO Q,OFFSET,OFF1 LXI H,OFF an integer to floating point, or fp to ASCII ; cvtf: macro where,value ;;where is the argument and what is it? ;; ;; A -> process immediate argument and push ;; ;; B -> process top of stack ;; ;; C -> process 2nd on stack ;; ;; D -> process # in de ;; ;; H -> process # in hl ;; ;; S -> convert top of stack to a string if 'A'-'where' ;;check for NOT A if 'B'-'where' ;;check for NOT B if 'C'-'where' ;;check for not C if 'D'-'where' ;;check for not D if 'H'-'where' ;;check ET 0FFFFH ;;STATEMENT NUMBER IS VALID EXX ;;SWITCH REGISTER SETS TO SINCE LXI B,NUMBER ;;STATEMENT NUMBER IS STORED IN OTHER BC IF T ;;PRINT NUMBER IF TRACE IF 'M'-'Q' CALL PSTAT ;;IS ON ENDIF ENDIF EXX ;;RESTORE PROGRAM REGISTERS ELSE ;;NO OPTIONS ENABLED IF VALID ;;IF OPTION WAS JUST TURNED OFF EXX ;;THEN SET ALTERNATE BC TO ZERO MOV B,A ;;CLEAR BC MOV C,A EXX VALID SET 00000H ;;SET INVALID FLAG ENDIF ENDIF ENDMAC ;;END OF MACRO GLBP MACRO Q,OFFSET,SIZE BY-REF PRECISION ERROR JR PERROR RNGERR: LXI H,RNGMSG ;POINT TO THE OUT OF RANGE MESSAGE JR PERROR ;PRINT THE ERROR MESSAGE ENDIF FLTERR: LXI H,FLTMSG ;FLOATING POINT ERROR JR PERROR STKERR: LXI H,STKMSG ;POINT TO STACK ERROR MESSAGE JR PERROR DIVERR: LXI H,OUMSG ;DIVIDE ERROR JR PERROR MLTERR LXI H,MLTMSG ;MULTIPLY ERROR PERROR: CALL TXTYP ;PRINT IT JMP ERROR ;AND ABORT ; IF NOT COMPILER ;The compiler shouldn't need these STRMSG DB 'String too lon','g'+80H REFMSG DB 'Call by rRUCT A SET ON THE STACK AT RUNTIME. ; ; IF THE PARAMETER OFF1 IS ZERO, THEN OFF2 CONTAINS THE NUMBER OF BYTES ; TO BE ALLOCATED ON THE STACK FOR THE SET. ; ; IF THE PARAMETER OFF1 IS NON-ZERO, SPACE HAS ALREADY BEEN ALLOCATED ON ; THE STACK AND THE SUBROUTINE CONSET IS CALLED TO SET THE RELEVANT ; BITS IN THE SET. CSET: MACRO Q,OFF1,OFF2 IF OFF1 LXI H,OFF1 CALL CONSET ELSE LXI H,-OFF2 ;; ALLOCATE SPACE ON THE STACK DAD S SPHL MVI B,OFF2 CSETCL SET $ MOV M,A ;; CLEAR THE BYTES 1 LXI D,OFFSET CALL ORGAN ENDMAC MTCH: MACRO Q,OFFSET,OFF1 LXI H,OFF1 LXI D,OFFSET CALL COMP ENDMAC NOMT: MACRO Q,OFFSET,OFF1 LXI H,OFF1 LXI D,OFFSET CALL FUSS ENDMAC ; ; xcfp: macro ;;exchange top two floating point numbers pop d ;;get op2 in de, hl pop h pop b ;;get low 16 bits of op1 xthl ;;exchange high 16 bits of op1 & op2 push d ;;save low 16 bits of op2 push h ;;save high 16 bits of op1 push b ;;save low 16 bits of op1 endmac ; ; convertfor not H ;; ;;process option S if value-4 ;;should we attempt to convert to fixed pt mov a,l ;;yes, first save fraction length pop b pop d ;;get fp number pop h ;;get field info mov h,a ;;save fraction length push h ;;restore stack push d push b xra a ;;clear acc call fout ;;convert to form ' sx.xxxxxxesxx' lxi h,13 ;;point to top of string dad s push h ;;save the parameter call fxdcvt ;;try to convert to fixed point else ;;otherwise simply print the string call fout ;;process fp -> ascii string endif else ;;process option H call cvtflt ;;process # in hl endif else ;;process option D xchg ;;put # in hl call cvtflt ;;process # in hl endif else ;;process option C pop b ;;get top of stack in bc, de pop d pop h ;;get integer in hl push d ;;save float # on stack push b call cvtflt ;;convert hl -> float xcfp ;;...and exchange op1 & op2 endif else ;;process option B pop h ;;get 2's complement value call ctln: macro reg,size exx mov a,e exx mov c,a xra a mov b,a lxi h,size dsub b dad s mvi m,cr endmac ; ; PASCAL PROGRAM ; endmac svln: macro ;;save the length of a string mov a,m ;;in the alt e reg. used with exx ;;gtln to append a carriage mov e,a ;;return to a variable length xra a ;;string being used by RESET exx ;;and REWRITE dcx h endmac gprogram show; (* This program prints the current memory size in kilobytes *) (* and the version number of CP/M on the console. *) (* Written by Robert Bedichek September 1980 *) (* NOTE: The external routines used herein are not in LIB.REL *) (* and thus must be explicitly linked in. *) const cpm = 5; (* BDOS entry point address. *) vercode = 12; (* CP/M code to return the version number *) type byte = 0..255; registers = record a: byte; bc, de, hl: integer 6:1, '.', reg.hl mod 16:1 ); (* Now figure out how big the workspace is. We look at the jump *) (* instruction at location 5. It points to one past the end of the *) (* workspace. Note the trickery involved because Pascal/Z can not have *) (* an integer bigger than 32,767. *) (* I know this code could be shorter, but I thought that this was clearer *) BDOS := peek( cpm + 1 ) - 256; if BDOS < 0 then begin kilobytes := (BDOS div 1024) + 64; quarterK := 25 * (((BDOS div 256) *+*+w!o* w##w!( F##N  .^#V!{!!!!! !!!hString too lonCall by reference precision erroIndex or value out of rangAttempted divide by zerMultiply overfloStack overfloFloating point overflow/underflo -- statement !9!o!9oRhw6  !͖ si sihT!!9!i nfmW_M/PM!!9!M/PC!!9! noisrev ! vtflt ;;call routine to convert # in hl endif else ;;process option A lxi h,value ;;get 16 bit value call cvtflt ;;convert to float, and done!! endif endmac dsb1 macro reg xra a dsbc reg d endmac cmpi macro q,value cpi value endmac svln: macro ;;save the length of a string mov a,m ;;in the alt e reg. used with exx ;;gtln to append a carriage mov e,a ;;return to a variable length xra a ;;string being used by RESET exx ;;and REWRITE dcx h endmac g end; var reg: registers; BDOS: integer; kilobytes: byte; quarterK: byte; procedure call( var x: registers; start: integer ); external; function peek( address: integer ): integer; external; begin writeln; writeln; reg.bc := vercode; call( reg, cpm ); write( 'This is ' ); (* If register h is zero then we are under CP/M, else we are under MP/M. *) if (reg.hl div 256) > 0 then write( 'MP/M' ) else write( 'CP/M' ); writeln( ' version ', reg.hl div 1mod 4) + 3) end else begin kilobytes := BDOS div 1024; quarterK := 25 * ((BDOS div 256) mod 4) end; writeln( 'There are ', kilobytes:1, '.', quarterK:1, ' kilobytes in the Transient Program Area' ); end. nteger bigger than 32,767. *) (* I know this code could be shorter, but I thought that this was clearer *) BDOS := peek( cpm + 1 ) - 256; if BDOS < 0 then begin kilobytes := (BDOS div 1024) + 64; quarterK := 25 * (((BDOS div 256) !9! nfm!!!.e3nf\m!!!tunfW_nfm@unfm\m###u nfmunfm\mu era erehT ! !9!  !gn!!.e3!gn)aerA margorP tneisnarT eht ni setybolik (!(!9!N(Gt!~FNV^fnwpqrstu^#V`i(  SxDM!=)#0 |z(z/W{/_|(|/g}/o#  -# z"BKgo(0|rx( jDrygoRxĐͮ 0#fn##|### !ͼdͼ ͼͼ!,/ R0ͬ^`iͶ^Ͷ^PYͬ^;F F###go͛ ͇ ͇#;F Fˆ###`go͛!9 PY FfnV go ғ | }~^(Vfn>f(zȯF+.̭̽l Nng)))V^G~ (#X(y(8 PG ͇BN͇#5'"xʤ z## Ư"w#w#wî ˆ++`i(  S_xDM!=()8 )0 0)+} E˸$}($0##0""L$q#s#r!(F!#6!*!!4 #4 #4!!+F&( 6##Nq+'6p & 6w+(É˞É### 8o+++v ~ k ###{"+++ˎ˞˦ 0 ### +++go 0 | }! uToo many open output file! uBad output file nam#}( ##|#(}#7ͮ 0!C )~6<(3b' " ^##wÉ!h  !r  ! ! uDisk erroError in extending filDisk fulDirectory fulBad filename ͘*^#~ 84 É#6͘*6O   É͘*6#~P( 4^qÉ5 7É~O#͘%~#?fʛ###b4~0#4 #4!4~0#4 #4!~b   76<+w_##~É͘ (* pascal program to drive ERASE - an external routine which *) (* allows pascal programs to erase files via cp/m's file *) (* system. *) program erase_driver; type filename = string 14; $string0 = string 0; $string1 = string 1; $string255 = string 255; var i : integer; oldfile : filename; newfile : filename; typefile :filename; function erase(oldfilen:filename):boolean;external; (* main* RENAME - ERASE v1.a 11/3/80 pec. * * RENAME external pascal function * * * rename requires the following declarations in the pascal program: * * type filestring = string 14; * * function rename(oldfile,newfile:filestring):boolean;external; * * * * rename returns true if it successfully renames oldfile to newfile. * It returns false otherwise. reasons for failure include an invalid * cpm file name (detected by the program) and the non-existence of * oldfile on the disk (detected by cpm)F~++( 8 G ͇F+N͇+++ݾ~c8 (8 Gy ͇OAO͇TRUEFALSEF~+++N Ő( 8G ͇( +N͇y(G++V^!9 z(6-+goGRw+O'GGdG GEOG #~-   60 +A~8 ( W ͇ N͇++++!9ѯɯR0 >0w+ G fnN++͓| z   +++~(###v###ʷ͘YÉ8 >+++###͘`i###b^(?"!5~< #5 #9G AN + 4 ͮ }r+sPYO>͘6+++6  6 #6# (8:*>_~:(0AG 0> :(*55*+Fx8I! 7ÉL(C O N   S T  Éw 8(.(w#H (#ͮ a8{0_ ͘+++f###%(68 . ! É͘y%4C f ###b"!5~< #5~< #5'"! 6!'+Fˆ"(w#w#w 44~0#4 #4!!4 #4 #4! 6!!%66ʉ>É͘É͘YÉ͘bM ͘%6#6bxÉ͘$^͘b|R?|7R|7R?|Rb$ɯ7|z(z/W{/_|(|/g}/o# ((!= goRW_= DM(go*7ɯt <)">*>#>+ɯ2b:2+:*j:"l:~(($Ϳ-*:|(a*l:"j: .*:|( (%".}2+:*j:~#(c-"j:Ϳ-*:|~c-}2b:*j:~#)(a"-"j:-Ϳ-*:|(!.}!a program driver *) begin while (true) do begin (* old file name *) writeln('enter name of file to be erased'); readln(oldfile); if erase(oldfile) then writeln('file erased') else writeln('failed deleting') end end. newfile : filename; typefile :filename; function erase(oldfilen:filename):boolean;external; (* main. * * * macros for pascal function environment entry and exit ENTR: MACRO Q,LVL,VSIZ IF LVL-1 MVI B,LVL LXI D,1-VSIZ IF S CALL ENTRSC ELSE CALL ENTER ENDIF ELSE LXI H,1-VSIZ DAD S SPHL CHAIN$: EXX LXI H,LAST EXX LXI H,-MARGIN DAD S LXI D,LAST DSUB D JC STKERR ENDIF ENDMAC EXIT: MACRO Q,SSIZ LXI H,SSIZ+8 JMP EXITF ENDMAC nmlist * PAGE * linker information ext entrsc,enter,exitf name rename entry rename name erase entry erase * constants etc. s set 1 ;conditional assembly variable used in enter cpm equ 5 ;cpm calling address rencon equ 23 ;cpm function number for renaming delcon equ 19 ;cpm function number for deleting fnsize equ 14 ;maximum length of a input parameter file name * PAGE * enter rename rename entr 0,2,36 ;enter at level 2,with 36 byte local storage * save original ix and iy and set iy to ix push iy ;save original iy push ix pop iy ;iy gets ix push ix ;save original ix * point iyo next file area dadx b call fname jc nogood * adjust disk specification of 1st file only (2nd ignored by cpm anyway) ldax d ;load disk select character call diskcode jc nogood stax d ;store disk select code * call cpm system to rename file mvi c,rencon ;load rename function number call cpm pop ix ;restore original ix and pop iy ; iy adi 1 ;check cpm return code (-1 if rename fails) jrz ex ;exit if failed inr 2(ix) ;set return to 1 = true if success(set to 0 ; oected by the program) and the non-existence of * oldfile on the disk (detected by cpm). * * * enter erase erase entr 0,2,36 ;enter at level 2,with 36 byte local storage * save original ix and iy and set iy to ix push iy ;save original iy push ix pop iy ;iy gets ix push ix ;save original ix * point iy to 1st byte of 1st file name parameter (hi addr) lxi b,fnsize+1+7 dady b * point ix to 1st byte of file control block (fcb) lxi b,-35 dadx b push ix ;save pntr to fcrue if success(set to 0 ; on entry to procedure) dex exit 0,15 ;exit delete environment,returning 15 bytes dnogood pop ix pop iy jr ex ;of parameter space * PAGE *DISKCODE subroutine * diskcode takes the character passed in a and converts it into * a valid cpm disk select code if possible. * A thru P are translated into 1 thru 16 respectively. '*' is * the default character and is translated into default disk code 0 * carry is clear(0) if diskcode succeeds and set(1) if it fae bc ret * * PAGE * FNAME subroutine * fname takes any valid cpm file name and expands it to a full length file * name for use in a fcb. * iy - points to input string and moves towards low memory as it * moves along in the string. The 1st byte is the string length. * d - counts the number of input string characters processed. * * ix - points to the output string and moves towards high memory as * it moves along in the string. * e - counts the number of output string to 1st byte of 1st file name parameter (hi addr) lxi b,fnsize+1*2+7 dady b * point ix to 1st byte of file control block (fcb) lxi b,-35 dadx b push ix ;save pntr to fcb for cpm call pop d ;d set up for cpm call * transfer 1st file name to fcb(0..15) call fname jc nogood * transfer 2nd file name to fcb(16..31) pop iy ;copy original ix push iy ;save original ix for later (again!) lxi b,fnsize+1+7 ;iy set to point to 2nd file name parameter dady b lxi b,4 ;move ix up 4 tn entry to procedure ex exit 0,30 ;exit rename environment,returning 30 bytes nogood pop ix pop iy jr ex ;of parameter space * PAGE * ERASE external pascal function * * * erase requires the following declarations in the pascal program: * * type filestring = string 14; * * function erase(oldfile:filestring):boolean;external; * * * * erase returns true if it successfully deletes oldfile. * It returns false otherwise. reasons for failure include an invalid * cpm file name (detb for cpm call pop d ;d set up for cpm call * transfer 1st file name to fcb(0..15) call fname jc dnogood * adjust disk specification of file ldax d ;load disk select character call diskcode jc dnogood stax d ;store disk select code * call cpm system to delete file mvi c,delcon ;load delete function number call cpm pop ix ;restore original ix and pop iy ; iy adi 1 ;check cpm return code (-1 if delete fails) jrz dex ;exit if failed inr 2(ix) ;set return to 1 = tils diskcode push b ;save bc mov b,a ;save a copy of char cpi '*' jrz def ;default drive select sui 'A' ; < A ? jm badd mov a,b ; reload character sui 'O' ; > P ? jp badd * have valid disk letter. encode it. mov a,b sui 40H ;subtract 40H from ascii code to get 1..16 jr okret * default disk specified. def mvi a,0 ;default disk select,give code 0 okret stc ;return with carry clear cmc jr bye badd stc ;bad char, return with carry set bye pop b ;restor characters processed. * * at the successful conclusion of fname ix and iy point 1 byte past * the last character in the appropriate direction. * * carry is clear(0) if fname succeeds,carry set(1) if fname fails. * * save registers fname push b push d * load byte counters and length of string lxi d,0101H ;both counts start at 1 mov c,0(iy) ;c gets length dcx iy ;move iy past length byte * look for disk specification mov a,-1(iy) ;':' is 2nd character if disk given cpi ':' ;':' indicates disk specified jnz deflt ;if no ':' then default disk * have disk specified diskg mov a,0(iy) ;pick up disk letter call upper ;force disk letter to uppercase jc baddis inr d ;count 2 input bytes processed inr d dcx iy dcx iy jr indisk * default disk to '*' deflt mvi a,'*' ;default disk * indisk mov 0(ix),a ;store disk specification inr e ;count a byte output processed inx ix * process file name name nloop mov a,c ;d <= length sub d jm endnam her byte output jr endnam * process the file extention ext inr d ;move over '.' even if not really there! dcx iy exloop mov a,c ; d <= length sub d jm endext mvi a,13 ; e < 13 ? sub e jm endext jz endext mov a,0(iy) ;pick up input character call upper ;trnanslate character jc badnam ;if illegal exit mov 0(ix),a ;store translated character inr e ;record a character in and out inr d inx ix dcx iy jr exloop * all of extension picked up. add ' 's to make f(0) if character is legal,set(1) if illegal * upper push b ;save bc * check if character is already uppercase mov b,a ;save copy of character sui 41H ; < 'A' ? jm notup mov a,b ;reload character sui 5bH ; > 'Z' ? jp notup mov a,b ; have upper return as is jr restok * check if lower case notup mov a,b ;reload sui 61H ;< 'a'? jm notlo mov a,b ;reload sui 7bH ;> 'z' ? jp notlo * have a lower case character. make uppercase by subtracting 32 mov a,b sui 32 egl stc ;failure. set carry * mop up and return rest pop b ret ui 40H ; > '?' ? jp ok1 jr illegl * check scattered illlegals ok1: mov a,b cpi 20H ; check for control chars (< space) jrc illegl ; c is set if (A) < space. cpi ',' jrz illegl cpi '*' jrz illegl cpi '[' jrz illegl cpi ']' jrz illegl cpi '.' jrz illegl * not illegal restok stc ;success so clear carry cmc jr rest * illegal character illQTT`TU$4XI95:QTTcI95kX[hr\ u u\mmUPHnYU@LDڪ p]7\/ (F!0-6?\+rB$A-+Ep@Vp4ʹ@ 8٠Pup"th :p\!k  b <57#v %@/p+~ ?Om]mUQ+~!w3IDGꉀ  TLW@[UdwVlI1@%6a~)'FRoʨ/W@[UdwVo6UUntFxݢdHb 궀ŷm<_O cʿ>` @yXt`( ؠ.mvi a,10 ;e < 11 sub e jm endnam jz endnam mov a,0(iy) ;pick up an input character cpi '.' ; if char = '.' jz endnam ; then name is ended * nchar call upper ;translate next char jc badnam mov 0(ix),a ;store translated char inr d ;record a byte in and out inr e inx ix dcx iy jr nloop * all of name picked up. add ' 's to make proper length endnam mvi a,10 ; while e < 10 sub e jrz ext ;when done go to extension mvi 0(ix),' ' inr e inx ix ;record anotield proper length endext mvi a,13 ;while e < 13 sub e jz done mvi 0(ix),' ' ;store blank inr e ;record byte out inx ix jr endext * success. return with carry = 0 done: stc cmc ;carry clear jr restore * failure. return with carry = 1 baddis badnam stc ;carry set * mop up and return restore pop d pop b ret * PAGE * UPPER subroutine * upper translates the character in a to uppercase and * checks if it is a legal cpm character for a file name * carry is clearjr restok * character is not a letter so check if illegal notlo mov a,b ;reload sui 3aH ; < ':' ? jm ok1 mov a,b sui 40H ; > '?' ? jp ok1 jr illegl * check scattered illlegals ok1: mov a,b cpi 20H ; check for control chars (< space) jrc illegl ; c is set if (A) < space. cpi ',' jrz illegl cpi '*' jrz illegl cpi '[' jrz illegl cpi ']' jrz illegl cpi '.' jrz illegl * not illegal restok stc ;success so clear carry cmc jr rest * illegal character illp7#v &2S3@a%Qp#v %@/p+~ ?Om]mUQ+~!w3IDGꉀ  TLW@[UdwVlI1@%6a~)'FRoʨ/W@[UdwVo6UUntFxݢdHb 궀ŷm<_O cʿ>` @yXt`( ؠ.(* pascal program to drive RENAME - an external routine which *) (* allows pascal programs to rename files via cp/m's file *) (* system. *) program rename_driver; type filename = string 14; $string0 = string 0; $string1 = string 1; $string255 = string 255; var i : integer; oldfile : filename; newfile : filename; typefile :filename; function rename(oldfilen,newfilen:filename):boolean;external; ; This Pascal/Z external function returns the value of the ; two byte word pointed to by the passed parameter. ; Written by Robert Bedichek 1980 ; The Pascal declaration is: ; function peek( address: integer ): integer; external; name peek entry peek peek pop b ; The return address. pop h ; The address to peek. mov e,m ; Low byte of the word. inx h mov d,m ; High byte of the word. mov h,b mov l,c pchl QRETTPEEK0\%XitRENERA1ASRCIwxyz{|}~RENERA1ARELRENDRV PASPEEK SRCPEEK $$$; converts the 16 bit integer in hl to a floating point # ; NAME CVTFLT ENTRY CVTFLT EXT ABS INCLUDE FPINIT.SRC ; ;THIS IS MOD CVTFLT,SO... $CVTFLT SET 0FFFFH ; INCLUDE FPMAC.SRC ; cvtflt: mov b,h ;check high byte, if negative, fix value call abs ;get absolute value of n mov a,b ;get old high byte ani 80h ;mask old high bit ora h ;or with absolute value mov h,a ;and restore pop b ;get return address mvi d,15 ;initial exponent, don't need intflg push d ;save on stack; CHAIN TO ANOTHER PASCAL PROGRAM WITH THE SAME GLOBAL STACK ; ENTRY CHAIN,L125 EXT FILNAM,OPNIN,PERROR,CHAIN$ INCLUDE DEFLT.SRC ; L125: CHAIN: LXI H,5CH ;CP/M default file control block. CALL FILNAM ;PROCESS FILENAME STORED BY FTXTIN CALL OPNIN ;OPEN IT JRC CHERR ;NOT THERE, CHAIN ERROR LXI D,100H ;Start of overlay. KEEPRD: PUSH D ;Save overlay pointer. MVI C,26 ; CP/M code to set DMA address. CALL CPM LXI D,5CH MVI C,20 CALL CPM ;Read 128 bytes of overlay. POP D (* main program driver *) begin while (true) do begin (* old file name *) writeln('enter present filename'); readln(oldfile); (* new file name *) writeln('enter new filename'); readln(newfile); if rename(oldfile,newfile) then writeln('file renamed') else writeln('failed renaming') end end.  newfile : filename; typefile :filename; function rename(oldfilen,newfilen:filename):boolean;external; inx s ;only need one byte push h ;save high 16 bits lxi h,0 ;save low 16 bits push h push h ;save scr1... inx s ;..which is only one byte push x push y ;save ix...and iy push b ;save return address dad s push h ;save pointer pop x ;in ix... xchg ;...and de normfp 2 ;normalize the number pop h ;get return address pop y pop x ;restore index registers pop d ;throw away excess bytes xra a ;clear acc pchl ;and.....return ; LXI H,128 DAD D ;Make DMA pointer point to next 128 byte chunk. XCHG ORA A ;Test code returned by CP/M. JRZ KEEPRD ;Branch if not EOF. ; ; JUMP INTO CALLED PROGRAM XRA A ; The compiled code likes A=0. JMP CHAIN$ ; Start program without reinitializing stack. CHERR: LXI H,CHMSG ;POINT TO THE MESSAGE JMP PERROR CHMSG: DB 'Unable to chai','n'+80H  MVI C,26 ; CP/M code to set DMA address. CALL CPM LXI D,5CH MVI C,20 CALL CPM ;Read 128 bytes of overlay. POP D ;CONSOLE ROUTINES ; NAME CONSOL ENTRY CSTS,CI,CO EXT POPHDB,PUSHBD INCLUDE DEFLT.SRC ; CSTS CALL PUSHBD ;SAVE ALL REGISTERS EXCEPT A MVI C,11 ; CP/M CODE FOR CONSOLE STATUS. CALL CPM ORA A ;TEST A FOR RETURN CODE. JZ POPHDB MVI A,0FFH JMP POPHDB ;CONSOLE IN READS AND ECHOS A CHARACTER FROM THE CONSOLE. CI CALL PUSHBD ;SAVE ALL REGISTERS EXCEPT A MVI C,1 ;CP/M CODE FOR CONSOLE READ. CALL CPM JMP POPHDB ;RESTORE REGISTERS AND RETURN. ;CONSOLE OUT PROCEDURE PRINTS A CH;CLOSES THE OUTPUT FILE WHOSE DESCRIPTOR IS POINTED TO BY HL ; NAME CLSOT ENTRY CLSOT EXT BYTOT,POPHDB,PUSHBD INCLUDE DEFLT.SRC ; ; CLSOT CALL PUSHBD ;SAVE ALL REGISTERS EXCEPT A PUSH PSW PUSH H DCX H DCX H DCX H ; 'FLAGS' BYTE BIT 4,M ; 'RANDOMLY ACCESSED' BIT INX H INX H INX H ;FCB LXI D,BYTPT ; OFFSET INTO FILE OF BYTE POINTER/COUNTER. DAD D JRZ NTTRAN ; NOT RANDOMLY ACCESSED MVI M,0FFH ; WANT TO FLUSH WHOLE BUFFER NTTRAN: XCHG POP H ; DE NOW POINTS TO S;ROUTINES TO COMPLEMENT AN OPERAND, AND CHECK FOR A ZERO OPERAND ; NAME CMPCHK ENTRY COMPOP,COMP1,ZERCHK,ZERCK1 INCLUDE FPINIT.SRC ; ; complement an operand ; compop: dad d ;and calculate addr of fpacc comp1: mvi b,fracln ;process whole mantissa mov a,m ;get first byte cma ;complement and... adi 1 ;..add one compl: mov m,a ;save present byte inx h ;bump pointer mov a,m ;get next byte cma ;complement and add aci 0 ;carry djnz compl ;check for last byte ret ;yes...;RANGE CHECK SUBROUTINES ; NAME CHKD ENTRY CHKDE,CHKHL EXT ILE,IGE,RNGERR ; CHKDE: CALL IGE ;MAKE SURE THAT THE UPPER BOUND IS JNC RNGERR ;GREATER THAN/ EQUAL TO DE MOV H,B MOV L,C CALL ILE ;MAKE SURE THAT THE LOWER BOUND IS RC ;LESS THAN/ EQUAL TO DE JMP RNGERR ;OOOPS!! ; ; CHKHL: PUSH H ;SAVE HL PUSH H ;SAVE IT AGAIN CALL ILE ;MAKE SURE HL IS LESS THAN/ EQUAL TO JNC RNGERR ;THE UPPER BOUND POP H ;GET A NEW HL MOV D,B MOV E,C CALL IGE ;MAKE SURE THAT HL IS ; convert a string to a floating point number ; NAME CVTSFP ENTRY CVTSFP,CVTH,CVTL EXT FADD1,FPTTEN,FPERR,FPDTEN INCLUDE FPINIT.SRC INCLUDE FPMAC.SRC ; cvtsfp: lxi d,0 mvi b,7 addzer: push d ;add 14 bytes of zeroes to the stack djnz addzer push x ;save ix, iy and hl push y push h xchg ;hl <- 0 dad s ;hl = sp push h pop x ;ix = sp inr intflg(x) ;set internal operations flag xchg ;de = sp nxtdig: pop h ;get next digit mov a,m dcx h ;bump and save pointer puARACTER PASSED IN REGISTER C ON THE CONSOLE. CO CALL PUSHBD ;SAVE ALL REGISTERS EXCEPT A MOV E,C ;CP/M WANTS THE CHARACTER IN E. MVI C,2 CALL CPM JMP POPHDB ;RESTORE REGISTERS AND RETURN. FH JMP POPHDB ;CONSOLE IN READS AND ECHOS A CHARACTER FROM THE CONSOLE. CI CALL PUSHBD ;SAVE ALL REGISTERS EXCEPT A MVI C,1 ;CP/M CODE FOR CONSOLE READ. CALL CPM JMP POPHDB ;RESTORE REGISTERS AND RETURN. ;CONSOLE OUT PROCEDURE PRINTS A CHTART OF FILE DESCRIPTOR. EOFILL MVI C,FILCHR CALL BYTOT LDAX D ORA A JZ FILLED JMP EOFILL FILLED XCHG MVI C,16 ; CP/M CODE FOR CLOSE FILE. CALL CPM POP PSW JMP POPHDB ; BIT 4,M ; 'RANDOMLY ACCESSED' BIT INX H INX H INX H ;FCB LXI D,BYTPT ; OFFSET INTO FILE OF BYTE POINTER/COUNTER. DAD D JRZ NTTRAN ; NOT RANDOMLY ACCESSED MVI M,0FFH ; WANT TO FLUSH WHOLE BUFFER NTTRAN: XCHG POP H ; DE NOW POINTS TO Sdone ; ; check number for a zero ; zerchk: dad d ;and calculate address of fpacc zerck1: mvi b,fracln ;process whole mantissa xra a ;clear accumulator zchka: ora m ;check next byte dcx h ;bump pointer djnz zchka ;any more? ret ;no, return ; pointer mov a,m ;get next byte cma ;complement and add aci 0 ;carry djnz compl ;check for last byte ret ;yes...GREATER THAN/EQUAL TO POP H ;GET A NEW HL RC ;THE LOWER BOUND JMP RNGERR ;ERROR BOUND IS JNC RNGERR ;GREATER THAN/ EQUAL TO DE MOV H,B MOV L,C CALL ILE ;MAKE SURE THAT THE LOWER BOUND IS RC ;LESS THAN/ EQUAL TO DE JMP RNGERR ;OOOPS!! ; ; CHKHL: PUSH H ;SAVE HL PUSH H ;SAVE IT AGAIN CALL ILE ;MAKE SURE HL IS LESS THAN/ EQUAL TO JNC RNGERR ;THE UPPER BOUND POP H ;GET A NEW HL MOV D,B MOV E,C CALL IGE ;MAKE SURE THAT HL IS sh h cpi '.' ;check for a decimal point jrz fractn ;yes, go indicate a fraction cpi 'e' ;check for a scale factor jrz scale cpi 'E' jrz scale cpi ' ' ;check for end of number jrz eofpn dcr dc1(x) ;add another notch to the digit counter call fptten ;op1 := op1 * 10 pop h ;get digit again push h inx h mov a,m sui '0' ;strip ascii bias lxi h,op2 ;make op2 = new digit dad d mvi m,7 ;exponent dcx h mov m,a ;high byte of mantissa xra a ;acc <- 0 dcx h mov m,a ;store a zero into this byte of mantissa dcx h mov m,a ;store a zero into this byte of mantissa dcx h mov m,a ;store a zero into this byte of mantissa normfp 2 ;normalize this number, and .... call fadd1 ;add jr nxtdig ;do next digit fractn: mvi dc1(x),0 ;indicate no decimal digits yet mvi dc2(x),0ffh ;fix mask to allow decimal digits jr nxtdig ;go do next digit eofpn: xra a ;clear acc pop h ;throw away string pointer jr scal6 ;and go do some scaling scale: pop h ;gete the digit dcx h ;bump the pointer mov a,m ;get next digit cpi ' ' ;check for end of exponent jrz scal5 sui '0' ;strip ascii bias jc fperr cpi 10 jnc fperr push d ;save stack pointer mov d,a ;save ones digit mov a,b ;get tens digit add a ;x2 add a ;x4 add b ;x5 add a ;x10 add d ; + ones digit pop d ;restore stack pointer mov b,a ;save exponent in b scal5: mov a,b ;get exponent bit 0,c ;check for negative exponent jrz scal6 ;no, don't negate neg djnz dcnst2 ;continue until done cvtdn: pop y ;restore y pop x ;restore x lxi h,8 ;throw away work space dad s sphl pop h ;get op1 pop d pop b ;throw away scratch bytes xra a ;clear acc ret cvth pop h xthl call cvtsfp ;convert to float ret ;return with two msb's in de cvtl pop h xthl call cvtsfp ;convert to float xchg ret ;return with two lsb's in de ; ; done2 -- done with a two operand operation ; NAME DONE2 ENTRY DONE2 EXT FNORM INCLUDE FPINIT.SRC INCLUDE FPMAC.SRC ; done2: normfp 1 ;first normalize result push x ;restore de as stack index pop d xra a ;clear acc, carry cmp intflg(x) ;check internal op flag rnz ;return if operation is internal pop d ;de <- return address pop y ;restore iy.... pop x ;...and ix ;remove op2, 2 scratch bytes and extra byte of op1 from stack lxi h,nbytes+3 dad s sphl ;fix stack po;SUBROUTINES TO SELECT A DEVICE AND DELETE A FILE ; NAME DSKFIL ENTRY SELDSK,DELETE,POPHDB,PUSHBD INCLUDE DEFLT.SRC ; ; ;SELECT DISK TELLS CP/M TO USE THE DEVICE SPECIFIED BY THE DEVICE NAME ;ENTRY IN THE FILE DESCRIPTOR POINTED TO BY HL. REGISTERS A AND F ARE TRASHED. SELDSK CALL PUSHBD ;SAVE ALL REGISTERS EXCEPT A ;SET DMA ADDRESS TO 80H FOR CP/M'S INTERNAL OPERATIONS. PUSH H LXI D,80H ; SYSTEM'S DMA AREA. MVI C,26 ; CP/M CODE TO SET DMA ADDRESS. CALL CPM POP H LXI D,DEVNUM pointer to string xra a ;clear acc mov c,a ;clear c mov a,m ;get first char of scale factor cpi '-' ;check for a leading sign jrnz scal2 ;no leading minus sign mov c,a ;set c to indicate a negative exponent jr scal3 scal2: cpi '+' ;check for a leading plus sign jrnz scal4 ;no, keep processing scal3: dcx h ;skip over sign and keep processing scal4: mov a,m ;get first digit sui '0' ;strip ascii bias jc fperr ;make sure than 0 <= exp <= 9 cpi 10 jnc fperr mov b,a ;sav;negate acc scal6: mov b,a ;save signed exponent mov a,dc1(x) ;get input bias ana dc2(x) ;...and... add b ;form corrected scale factor jm dcnst ;negative exp requires division jrz cvtdn ;zero -> done mov b,a ;save it mcnst: push b ;save counter call fptten ;multiply by ten pop b ;get counter djnz mcnst ;continue until done jr cvtdn dcnst: neg ;make counter positive mov b,a ;save in b dcnst2: push b ;save counter call fpdten ;divide op1 by ten pop b ;get counter inter xchg ;return addr -> hl xra a ;clear accumulator pchl ;return ;  ; done2: normfp 1 ;first normalize result push x ;restore de as stack index pop d xra a ;clear acc, carry cmp intflg(x) ;check internal op flag rnz ;return if operation is internal pop d ;de <- return address pop y ;restore iy.... pop x ;...and ix ;remove op2, 2 scratch bytes and extra byte of op1 from stack lxi h,nbytes+3 dad s sphl ;fix stack poDAD D ; ADDRESS OF DEVICE NUMBER NOW IN HL MOV E,M MVI C,14 ; CP/M CODE FOR SELECT DISK. CALL CPM JMPR POPHDB ;DELETE REMOVES THE FILE (FROM THE DIRECTORY) WHICH IS SPECIFIED BY THE ;FILE DESCRIPTOR POINTED TO BY HL. DELETE CALL PUSHBD ;SAVE ALL REGISTERS EXCEPT A PUSH PSW CALL SELDSK ; SELECT THE PROPER DRIVE. XCHG MVI C,19 ; CP/M CODE FOR DELETE FILE ENTRY CALL CPM POP PSW POPHDB POP H POP D POP B EXX EXAF POP PSW EXAF POP Y POP X POP H POP D POP B RET ; PUSHBD EXX POP D ;SAVE RETURN ADDRESS EXX PUSH B ;SAVE ALL REGISTERS EXCEPT A PUSH D PUSH H PUSH X PUSH Y EXAF PUSH PSW EXAF EXX PUSH B PUSH D PUSH H PUSH D ;RETURN ADDRESS EXX RET E ALL REGISTERS EXCEPT A PUSH PSW CALL SELDSK ; SELECT THE PROPER DRIVE. XCHG MVI C,19 ; CP/M CODE FOR DELETE FILE ENTRY CALL CPM POP PSW POPHDB POP H POP D POP B EXX EXAF POP PSW EXAF POP Y POP X POP H POP D POP B ;DYNAMIC STORAGE ALLOCATION AND DE-ALLOCATION ROUTINES ; NAME DYNALL ENTRY NEW,MARK,RELEASE,L126,L127,L128 EXT HPERR INCLUDE DEFLT.SRC INCLUDE FCTMAC.SRC ; ; ; NEW -- ALLOCATE MORE STORAGE TO THE HEAP ; L126: NEW: IF NOT COMPILER ;DON'T USE WITH COMPILER PUSH B ;MOVE # BYTES TO ALTERNATE REGS; EXX ;GO TO ALTERNATE REGISTER SET POP D ;GET SIZE OF ALLOCATION DAD D ;ADD TO PREVIOUS TOP OF HEAP PUSH H ;MOVE POINTER TO ALTERNATE REGS EXX POP D MOV M,D ;STORE IN POINTER VARIABLE OF THE POINTER DCX H MOV E,M PUSH D ;MOVE POINTER TO ALTERNATE REGS EXX POP H ;NEW TOP OF HEAP EXX RET ENDIF  EXX POP D ;AND STORE IT IN THE MOV M,D ;POINTER USED AS AN ARGUMENT DCX H ;TO THE MARK ROUTINE MOV M,E RET ENDIF ; ; RELEASE STORAGE TO THE POINT SPECIFIED L128: RELEASE: IF NOT COMPILER ;DON'T USE WITH COMPILER MOV D,M ;GET THE VALU;DIVIDE ROUTINES, AND MOD ROUTINE ; NAME DIVD ENTRY IDIVD,IMOD ; ;DIVIDE HL BY DE ; DETERMINE SIGN OF RESULT AND SAVE IT IDIVD: MOV A,H XRA D PUSH PSW ;MAKE BOTH THE DIVISOR AND DIVIDEND POSITIVE BIT 7,D JRZ DIVSPO MOV A,D ;CHANGE SIGN CMA MOV D,A MOV A,E CMA MOV E,A INX D DIVSPO: BIT 7,H JRZ DIVDPO MOV A,H ;CHANGE SIGN CMA MOV H,A MOV A,L CMA MOV L,A INX H ;NOW BOTH ARE POSITIVE, CHECK FOR DIVISION BY ZERO DIVDPO: XRA A CMP D JRNZ CKNM ORA E JRINDICATES OVFL ERROR RET NOTTWO: XRA A ;CLEAR A ;NORMALIZE THE DIVISOR, KEEPING COUNT OF THE NUMBER ;OF SHIFTS REQUIRED TO ACCOMPLISH THIS CKNM: XCHG ;IT'S EASIER TO SHIFT HL CKNM1: BIT 6,H JRNZ NORM INR A DAD H ;SHIFT DIVISOR LEFT ONE BIT JMPR CKNM1 NORM: XCHG ;RESTORE DIVISOR TO DE LXI B,0H INR A ;DIVIDE LOOP DIVLOP: ORA A ;CLEAR CARRY DSBC D ;ATTEMPT SUBTRACTION JRC FAIL STC RLAR C ;SHIFT ONE INTO ANSWER RLAR B JMPR TEST ;SUBTRACTION FAILED FAIL: DAD D SLE DCX H MOV M,E LXI H,-MARGIN DAD S ;CHECK FOR A HEAP OVERFLOW DSUB D JC HPERR RET ENDIF ; ; MARK POINTER VAR WITH THE PRESENT TOP OF HEAP ; L127: MARK: IF NOT COMPILER ;DON'T USE WITH COMPILER EXX PUSH H ;GET THE TOP OF THE HEAP EXX POP D ;AND STORE IT IN THE MOV M,D ;POINTER USED AS AN ARGUMENT DCX H ;TO THE MARK ROUTINE MOV M,E RET ENDIF ; ; RELEASE STORAGE TO THE POINT SPECIFIED L128: RELEASE: IF NOT COMPILER ;DON'T USE WITH COMPILER MOV D,M ;GET THE VALUZ ZERO ;DIVISION BY ZERO ;CHECK FOR DIVISION BY ONE DCR A JRNZ NOTONE ;DIVISION BY ONE OR MINUS ONE POP PSW XRA H JP ONEDON XCHG ;DIVISOR NEGATIVE CHANGE SIGN XRA A MOV H,A ;OF THE ANSWER MOV L,A DSBC D ONEDON: XRA A MOV D,A ;REMAINDER:=0 MOV E,A RET NOTONE: DCR A JRNZ NOTTWO ;DIVISION BY TWO MOV B,H ;ANSWER INTO BC MOV C,L SRAR B RRAR C MOV H,A ;REMAINDER:=0 MOV L,A RLAR L ;REMAINDER = CARRY JR SIGNS ;DIVISION BY ZERO ZERO: POP D STC ;SET CARRY AR C ;SHIFT ZERO INTO NUMBER RLAR B ;END LOOP TEST TEST: SRAR D ;SHIFT DIVISOR RRAR E DCR A JRNZ DIVLOP ;DONE DIVISION IS COMPLETE ;THE MAGNITUDE OF THE REMAINDER IS IN DE ;THE MAGNITUDE OF THE ANSWER IS IN BE SIGNS: POP PSW ;GET SIGN OF RESULT XCHG ;REMAINDER INTO DE LXI H,0H JP LIKE DSBC B ;CARRY IS ALREADY CLEAR FROM XRA H XRA A ;RESET CARRY RET LIKE: DAD B XRA A ;CLEAR A AND RESET CARRY RET ;MOD RETURNS HL - ( ( HL DIV DE ) * DE ) IMOD: BIT 7,H ;CHECK SIGN OF RESULT JRZ POSRSLT CALL IDIVD RC ;DONE IF AN ERROR OCCURRED MOV H,A MOV L,A ;CHANGE SIGN OF RESULT DSBC D XRA A ;CLEAR CARRY RET ;RESULT IS POSTIVE POSRSLT CALL IDIVD XCHG RET RESULT XCHG ;REMAINDER INTO DE LXI H,0H JP LIKE DSBC B ;CARRY IS ALREADY CLEAR FROM XRA H XRA A ;RESET CARRY RET LIKE: DAD B XRA A ;CLEAR A AND RESET CARRY RET ;MOD RETURNS HL - ( ( HL DIV DE ) * DE ) IMOD: BIT 7,H ;CHECK SIGN OF RE; INITIALIZE SOME RUN-TIME PARAMETERS TO THEIR CORRECT DEFAULT VALUES ; ; R: SET 0FFFFH ;DEFAULT FOR RANGE CHECKING IS YES C: SET 0FFFFH ; " " CTRL-C " " " M: SET 0FFFFH ; " " MATH " " " S: SET 0FFFFH ; " " STACK " " " D: SET 0FFFFH ; " " DIVIDE " " " E: SET 00000H ; " " EXTENDED ERROR MESSAGES IS OFF F: SET 0FFFFH ;DEFAULT FOR FLOATING POINT CHECKING IS ON. T: SET 00000H ; " " DEFAULT FOR TRACE OPTION IS OFFTE DEVNUM EQU 36 ; OFFSET OF DEVICE NUMBER ENTRY. BYTPT EQU 37 ; OFFSET OF BYTE POINTER/COUNTER ENTRY. LSBYT EQU 38 ; OFFSET OF LAST BLOCK BYTE COUNT. DATAB EQU 39 ; OFFSET OF DATA BUFFER ENTRY. SETRAN EQU 36 ; SET RANDOM RECORD FUNCTION FILCHR EQU EOFMRK ; BYTE TO PAD END OF FILE WITH. ; TXTBUF EQU BUFLEN+2+1+1 GETP EQU TXTBUF ; POINTS TO NEXT CHARACTER TO READ FROM BUFFER. PUTP EQU TXTBUF-1 ; Points to last character in buffer. $FXDCVT SET 0 ;SUBROUTINES TO ENTER AND EXIT A PROC/FCT ; NAME ENTEXT ENTRY ENTRSC,ENTER,EXITF EXT STKERR,CLSOT,fsub,flterr,MXOUT include deflt.src ; DSUB: MACRO Q,SIZE IF 0!SIZE&8000H ;;CHECK FOR FLOATING POINT SUBTRACTION CALL FSUB IF F ;;CHECK FOR ERROR IF REQUIRED JC FLTERR ENDIF ELSE ;;SUBTRACT Q OR DE FROM HL XRA A ;;CLEAR CARRY DSBC Q D ;;SUBTRACT IT ENDIF ENDMAC ;;DONE ; ; ENTRSC: INR A ;INDICATE STACK CHECKING ENTER: XTIX ;SAVE OLD DA POINTER LXI H,0 ;CLEAR OUT NEW;CHECK FOR SP >= TOH+MARGIN JC STKERR ;...STACK OVERFLOW ERROR RET ;ALL DONE ; ; ; EXITF: PUSH IX POP D ;DE <- IX DAD D ; ; IN ORDER TO CLOSE OUTPUT FILES CORRECTLY JUST ; CLOSE ALL FILES WHOSE BUFFER ADDRESS IS LESS THAN ; THE ADDRESS IN THE HL REGISTER PAIR ; B, C, D, E, H, L MAY BE CHANGED PLEASE LEAVE THE ; OTHER REGISTERS INTACT ( THE ACCUMULATOR HAS A ZERO ) ; PUSH Y ;SAVE Y INX Y LXI B,MXOUT ;B GETS MAX. NUMBER OF OUTPUT FILES XCHG ;NEW STACK POINTER IN DE SFLT: MO VALID: SET 00000H ;STATEMENT NUMBER ISN'T VALID ; ; ; PASCAL DEFAULTS ; CR EQU 13 ;CARRIAGE RETURN LF EQU 10 ;LINE FEED EOFMRK EQU 1AH ; Enf of file marker. BUFLEN EQU 80 ;SIZE OF PASCAL'S CONSOLE BUFFER. MARGIN EQU 50 ;STACK OVERFLOW MARGIN COMPILER EQU 0H ;TRUE IF ASSEMBLING THE COMPILER. MAXDRV EQU 16 ;MAXIMUM # OF DRIVES (USED BY FILNAM). RESTRT EQU 0 ;SYSTEM RESTART ADDRESS. CPM EQU 5 ; CP/M ENTRY ADDRESS. FCB EQU 0 RANREC EQU 33 ; OFFSET OF RAND.REC.BLOCK # LOW BY DA PUSH H PUSH B ;SAVE LEVEL NUMBER DAD S ;SP -> HL PUSH H ;THIS VALUE IS NEW DA POINTER AND XTIX DAD D ;SUBTRACT ROOM FOR VARIABLES POP D ;GET RETURN ADDRESS SPHL ;NEW SP PUSH D ;RETURN ADDR -> TOP OF STACK ORA A ;DO STACK CHECKING? RZ ;NO, JUST RETURN XRA A ;CLEAR ACCUMULATOR EXX MOV B,A ;CLEAR STATEMENT REGISTER MOV C,A PUSH H ;MOVE TOP OF THE HEAP EXX LXI D,MARGIN ;GET SAFETY MARGIN DSUB D ;SUBTRACT SAFETY MARGIN POP D ;GET TOP OF HEAP DSUB D V H,1(Y) ;GET POSSIBLE BUFFER ADDRESS MOV L,0(Y) MOV A,H ORA L ;CHECK FOR A ZERO JRZ FGT ;YES, DON'T TRY TO CLOSE IT PUSH H DSBC D ;SEE IF FILE IS BELOW THE STACK POP H JRNC FGT ;NO, DON'T CLOSE IT INX H ;POINT TO DOS BUFFER INX H INX H CALL CLSOT ;CLOSE THE FILE XRA A MOV 0(Y),A ;INDICATE THAT THIS SLOT IS EMPTY MOV 1(Y),A FGT: INX Y INX Y DJNZ SFLT XRA A ;ZERO A POP Y ;RESTORE Y SPIX ;NEW SP POP B ;SKIP LEVEL NUMBER XCHG ;RESTORE HL (NEW STACK POINTER) POP D ;GET RETURN VALUE POP X ;OLD DA POINTER POP B ;GET RETURN ADDRESS SPHL ;SET NEW STACK POINTER MOV H,B ;RETURN ADDRESS -> HL MOV L,C CMP E ;SET CARRY IF NECESSARY EXX ;CLEAR BC AS STATEMENT TRACE MOV B,A MOV C,A EXX PCHL ;RETURN  DJNZ SFLT XRA A ;ZERO A POP Y ;RESTORE Y SPIX ;NEW SP POP B ;SKIP LEVEL NUMBER XCHG ;RESTORE HL (NEW STACK PO; intrinsic function for e to the x ; NAME EXPFCT ENTRY EXPFCT,L133 EXT ABS,FPSQR,TRUNC INCLUDE DEFLT.SRC INCLUDE FCTMAC.SRC ; ; ; L118 EQU FPSQR L115 EQU ABS L129 EQU TRUNC ; ; ; function exp( x: real ):real; ; const yc = 0.34657359; ; a0 = 12.015017; ; a1 = -601.80427; ; b1 = 60.090191; ; log2e = 1.442695; ; var t1, ty, tn: real; ; t2, i: integer; ; begin L133: expfct: FC2285 ENTR D,2,16 ; t1 := x * log2e; LXI H,-4 DADD S SPHL XCHG PUSH IX POP H L for i := 1 to abs( t2 ) do tn := tn + tn; MOV -12(IX),A MVI -13(IX),1 PUSH IX POP H LXI B,-12 DADD B PUSH H MOV L,-15(IX) MOV H,-14(IX) CALL L115 XTHL FC2348 MOV D,M DCX H MOV E,M XTHL PUSH H GE D,0 JNC FC2349 inr -4(x) ;multiply by 2 by incrementing the exponent POP H XTHL INR M INX H JRNZ FC2369 INR M JV FC2370 FC2369 JMP FC2348 FC2349 POP D FC2370 POP D ; if t2 < 0 then tn := 1.0 / tn; MOV L,-15(IX) MOV H,-14(IX) MOV D,A MOV E,PUSH D MULT D,-4 LXI H,3 DADD S XCHG PUSH IX POP H LXI B,-8 DADD B XCHG LXI B,4 LDDR POP H POP H ; exp := tn * sqr( 1.0 + 2.0 * ty / (a0 - ty + (a1 / (b1 + sqr( ty ) ) ) ) ); LXI H,-4 DADD S SPHL XCHG PUSH IX POP H LXI B,-7 DADD B LXI B,4 LDIR LXI H,320 MOV D,A MOV E,A PUSH H PUSH D LXI H,576 MOV D,A MOV E,A PUSH H PUSH D LXI H,-4 DADD S SPHL XCHG PUSH IX POP H LXI B,-11 DADD B LXI B,4 LDIR MULT D,-4 LXI H,1120 ; end; EXIT D,4 ; -4 LXI H,2763 LXI D,14780 PUSH H PUSH D LXI H,1656 LXI D,11821 PUSH H PUSH D LXI H,-4 DADD S SPHL XCHG PUSH IX POP H LXI B,-11 DADD B LXI B,4 LDIR CALL L118 DADD D,-4 FDVD D,-4 DADD D,-4 FDVD D,-4 DADD D,-4 CALL L118 MULT D,-4 LXI H,3 DADD S XCHG PUSH IX POP H LXI B,15 DADD B XCHG LXI B,4 LDDR POP H POP H XI B,8 DADD B LXI B,4 LDIR LXI H,348 LXI D,21789 PUSH H PUSH D MULT D,-4 LXI H,3 DADD S XCHG PUSH IX POP H XCHG LXI B,4 LDDR POP H POP H ; t2 := trunc( t1 ); LXI H,-4 DADD S SPHL XCHG PUSH IX POP H DCX H DCX H DCX H LXI B,4 LDIR CALL L129 MOV -14(IX),D MOV -15(IX),E ; tn := 1.0; LXI H,320 MOV D,A MOV E,A PUSH H PUSH D LXI H,3 DADD S XCHG PUSH IX POP H LXI B,-4 DADD B XCHG LXI B,4 LDDR POP H POP H ; A LESS D,0 JNC FC2372 LXI H,320 MOV D,A MOV E,A PUSH H PUSH D LXI H,-4 DADD S SPHL XCHG PUSH IX POP H LXI B,-7 DADD B LXI B,4 LDIR FDVD D,-4 LXI H,3 DADD S XCHG PUSH IX POP H LXI B,-4 DADD B XCHG LXI B,4 LDDR POP H POP H FC2372 ; ty := (t1 - t2) * yc; LXI H,-4 DADD S SPHL XCHG PUSH IX POP H DCX H DCX H DCX H LXI B,4 LDIR MOV L,-15(IX) MOV H,-14(IX) PUSH H CVTF B DSUB D,-4 LXI H,-168 LXI D,-18165 PUSH H LXI D,7873 PUSH H PUSH D LXI H,-4 DADD S SPHL XCHG PUSH IX POP H LXI B,-11 DADD B LXI B,4 LDIR DSUB D,-4 LXI H,2763 LXI D,14780 PUSH H PUSH D LXI H,1656 LXI D,11821 PUSH H PUSH D LXI H,-4 DADD S SPHL XCHG PUSH IX POP H LXI B,-11 DADD B LXI B,4 LDIR CALL L118 DADD D,-4 FDVD D,-4 DADD D,-4 FDVD D,-4 DADD D,-4 CALL L118 MULT D,-4 LXI H,3 DADD S XCHG PUSH IX POP H LXI B,15 DADD B XCHG LXI B,4 LDDR POP H POP H ;CLOSE OUTPUT FILES WHEN ERROR DETECTED ; NAME ERROR ENTRY ERROR,L0 EXT PSTAT,TIN,CLSOT,MXOUT include deflt.src ; ERROR: EXX ;CHECK STATEMENT NUMBER MOV A,B ORA C CNZ PSTAT ;PRINT NON-ZERO STATEMENT NUMBER EXX ERR1: CALL TIN ;ERROR EXIT ROUTINES ARE THE SAME JRNC ERR1 ;AS NORMAL EXIT BUT EMPTY TXTIN FIRST ; ; L0: INX Y LXI B,MXOUT ;CLOSE ALL REMAINING OPEN OUTPUT FILES L0A: MOV H,1(Y) ;GET NEXT ADDRESS MOV L,0(Y) ;AND CHECK FOR NON-ZERO INX Y ;BUMP POINTER INX Y M;ROUTINES FOR EOLN,EOF,AND FOR FILLING THE TXTIN BUFFER ; NAME EOFLN ENTRY EOLN,EOF,FTXTIN,L120,L121,L124 EXT TOUT,TIN,MTRUE,MTRUE1,FALSE INCLUDE DEFLT.SRC ; ;EOLN RETURNS THE CARRY SET IF THE END OF LINE FLAG IN THE BUFFER ;IS SET AND RETURNS THE CARRY RESET IF IT ISN'T. IT EXPECTS HL TO CONTAIN ;THE FILE BUFFER ADDRESS. ;MUST BE CALLED WITH A 0 ;EOLN( 0 ) IS DEFINED AS EOLN ON THE CONSOLE ;EOLN MUST PRESERVE REGISTERS BECAUSE IT IS CALLED BY INPUT ROUTINES L120: EOLN: XRA A PUSH H RETURNS THE CARRY SET IF END OF FILE IS TRUE AND RESET IF IT IS ;FALSE. IT EXPECTS HL TO CONTAIN THE BUFFER ADDRESS. ;A REG MUST BE 0 L121: EOF: XRA A CMP H ;FOR CONSOLE FILES END OF FILE IS ALWAYS FALSE JZ FALSE BIT 1,M ;EOF FLAG,BIT 1 OF BYTE 1 OF BUFFER JNZ MTRUE JMP FALSE ;FTXTIN ALLOWS THE USER TO FILL THE PASCAL TXTIN BUFFER L124: FTXTIN: MOV H,A ;SET HL TO LENGTH OF STRING+1 MOV L,C INX H DAD SP ;POINT TO STRING PUSH H ;SAVE THIS POINTER MOV B,C ;MOVE COUNT TO B;UNSTRUCTURED RELATIVE OPERATORS ; NAME URELOP ENTRY ILE,ILT,IGE,IGT,MTRUE,FALSE,MTRUE1 ; ;UNSTRUCTURED RELOPS ;HLDE ; CMPINT: MACRO CARRY ;SUBTRACT DE FROM HL AFTER INITIALIZING CARRY XRA A ;CLEAR ACCUMULATOR IF CARRY STC ENDIF DSBC D ENDMAC ;GREATER THAN OR EQUAL TO IGE: MOV A,H ;TEST FOR LIKE SIGNS XRA D JM GDIFF ;NO! CMPINT 0 ;COMPARE INTEGERS CMC ;CARRY WAS CLEAR IF HL >= DE RET ;LESS THAN OR EQUAL TO ILE: MOV A,H ;TEST FOR LIKE SIGNS XRA D JM LLAR H ;SET CARRY IF HL < 0 RET MTRUE: XRA A ;CONDITION IS TRUE, CLEAR A, SET CARRY STC RET MTRUE1 POP D POP H JR MTRUE FALSE: XRA A ;CONDITION IS FALSE, CLEAR A, RESET CARRY RET EST FOR LIKE SIGNS XRA D JM LDIFF ;NO! CMPINT 0 ;COMPARE INTEGERS RET ;CARRY IS SET IF HL < DE ; SIGNS DIFFERENT ON A > OR >= TEST GDIFF: MOV H,D ;REVERSE THE NEXT TEST ; SIGNS DIFFERENT ON A < OR <= TEST LDIFF: XRA A ;CLEAR ACC SOV A,H ORA L INX H ;ADD 3 TO POINTER IN CASE INX H ;IT'S A FILE POINTER INX H CNZ CLSOT ;CLOSE FILE FOR NON-ZERO POINTER DJNZ L0A ;GO CHECK NEXT POINTER IF THERE IS ONE JMP RESTRT ;ALL DONE ; EXIT ROUTINES ARE THE SAME JRNC ERR1 ;AS NORMAL EXIT BUT EMPTY TXTIN FIRST ; ; L0: INX Y LXI B,MXOUT ;CLOSE ALL REMAINING OPEN OUTPUT FILES L0A: MOV H,1(Y) ;GET NEXT ADDRESS MOV L,0(Y) ;AND CHECK FOR NON-ZERO INX Y ;BUMP POINTER INX Y MCMP H ;CHECK FOR CONSOLE POINTER JRNZ FEOLN ;NO...CHECK FILE EOLN PUSH D LHLD 6 LXI D,-PUTP DAD D MOV A,M ; A := fill pointer. DCX H CMP M ; fill pointer - text_in_pointer JC MTRUE1 ; Branch if end of line. MOV E,M MVI D,0 DAD D INX H ; HL points to next character to read. MOV A,M CPI CR ; EOLN is also true if we about to read a CR. JZ MTRUE1 POP D POP H JMP FALSE FEOLN: BIT 0,M ;TEST EOLN FLAG, BIT 0 OF BYTE 1 OF BUFFER POP H JZ FALSE JMP MTRUE ;EOF -REGISTER FTXT2: CALL TIN ;FIRST EMPTY THE BUFFER CPI CR JRNZ FTXT2 FTXT3: MOV C,M ;GET CHAR CALL TOUT DCX H ;BUMP POINTER DJNZ FTXT3 ;CHECK FOR MORE MVI C,CR CALL TOUT ;ADD A CR POP H POP D ;GET RETURN ADDRESS INX H ;FIX STACK SPHL XRA A XCHG ;AND... PCHL ;...RETURN T HL TO LENGTH OF STRING+1 MOV L,C INX H DAD SP ;POINT TO STRING PUSH H ;SAVE THIS POINTER MOV B,C ;MOVE COUNT TO BDIFF ;NO! CMPINT 1 ;COMPARE INTEGERS RET ;CARRY IS SET IF HL <= DE ;GREATER THAN IGT: MOV A,H ;TEST FOR LIKE SIGNS XRA D JM GDIFF ;NO! CMPINT 1 ;COMPARE INTEGERS CMC ;CARRY WAS CLEAR IF HL > DE RET ;LESS THAN ILT: MOV A,H ;TEST FOR LIKE SIGNS XRA D JM LDIFF ;NO! CMPINT 0 ;COMPARE INTEGERS RET ;CARRY IS SET IF HL < DE ; SIGNS DIFFERENT ON A > OR >= TEST GDIFF: MOV H,D ;REVERSE THE NEXT TEST ; SIGNS DIFFERENT ON A < OR <= TEST LDIFF: XRA A ;CLEAR ACC S