IMD 1.18: 22/01/1996 6:45:07 micro cornucopia kaypro user group disk 16 pascal     PC SUBXA PCOCOMPARE COM FWD PASHW5 PASr HW5DATA EX14 COMPFET COM6 !"PFET PASW#$%&'()*+,-PLAYKAL PASb./0123456789:PLAYDATA ;PPC COM<=>?@ABCDEFGHIJKPPC PASLMNOPQRSTUVWXYZ[PPC PASN\]^_`abcdeREGEN DOCfghRTP ASMVijklmnopqrsppc $1.pas a.pco ^| pfet a.pco a.oco era a.pco pip $1.com=rtp.com,a.oco[ov] era a.oco RTP COM tuPASYNTAXDOC/vwxyz{POPS DOC|}PSTACK DOC ~EQ COMSTIRLINGPASTESTER PASVALIDATESUBXA OCOEQ PAS POWTWO PASDISK DOCSTIRLINGCOMHW5 COM*PPC DOC[EX14 DOC/CRC DOCCRC COMPASCAL DOC16-DISK DOCCRCKLISTCRC     h      $ F h  $ F       $ F    4!FILES UNEQUAL AFTER $  PLAST DATA READ FROM FILE 1: $ *-,~ ʨ w w ڱұ_:<2<2͝ $ 2> w>(_͜͜:2>)w\Ð|*w,"!~0Y24+EOF FILE 1, NOT FILE 2 $  X:Yg^EOF FILE 2 BEFORE FILE 1 $  ͂FILES MATCH, LENGTH IS $   Ð ڥ0_w#¶N BYTES $2>)w\Ð|*w,"!~0*w#"wɯ2^2r!"u"wR<   NO FILE1 FILE$!l. ;U ]!mͶD~# ;!\R ;*Q*S}|ڮ!"S*Q{zҠ*O.š*S"Sl*S"Q!"S*O*Q}>*S#"Sɯ2:2N!"Q"S.<  NO FILE2 FILE$G  = 5; (* pointer to right brother offset *) lev = 6; (* node level number *) lexp = 7; (* pointer to lexicographic predecessor *) lexs = 8; (* pointer to lexicographic successor *) nil = 0; (* zeroth element never used *) sent = '$';(* sentinal character *) maxint = 32767; (* kludge cause not defined by compiler *) type ary = array[0..dim] of word; boolean = (false, true); (* kludge till compiler is done *) var (* global va readnode until (ch=sent); (* done reading nodes *) rmost:=p; (* record pointer to right most node *) h[p+rforst]:=nil; (* right most node has no right brother *) h[p+lexs ]:=nil (* right most node has no lexicographic successor *) end; (* procedure readtree *) (* given a forest of trees (all leaves when we start), build them into a single tree using phase 1 of the hu-tucker algorithm. the root of the resultant tree will be in lmost on exit. the algorithmget#0(c); frq:=0; while (c>='0') and (c<='9') do begin frq:=frq*10+c-'0'; get#0(c) end (* while *) end; repeat get#0(c) until (c=10) (* ignore till lf found *) end; (* readnode *) begin readnode; (* readln(ch, frq); *) prev:=nil; (* no left forest for first node *) repeat new(var p); if (prev=nil) then lmost:=p; (* record pointer to first node *) h[p+char  against the sum of the frequencies of the trees under consideration. *) procedure picklr; var i,j : word; (* pointers to left and right nodes which are mininimum pair candidates *) minsum : word; (* mininimum sum found so far *) (* compare the sum of the frequencies of nodes i and j. if their sum is less than the minimum found so far, then record the new minimum (in minsum) and the position of i andriables *) h : ary; (* the heap *) hp : word; (* the heap pointer *) lmost, rmost : word; (* left and right most ends of the list *) lexfirst : word; (* pointer to first node in lex order *) procedure new(var p:word); begin hp:=hp+1; p:=hp*rl; if (p>dim-rl) then put#1('heapover') end; (* procedure new *) (* read a sequence of characters and weights from the standard input file and create a node for each pair. the nodes are li is implemented using two internal procedures.the first (picklr) chooses two trees for combination, and the second (combinelr) combines the two chosen trees to form new internal node in the final tree. this process is repeated unitl the forest contains only one tree. *) procedure build1tree; var left, rite : word; (* pointers to nodes to be combined *) (* pick two trees from the forest which satisfy the following rules: let i and j be pointers to the left and ]:=ch; h[p+freq ]:=frq; h[p+lst ]:=nil; (* leaves have no subtrees *) h[p+rst ]:=nil; h[p+lforst]:=prev; (* link to last node read created *) h[p+lexp ]:=prev; (* predecessor is also last node created *) if (prev<>nil) then begin (* on all but first node . . . *) h[prev+rforst ]:=p; (* make previous right forest pointer and *) h[prev+lexs ]:=p (* lexicographic successor point to the new node *) end; prev:=p;  j as the two best candidates for combining. *) procedure takemin; begin if (h[i+freq]+h[j+freq]nil) do begin (* more i's to test *) j:= h[i+rforst]; nked into a doubly linked list to form a forest as they are read. *) procedure readtree; var ch : word; (* node value *) frq : word; (* frequency *) p : word; (* pointer to new node *) prev: word; (* pointer to previous node read (for linking) *) procedure readnode; var c : word; begin get#0(ch); (* get node value character *) if (ch<>sent) then begin get#0(c); while (c=' ') do right trees i) no external nodes occur between i and j. ii) the sum of the weights of i and j is minimal for all i and j satisfying rule (i). iii) the index i is minimal for all i satisfying rules (i), (ii). iv) the index j is minimal for all j satisfying rules (i), (ii), (iii). pointers to the two trees chosen will be left in left and rite (respectivly). one internal procedure is used to compare the minimum sum found so far  (* compare to internal nodes till exeternal is found *) while (h[j+char]=sent) do begin takemin; j:=h[j+rforst] (* on to the next tree *) end; (* j now points to only external node candidate *) takemin; i:=h[i+rforst ] (* move to next tree in forest *) end (* while not out of i's *) end; (* procedure picklr *) (* combine the two trees pointed to by left and rite to form a new internal node  of the resultant tree will be in lexfirst on exit. the algorithm is implemented using two internal procedures. the first (picklr) chooses two trees for combination, and the second (combinelr) combines the two chosen trees to form a new internal node in the final tree. this process is repeated unitl the forest contains only one tree. the procedure used is very similar to that used to build the tree in phase 1. *) procedure build3tree; var maxlev : word; (* largest level iw node *) if (h[left+lforst]<>nil) then h[h[left+lforst ]+rforst ]:=newn; h[h[left+rforst ]+lforst ]:=newn; (* delete rite node *) h[h[rite+lforst ]+rforst ]:=h[rite+rforst]; if (h[rite+rforst]<>nil) (* rite has a right neighbor *) then h[h[rite+rforst ]+lforst ]:=h[rite+lforst]; (* update leftmost and rightmost pointers *) if (lmost=left) then lmost:=newn; if (rmost=rite) then rmost:=h[rite+lforst] end; (* procedurpick two trees from the forest which satisfy the following rules: let i and j be pointers to the left and right trees: i') the trees i and j must be adjacent in the working sequence. ii') the levels of trees i and j must be maximal among all remaining levels. iii') the index i is minimal for all i and j satisfying rules (i'), (ii'). a pointer to the left most chosen will be left in left. the right tree chosen is its lexin the final tree. link this new node into the existing forest in place of the left tree. the rite tree is deleted from the forest. pointers to the leftmost and rightmost (lmost and rmost, respectivly) are updated in the process. the frequency of the new new node becomes the sum of the frequencies of its offspring. *) procedure combinelr; var newn : word; (* pointer to new node created *) begin new(var newn); (* get pointer to new n tree *) picklev: word; (* level of node now being picked *) left : word; (* left most node to be replaced *) (* setlev will traverse the tree generated in phase 1 and assign levels to each of the nodes. also, the deepest level reached will be recorded in maxlev on exit. *) procedure setlev; (* traverse a node of a tree pointed to by the first argument, assigning it the level passed in the second argumente combinelr *) begin (* procedure build1tree *) repeat picklr; combinelr; put#1('.'); (* show progress on screen . . . *) until (lmost=rmost) (* only one node left *) end; (* procedure build1tree *) (* given the tree built in phase 1, traverse it (in order will do) and assign a level to each node. then return to the original forest of trees (all leaves when we start), build them into a single tree using phase 3 of the hu-tucker algorithm. the rooticographic successor. *) procedure picklr; var picked : boolean; (* true if one picked on this lev el *) begin picked:=false; while (picked=false) do begin left:=lexfirst; (* start with first node in lexicographic order *) while (left<>nil) and (picked<>true) do if (h[left+lev]=picklev) then picked:=true else left:=h[left+lexs]; if (picked=false) then picklev:=picklev-1 end (* while node on heap *) h[newn+char]:=sent; (* init all internal nodes to sent char *) h[newn+freq]:=h[left+freq]+h[rite+freq]; (* link to left and right subtrees (offspring) *) h[newn+lst]:=left; h[newn+rst]:=rite; (* link new node into the forest in place of old left *) (* first, make new node to point to its neighbors in the forest *) h[newn+lforst ]:=h[left+lforst]; h[newn+rforst ]:=h[left+rforst]; (* second, make neighbors point to ne. *) procedure travinord(p : word ; curlev : word); begin if (p<>nil) then begin if (curlev>maxlev) then maxlev:=curlev; travinord(h[p+lst], curlev+1); h[p+lev]:=curlev; travinord(h[p+rst], curlev+1) end end; (* procedure travinord *) begin (* procedure setlev *) maxlev:=0; travinord(lmost, 0) (* root is leftmost node *) end; (* procedure setlev *) (*   *) end; (* procedure picklr *) (* combine the tree pointed to by left and its lexicographic successor to form a new internal node in the final tree. link this new node into the existing lexicographic sequence in place of the left tree and its successor. the pointer to the first node in the sequence (lexfirst), is updated in the process. *) procedure combinelr; var newn : word; (* pointer to new node created *) rite : word; (* pointe) put#1(13,10); put#1('decoded ', 'message ',13,10); eof:=false; getoz; while (eof=false) do begin p:=lexfirst; (* start at root of phase 3 tree *) while (h[p+char]=sent) do begin (* while at internal node *) if (ch='0') then p:=h[p+lst] (* left turn *) else p:=h[p+rst]; (* right turn *) getoz end; (* while at internal node *) put#1(h[p+char]) end (* while not eof *) end; (* procedure decode *v#,13,10); picklev:=maxlev; repeat picklr; combinelr; put#1('.') (* show progress on screen . . . *) until (picklev<=1) (* true when all nodes have been picked *) end; (* procedure build3tree *) (* decode a sequence of 1's an 0's read from the standard input file into a sequence of characters written to standard output. this is done by starting at the root and taking a left when a zero is read, a right when a one is read. this is continued unitl a leA 622 B 132 C 311 D 297 E 1053 F 168 G 165 H 363 I 614 J 6 K 31 L 307 M 248 N 573 O 606 P 189 Q 10 R 587 S 581 T 768 U 227 V 70 W 113 X 25 Y 107 Z 6 1821 $ 00001111001111010010100010101100011110100011010000011011110111 01000010001101110111011000011010011011001000100011111 100011011000011010111110001001001111 1011011001001000011011111110111101110001001010100011011010111111 000111000010001 r to right node being combined *) begin new(var newn); rite:=h[left+lexs]; (* right node is allways next in lex order *) h[newn+char]:=sent; (* init all internal nodes to sent char *) (* link left and right subtrees to new node *) h[newn+lst]:=left; h[newn+rst]:=rite; (* level of new node is one less than level of its offspring *) h[newn+lev]:=h[left+lev]-1; h[newn+lexs]:=h[rite+lexs]; h[newn+lexp]:=h[left+lexp]; (* ) begin (* main line *) hp:=0; (* initialize heap pointer *) readtree; lexfirst:=lmost; (* first node in lex order is leftmost *) build1tree; build3tree; decode end. af is reached, when the character in that leaf is printed. this process is repeated until end-of-file is found. *) procedure decode; var eof : boolean; ch : word; (* last one or zero read from input *) p : word; (* pointer used to traverse tree *) procedure getoz; begin get#0(ch); while (ch=13) or (ch=10) or (ch=' ') do get#0(ch); if (ch=26) then eof:=true end; (* procedure getoz *) begin (* prodecure decode *link new node in place of left node from left *) if (h[left+lexp]<>nil) then (* left has a lex predecessor *) h[h[left+lexp]+lexs]:=newn; if (h[rite+lexs]<>nil) then (* right has a lex successor *) h[h[rite+lexs]+lexp]:=newn; if (left=lexfirst) then (* new node becomes lex first *) lexfirst:=newn end; (* procedure combinelr *) begin (* procedure build3tree *) setlev; (* compute node levels *) put#1(13,10); put#1('maxlev =',maxle  !9"$1>2ͤ*?*}_|W!x< ~#/bkxp :/<2/Z~#2.:.2.lA+";#:o&6 !S0> 2*h:!"2>2!"4*2#"2:  G*4H'6 #6 #"4òe!='2|\<%!]&6.#e&6$z*4!"4\%*46"6}|q2&2'2(28!"2*;"9"= „2u| > 2O:&yʯ;A^$2) O:8yuNu͒:; ?|$%.ʘ#ʓ<ʪ>y arguments - $EX 1.4 11-22-82$ $ppppppppppppppppppppppppppppppppI"""~+"21*|g."*" *! 1*~*"*"#^#V!_:O*AâÐu!9"!ͥ͢ʽ½ͥ*#w">*:2́a OC[[ 2> O:y½ͨÚ*"222Úͥ͢ʽ 7ͨOL*q!"q*q!1*K ^#V> H*q!"q*q!r*K ^#V> *K ^#V> H*q!"q*q! *K ^#V> *K ^#V> *K ^#V> H*q!"q*q!$ *K ^#V>  *K ^#V>ù>ù>ù>ù> > 2)u!A0> 2*h> ~!)w¹O:(yʹ:&yʹ#!):8=28ʏ jw:8ʉ> > ~> ~>ù>!(£w>ù>2)!&u2&2'ù>2)!'u2'2&ù*6}|ʉw+*###>E#>X#>Oͤ*$:6+6} %. 6+6X+6E+:w+:w+6*'ͤͤͤͤ*,ͪ fͤ ͤͤ zͤ|`ڣ{G @;:?$.#<>G@G$^|1Y:Y12+!U _^#V{ Zãî-:M\zÆÜ<?óRTP REV 00.8R*."KlͲ:] |?|x2'!\ͧ:m ʙ?ʙx2(!lͧ w#©:'2<!"+:(<2!!"-*K^#V=z z>z{:'$:*$**+}R/!/~#"+O:(l:)lysY*-}/œ!w#"-2*o&2)}X ھ> |Ļ0X2)͸2)}X|X:(>su u!Kw!Ww2*"x: :y2è*~+"*#"**{z­og"!m*å1!J!m*! (~#:!0:A[a{2:~$#Oͨ!A!!u >>>Ex Aborted<<< $ (Ex Active)$ (Ex Completed) >$ßâåèBDOS>   "IH! !B"$$HB!$BD$$$$H"D $$I """~+"21*| *K ^#V> *K ^#V> H*K ^#V>E33*K ^#V!9>E33H*K ^#V>E33*K ^#V'>E33H*q!5*q!Ҵ'REVO DC*>!> "q> "q*q*q*q!6!# s#r> "q> "q*q*q!6"q*q*q!J s#r*q!"qÎ*q!#^#V"q*q!9"q*q*q!63"q*q!J^#V"q*q!"qH;;!*K s#r!*K ^#Vʽ1 !P> *K ^#V!^#V>! > *K ^#V!^#V>w+#~!A:+P_^#V{P w#&*2#"2!)6!86kb"0"9 :(:&:8<28", ʜ os#r#:*b ʜ ‰o>  ~ µ> #_ê!ͤ@ͤ*2*0~# 6 ~#_   |{0_~#'_x{ w#0SUB error line # $ (Ex Already Present)$ Text buffer empty$ Input/EX Buffer Overlap$ No parameter or default parameter$ Parameter$ File filename.typ$ not there$ Control character$ Too man:-<" disk error$>V#^#=0 >V+^+=A`i>s#r#=P`i!9u# j㯓_WDM!yʙ Ïů_Wک`i*K!9"K*K!9"K*K"K  ! > ! > *K ^#V#*K s#ræ33H*q![ !![>E3333o !!0[>E3333H;;*q*K s#r*K ^#V! !!*q3[>E3333!*!K[>E3333! >E33d *K ^#V! !!*q*q[>E3333d !>*K ^#V4>E3333!![>E3333!!*q3[>E3333!>E33H*q! *K ^#V!^#V!ʷ *K ^#V!^#V*K s#r !P> *K ^#V>'DNIFEDNU>!! > ! > H*q*q*q;;*qg >E33[>E3333R!R!;;*qg >E33[>E3333R33c!} >E!>E33c!!>*q4>E3333!! !*q6[>E3333c! r >E!!!!^>E!9!#!V!u>E!9c! `r >E!!! ! >E!9!s!#!ru>E!9c!›!!)!!>E!9!>E33c!r >E!V!!3u>E!9c!r >E!!;!su>E!9c+!u>E!9k!@!!!u>E!9k' RPO DAB>!*q>! > ! > 33c!*q!¸!**q*q[>E3333!>E33r >E!^!#!V!>E!9c!P*q!(!>E33!"*q*q[>E3333Mr >E!!s!#!r>E!9c!!;;*qg >E33[>E3333*q!¢!!B[>E3333!>*q4>E3333!!E[>E3333c!µ*q!!3>=*q!!s!#>E!9!r>E33c!8c'PO-P DAB>!*q>! > ! > 33H*K ^#V"q!"q>E*q!ʠ >E%*q!*q!'REVO BL*>!*q*q! s#r%*q!^#V*q%'RE ESAHP>!'P ROR>!*q>*q!*q!I*q"qH'VER TEFP>!! > !>!.> !>!>!R> ! > ! > !"q!*q*q!! s#r*q#"qð33!"q' 1 SSAP>!! >*q!9>E!9H*q!M !!!?!>E!9Ì !v !!!u>E!9Ì ! !>!4>E3333!*q![>E3333!*q![>E3333!=>E33Ì !J !>!4>E3333!*q![>E3333!*q![>E3333!=>E33Ì !h !>E33Ì !Œ !?!4>E3333Ì 33H*q! !!*q[>E3333!>E33c!p*q! !!H[>E3333k!!*!!V!!3>E!9c!W!!;!!s>E!9c!!„!!!!>E!9c!r >E!!!^u>E!9!!!u>E!9c!r >E!!! !s>E!9c! G!!'[>E3333>E >E>E >Ec! sr >E!!*[>E3333c! Ÿr >E!!-[>E3333c! !!)!)!)>E!9!!!u>E!9c!!>E33?Ѣʃ!"q*q*q$@!;>E33*q#"q33!!3"q*q*q~!3>E33*q+"qU33ò!!!*q3[>E3333!9!4>E3333c!!;;*qg >E33[>E3333c!W*q!&!;;*qg >E33[>E3333R!V!;;*qg >E33[>E3333R!¦!;;*qg >E33[>E3333!;;*qg >E33[>E3333R!!*q![>E3333!;;*qg >E33[>E3333R!"! ! > !hB33*q>'SEDOC-P >!' DAER >!! > ! > !"q' 2 SSAP>!! > ! > !hB33' !ENOD>!! > ! > >$) !!!!>E!9k!M !!3[>E3333k!q !!6[>E3333k!• !!9[>E3333k!µ 6 >E!"qk!  6 >E!"qk!  6 >E!"qk! 6 >E!"qk! 56 >E!"qk! U6 >E!"qk!‰ >E!!4>E3333!"qk!½ >E!!4>E3333!"qk!!!#!u>E!9!"qk!!!!!*[>E3333c!ˆ!!![>E3333!9!~!#!f>E!9!o>E33!!-[>E3333!>E33c!r >E!!!)u>E!9!)!)!u>E!9!!*[>E3333c!Œr >E!>E33!!![>E3333!9!~!#!f>E!9!o!)!)u>E!9!)!4>E3333!!-[>E3333!>E33c!²r >E!>E33c!!!^!#!V>E!9!>E33c!(!!  (* TITLE PASCAL FAST EXECUTION TRANSLATOR FILENAME PFET.PAS AUTHOR Robert A. Van Valzah 10/06/79 LAST REVISOR R.A.V. 01/14/80 REASON repaired bug in astoi code *) const vhu = 0; (* version number hundreds *) vtn = 0; (* tens *) vun = 8; (* units *) devrel = 'r'; (* development or release version *) nlab = 500; (* max number of p-labels *) codemax = 5000; (* max number of p-instructions *) ocode = 1536; (* object code base address *) rtporg = 256; (* run time package bas false *) (* global variables for procedure getpcd for speed *) adlo, adhi : word; (* global variables for function eieiadr for speed *) eii, eij, eik : word; (* global variables for procedure trans for speed *) transi : word; procedure co1b(ch: word); begin coa:=coa+1; if pass=2 then put#0(ch) end; (* co1b *) procedure co2b(c1,c2: word); begin coa:=coa+2; if pass=2 then put#0(c1,c2) end; (* co2b *) procedure co3b(c1,c2,c3: word); begin coa:=coa+3; ifodes *) cal, jpc, jump, lit, opr, lod, sto, int, csp, lodx, stox, alit, alod, asto, alodx, astox, pshf, clod, csto, clodx, cstox, halt, lab, peof, (* end of p-code file *) laa, lodi, stoi, clodi, cstoi, alodi, astoi, indx, aindx, cindx ); fflags = ( (* flags set when condition is false *) ifnz, ifz, ifcz, ifznc, ifnc, ifc ); labtyp = array[0..nlab] of word; codtyp = array[0..codemax] of word; var label : labtyp; (* label p-addresses *) adr : labtyp; (* label 8080 a) procedure varadr; var lev : word; begin lev:=l; if lev=0 then begin (* local ref *) coopad(lxib,0-a); coopad(lhld,br); co1b(dadb) end else if lev=255 then (* global ref *) coopad(lxih,a+glram) else begin (* intermediate ref *) co2b(mvia,lev); coopad(call,base); coopad(lxid,0-a); co1b(dadd) end end; (* varadr *) function eieiadr(pad: word (* p-code address *) ); begin if pass=2 then if adr[pad]<>0 then eieiadr:=adr[pad] else put#1('P',pad#,'undefie address *) (* runtime package entry points *) base = rtporg+3; cmpr = base+3; cspbase = cmpr+3; spalit = cspbase+30; spalod = spalit+3; spasto = spalod+3; acmpr = spasto+3; opr3 = acmpr+3; opr4 = opr3+3; opr5 = opr4+3; opr14 = opr5+3; opr15 = opr14+3; spcal0 = opr15+3; spcal = spcal0+3; spret = spcal+3; br = spret+3; (* 8080 instructions *) lhld = 42; shld = 34; pushh = 229; pushd = 213; pushb = 197; pushpsw = 245; poph = 225; popd = 209; popb = 193; sphl = 249; pchl  pass=2 then put#0(c1,c2,c3) end; (* co3b *) procedure co4b(c1,c2,c3,c4: word); begin coa:=coa+4; if pass=2 then put#0(c1,c2,c3,c4) end; (* co4b *) procedure coad(ad: word); begin co1b(ad); co1b(ad/256) end; (* coad *) procedure coopad(op,ad: word); begin co1b(op); coad(ad) end; (* coopad *) procedure getpcd; (* get next p-code to f, l, and a *) begin if pass=1 then begin if cix>codemax then put#1('*cd over'); get#0(f); get#0(l); fla[cix]:=f+l*256; ddresses *) fla : codtyp; (* p-code function & level *) aa : codtyp; (* p-code address *) f : word; (* current instruction function *) l : word; (* current instruction level *) a : word; (* current instruction address *) coa : word; (* code out address *) cx : word; (* p-code array index *) cix : word; (* number of p-codes read *) glram : word; (* base address of global ram *) pass : word; (* pass number *) lfl : fflags; (* flags set when last translated conditional is nd',13,10) end; (* eieiadr *) procedure dw2; begin co4b(f, l, a, a/256) end; (* dw2 *) procedure flagtoa; begin case lfl of ifnz: begin co4b(adi, 255, cmc, sbba) end; (* ifnz *) ifz: begin co3b(adi, 255, sbba) end; (* ifz *) ifcz: begin co2b(mvia, 0); coopad(jc,coa+7); coopad(jz,coa+4); co1b(dcra) end; (* ifcz *) ifznc: begin co2b(mvia, 0); coopad(jz,coa+6); coopad(jnc,coa+4); co1b(dcra) end; (* ifznc *) ifnc: co1b(sbba); ifc: begin co2b(cmc= 233; xchg = 235; xthl = 227; dadh = 41; dadsp = 57; dadd = 25; dadb = 9; call = 205; jmp = 195; jz = 202; jnz = 194; jnc = 210; jc = 218; mvia = 62; adi = 198; mvid = 22; lxih = 33; lxid = 17; lxib = 1; movem = 94; movdm = 86; movme = 115; movmd = 114; movbh = 68; movcl = 77; movam = 126; movhm = 102; movla = 111; movae = 123; cmc = 63; sbba = 159; dcra = 61; orad = 178; anad = 162; inxsp = 51; dcxsp = 59; dcxh = 43; inxh = 35; type pops = ( (* p-op c get#0(adlo); get#0(adhi); a:=adlo+adhi*256; aa[cix]:=a; cix:=cix+1 end else begin (* must be pass 2 *) a:=fla[cx]; (* use a as a temp *) l:=a/256; f:=a-l*256; a:=aa[cx]; cx:=cx+1 end end; (* getpcd *) procedure wrsym; var i : word; begin for i:=0 to nlab do begin put#1('P',label[i]#); put#1(' ',adr[i]#); put#1(13,10) end end; (* wrsym *) procedure gencmp; begin if l=0 then coopad(call,cmpr) else coopad(call,acmpr) end; (* gencmp *  , sbba) end (* ifc *) end (* case lfl of *) end; (* flagtoa *) procedure trans; begin case f of lit: begin coopad(lxih,a); co1b(pushh) end; opr: case a of 0: (* procedure return *) coopad(jmp,spret); 2: (* (top)=(top)+(top-1) *) begin co4b(popd, poph, dadd, pushh) end; (* case opr sub *) 3: (* (top)=(top)-(top-1) *) coopad(call,opr3); 4: (* multiply *) coopad(call,opr4); 5: (* divide *) coopad(call,opr5); 8: begin (* (top)=(top-1) condi: begin coopad(jc,eieiadr(a)); coopad(jz,eieiadr(a)) end; (* ifcz *) ifznc: begin coopad(jz,coa+6); coopad(jnc,eieiadr(a)) end; (* ifznc *) ifnc: coopad(jnc,eieiadr(a)); ifc: coopad(jc,eieiadr(a)) end (* case lfl of *) end; (* jpc *) pshf: begin flagtoa; co1b(pushpsw) end; (* pushf *) csp: begin co2b(mvia, l); coopad(call,cspbase+3*a) end; (* csp *) lodx: begin varadr; co4b(popd, dadd, dadd, movem); co3b(inxh, movdm, pushd) end; (* lodx *)(* case opr *) lod: begin if l=255 then begin (* global lod *) coopad(lhld,a+glram); co1b(pushh) end (* global *) else begin (* intermediate to local *) varadr; co4b(movem, inxh, movdm, pushd); end end; (* case lod *) sto: begin if l=255 then begin (* global sto *) co1b(poph); coopad(shld,a+glram) end else begin (* intermediate to local *) varadr; co4b(popd, movme, inxh, movmd) end end; (* sto *) cal: begin coopad(lxid,eieiadr(a)); if l=0nd; (* asto *) aindx: begin co4b(poph, dadh, dadh, dadh); co3b(popd, dadd, pushh) end; (* case aindx *) alodi: begin (* alfa load indirect *) co1b(poph); coopad(call,spalod) end; (* case alodi *) astoi: begin (* alfa store indirect *) coopad(lxih,8); co4b(dadsp, movam, inxh, movhm); co1b(movla); coopad(call,spasto); co1b(poph) end; (* case astoi *) alodx: begin varadr; co3b(popd, xchg, dadh); co3b(dadh, dadh, dadd); coopad(call,spalod) end; (* alodx *) asttional *) gencmp; lfl:=ifnz end; (* opr 8 *) 9: begin (* (top)<>(top-1) condtional *) gencmp; lfl:=ifz end; (* opr 9 *) 10: begin (* (top)<(top-1) conditinal *) gencmp; lfl:=ifcz end; (* opr 10 *) 11: begin (* (top-1)>=(top) conditonal *) gencmp; lfl:=ifznc end; (* opr 11 *) 12: begin (* (top-1)>(top) conditionla *) gencmp; lfl:=ifnc end; (* opr 12 *) 13: begin (* (top-1)<=(top) conditional *) gencmp; lfl:=ifc end; (* opr 13 *) 14: begin (* ( stox: begin varadr; co4b(popd, popb, dadb, dadb); co3b(movme, inxh, movmd) end; (* stox *) indx: begin (* index word array *) co4b(poph, dadh, popd, dadd); co1b(pushh) end; (* case indx *) clod: begin varadr; co3b(movdm, pushd, inxsp); end; (* clod *) csto: begin varadr; co3b(popd, dcxsp, movme) end; (* csto *) clodi: begin (* character load indirect *) co4b(poph, movdm, pushd, inxsp) end; (* case clodi *) cstoi: begin (* character store indirect *) co4b(p then coopad(call,spcal0) else begin co2b(mvia, l); coopad(call,spcal) end; end; (* cal *) int: begin if (a>=0-4) and (a<=4) then begin for transi:= 1 to a do co1b(dcxsp); for transi:= 0-1 downto a do co1b(inxsp) end else begin coopad(lxih,0-a); co2b(dadsp, sphl) end end; (* int *) jump: begin coopad(jmp,eieiadr(a)) end; (* jump *) jpc: begin case lfl of ifnz: coopad(jnz,eieiadr(a)); ifz: coopad(jz,eieiadr(a)); ifczox: begin varadr; co1b(xchg); coopad(lxih,8); co4b(dadsp, movam, inxh, movhm); co3b(movla, dadh, dadh); co2b(dadh, dadd); coopad(call,spasto); co1b(poph) end; (* case astox *) laa: begin varadr; co1b(pushh) end; (* case laa *) lodi: begin (* load word indirect *) co4b(poph,movem,inxh,movdm); co1b(pushd) end; (* case lodi *) stoi: begin (* store word indirect *) co4b(popd,poph,movme,inxh); co1b(movmd) end; (* case stoi *) peof: begin (* do nothing *) end (top)=(top-1) or (top) *) flagtoa; co2b(popd, orad); lfl:=ifz end; (* opr 14 *) 15: begin (* (top)=(top-1) and (top) *) flagtoa; co2b(popd, anad); lfl:=ifz end; (* opr 15 *) 19: begin (* increment (top) *) co3b(poph, inxh, pushh); lfl:=ifz end; (* opr 19 *) 20: begin (* decrement (top) *) co3b(poph, dcxh, pushh) end; (* opr 20 *) 21: begin (* copy (top) *) co3b(poph, pushh, pushh) end (* case opr 21 *) else put#1('bad opr ',a#,13,10) end; opd, dcxsp, poph, movme) end; (* case cstoi *) cindx: begin (* character array index *) co4b(poph, popd, dadd, pushh) end; (* case cindx *) clodx: begin varadr; co3b(popd, dadd, movem); co3b(mvid, 0, pushd) end; (* clodx *) cstox: begin varadr; co4b(popd, popb, dadb, movme) end; (* cstox *) alit: begin coopad(call,spalit); getpcd; dw2; getpcd; dw2 end; alod: begin varadr; coopad(call,spalod) end; (* alod *) asto: begin varadr; coopad(call,spasto) e  * case peof *) else put#1('bad p-op',f#,13,10) end (* case f of *) end; (* trans *) procedure pass12(ps: word); begin pass:=ps; coa:=ocode; repeat getpcd; if f<>lab then trans else if pass=1 then if a>nlab then put#1('*lb over') else adr[a]:=coa else (* pass = 2 *) if adr[a]<>coa then put#1('Phase er', 'ror P',a#) until f=peof; if pass=1 then glram:=coa end; (* pass12 *) begin (* main line *) (* zero all addresses for undefined label d procedure setbd *) function min(x, y : integer); begin if (xy) then max:=x else max:=y end; (* function max *) procedure getroot; begin get#0(ch); setbd(1, rleft ,ch-'0'); get#0(ch); setbd(1, rright ,ch-'0'); get#0(ch); setbd(1, rkal ,ch-'0'); get#0(ch); setbd(1, bleft ,ch-'0'); get#0(ch); setbd(1, brightAT = 9; (* 1 MEANS ON BEST PATH, 0 IF NOT *) OUTCOM = 10; (* 0 MEANS blue WIN, 1 MEANS DRAW, 2 MEANS red WIN *) ncols = 11; (* number of columns in bd matrix *) rwin = 2; (* outcom value for red win *) draw = 1; (* outcom value for draw *) bwin = 0; (* outcom value for blue win *) rturn = 0; (* turn value for red's turn *) bturn = 1; (* turn value for blue's turn *) left = 0; (* move from left pit *) right = 1; (* move from right pit *) offbespat moving : boolean; frompit, topit, sowston, pturn, (* rturn if red players turn, bturn otherwise *) i : integer; begin pturn:=board(father, turn); if (pturn=bturn) then if (sourcpit=left) then frompit:=bleft else frompit:=bright else (* must be red's turn *) if (sourcpit=left) then frompit:=rleft else frompit:=rright; (* put#0('frompit=',frompit#,13,10); *) for i:=rleft to ouetection *) (* use cix as temp index *) put#1('pfet rev',' ',vhu#,'.',vtn#,vun#,devrel,13,10); for cix:=0 to nlab do adr[cix]:=0; cix:=0; put#1('Pass 1 ',13,10); pass12(1); put#1(cix#,' p-codes', ' read ',13,10); cx:=0; put#1('Pass 2 ',13,10); pass12(2); put#1('done! ',13,10) end.  ,ch-'0'); get#0(ch); setbd(1, bkal ,ch-'0'); get#0(ch); setbd(1, turn ,ch-'0'); setbd(1, outcom , draw); setbd(1, bespat , offbespat) end; (* procedure getroot *) procedure prtrow(row : integer); begin put#0(13,10); put#0(' ', ' ', board(row, bright)#, ' ', ' ', board(row, bleft )#, 13,10); put#0(board(row, bkal)#, ' '); if board(row, outcom)=rwin then put#0('r', 'e', 'd', ' ') else if board(row, outcom)=draw then put = 0; (* bespat value if node is off best path *) onbespat = 1; (* bespat value if node is on best path *) type ary = array[0..1000] of integer; boolean = (false, true); var ch : integer; bd : ary; next : integer; (* row number of next "free" row in array board *) function board(row, col : integer); begin board := bd[row*ncols + col] end; (* function board *) procedure setbd(row, col, val : integer); begin bd[row*ncols + col] := val end; (*tcom do (* copy father board to son *) setbd(son, i, board(father, i)); (* test if able to move *) if (board(father, frompit)=0) (* if frompit has no stones *) or (board(father, bkal)>6) (* or blue has won *) or (board(father, rkal)>6) (* or red has won *) then (* unable to move *) setbd(son, turn, board(father, turn)) else (* still have move left *) if (board(father, turn)=rturn) then setbd(son, turn, bconst (* 'CONSTANT' VARIABLES USED TO REFERENCE COLS OF BOARD *) RLEFT = 0; (* STONES IN RED'S LEFT PIT *) RRIGHT = 1; (* STONES IN RED'S RIGHT PIT *) RKAL = 2; (* STONES IN RED'S KALAH *) BLEFT = 3; (* STONES IN BLUE'S LEFT PIT *) BRIGHT = 4; (* STONES IN BLUE'S RIGHT PIT *) BKAL = 5; (* STONES IN BLUE'S KALAH *) TURN = 6; (* -1 MEANS RED'S TURN, 1 MEANS BLUE'S TURN *) LSON = 7; (* ROW NUMBER OF LEFT SON *) RSON = 8; (* ROW NUMBER OF RIGHT SON *) BESP#0('d', 'r', 'a', 'w') else put#0('b', 'l', 'u', 'e'); put#0(' ', board(row, rkal)#, ' '); if (board(row, bespat)=onbespat) then put#0('this boa', 'rd is on', ' the bes', 't possib', 'le path.'); put#0(13,10); put#0(' ', ' ', board(row, rleft )#, ' ', ' ', board(row, rright)#, 13,10) end; (* procedure prtrow *) procedure compconf(father, son, sourcpit : integer); var sowopp,   turn) else setbd(son, turn, rturn); moving:=true; while (moving=true) do begin sowston:=board(son, frompit); (* put#0('sowston=',sowston#,13,10); *) setbd(son, frompit, 0); topit:=frompit; sowopp:=false; while (sowston>0) do begin topit:=topit+1; (* put#0('topit= ',topit#,13,10); *) if (topit>bkal) then topit:=rleft; if (topit=rkal) and (pturn=bturn) then topit:=bleft; if (topit=bkal) begin setbd(son, rkal, board(son, rkal)+board(son, bleft)); setbd(son, bleft, 0) end end end end (* while moving=true *) end; (* procedure compconf *) procedure growtree(root : integer); begin (* put#0('growtree',root#,13,10); *) compconf(root, next, left); (* attempt to grow left son *) if (board(root, turn)<>board(next, turn)) then (* there is a left son *) begin (* put#0('leftson ve *) else (* not a go again move *) moving:=false; (* check for capture *) if (board(son, topit)=2) or (board(son ,topit)=3) then (* capture possible *) begin if (pturn=bturn) and ((topit=rleft) or (topit=rright)) then begin setbd(son, bkal, board(son, bkal)+board(son, topit)); setbd(son, topit, 0); if (topit=rright) and ((board(son, rleft)=2) or (board(son, rleft (* init all nodes to "off best path" *) setbd(root, outcom, offbespat); findout(board(root, lson)); (* find outcome of left subtree *) findout(board(root, rson)); (* find outcome of right subtree *) (* determine outcome of father *) (* first, see if he has any sons *) if (board(root, lson)=0) and (board(root, rson)=0) then (* he has no sons *) (* determine outcome from pits *) if (board(r and (pturn=rturn) then topit:=rleft; (* put#0('topit= ',topit#,13,10); *) (* set sowopp to true if sowing into opponents pits *) if (pturn=bturn) then if (topit=rleft) or (topit=rright) then sowopp:=true; if (pturn=rturn) then if (topit=bleft) or (topit=bright) then sowopp:=true; setbd(son, topit, board(son,topit)+1); (* sow a stone *) sowston:=sowston-1 (* number to sow is ',13,10); prtrow(next); *) setbd(root, lson, next); (* link son to father *) next:=next+1; growtree(next-1) end else (* there is not left son *) setbd(root, lson, 0); compconf(root, next, right); (* attempt to grow right son *) if (board(root, turn)<>board(next, turn)) then (* there is a right son *) begin (* put#0('rightson',13,10); prtrow(next); *) setbd(root, rson, next); (* link son to father *) next:=next+1; gr)=3)) then begin setbd(son, bkal, board(son, bkal)+board(son, rleft)); setbd(son, rleft, 0) end end; if (pturn=rturn) and ((topit=bleft) or (topit=bright)) then begin setbd(son, rkal, board(son, rkal)+board(son, topit)); setbd(son, topit, 0); if (topit=bright) and ((board(son, bleft)=2) or (board(son, bleft)=3)) then oot, bkal)>6) then (* blue has won *) setbd(root, outcom, bwin) else (* either red win or draw *) if (board(root, rkal)>6) then (* red has won *) setbd(root, outcom, rwin) else (* neither won, therefore draw *) setbd(root, outcom, draw) else (* he has at least one son *) (* determine outcome from sons *) one less now *) end; (* while sowston>0 *) (* check for go again, set moving *) if (sowopp=true) and (board(son, topit) > 1) then if ( (pturn=bturn) and ((topit=bleft) or (topit=bright)) ) or ( (pturn=rturn) and ((topit=rleft) or (topit=rright)) ) then (* a go again move *) begin moving:=true; frompit:=topit end else moving:=false (* not a go again moowtree(next-1) end else (* there is no right son *) setbd(root, rson, 0) end; (* procedure growtree *) procedure prttree(root : integer); begin if (root<>0) then begin prttree(board(root, lson)); (* print left subtree *) prtrow (root); (* print the node *) prttree(board(root, rson)) (* print right subtree *) end end; (* procedure prttree *) procedure findout(root : integer); begin if (root<>0) then begin    if (board(root, lson)=0) (* if no left son *) then (* outcome is from right son *) setbd(root, outcom, board( board(root, rson), outcom) ) else (* he has a left son *) if (board(root, rson)=0) (* if no right son *) then (* outcome is from left son *) setbd(root, outcom, board( board(root, lson), outcom) ) p:=board(p, lson) (* go left *) else (* right is better ro = *) p:=board(p, rson) (* go right *) end; (* while not a leaf *) setbd(p, bespat, onbespat) (* final leaf is on best path *) end; (* procedure findbespat *) begin (* main line *) getroot; while (ch-'0'<>2) do (* do while not eof *) begin put#0(13,10,13,10); put#0('root boa', 'rd is '); prtrow(1); nex (* root has no left son *) p:=board(p, rson) (* move on right son *) else if (board(p, rson)=0) then (* root has no right son *) p:=board(p, lson) (* move on to left son *) else (* root has both sons *) if (board(p, turn)=bturn) (* if blue's turn *) then (* see if left outcom is better than right *) if ( board( board(p, lson), outcom) <= board( board(p, rson), outcom) 025113111302512221321611112022222202222222  else (* he has both sons *) if (board(root, turn)=bturn) then (* outcome is minimum of sons' outcomes *) setbd(root, outcom, min(board( board(root, lson), outcom), board( board(root, rson), outcom) ) ) else (* outcome is maximum of sons' outcomes *) setbd(root, outcom, t:=2; (* row 2 is first free row *) growtree(1); findout(1); findbespat; put#0(13,10,13,10); put#0('output t', 'ree '); prttree(1); getroot end end.  ) then (* left is better or = *) p:=board(p, lson) (* go left *) else (* right is better *) p:=board(p, rson) (* go right *) else (* it must be red's turn *) if ( board( board(p, lson), outcom) >= board( board(p, rson), outcom) ) then (* left is better or = *)  max(board (board(root, lson), outcom), board (board(root, rson), outcom) ) ) end (* if root<>0 *) end; (* procedure findout *) procedure findbespat; var p : integer; (* work pointer used to traverse tree *) begin p:=1; (* loop unitl leaf is found *) while (board(p, lson)<>0) or (board(p, rson)<>0) do begin setbd(p, bespat, onbespat); if (board(p, lson)=0) then  Zãî-:M\zÆÜ<?óRTP REV 00.8R*."KlͲ:] |?|x2'!\ͧ:m ʙ?ʙx2(!lͧ w#©:'2<!"+:(<2!!"-*K^#V=z z>z{:'$:*$**+}R/!/~#"+O:(l:)lysY*-}/œ!w#"-2*o&2)}X ھ> |Ļ0X2)͸2)}X|X:(>s>E33 >EH *K ^#V> *K ^#V> *K ^#V> *K ^#V!9> H*iV!"iV*iV!,Ҕ 'REVO YS*>! *iV*K *!yC!9~#fo)))-*iV *K ^#V!L s#r*iV *K ^#V!;O s#r*iV*K ^#V!Q s#r*iV*K ^#V!S s#rH!!QV*!yC!9~#fo)))-*iV"yV*yV!yC)))*!QV*0q *yV!3"yVC *yV! !h>E33*yV*K s#rH*kV!"kV*kV*K s#rH;;*K ^#V!;O^#V*K s#r*K ^#V!, *K ^ > "KV! "KVH*KV! -KB*KV!A>@A=*KV!Z?Ѣb !"uV*uV!ڏʏ*uV*KV!YV s#r*uV!"uVKB*KV!A>کʩ=*KV!ZѲ*KV!0>=*KV!9ѲѢ\*uV!*uV! !YV s#r*uV!"uV!"wV!"sV!*sVAҜ*sV*wV!YV^#V*wV!!YV^#V!6!QV s#r*wV!"wV*sV#"sV133!"sV!"wV*sV*wV!9"uV!QV**uV!@)))*0*uV!3"wV!QV**uV!@)!!*K ^#V!c >E!9*K ^#V!*K s#r*MV! *K ^#V>s#r!>s#r! ! >E3333 ;;w >E*K s#r!! >E3333!! >E3333;;w >E*K ^#V3!>s#r!>s#rH;;*MV!('B>E!!  >E3333'B>^#V*K s#r!!  >E3333!$! >E3333'B!>s#r>^#V>s#r>^#V*K ^#V6>s#rH!9!! >E3333!:-<" disk error$>V#^#=0 >V+^+=A`i>s#r#=P`i!9u# j㯓_WDM!yʙ Ïů_Wک`i*K!9"K*K!9"K*K"K#V!*K ^#V!Q^#V >E!9t *K ^#V>^#V*K ^#V3*K ^#V!Q^#V >E!9H;;*MV!¤ *OV*K s#r>Eä! !!B^#V*K s#r>Eä!–;; >E*K s#r*K ^#V!L^#V!$!g>E33*K ^#V!Q^#V*K s#r>E*MV!“>E*K ^#V!Q^#V;;w >E*K s#rLä!2>E3333H;;!! >E3333!QV*!!!!c >E!9*iV*K s#r!! >E))*0  *uV!"sV*sV*wVҮ*sV!3*wVW *uV!@^#V"MV_ !"MV *KV!0>u v =*KV!9?Ѣ !"OV!"MV*OV! 6*KV!03"OVKB*KV!0> =*KV!9Ѳʙ *KV!(L KB*KV!*A KB*KV!* KB*KV!) KB>EI ! "MV *KV!' !"MV!"uVKB*uV*KV!B s#r*uV!"uV*KV!'j KB*KV!'j *uV!3"IV *KV!A^#V"MVKBH*MV*K ^#V *K ^#VQV**K -!! >E3333>E*K *>^#V>^#V>^#V>^#Vc >E!9H!9!! >E3333!QV*!>^#V!!c >E!9*iV*K s#r*MV! &>E!! >E3333!QV*!>^#V!!c >E!9!! >E3333!! >E3333;; >E*K s#r*K ^#V!S^#V*K s#r*K ^#V!L^#V*K s#r*K ^#V!!*K s#r*K ^#V*K s#r+*K ^#V!!*K d7!"mV!>> !>> *K ^#V>!> !<> !<> H> "KV*oV! k*KV> *KV!a|ҋ*KV! 3"KV*KV! *KV!  > "KV*oV! *KV> *mV! !"mV'********>!! > ! >3333*K ^#V;;w >E!Q s#rH;;!>s#r*MV!;; >E*K s#r*K ^#V!L^#V!?*K ^#V!L^#V!?Ѳ*K ^#V!L^#V>s#r*K ^#V!Q^#V>s#r*K ^#V!S^#V>s#r>Eÿ*K ^#V!L^#V!±;;w >E*K s#r!! >E3333!! >E3333;;w >E*K ^#V3!>s#r!>s#rÿ!g>E33 *MV! ‘!*K s#r>E!! >E3333!QV*  s#r*K ^#V*K s#r+!g>E33*K ^#V*K s#r*iV*K ^#V\N*K ^#V*K ^#V!L s#r*K ^#V*K ^#V!S s#r>^#V!*K ^#V>^#V!Q s#r *K ^#V>^#V*K ^#V!Q s#r>^#V*K ^#V>s#r*K ^#V#*K s#rE33H;;>E*MV! `>E*MV!/ʵ! >E*MV! ²>E! >EÍL>E!! >E3333;; >E*K s#r*K ^#V!L^#V!B*MV!?*MV!?Ѳ*MV!%?Ѳ *MV!%f!!! >E!9*MV*K s#r>EB*K ^#V!´!!! >E!9*K ^#V!!!! >E!9!!! >E!9HB*MV!  >E*MV!_ >EB!*K ^#V!  >E!9 *MV! ž >EB!*K ^#V!  >E!9 B!*K ^#V!  >E!9Á!*MV! E!>E*MV!!>EB!!*K s#r!>E33!33*K ^#V*K ^#V >E3333n!˜!!*K ^#V!Q^#V >E!9!>E33>En!>E!*K ^#V >E3333!!! >E!9!>E33n!">E*K ^#V!S^#V!I!*K s#r!>E33!*MV!®>E! >E33!!  >E3333! *K s#r!>E33! *K s#r!>E33!!*K s#r!>E3333 >E3333! B33!!!*K ^#V!S^#V3!3 >E!9`%!g>E3333÷.!!&>E! B33!+!4 >E3333;; >E*K s#r!!*K ^#V >E!9!>E*MV!m&;; >E*K s#r!!*K ^#V >E!9!!*K ^#V >E!9>E!>E!!*K ^#V >E!9Í&!!*K ^#V >E!9÷.!8)>E!! >E3333;; >E*K s#r!!3 >E3333!!3 >E3333! B#!*K ^#V >E3333>!*K ^#V >E3333*MV! ʵ! ! >E3333!>^#V*K ^#V!;O^#V3*K ^#V!Q^#V >E!9!!!*K ^#V!S^#V3 >E!9H>^#V!*K ^#V>s#r=>^#V*K ^#V=!>E33H;;;;*MV!‡!!*OV >E!9!>E33>EÁ!¨*IV!!!!!B^#V >E!9!>E33Ý!>E33! !! >E!9!*K ^#V!  >E!9B!B!*K ^#V!  >E!9Á!*MV!!>EB!*K ^#V! >E!9*K ^#V"qVH!9*MV!e%;; >E*K s#r*K ^#V!L^#V!">E!!  >E3333! B33!!  >E3333!!3 >E3333!!3 >E3333! B33*K ^#V!S^#V!Q^#V!Ž"!*K s#r"!­"! *K s#r"!"!*K s#r"33*K ^#V*K ^#V >E3333`%!s#*K ^#V*K ^#V >E3333n!n!!! >E!9*K ^#VS>E33!>E33n33Á!:>E3333H;;@B*MV!?*MV!?Ѳ*MV!?Ѳʉ*MV!!!! >E!9*MV*K s#r>E@B*K ^#V!<!!! >E!9Æ*K ^#V!m!!! >E!9Æ!!! >E!9ÎH;;*MV!?*MV!?Ѳ*MV*K s#r>EB*K ^#V!!!! >E!933!*K ^#V >E3333*MV!,T'>E!*K s#r! *K s#rÙ'*MV!‹'>E!*K s#r! *K s#rÙ'!7>E33! B33!!6 >E3333;; >E*K s#r!!*K ^#V >E!9!!! >E!9!*K ^#V >E3333!!*K ^#V >E!9;; >E*K s#r!!*K ^#V >E!9!>E!*K ^#V >E3333!!*K ^#V >E!9!*K ^#V >E3333!!*K ^#V >E!9!!!B^#V!!B^#V!!B^#V!!B^#V!6 >E!9!!B^#V!!B^#V!!B^#V!!B^#V!6 >E!9>EÁ! >E>^#V >E33*qV>E33! ! >E3333Á!s;; >E*K s#r*K ^#V!L^#V!H>E!!  >E3333! >E33!!  >E3333*K ^#V!S^#V!Q^#V!! *K s#r!>E33!!!*K s#r!>E33!!!>E!*K ^#V >E3333!!3 >E3333!!3 >E3333! B33!!! >E!9`%!«$>E*MV!¾#>E! B33!!  >E3333!!3 >E3333!!3 >E3333! B33*qV!w$*K ^#V!S^#V!4$! *K s#rr$!S$!*K s#rr$!r$!*K s#rr$33Æ$! *K s#r*K ^#V*K ^#V >E3333`%!$*K ^#VSB33`%!R%>E!!3 >E3333!!3  *K ^#V >E!9!!!!3 >E!9÷.!*);; >E*K s#r!!*K ^#V >E!9>E!>E*MV!z)!.!5 >E3333! B33!!*K ^#V >E!9÷.!°+>E! B33*MV!$*!>E33;; >E*K s#r>E!!! >E!9!!;;w >E >E!9!! >E3333!!! >E!9;; >E*K s#r!!*K ^#V >E!9!>E!!*K ^#V >E!9!!>E!QV**K ^#V*K ^#V;; >E!c >E!9!! >E3333*iV*K s#r!*K s#r*MV! „3.B*K ^#V*K ^#V!S s#r!! >E3333!QV*' DRAWROF03>E+5!QV*'DRAWKCAB05>E!! >E3333!*K s#r*K ^#V!yC)))*!QV-!QV**K ^#V!yC)))*0}4*K ^#V!*K s#r94*K ^#V'********!yC!9~#fo)))-*K ^#V*K ^#V!Q^#V!Q s#r*K ^#V!*K ^#V!Q^#V1>E/>E!*K s#r!! >E3333!QV*!>^#V!!!c >E!9*MV! .!! >E3333!! >E3333;; >E*K s#r*K ^#V!0*K ^#V!L^#V!/!*K s#r0!*K s#r*K ^#V!*K s#r*iV*K ^#V<01*K ^#V*K ^#V!L s#r*K ^#V*K ^#V!S^#V!S s#r*K ^#V>^#V*K ^#V!S^#V!3!Q s#r>^#V*K ^#V!S^#V>s#r*K YARRA!@!9~#fo)))-!!!@ s#r!' NIGEB!@!9~#fo)))-!!!@ s#r!' ESAC!@!9~#fo)))-!!!@ s#r!' TSNOC!@!9~#fo)))-!!!@ s#r!' VID!@!9~#fo)))-!!!@ s#r!' OD!@!9~#fo)))-!!!@ s#r!' OTNWOD!@!9~#fo)))-!!!@ s#r! ' ESLE!@!9~#fo)))-! !!@ s#r! ' DNE!@!9~#fo)))-! !!@ s#r! ' ROF!@!9~#fo)))-! !!*K ^#V >E!9*MV!?*MV!?Ѳ-**MV!Y+>E!>E!!  >E3333!!*K ^#V >E!9!!!!3 >E!9÷.! },>E!!c >E3333;;w >E*K s#r! !  >E3333!! >E3333!*K ^#V! >E!9;; >E*K s#r!*K ^#V >E3333! ! >E3333÷.!(‹->E!!c >E3333;;w >E*K s#r*MV! ,! >E33>E! B33*qV! -!3333+5*K ^#V!*kV1>E3333*K ^#V"iV!! >E3333ì2!! >E3333!!*K ^#V >E!9*K ^#V!ʺ5!!*K ^#V >E!9!B*MV!5>E!B5*K ^#V! 6!!! >E!9!!  >E3333*MV! R7>E!*K s#r*iV*K ^#Va6P7! > ! > *K ^#V>! > *K ^#V!yC)))*>!! > *K ^#V!L^#V>! > *K ^#V!;O^#V>! > *K ^# ^#V#*K s#r%033*MV!.*K ^#V!*K s#r*iV*K ^#V`1Ҷ1*K ^#V*K ^#V!Q^#V>^#V3!Q s#r*K ^#V#*K s#rI133! ! >E3333H!9!*K s#r*iV*K s#r*MV!02>EB!! >E3333*MV!2*MV!-n2>EB!! >E3333*MV!F2*MV!/¬2>EyB!! >E3333*MV!ʄ2*MV!&?*MV!?ѲQ5*MV!&2!*K s#r2!*K s#r@ s#r! 'NOITCNUF!@!9~#fo)))-! !!@ s#r! ' TEG!@!9~#fo)))-! ! !@ s#r!' FI!@!9~#fo)))-!!!!@ s#r!' DOM!@!9~#fo)))-!!"!@ s#r!' TON!@!9~#fo)))-!!#!@ s#r!' FO!@!9~#fo)))-!!$!@ s#r!' RO!@!9~#fo)))-!!%!@ s#r!'RUDECORP!@!9~#fo)))-!!&!@ s#r!' MARGORP!@!9~#fo)))-!!'!@ s#r!' TUP!@!9~#f*K s#r-!*K s#r*MV!?->E!*K s#r!*K ^#V*K ^#V >E!9*MV! ,! ! >E3333÷.!->E!>E*MV!ʘ-!!  >E3333÷.!0·.>E;; >E*K s#r!!*K ^#V >E!9! B33;; >E*K s#r!!*K ^#V >E!9!!6 >E3333!>E!!*K ^#V >E!9!!*K ^#V >E!9÷.33H!9*iV*K s#r*iV*K s#r!*K s#r>E*MV!/V!Q^#V>! > *K ^#V!S^#V>*K ^#V#*K s#rJ633*K ^#V"iVH!"KV!*KVʀ7Ҡ7*KV!!A s#r*KV#"KVp733!+!!A s#r!-!!A s#r!*!!A s#r!/!!A s#r!:!!A s#r!;!!A s#r!=!!A s#r!#!!A s#r!<! !A s#r!>! !A s#r!(! !A s#r!)! !A s#r![!!A s#r!]!!A s#r!.!!A s#r!,! !A s#r!' DNA!@!9~#fo)))-!!!@ s#r!'   o)))-!!(!@ s#r!' DROCER!@!9~#fo)))-!!)!@ s#r!' TAEPER!@!9~#fo)))-!!*!@ s#r!' NEHT!@!9~#fo)))-!!+!@ s#r!' OT!@!9~#fo)))-!!,!@ s#r!' EPYT!@!9~#fo)))-!!-!@ s#r!' LITNU!@!9~#fo)))-!!.!@ s#r!' RAV!@!9~#fo)))-!!/!@ s#r!' ELIHW!@!9~#fo)))-!!0!@ s#r!"mV!"iV' VER CPP>!!>!.> !>!rsion *) norw = 29; (* number of reserved words *) al = 8; (* length of identifiers *) alm1 = 7; (* length of id minus 1 *) llen = 80; (* max input line length *) symax = 300; (* max number of symbol table entrys *) ordminchar = 0; (* minimum legal char ord value *) ordmaxchar = 127; (* maximum legal char ord value *) intsize = 2; (* size of integer in stack units *) charsize = 1; (* size of character *) boolsize = 2; (* size of boolean *) alfasize = 8; (* size of alfa *) true = 1; (-codes around in core. This cuts down on memory requirements and allows the compiler to write the p-code to disk as it is generated. The overall design uses recursive descent where ever possible. internal structure ================== The compiler can be broken down into the major functional units shown in the table below. In this compiler, code generation is rolled right in with the parsing routines. As soon as a valid construct is recognized, code for it is emitted. Block nesting and func dontcare ); (* define all array types needed this is a temporary kludge until the compiler will accept arrays in var declarations *) rwwtyp = array[0..norw] of word; rwatyp = array[0..norw] of alfa; alatyp = array[0..alm1] of word; chatyp = array[ordminchar..ordmaxchar] of word; linetyp = array[0..llen] of word; statyp = array[0..symax] of alfa; stwtyp = array[0..symax] of word; var (* indexed by reserved word number *) wsym : rwwtyp; (* gives token of type s>!R> ! > ! > '?GNITSIL>!> "oV' REGETNI!!!!c B!9' RAHC!!!!c B!9' NAELOOB!!!!c B!9' ETYB!!!!c B!9' DROW!!!!c B!9' AFLA!!!!c B!9! "KVB!"kV!!! B!9!!1B3333!!!  B!9!!! B!9*MV!ʦ@!B33>$* kludge until implemented in compiler *) false = 0; type symbol = ( (* symbol tokens *) nul, ident, number, charcon, plus, minus, times, slash, eql, lss, gtr, lparen, rparen, comma, semicolon, period, lbrack, rbrack, colon, pound, andsym, arraysym, beginsym, casesym, constsym, divsym, dosym, downtosym, elsesym, endsym, forsym, funcsym, getsy, ifsym, modsym, notsym, ofsym, orsym, procsym, progsym, putsym, recordsym, repeatsym, thensym, tosym, typesym, untilsym, vation is shown below. FUNCTION ROUTINE NAME ======== ============ error processing error, test symbol table routines enter, position token scanner getsym char scanner getch, getline, etc. semantic routines block declaritive const, typ, var dcl statement scanner statement expression scanner epxression, sexp, term, factor main line *) const vhu = 0; (* version number hundreds *) vtn = 0; (* tens *) vun = 8; (* units *) devrel = 'r'; (* development or release veymbol *) rword : rwatyp; (* holds reserved word in order *) (* indexed by ascii character value *) ssym : chatyp; (* gives token of type sybol *) (* indexed by character number 0 .. *) ccon : linetyp; (* last character constant read *) (* symbol table *) (* indexed by tx *) stname : statyp; (* symbol table entry name *) stkind : stwtyp; (* symbol table entry kind *) stlev : stwtyp; (* symbol table entry level *) stadr : stwtyp; (* symbol table address *) stlen : stwtyp; (* symb(* TITLE Pascal Pascal Compiler (pascal self compiler) FILENAME PPC.PAS AUTHOR Robert A. Van Valzah 9/01/79 LAST REVISOR R. A. V. 01/05/80 REASON repaired bug in var parameters *) (* This is a single pass pascal subset compiler. Source code is read from the input device and a listing is produced. A label addressed p-code is used so that forward references are no problem. The use of theses labels removes the need for "backplugging", and with it, the need to keep the generated prsym, whilesym ); object = ( (* types of symbol table entrys *) notype, constant, prozedure, funktion, simpvar, arrayvar, tipe, simptype, varparm ); pops = ( (* p-op codes *) cal, jpc, jmp, lit, opr, lod, sto, int, csp, lodx, stox, alit, alod, asto, alodx, astox, pshf, clod, csto, clodx, cstox, halt, lab, peof, (* end of p-code file *) laa, lodi, stoi, clodi, cstoi, alodi, astoi, indx, aindx, cindx ); exptyp = ( (* possible expression types *) wurd, alpha, chars,  ol table length *) (* stname allways contains name, contents of stkind determines meaning of other arrays: stkind stlev stadr stlen ====== ===== ===== ===== constant 0=declared const value -- 1=scalar element prozedure lexical level label number parm len funktion " " " simpvar lexical level stack disp length arrayvar lexical level base stack disp type ptr simptype -- cardinality length tipe 0=array element length total length notes: type ptr is ibegin aw[gsk]:=ch; gsk:=gsk+1 end; getch until ((ch<'A')or(ch>'Z'))and((ch<'0')or(ch>'9')); (* blank remainder of aw *) while gsk=rword[gsk] global variables based on result of scan. token scaned ============ identifier sym=ident, id= number sym=number, num= character const sym=charcon, cclen=, ccon= special symbol sym= resreved word sym= *) procedure getsym; (* see global variables for local var declaration *) procedure getch; begin get#0(ch); if listing<>13 then put#1(ch);  getsym end; (* emit the p-instruction passed in the arguments. *) procedure gen(op: pops; lev,adr: word); begin put#0(op, lev, adr, adr/256) end; (* gen *) (* enter an identifier into the symbol table with the attributes passed as arguments *) procedure enter(nam: alfa; kind,lev,adr,len: word); begin tx:=tx+1; if tx>symax then put#1('*SY OVER') else begin stname[tx]:=nam; stkind[tx]:=kind; stlev[tx]:=lev; stadr[tx]:=adr; stlen[tx]:=len end end; (* enter *) ndex of symbol table entry for declared type of array. this is a kludge to save symbol table space. *) (* global scanner result variables *) cclen : word; (* length of last character constant *) ch : word; (* last character read *) sym : symbol; (* last symbol read *) num : word; (* last number read *) id : alfa; (* last identifier read *) (* temp used in getsym *) aw : alatyp; (* global pointers *) tx : word; (* index of last st entry *) nl : word; (* lathen gsi:=gsk+1 until gsi>gsj; if gsi-1>gsj then sym:=wsym[gsk] else sym:=ident end else if (ch>='0') and (ch<='9') then begin (* number *) num:=0; sym:=number; repeat num:=num*10+(ch-'0'); getch until (ch<'0') or (ch>'9') end else if ch='(' then begin getch; if ch='*' then begin (* inside of comment *) repeat repeat getch until ch='*'; getch until ch=')'; getch; getsym end else sym:=lparen end else if ch='''' then begin (* if ch>=97 then ch:=ch-32; if ch<32 then begin (* this is for speed *) if ch=13 then begin (* get & ignore the line feed *) get#0(ch); if listing<>13 then put#1(ch); if errflag=true then begin errflag:=false; put#1('********',13,10); get#1(ch) end end; ch:=32 end end; (* getch *) begin (* getsym *) while ch=' ' do getch; if (ch>='A') and (ch<='Z') then begin (* id or reserved word *) gsk:=0; repeat if gskid do posi:=posi-1; if posi=0 then error(104); position:=posi end; (* position *) (* returns the next available label number *) function nlab; begin nl:=nl+1; nlab:=nl end; (* semantic routine to compile a block *) procedure block(lev, plab: st assigned label number *) errflag : word; (* error occured in last line *) listing : word; (* 13 if no listing wanted *) erestyp : exptyp; (* result type of expression *) (* global variables for procedure getsym for speed *) gsi, gsk, gsj : word; (* global variables for function position for speed *) posi : word; procedure error(n: word); (* parameter is error number *) begin errflag:=true; put#1('>','>',n#,7,'<','<') end; (* scan next token from input stream. set character constant *) sym:=charcon; gsk:=0; repeat repeat getch; ccon[gsk]:=ch; gsk:=gsk+1 until ch=''''; getch until ch<>''''; cclen:=gsk-1 end else begin (* special symbol *) sym:=ssym[ch]; getch end end; (* getsym *) (* test for present symbol equal to first argument, error number of second argument is issued if not. also gets next symbol if desired symbol was present *) procedure test(s1, errn: word); begin if sym<>s1 then error(errn) else  word); var (* values returned by typ *) ttype : object; (* type type (simple or not) *) tadr : word; tlen : word; dx : word; (* data allocation index *) px : word; (* parameter allocation index *) btype : object; (* block type (func or proc) *) tx0 : word; (* table index at start of block *) tx1 : word; (* table index at start of nested proc/func *) i : word; (* temp used in fwd ref *) (* emit the p-instruction passed in the first argument, taking the level and adk,12); test(ofsym,8); styp; ttype:=tipe; tadr:=tlen; tlen:=tlen*scard end end; (* typ *) procedure typedcl; var tid : alfa; (* type identifer *) begin test(ident,2); tid:=id; test(eql,16); typ; enter(tid,ttype,lev,tadr,tlen) end; (* typdcl *) procedure vardcl; var i : word; tx0 : word; tlen : word; (* total length *) vkind : word; (* variable type *) len : word; begin test(ident,2); enter(id,notype,lev,0,0); tx0:=tx; cript cardinality *) procedure styp; var i : word; begin ttype:=simptype; if sym=ident then begin i:=position; if (stkind[i]=simptype) or (stkind[i]=tipe) then begin ttype:=stkind[i]; tadr:=stadr[i]; tlen:=stlen[i]; getsym end else if stkind[i]=constant then begin i:=compcon; test(period,20); test(period,20); tadr:=compcon-i+1; tlen:=intsize end else error(103) end else if sym=lparen sym; test(ident,2); j:=position; if stkind[j]=varparm then genlev(lod,j) else genlev(laa,j) until sym<>comma; test(rparen,4) end; gen(cal,lev-stlev[i],stadr[i]); gen(int,0,0-stlen[i]) end; (* procedure call *) procedure expression(etyp: exptyp); backward; procedure chetyp(destyp: exptyp); begin if etyp=dontcare then etyp:=destyp else if etyp<>destyp then error(129) end; (* chetyp *) procedure sexp; var addodress from the symbol table entry passed in the second argument. *) procedure genlev(op: pops; i: word); var stl : word; begin stl:=stlev[i]; if stl=1 (* only if global variable ref *) then gen(op,255,stadr[i]) else gen(op,lev-stl,stadr[i]) end; (* genlev *) function compcon; (* returned value is a compile time constant *) var i : word; begin case sym of number: begin compcon:=num; getsym end; charcon: begin compcon:=ccon[0]; getsym end; ident: beg while sym=comma do begin getsym; test(ident,2); enter(id,notype,lev,0,0) end; test(colon,5); test(ident,2); i:=position; tlen:=stlen[i]; (* total length of variable *) vkind:=stkind[i]; if vkind=simptype then begin vkind:=simpvar; len:=tlen end else if vkind=tipe then begin vkind:=arrayvar; len:=i (* pointer to array type info *) end else error(103); for i:=tx0 to tx do begin stkind[i]:=vkind; stlen[i]:=len; if lev=1 then stadr[i]:then begin i:=0; repeat getsym; test(ident,2); enter(id,constant,intsize,i,0); i:=i+1 until sym<>comma; tadr:=i; tlen:=intsize; test(rparen,4) end else begin i:=compcon; test(period,20); test(period,20); tadr:=compcon-i+1; tlen:=intsize end end; (* styp *) begin (* typ *) if sym<>arraysym then styp else begin getsym; test(lbrack,11); styp; scard:=tadr; (* save subscript cardinality *) test(rbracp : symbol; procedure term; var mulop : symbol; procedure factor; var i : word; op : pops; begin (* factor *) case sym of number: begin (* load constant *) gen(lit,0,num); chetyp(wurd); getsym end; (* case number *) charcon: begin (* load string literal *) if cclen=1 then begin gen(lit,0,ccon[0]); chetyp(wurd) end else begin chetyp(alpha); gen(alit,0,0); gen(ccon[7],ccon[6], ccon[5]+ccon[4]*256); in i:=position; if stkind[i]<>constant then error(103); compcon:=stadr[i]; getsym; while sym=plus do begin getsym; compcon:=stadr[i]+compcon end end (* case ident *) else error(50) end (* case sym of *) end; (* function compcon *) procedure constdcl; var ctx : word; begin test(ident,2); enter(id,constant,0,0,0); ctx:=tx; test(eql,16); stadr[ctx]:=compcon end; (* constdcl *) procedure typ; var scard : word; (* array subs=dx else stadr[i]:=dx+tlen; dx:=dx+tlen end end; (* vardcl *) procedure statement; var i, elab, flab, tlab, op, updn : word; procedure expression; forward; procedure call(i: word); var j : word; begin getsym; if sym=lparen then begin getsym; if sym<>varsym then begin expression(dontcare); while sym=comma do begin getsym; expression(dontcare) end end else (* procedure has var parameters *) repeat get   gen(ccon[3],ccon[2], ccon[1]+ccon[0]*256) end; getsym end; (* case charcon *) lparen: begin (* get sub expression *) getsym; expression(etyp); chetyp(erestyp); test(rparen,4) end; (* case lparen *) ident: begin i:=position; case stkind[i] of arrayvar: begin (* index into array var *) getsym; test(lbrack,11); expression(wurd); test(rbrack,12); case stadr[stlen[i]] of intsize: begin op:=lo begin (* expression *) sexp; if sym=lss then begin getsym; if sym=eql then begin getsym; sexp; gen(opr,etyp,13) end else if sym=gtr then begin getsym; sexp; gen(opr,etyp,9) end else begin sexp; gen(opr,etyp,10) end end else if sym=gtr then begin getsym; if sym=eql then begin getsym; sexp; gen(opr,etyp,11) end else begin sexp; gen(opr,etyp,12) end end else if sym=eql then begin getsym; sexp;  funktion: begin (* function reference *) gen(int,0,intsize); call(i); chetyp(wurd) end (* case funktion *) end (* case stkind[i] of *) end (* case ident *) else error(58) end (* case sym of *) end; (* factor *) begin (* term *) factor; while (sym=times) or (sym=slash) or (sym=andsym) do begin if sym=andsym then gen(pshf,0,0); mulop:=sym; getsym; factor; if mulop=times then gen(opr,0,4) else if mulop= alfasize: op:=stox; intsize: op:=sto; charsize: op:=csto end (* case stlen[i] of *) else op:=asto; genlev(op,i) end; (* case simpvar *) prozedure: begin (* procedure call *) call(i) end; (* case prozedure *) funktion: begin (* function return value *) getsym; test(colon,51); test(eql,51); expression(dontcare); gen(sto,0,0-stlen[i]-6) end (* case funktion *) else error(103) end (* case stkind[i] *) end; (* case idendx; chetyp(wurd) end; alfasize: begin op:=alodx; chetyp(alpha) end; charsize: begin op:=clodx; chetyp(wurd) end end; (* case *) genlev(op,i); end; (* case arrayvar *) constant: begin (* load constant *) gen(lit,0,stadr[i]); chetyp(wurd); getsym end; (* case constant *) varparm: begin (* load from var parameter *) getsym; genlev(lod,i); gen(lodi,0,0); chetyp(wurd) end; (* case varparm *) gen(opr,etyp,8) end; erestyp:=etyp end; (* expression *) begin (* statement *) case sym of ident: begin (* could be anything *) i:=position; case stkind[i] of arrayvar: begin (* array assignment *) getsym; test(lbrack,11); expression(wurd); test(rbrack,12); test(colon,51); test(eql,51); expression(dontcare); case stadr[stlen[i]] of charsize: op:=cstox; intsize: op:=stox; alfasize: op:=astox end; (* case stadr[stlen[i]] of *) slash then gen(opr,0,5) else gen(opr,0,15) end end; (* term *) begin (* sexp *) if (sym=plus) or (sym=minus) then begin addop:=sym; getsym; term; if addop=minus then gen(opr,0,1) end else term; while (sym=plus) or (sym=minus) or (sym=orsym) do begin if sym=orsym then gen(pshf,0,0); addop:=sym; getsym; term; if addop=plus then gen(opr,0,2) else if addop=minus then gen(opr,0,3) else gen(opr,0,14) end end; (* sexp *) t *) ifsym: begin getsym; expression(dontcare); test(thensym,52); flab:=nlab; gen(jpc,0,flab); statement; if sym=elsesym then begin elab:=nlab; gen(jmp,0,elab); gen(lab,0,flab); getsym; statement; gen(lab,0,elab) end else gen(lab,0,flab) end; (* case ifsym *) forsym: begin getsym; test(ident,2); i:=position; test(colon,51); test(eql,51); expression(dontcare); genlev(sto,i); if sym=tosym then begin getsym; updn:=19; op:=11 e simpvar: begin (* load from simple var *) getsym; case stlen[i] of intsize: begin op:=lod; chetyp(wurd) end; alfasize: if sym=lbrack then begin getsym; expression(wurd); test(rbrack,12); op:=lodx; chetyp(wurd) end else begin op:=alod; chetyp(alpha) end; charsize: begin op:=clod; chetyp(wurd) end end; (* case stlen[i] *) genlev(op,i) end; (* case simpvar *)  genlev(op,i) end; (* case arrayvar *) varparm: begin (* var parameter assignment *) getsym; genlev(lod,i); test(colon,51); test(eql,51); expression(dontcare); gen(stoi,0,0) end; (* case varparm *) simpvar: begin (* simple variable assignment *) getsym; if sym=lbrack then begin getsym; expression(dontcare); test(rbrack,12) end; test(colon,51); test(eql,51); expression(dontcare); if erestyp=wurd then case stlen[i] of   nd else if sym=downtosym then begin getsym; updn:=20; op:=13 end else error(55); expression(dontcare); test(dosym,54); tlab:=nlab; gen(lab,0,tlab); gen(opr,0,21); genlev(lod,i); gen(opr,0,op); elab:=nlab; gen(jpc,0,elab); statement; genlev(lod,i); gen(opr,0,updn); genlev(sto,i); gen(jmp,0,tlab); gen(lab,0,elab); gen(int,0,0-intsize) end; (* case forsym *) repeatsym: begin tlab:=nlab; gen(lab,0,tlab); repeat getsym; statemenition; if ptyp=notype then if stkind[i]=simptype then ptyp:=simpvar else ptyp:=arrayvar; for j:=tx1+1 to tx do begin stkind[j]:=ptyp; stlen[j]:=stlen[i]; stadr[j]:=px+stlen[i]-6; px:=px+stlen[i] end; until sym<>semicolon; for j:=tx0+1 to tx do stadr[j]:=stadr[j]-px; test(rparen,4) end; (* plist *) begin (* block *) dx:=0; tx0:=tx; if sym=constsym then begin getsym; repeat constdcl; test(semicolon,14) until sym<>ident typ=wurd then op:=1 else op:=8; if sym=pound then begin getsym; op:=3 end; gen(csp,i,op) until sym<>comma; test(rparen,4) end; (* case putsym *) beginsym: begin repeat getsym; statement until sym<>semicolon; test(endsym,13) end; (* case beginsym *) whilesym: begin getsym; tlab:=nlab; gen(lab,0,tlab); expression(dontcare); elab:=nlab; gen(jpc,0,elab); test(dosym,54); statement; gen(jmp,0,tlab); gen(lab,0,elab); en getsym; statement end; if lev<>1 then gen(opr,0,0); test(endsym,13); if sym=comma then begin getsym; for tx1:=1 to tx do put#1(13,10,tx1#, ' ',stname[tx1], ' ',stkind[tx1]#, ' ',stlev[tx1]#, ' ', stadr[tx1]#, ' ',stlen[tx1]#) end; tx:=tx0 end; (* block *) begin (* main line *) (* init special symbol token array *) for ch:=ordminchar to ordmaxchar do ssym[ch]:=nul; ssym['+']:=plus; ssym['-']:=minus; ssym['*']:=times; ssym['/']:=slash; ssym[':']:=colon; ssyt until sym<>semicolon; test(untilsym,53); expression(dontcare); gen(jpc,0,tlab) end; (* case repeatsym *) casesym: begin getsym; expression(dontcare); if sym<>ofsym then error(8); elab:=nlab; (* end label *) repeat getsym; gen(opr,0,21); (* dup *) gen(lit,0,compcon); test(colon,5); gen(opr,0,8); (* equal relop *) flab:=nlab; gen(jpc,0,flab); statement; gen(jmp,0,elab); gen(lab,0,flab) until (sym=elsesym) or (sym=endsym);  end; if sym=typesym then begin getsym; repeat typedcl; test(semicolon,14) until sym<>ident end; if sym=varsym then begin getsym; repeat vardcl; test(semicolon,14) until sym<>ident end; while (sym=procsym) or (sym=funcsym) do begin if sym=procsym then btype:=prozedure else btype:=funktion; getsym; enter(id,btype,lev,nlab,0); test(ident,2); tx1:=tx; px:=0; if sym=lparen then plist; stlen[tx1]:=px; (* arg len into proc *) test(semd (* case whilesym *) end (* case *) end; (* statement *) (* scan a parameter list for a func or proc call and allocate variables for parameters *) procedure plist; var tx0, tx1, i, j : word; ptyp : object; begin tx0:=tx; repeat tx1:=tx; ptyp:=notype; repeat getsym; if sym=varsym then begin getsym; ptyp:=varparm end; test(ident,2); enter(id,notype,lev+1,0,0) until sym<>comma; test(colon,5); test(ident,2); i:=posm[';']:=semicolon; ssym['=']:=eql; ssym['#']:=pound; ssym['<']:=lss; ssym['>']:=gtr; ssym['(']:=lparen; ssym[')']:=rparen; ssym['[']:=lbrack; ssym[']']:=rbrack; ssym['.']:=period; ssym[',']:=comma; (* init reserved word arrays *) (* must be in alpahbetical order for binary search *) rword[ 1]:='AND '; wsym[ 1]:=andsym; rword[ 2]:='ARRAY '; wsym[ 2]:=arraysym; rword[ 3]:='BEGIN '; wsym[ 3]:=beginsym; rword[ 4]:='CASE '; wsym[ 4]:=casesym; rword[ 5]:='CONST '; wsym[ 5] if sym=elsesym then begin getsym; statement end; test(endsym,13); gen(lab,0,elab); gen(int,0,0-intsize) end; (* case casesym *) getsy: begin getsym; test(pound,99); i:=compcon; test(lparen,9); test(ident,2); gen(csp,i,0); i:=position; genlev(sto,i); test(rparen,4) end; (* case getsy *) putsym: begin getsym; test(pound,99); i:=compcon; if sym<>lparen then error(9); repeat getsym; expression(dontcare); if eresicolon,14); if id='FORWARD ' then getsym else if id='BACKWARD' then begin getsym; test(semicolon,14); i:=1; id:=stname[tx1]; while id<>stname[i] do i:=i+1; stname[i]:='********'; stadr[tx1]:=stadr[i]; block(lev+1,stadr[i]) end else block(lev+1,nl); tx:=tx1; (* leave only proc name in table *) test(semicolon,14) end; test(beginsym,17); gen(lab,0,plab); if lev<>1 then gen(int,0,dx); statement; while sym=semicolon do begin   :=constsym; rword[ 6]:='DIV '; wsym[ 6]:=divsym; rword[ 7]:='DO '; wsym[ 7]:=dosym; rword[ 8]:='DOWNTO '; wsym[ 8]:=downtosym; rword[ 9]:='ELSE '; wsym[ 9]:=elsesym; rword[10]:='END '; wsym[10]:=endsym; rword[11]:='FOR '; wsym[11]:=forsym; rword[12]:='FUNCTION'; wsym[12]:=funcsym; rword[13]:='GET '; wsym[13]:=getsy; rword[14]:='IF '; wsym[14]:=ifsym; rword[15]:='MOD '; wsym[15]:=modsym; rword[16]:='NOT '; wsym[16]:=notsym; rword[17]:='OF '; rting at 100h. 5) Boot back to the CCP. 6) Save memory up to one byte below the final code address printed by the assembler. F'rinstance if 0600 was last address, type "SAVE 5 RTP.COM". This procedure must be followed so that PIP can be used to concatenate the runtime package and the object code produced by the compiler. It will also make your life a lot easier when using COMPARE.COM to compare parents and childern (should you ever try and extend the compiler). If you make changes  '; (* init the character scanner *) getsym; nl:=1; gen(jmp,0,1); block(1,1); gen(csp,0,9); gen(peof,0,0); if sym<> period then error(20) end. eof ler. After making any changes to the compiler, you'll probably want to make sure that you can still compile and execute tester.pas. This test doesn't test all functions of the compiler either, but passing tester is good sign that you haven't broken anything major. By the way, it is normal to get a few type missmatch errors while compiling tester. A new version of the compiler which is smarter about type checking would prevent these messages. wsym[17]:=ofsym; rword[18]:='OR '; wsym[18]:=orsym; rword[19]:='PROCEDUR'; wsym[19]:=procsym; rword[20]:='PROGRAM '; wsym[20]:=progsym; rword[21]:='PUT '; wsym[21]:=putsym; rword[22]:='RECORD '; wsym[22]:=recordsym; rword[23]:='REPEAT '; wsym[23]:=repeatsym; rword[24]:='THEN '; wsym[24]:=thensym; rword[25]:='TO '; wsym[25]:=tosym; rword[26]:='TYPE '; wsym[26]:=typesym; rword[27]:='UNTIL '; wsym[27]:=untilsym; rword[28]:='VAR '; wsym[28]:=varsym; rword[29]:to ppc.pas or pfet.pas, you'll want to be sure that the new compiler is capable of compiling itself. In genetics, this would be like making sure that your children are not sterile. The file validate.sub should help make sure you don't have sterile children. It uses a "know fertile" compiler (ppc.com, pfet.com) to compile the new ppc.pas and pfet.pas. The resulting compiler is then used to compile ppc.pas and pfet.pas again. The results of this second compilaton are compared to the results of the  Notes on regenerating the compiler ================================== When reassembling the runtime package, do not use LOAD to create RTP.COM. Instead, you must use a debugger and do the following: 1) Assemble RTP.ASM to produce RTP.HEX. Make note of the final code address printed by the assembler. RTP.COM should go up to this address minus 1. 2) Fire up your favorite debugger (DDT will do). 3) Fill memory with 0's. 100h - 1000h should do. 4) Now you can read in RTP.HEX, sta='WHILE '; wsym[29]:=whilesym; errflag:=false; (* clear line error flag *) tx:=0; (* init table pointers *) put#1('ppc rev ',vhu#,'.',vtn#,vun#,devrel,13,10); put#1('Listing?'); get#1(listing); (* define standard type identifiers *) enter('INTEGER ',simptype,0,0,intsize); enter('CHAR ',simptype,0,0,charsize); enter('BOOLEAN ',simptype,0,0,boolsize); enter('BYTE ',simptype,0,0,charsize); enter('WORD ',simptype,0,0,intsize); enter('ALFA ',simptype,0,0,alfasize); ch:='first. If they match, it is safe to erase the "known fertile" compiler because you now know that you have a compiler which can reproduce itself. If they miscompare, you'd better find out why and fix it before erasing the parents. You should also note that this test only guarantees that you'll be able to continue to use the compiler to compile itself. It does N-O-T guarantee that you've got a fully functional compiler, because the compiling the compiler does not exercise all functions of the compi  ; ; TITLE PASCAL RUNTIME MODULE ; FILENAME RTP.ASM ; AUTHOR Robert A. Van Valzah 8/30/79 ; LAST REVISED 12/10/79 R.A.V. ; REASON changed entry of spalod for hl=lsbyte of alfa ; ; vhu equ 0 ;verision number hundreds vtn equ 0 ;version number tens vun equ 8 ;version number units devrel equ 'R' ;development or release version ; bdos equ 5 open equ 15 close equ 16 delete equ 19 readrec equ 20 writerec equ 21 make equ 22 setdma equ 26 ; romorg equ 100h org romorg jmp startup jmp dos lxi d,ofcb mvi c,make call bdos inr a jz diskerr ;no idrectory space xra a ;zap fcbnr sta ofcb+32 lxi h,obuf ;init output buffer pointer shld optr ret ; ; base follow static links back reg a levels, return base ; in reg hl ; base: lhld br ;start with current base follow: mov e,m ;get a link to reg de inx h mov d,m xchg ;link to reg hl dcr a ;enough links followed? jnz follow ;no ret ;yes ; ; cmpr is called to set flags like (top)-(top-1) before ; the call tmov a,b ;get ciflag value sta ciflag ;store it lxi h,ifcb ;copy first name into input fcb lxi d,5ch call copynam lda 6dh ;get first name byte of fcb2 mvi b,0ffh ;same as above cpi ' ' jz set2 cpi '?' jz set2 inr b set2: mov a,b sta coflag lxi h,ofcb ;copy second name into output fcb lxi d,6ch call copynam ret ; ; copynam moves a file name from de to hl. ; clobbers reg hl, de, b, a. ; copynam: mvi b,12 ;filename length cn1: ldax d ;get from source mov m,a ;put tdma call bdos lxi h,ibuf noread: mov a,m ;get character inx h shld iptr ;update pointer ret ; ; putd puts a character to the pascal output file. it goes ; to the console if coflag is true, else to the disk. ; char is passed in reg a. ; putd: mov c,a ;save char while testing coflag lda coflag ora a jnz co ;out to console lda odev ;get output device ora a jnz co ;only device zero can go to disk mov a,c ;get character back call odiskch ;out to disk ret co: mov e,c ;gebase jmp cmpr jmp csp0 jmp csp1 jmp $ jmp csp3 jmp $ jmp $ jmp $ jmp $ jmp csp8 jmp csp9 jmp spalit jmp spalod jmp spasto jmp acmpr jmp opr3 jmp opr4 jmp opr5 jmp $ jmp $ jmp spcal0 jmp spcal jmp spret br ds 2 ; ; insert version number in object ; db 'RTP REV ' db vhu+'0', vtn+'0', '.', vun+'0', devrel ; ; startup sets up the i/o and stacks before transfering to ; the object code for execution ; startup: lhld 6 ;set stack under bdos mvi l,0 spo cmpr ; returns reg a non zero if zero flag is reset ; cmpr: pop h ;cmpr return address to reg hl pop d ;(top) to reg de xthl ;(top-1) to reg hl, return address to stack mov a,d ;compare signs xra h jp samsin ;same sign - unsigned compare ok mov a,d ;opposite sign ral mvi a,0ffh ;return nonzero value ret samsin: mov a,d ;compre msb's sub h rnz mov a,e sub l ret ; ; gets gets a character from the pasacl input file. it ; comes from the console if ciflag is true, else o dest inx d inx h dcr b jnz cn1 ret ; ; openf opens the file name in fcb1 for input if ciflag is ; false and opens the name in fcb2 for output if coflag is ; false ; openf: lda ciflag ;get ciflag ora a jnz op1 ;skip open if true xra a ;zap fcbnr sta ifcb+32 lxi d,ifcb mvi c,open call bdos inr a jz diskerr ;not found lxi h,ibuf+80h ;init input buffer pointer shld iptr op1: lda coflag ;get coflag ora a rnz ;skip open if true lxi d,ofcb mvi c,delete call bt character back mvi c,2 call bdos ret ; ; odiskch sends the character in reg to the disk output file ; odiskch: push psw lhld optr ;see if past end of out buffer mov a,l cpi (obuf+80h) and 0ffh jnz nowrite ;nope lxi d,obuf mvi c,setdma call bdos lxi d,ofcb mvi c,writerec call bdos ora a jnz diskerr lxi d,80h ;restore dma address mvi c,setdma call bdos lxi h,obuf nowrite: pop psw mov m,a ;store in buffer inx h shld optr ;save new pointer ret ; ; csp0 hl shld br ;inti base reg call setio ;set ciflag and coflag call openf ;open files if needed jmp ocode ;vector to generated object code ; ; setio sets ciflag to 0ffh (true) if input is to come from ; the console (as opposed to 0h if it is to come from disk) ; and likewise for coflag for console output ; setio: lda 5dh ;first name byte of fcb1 mvi b,0ffh ;prepare ciflag value cpi ' ' ;blank means console in jz set1 cpi '?' ;? means console in too jz set1 inr b ;reg b = 0 set1: from disk. ; char returned in reg a. ; gets: lda ciflag ora a jnz ci ;in from console lda idev ora a jnz ci call idiskch ;intput disk character ret ci: mvi c,1 call bdos ret ; ; idiskch gets a character from the input disk file to reg a ; idiskch: lhld iptr mov a,l cpi (ibuf+80h) and 0ffh jnz noread ;dont have to read record lxi d,ibuf mvi c,setdma call bdos mvi c,readrec lxi d,ifcb call bdos ora a jnz diskerr lxi d,80h ;restore dma address mvi c,set  read a character and push it to stack ; csp0: sta idev ;save input device call gets mov l,a mvi h,0 xthl pchl ; ; csp1 pop stack and write it as a character ; csp1: sta odev ;save output device for putd pop h ;csp1 return address to reg hl xthl ;return adr to stack, (top) to reg hl mov a,l ;char to reg a for putd call putd ret ; ; prthl prints the contents of reg hl as a decimal number ; on the pascal output file ; prthl: lxi b,-10 ;divisor setup: lxi d,-1 ;quotient stack ; spalod: lxi b,7 ;bias hl to point to msbyte dad b pop b ;get return address to reg b mvi a,4 ;four words per alfa moralod: mov d,m ;get a word from the alfa dcx h mov e,m dcx h push d ;and push it into the stack dcr a ;done all words yet? jnz moralod ;no mov h,b ;pchl to return address mov l,c pchl ; ; spasto enter with reg hl pointing to lsbyte (first character) ; of an alfa variable, ; an alfa is popped from the stack and stored at reg hl ; spasto: pop b ;getputd pop d ;get word count dcr d ;doen all 4 words? jnz csp81 ;nope ret ; ; csp9 returns control to the operating system (boots) ; csp9: lda coflag ;was output to console? ora a jnz 0 ;yes - just return to cp/m seof: mvi a,1ah ;send eof character call odiskch lda optr cpi (obuf+1) and 0ffh jnz seof ;until last record has been written lxi d,ofcb mvi c,close call bdos ;close output file inr a jz diskerr jmp 0 diskerr: lxi d,errmsg mvi c,9 call bdos jmp 0 errm) sub e mov e,a sbb d sub e mov d,a dad d ;add -(top) to (top-1) xthl ;leave restult on stack and return pchl ;address in reg hl ; ; opr4 multiply (top) by (top-1) ; opr4: pop h pop d xthl push b mov b,h mov c,l lxi h,0 mulmor: mov a,c ora b jz muldone dcx b dad d jmp mulmor muldone: pop b xthl pchl ; ; opr5 divides (top-1) by (top) ; opr5: pop h pop d xthl push b xra a ;negate reg de sub e mov e,a sbb d sub e mov d,a lxi b,-1 sub10: dad b ;divide by continued subtraction inx d ;update quotient jc sub10 ;keep dividing till under draft mvi a,10 ;get remainder to reg a add l push psw ;save on stack xchg ;quotient to reg hl mov a,h ;any digits left? ora l cnz setup ;yes - recurse to print next digit pop psw ;no - get digits to print from adi '0' ;stack in reverse order & convert jmp putd ;to ascii and print 'em ; ; csp3 pops the stack and writes it as a decimal number to ; the pascal output file ; cs return address mvi a,4 ;four words per alfa morasto: pop d ;get a word from the stack mov m,e ;and store it into alfa inx h mov m,d inx h dcr a ;done all words yet jnz morasto ;no mov h,b ;pchl to return address mov l,c pchl ; ; acmpr compares two alfa variables on the stack, sets flags ; like (top)-(top-1) ; acmpr: lxi h,18 ;compute stack pointer after dad sp ;compare is done push h ;save it lxi d,-8 ;compute address of top-1 dad d xchg ;top-1 ptr to reg de dad dsg: db 'disk error$' ; ; spalit takes the eight bytes following the call to it ; and pushes them into the stack ; spalit: pop h ;return address to reg hl mvi a,4 ;eight bytes is four words moralit: mov d,m ;get a word from code and . . . inx h mov e,m inx h push d ;push it into the stack dcr a ;done all words? jnz moralit ;no pchl ;return to byte following dw's ; ; spalod enter with a pointer to lsbyte (first character) ; of alfa variable and it ; pushes the variable into the  mordiv: inx b dad d jc mordiv mov h,b mov l,c pop b xthl pchl ; ; call here with adr to call in reg de ; spcal0: lhld br push h ;static link push h ;dynamic link lxi h,0 dad sp shld br xchg ;pchl to address to call pchl ; ; call here with level difference in reg a and ; address to call in reg de ; spcal: lhld br ;dynamic link push h push d ;save call address call follow ;get static link xthl ;static link to stack, call addresss to hl xchg ;call addrep3: sta odev ;save output device for putd pop h ;get return address to reg hl xthl ;(top) to reg hl, return address back to stack call prthl ;print ret ; ; csp8 prints the alfa variable on the stack ; csp8: sta odev ;save output device for putd mvi d,4 ;number of words to pop csp81: pop h ;top word from stack to hl xthl push d ;save word count push h ;save ms char of word mov a,l ;print ls char of word call putd pop h ;get word again mov a,h ;print ms char of word call  ;top ptr to reg hl xchg ;top ptr to reg de, top-1 to hl mvi c,8 ;chars per alfa moracmp: ldax d cmp m jnz exitacm ;miscompare - return with flags inx h inx d dcr c jnz moracmp ;not done comparing exitacm: pop h ;new stack pointer to reg hl pop d ;return address to reg de sphl xchg pchl ; ; opr3 subtracts (top) from (top-1) ; opr3: pop h ;return address to reg hl pop d ;(top) to reg de xthl ;put back return address, (top-1) to hl xra a ;negate reg de, holding (top  ss to reg de lxi h,0 dad sp shld br xchg ;pchl to call address pchl ; ; jump here to return from a procedure ; spret: lhld br ;get old sp back sphl pop psw ;pop and ignore static link pop h ;dynamic link shld br ;restore base register ret ; ifcb db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 ;a few too many ofcb db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 ciflag db 0 coflag db 0 odev db 0 idev db 0 ; i:-<" disk error$>V#^#=0 >V+^+=A`i>s#r#=P`i!9u# j㯓_WDM!yʙ Ïů_Wک`i*K!9"K*K!9"K*K"K | | |--> OF --> simple type ---------------------| variable ------------> variable identifier ----------------------------> | | |---------------------------| | | | |--> [ --> expression --> ] --| factor ------------> ' -----> character -----> ' ----------------> | ^ | | | |----------------| | | | |--> variable --------------------------------->| | | |--> function identifier ---------------------->| | | |ptr ds 2 optr ds 2 ibuf ds 128 obuf ds 128 ; org (($-1) and 0ff00h) + 100h ocode: ;start of compiled code ; end romorg  UPPER CASE means that this reserved word must appear literaly. identifier ------------> letter ------------------------> ^ | |-- letter <--| |-- digit <--| number ------------> digit --------> ^ | |---------------| constant -----------> number ----------------------------------------------> | ^ |--> constant identifier ----------------------------| | ^ | | | |-- constant <-- + --| | | | | | | | |-----------------------| | | | | | |--> ( -----> expression -----> ) ------>| | ^ | | | |----- , <------| | | | |--> ( --> expression --> ) --------------->| | | |--> constant ----------------------------------| term ------------> factor --------------------------------> ^ | |-- factor <----- * <--| ^ | |-- / <--| |-- AND <--| simple expression -----------> + -------> term ----------------Zãî-:M\zÆÜ<?óRTP REV 00.8R*."KlͲ:] |?|x2'!\ͧ:m ʙ?ʙx2(!lͧ w#©:'2<!"+:(<2!!"-*K^#V=z z>z{:'$:*$**+}R/!/~#"+O:(l:)lysY*-}/œ!w#"-2*o&2)}X ھ> |Ļ0X2)͸2)}X|X:(>s--> ' --> character --> ' ----------------------| simple type ----------------> type identifier ----------------> | ^ |--> ( ----> identifier -----> ) --| | ^ | | | |------ , <----| | | | |--> constant --> .. --> constant ---| type ----------------> simple type --------------------------------> | ^ |--> ARRAY --> [ --> simple type --> ] --| | | | |----------------------------------------| |   ----------------> | ^ ^ | |--> - --| |-- term <----- + <--| ^ | |-- - <--| |-- OR <--| expression -----------> simple expression --------------------------------------> | ^ |--> = -----> simple expression --| | ^ |--> < --| |--> > --| |--> <> --| |--> <= --| |--> >= --| parameter list --------------------------------------------------------------------------> | | |--> ( -----> identi------------------> ) -->| | ^ | ^ | | | | |--> # --| | | | | | | | |---------- , <---------------| | | | |--> FOR --> variable identifier --> := --> expression --| | | | |<-------------------------------------------------| | | | |-----> DOWNTO -----> expression --> DO --> statement -->| | ^ |----> TO ----| block -----------> CONST -----> identifier --> = --> const | | |--> ELSE --> statement -->| | | |--> CASE --> expression --> OF ------------------------> END -->| | | ^ | | |<-----------------------------| | | | | | | | |-----> constant --> : --> statement ------------>| | | ^ | | | | | |--------------- ; ---------------| | | | | | | | | |<---------------------------| | | | | | | | |--> ELSE -- This file descibes the function of each of the p-op codes, as best I can remember them while looking at my notes and code of over a year ago. (Sorry, it's the best I can offer you.) Entered 02/20/81, from notes dated 09/01/79 The compiler does not generate all of the p-codes given here. Some were for planed enhancements that never were finished. Similarlay, the translator (pfet) will translate many p-codes that the compiler presently does not generate. There may be some p-codes it does genfier -----> : --> type identifier -----> ) --| ^ ^ | | | |----- , <-----| | | | |----------------------- ; <------------------| statement ---------------------------------------------------------------------> | ^ |-----> variable ----------------> := --> expression --------->| | | ^ | | |--> function identifier --| | | | |--> procedure identifier -------------------------------------->| | | | | ant --| | ^ | | | | |<------------------------------------- ; <-------| | |--> TYPE ------> identifier --> = --> type ------| | ^ | | | | |<------------------------------------- ; <-------| | |--> VAR -------> identifier -----> : --> type identifier ---| | ^ | | | |<----- , ------| | | ^ | |<-------------------------------------------------------------> statement ------------->| | | | |--> WHILE --> expression --> DO --> statement ----------------->| | | |--> REPEAT -----> statement -----> UNTIL --> expression ------->| | ^ | | | |----- ; <-----| | | | |--> GET --> # --> constant --> ( --> variable --> ) ----->| | | |--> PUT --> # --> constant --> ( --| | | | | | |<--------------------| | | | | | |-----> expression -erate that are not listed here, but this is the bulk of the usefull ones and will give you the general idea. lit 0,c push word constant c into stack opr n,m perform operation m on top of stack element(s) of type n, where n=0 is word, n=1 is alfa lod l,a push word at l+a into stack sto l,a po stack into l+a cal l,a call routine at p label a, level l away int 0,n add n to stack pointer jump 0,a jump to p label a jpc c,a jump to p label a after popping stack c=0 jump if (top)|<-----------------------| | | | | | |--> ( ------------------> expression -----> ) ---------->| | | ^ ^ | | | |--> VAR --| |------ , <-----| | | | |--> BEGIN -----> statement -----> END ------------------------->| | ^ | | | |----- ; <-----| | | | |--> IF --> expression --> THEN --> statement ------------------>| | | | | |<--------| | | | | | |<----- ; <----- block <----- ; <--------------------| | | |-----> procedure -----> identifier --> parameter list --| | | ^ | |--> function ---| | |--> begin -----> statement -----> end --------------------> ^ | |----- ; <-----| program ------------> block --> . ---------------------------------------->   =false, c=1 jump if (top)=true csp 0,n call standard procedure n lodx l,a push word at l+a+(top) into stack stox l,a pop stack into l+a+(top-1) alit 0,0 push alfa which follows (next 2 p-ops or 8 bytes) into stack, msbyte follows first (may have changed) alod l,a push alfa at l+a into stack asto l,a pop alfa from stack into l+a alodx l,a push alfa at l+a+(top) to stack astox l,a pop alfa from stack into l+a+(top-5) pshf 0,0 push true or false into stack based on result of lale 1 | 2 | | . | | . | | . | local variable n | n |__________________| | function value | function return value -10 |__________________| -9 | parameter 1 | -8 |__________________| -7 | parameter 2 | -6 |__________________| -5 | return address | -4 |__________________| -3 | dynamic link | -2 |__________________| -1 | static link | BR -> 0 |__________________| 1 | local vaã;;!*K s#r!*K ^#V/n*K ^#V! ^#V>! > *K ^#V#*K s#r33! > ! > H;;!*K s#r!*K ^#VʱҞ*K ^#V! ^#V!?*K ^#V*K ^#V! ^#V!?st conditional executed laa l,a load absolute machine address of l,a into stack used for var parameters lodi 0,0 load word pointed to by top of stack into stack pops address first stoi 0,0 store word on top of stack at address on (top-1) lab 0,n defines the p label n Zãî-:M\zÆÜ<?óRTP REV 00.8R*."KlͲ:] |?|x2'!\ͧ:m ʙ?ʙx2(!lͧ w#©:'2<!"+:(<2!!"-*K^#V=z z>z{:'$:*$**+}R/!/~#"+O:(l:)lysY*-}/œ!w#"-2*o&2)}X ھ> |Ļ0X2)͸2)}X|X:(>sriable 1 | 2 |__________________| ^^^ offsets from BR (base register) Ѣ*K ^#V*K ^#V3!! ^#V!?Ѣʂ*K ^#V*K ^#V! s#r*K ^#V!! s#r*K ^#V*K ^#V!! s#r*K ^#V*K ^#V3!!! s#r*K ^#V!  *K ^#V!>E33>E*K ^#V!! s#r*K ^#V*K ^#V!! s#r*K ^#V*K ^#V3!!! s#r*K ^#V#*K s#rÚ33H!"} !*} ʿ*} !! s#r*} #"} ï33!"} !*}  *}  The runtime stack is kept on the 8080 machine stack. In all diagrams below, the highest memory address is at the T-O-P of the diagram. char word alfa (01234567) ==== ==== =============== 7 6 5 4 3 2 H 1 pointer to -> x L 0 ____________________ -5 | return address | -4 |__________________| -3 | dynamic link | -2 |__________________| -1 | static link | BR -> 0 |__________________| 1 | local variab:-<" disk error$>V#^#=0 >V+^+=A`i>s#r#=P`i!9u# j㯓_WDM!yʙ Ïů_Wک`i*K!9"K*K!9"K*K"K  !! s#r*} #"} 33!!3"} !*} B j *} !!! s#r*} #"} 2 33!B33>$; t5 = (zero,one,two); t6 = 0..99; t7 = array [t1] of t6; watyp = array [0..amax] of word; aatyp = array [0..amax] of alfa; var v1 : t1; v2,v3 : t2; v4 : t6; gi : word; (* global variables used below *) gj : word; gwa : watyp; (* global word array *) gaa : aatyp; (* global alfa array *) apatr : alfa; (* alfa test pattern *) procedure fortest; var i : word; procedure crlf; (* test nested procedures *) begin put#1(13,10) end; begin put#1('for test',13,10); pdy of table *) put#1(n#, ':', 9); for k:=1 to n do put#1(stirling(n,k)#, 9); put#1(13, 10) (* start new line *) end end. '+'6'*256) then put#1('alfa sub') end; (* simpvar *) procedure arytest; (* test array variables *) var i: word; (* index to test arrays *) (* return word array test data based on subscript *) function pattern(i: word); begin pattern:=amax-i+13 end; procedure wordary; (* test word arrays *) var lwa: watyp; (* local word array *) begin put#1('lwordary'); (* fill array with test pattern *) for i:=0 to amax do lwa[i]:=pattern(i); for i:=0 to amax do if lwa[iut#1('lcl 1-10'); for i:=1 to 10 do put#1(' ',i#); crlf; put#1('gbl 1-10'); for gi:=1 to 10 do put#1(' ',gi#); crlf; put#1('lcl 10-1'); for i:=10 downto 1 do put#1(' ',i#); crlf; end; (* procedure fortest *) procedure repttest; var i : word; begin put#1('rpt 1-10'); i:=1; repeat put#1(' ',i#); i:=i+1 until i>10; put#1(13,10) end; (* procedure repttest *) procedure whiltest; var i : word; begin put#1('whl 1-10'); i:=1; while i<=10 do begin put#1(* TITLE pascal compiler TESTER program FILENAME TESTER.PAS AUTHOR Robert A. Van Valzah 01/08/80 LAST REVISED R. A. V. 01/15/80 REASON added repeat and while testing *) (* check that all legal declaraton syntax is accepted *) (* semantics can be checked only by inspection of the generated code *) const c1 = 'x'; c2 = 13; c3 = c2; c4 = c3+13; c5 = c2+c3+c4; amax = 513; (* max array subsript tested *) type t1 = c1..c2; t2 = 0 ..c2; t3 = c1..99; t4 = t3]<>pattern(i) then put#1('lwa fail',i#); for i:=0 to amax do gwa[i]:=pattern(i); for i:=0 to amax do if gwa[i]<>pattern(i) then put#1('gwa fail ',i#); put#1(13,10) end; (* procedure wordary *) procedure alfaary; (* test alfa arrays *) var laa: aatyp; a: alfa; (* return alfa array test data based in apatr *) procedure alfapatr(i: word); begin apatr[3]:=i*3; apatr[2]:=i*5; apatr[1]:=i*7; apatr[0]:=i*9 end; (* procedure alfapatr *) var n,k : integer; function stirling(n,k : integer); begin if (k=1) or (n=k) then stirling:=1 else stirling:=stirling(n-1,k-1)+k*stirling(n-1,k) end; (* function stirling *) begin (* main line *) put#1(9,9,9,9,9,'k',13,10); (* print centered "k" *) put#1('n', 9); (* print column headings *) for n:=1 to 10 do put#1(n#,9); put#1(13, 10); put#1(9,'=',9,'=',9,'=',9,'=',9,'=',9,'=',9,'=',9,'=',9,'=',9,'=',13,10); for n:=1 to 10 do begin (* print bo(' ',i#); i:=i+1 end; put#1(13,10) end; (* procedure whiltest *) procedure simpvar; (* test simple variables *) var i,j : word; a,b : alfa; begin put#1('testing ','simpvars',13,10); i:=513;j:=1027; (* adjacent vars unique? *) if i<>513 then put#1('nope i=',i#); if j<>1027 then put#1('nope j=',j#); a:='abcdefgh'; if a<>'abcdefgh' then put#1('alfacmpr'); (* test simple alfa subscripting hack *) a[2]:='5'+'6'*256; (* a should = 'abcd56gh' *) if (a<>'abcd56gh') or (a[2]<>'5   begin (* procedure alfaary *) put#1(13,10,'lalfaary'); for i:=0 to amax do begin put#1('-'); alfapatr(i); laa[i]:=apatr end; for i:=0 to amax do begin alfapatr(i); if laa[i]<>apatr then put#1('laa fail',i#) else put#1('.') end; put#1(13,10,'galfaary'); for i:=0 to amax do begin put#1('-'); alfapatr(i); gaa[i]:=apatr end; for i:=0 to amax do begin alfapatr(i); if gaa[i]<>apatr then put#1('gaa fail',i#) else put#1('.')>E33>E*K ^#V!! s#r*K ^#V*K ^#V!! s#r*K ^#V*K ^#V3!!! s#r*K ^#V#*K s#rÚ33H!"} !*} ʿ*} !! s#r*} #"} ï33!"} !*}  *} !! s#r*} #"} 33!!3"} !*} B j *} !!! s#r*} #"} 2 33!B33>$or i:= 0-7 to 7 do c[i+7] :=true; try(1) end.  end; put#1(13,10) end; (* procedure alfaary *) begin (* procedure arytest *) wordary; alfaary end; (* procedure arytest *) begin (* main line *) fortest; repttest; whiltest; simpvar; arytest end.  (* Prints solutions to the problem of placing eight queens on a chess board in such a way that no queen checks against any other queen. See "Algorithms+Data Structures = Programs", Niklaus Wirth. *) type boolean = (false, true); aryi = array[0.. 8] of integer; aryb = array[0..16] of boolean; var i : integer; a, b, c: aryb; x : aryi; procedure print; var k : integer; begin for k:=1 to 8 do put#0(x[k]#,' '); put#0(13,10) enã;;!*K s#r!*K ^#V/n*K ^#V! ^#V>! > *K ^#V#*K s#r33! > ! > H;;!*K s#r!*K ^#VʱҞ*K ^#V! ^#V!?*K ^#V*K ^#V! ^#V!?Ѣ*K ^#V*K ^#V3!! ^#V!?Ѣʂ*K ^#V*K ^#V! s#r*K ^#V!! s#r*K ^#V*K ^#V!! s#r*K ^#V*K ^#V3!!! s#r*K ^#V!  *K ^#V!ppc ppc.pas a.pco pfet a.pco a.oco era a.pco pip ppcnew.com=rtp.com,a.oco[vo era a.oco ppc pfet.pas a.pco pfet a.pco a.oco era a.pco pip pfetnew.com=rtp.com,a.oco[vo era a.oco ppcnew ppc.pas a.pco pfetnew a.pco a.oco era a.pco pip ppcself.com=rtp.com,a.oco[vo era a.oco compare ppcself.com ppcnew.com ppcnew pfet.pas a.pco pfetnew a.pco a.oco era a.pco pip pfetself.com=rtp.com,a.oco[vo compare pfetself.com pfetnew.com d; (* procedure print *) procedure try(i : integer); var j : integer; begin for j:=1 to 8 do if (a[j]=true) and (b[i+j]=true) and (c[i-j+7]=true) then begin x[i]:=j; a[j]:=false; b[i+j]:=false; c[i-j+7]:=false; if i<8 then try(i+1) else print; a[j]:=true; b[i+j]:=true; c[i-j+7]:=true end end; (* procedure try *) begin (* main line *) for i:= 1 to 8 do a[i] :=true; for i:= 2 to 16 do b[i] :=true; f  (* decimal representaton of negative powers of 2 *) const n=10; type digit = 0..9; digtyp = array[1..n] of digit; var i,k,r: integer; d : digtyp; begin for k:=1 to n do begin put#0('.'); r:=0; for i:=1 to k-1 do begin r:=10*r+d[i]; d[i]:=r/2; r:=r-2*d[i]; put#0(d[i]+'0') end; d[k]:=5; put#0('5',13,10) end end. bers tester.pas tests functionality of Pascal compiler validate.sub submit file to make sure you have a "fertile" compiler Both playkal.pas and hw5.pas are solutions to programming assignments for my computer science classes at the University of Illinos. They are included here to show how to build trees when you don't have pointers. They also illustrate a kludgey way of simulating Pascal records when you don't have them either. stirling.pas is included to show a kludgey way to do outputa message hw5data sample data for above pasyntax.doc syntax graphs for this Pascal compiler pc.sub submit file to compile a Pascal program pfet.com object code of the p-code to 8080 translator pfet.pas source of above phone.c C program to print words you can spell with your phone number playkal.pas Pascal program to determine best moves in game of Kalah playdata sample data for above pops.doc documentation on the p-codes used by the compiler powtwo.pas Pascal program to prinZãî-:M\zÆÜ<?óRTP REV 00.8R*."KlͲ:] |?|x2'!\ͧ:m ʙ?ʙx2(!lͧ w#©:'2<!"+:(<2!!"-*K^#V=z z>z{:'$:*$**+}R/!/~#"+O:(l:)lysY*-}/œ!w#"-2*o&2)}X ھ> |Ļ0X2)͸2)}X|X:(>s formatting. t negative powers of two ppc.com object code of Pascal to p-code compiler ppc.doc users manual for Pascal compiler ppc.pas source of Pascal compiler pstack.doc documentation on the run time p-machine stack regen.doc notes on how to modify and compile the compiler rtp.asm source for the run time package rtp.com object of above speed.com makes your system go faster by disk buffering speed2.com above for 2.x systems stirling.pas Pascal program to print a table of Stirling num:-<" disk error$>V#^#=0 >V+^+=A`i>s#r#=P`i!9u# j㯓_WDM!yʙ Ïů_Wک`i*K!9"K*K!9"K*K"K Contents of this disk ===================== compare.com file compare utility from previous CP/M UG disk an absolute must for self compiler writers cpmdir.c V7 UNIX C program to print a CP/M directory on stdout disk.doc this file eq.pas prints all solutions to the "eight queens problem" fromcpm.c V7 UNIX C program to read a CP/M file to standard output fwd.pas Pascal program illustrating forward procedure declarations hw5.pas builds an optimal binary search tree and decodes   *K ^#V!?*K ^#V*K ^#V?ѲN! *K s#r;;*K ^#V!3*K ^#V!3>E3333*K ^#V;;*K ^#V!3*K ^#V>E33336 *K s#rH! > ! > ! > ! > ! > !K> ?ѢU>^#V! 6*K ^#V!03>s#r> *K s#r> *K s#r*K ^#V! UH!9bB!*K s#r*K >E33*K ^#V!*K ^#V"R*K ^#V!*K ^#V! s#r*K ^#V!*K ^#V! s#r*K ^#V!!! s#r*K ^#V!!! s#r*K ^#V!*K ^#V! s#r*K ^#V!*K ^#V! s#r*K ^#V! *K ^#V!*K ^#V! s#r*K ^#V!:-<" disk error$>V#^#=0 >V+^+=A`i>s#r#=P`i!9u# j㯓_WDM!yʙ Ïů_Wک`i*K!9"K*K!9"K*K"K^#V!!^#V!*K ^#V! s#r>^#V!!^#V!*K ^#V! s#r>^#V!!^#V!>^#V!!^#V! s#r>^#V!!^#V!?>^#V!!^#V!>^#V!!^#V! s#r*R>^#Ve*K ^#V"R*T>^#VŸ>^#V!!^#V"TH;;;;w Bu B!.> *R*T¦H*K ^#V!ʷ*K ^#V>^#V! > ! > !N> ! > !"! *Aa*>! > *#"133! > ! > ! > !=> ! > !=> ! > !=> ! > !=> ! > !=> ! > !=> ! > !=> ! > !=> ! > !=> ! > !=> ! > ! > !"! *W*>!:> ! > !"**ʎҾ;;**B3333>! > *#"~33! > ! > *#"G33>$*K ^#V! s#r*K ^#V*K s#rbB*K ^#V!$—*K ^#V"T*K ^#V!!! s#r*K ^#V!!! s#rH>^#V!!^#V>^#V!!^#V>^#Vt t >^#V!!^#V>^#V!!^#V>s#r>^#V>s#r>^#V>s#rH!9*R*K s#r!*K s#r*K ^#V!!^#V!r *K ^#V!!^#V*K s#r*K ^#V!!*P!"P*K ^#V*P! 6s#r*K ^#V^#V!*! 3_'REVOPAEH>!H;;> >s#r>^#V!$U> *K s#r*K ^#V! > *K s#rÝ!>s#r*K ^#V!0>=*K ^#V!9*K ^#V>s#r*K ^#V!!^#V*K ^#V!>E3333*K ^#V!*K ^#V! s#r*K ^#V!!^#V*K ^#V!>E3333H!>s#r*R!B3333H;;!*K s#r*K ^#V!*V>s#r>^#V!*K ^#V!Ѣʼ>^#V!!^#V>^#V!*K s#rù>^#V!!^#V>s#r*K ^#V!>^#V!3>s#rH;;;;*Zãî-:M\zÆÜ<?óRTP REV 00.8R*."KlͲ:] |?|x2'!\ͧ:m ʙ?ʙx2(!lͧ w#©:'2<!"+:(<2!!"-*K^#V=z z>z{:'$:*$**+}R/!/~#"+O:(l:)lysY*-}/œ!w#"-2*o&2)}X ھ> |Ļ0X2)͸2)}X|X:(>s^#V!$A  B*K ^#V!!^#V*K s#r  B*K ^#V!!^#V*K s#rÚ H;;*K >E33*K ^#V!!$! s#r*K ^#V!>^#V!!^#V>^#V!!^#V! s#r*K ^#V!>^#V! s#r*K ^#V!>^#V! s#r*K ^#V!>^#V!!^#V! s#r*K ^#V!>^#V!!^#V! s#r>^#V!!^#V!: >  K >E33>^#V!!^#V*K s#r*K ^#V!!$! s#r*K ^#V!>^#V! s#r*K ^#V!*K ^#V! s#r*K ^#V!>^#V!!^#V!3! s#r*K ^#V!*K ^#V!!^#V! s#r*K ^#V!>^#V!!^#V! s#r>^#V!!^#V!>^#V!!^#V!*K ^#V! s#r*K ^#V!!^#V!**K ^#V!s A.PCO and A.OCO will be erased. In general, to use this automatic .PAS->.COM translation enter: EX14 PC filename where filename is the name of your pascal program which must have the extent .PAS though you do not enter it. The following files must be on the disk: Your source file (filename) PPC.COM PFET.COM EX14.COM PC.SUB PIP.COM as well as some extra space for the output files. To manually create an object file from a Pascal file do the following: (again I will tart with "********" and otherwise be blank to call attention to the error. The compiler will also wait for a single character from the console before compilation continues. This is so people with crt's can see the error. Error numbers should be looked up in Jensen and Wirth (see below). Error number 99 is pound sign ("#") expected. The compiler should work with a 32k CP/M and might work in 24k, but there are no memory overflow checks. If it hangs or something, you !^#V!*K ^#V! s#r>^#V*VP*K ^#V"VH!9B! > ! > '= VELXAM>!*K ^#V>! > ! > *K ^#V*K s#rBB!.> *K ^#V!ڸH> >s#r>^#V! ?>^#V! ?Ѳ>^#V! ?Ѳ`> >s#r>^#V!ˆ!>s#rH!9! > ! > ' DEDOCED>!' EGASSEM>!! > ! > !*K s#rB*K ^#V!*Vuse EQ.PAS as an example). 1. Compile----> Enter: PPC input_filename output_filename (e.g. PPC EQ.PAS EQ.PCO) Any file extent is acceptable but since there are intermediate files I recommend the following extents to avoid confusion: .PAS for pascal source code .PCO for p-code (compiler output) .OCO for object code (PFET output) .COM for final program The compiler will ask "LISTING?". You reply with a single character; carriage return means no listing, any ot PPC Users Manual How to use the compiler ======================= If you have a file named EQ.PAS and you want to compile it, you'd just type: EX14 PC EQ This will use the submit file PC.SUB to automatically compile EQ.PAS to a file called A.PCO. PFET.COM will be summoned next and use the file A.PCO as input and produce a file called A.OCO as output. Then PIP will be called (make sure it is on the disk) to link A.OCO with RTP.COM and produce the file EQ.COM as output. Then the file probably don't have enough memory. 2. P-code to Object code------> Enter: PFET input_file output_file (e.g. PFET EQ.PCO EQ.OCO) This will take place rather quietly and quickly. PFET makes 2 passes and will output its pass # to the counsole. When finished it outputs DONE! and Warm Boots. 3. Link-------> Enter: PIP output_file=RTP.COM,input_file[ov] (e.g. PIP EQ.COM=RTP.COM,EQ.OCO[ov]) The square brackets at the end are pip parameter delimiters. The parameter*K s#r*K ^#V!!^#V!$¥*K ^#V!0t*K ^#V!!^#V*K s#rÜ*K ^#V!!^#V*K s#rB *K ^#V!!^#V> H!"P}B*R"VBSBB>$her character means yes listing. The listing will be sent to the console as the compilation proceeds. Entering a ^P (control-P) before entering PPC will also send the listing to the printer. Compiler Error Detection Any errors detected in the compilation are flagged in this listing. At some point (hopefully reasonably near to the point of infraction) the error number will be inserted into the listing, enclosed in ">>" and "<<". The line following an error will s  s within them tell pip that these are object files(o), and to verify the transfer(v). You may now run the file EQ.COM by entering: EQ . How it all works ================ The program PPC.COM takes your Pascal source and makes a single pass over it translating it to a sort of p-code as it goes. This p-code is written to disk. PFET.COM reads the p-code file on its first pass, assigning 8080 addresses to all p-code labels and storing the p-code in memory for the second passoperand is likely to be less than the other, put the lesser operand on the left of the multiplication symbol for best speed. Dividing a large number by one takes a long time -- dividing it by zero takes forever! (It's not that I'm not aware of the shiftng methods of division and multiplication, it's just that I wanted something quick and didn't feel like looking up the good routines. I've never felt the need to replace these routines with the good ones.) Also note that there is no integer negatioace character. Comments are begun with the sequence "(*" and ended with "*)". Identifiers may be very long, but only the first 8 are significant. The data type Boolean is not supported. Relational and logical operators may be used only in if statements. The boolean constant identifiers true and false are not defined. The not operator is not implemented. These are the legal relational and logical operators: =, <>, <, <=, >=, >, and, and or. The data type integer is available. Values mused compile time constant expressions to make coding the translator easier. See the syntax graphs to see where these can be used. Variable declarations have the restriction that the type must be a type identifier and may not be a complex type. Thus var months : array [ 1 .. 12 ] of integer; is illegal, while type mtharray = array [ 1 .. 12 ] of integer; var months : mtharray; is legal. In this implementation, functions can return only integer values. This makes it unnecessary (an. On its second pass, PFET reads the p-code from memory and generates the actual 8080 object code. This code is written to a disk file. The last step in compilation is to link the generated object code to the run time package. This is done by simply using PIP to concatenate the run time package and the object file from PFET to produce an executable .COM file. The compiler (PPC) is written in Pascal, as is the p-code translator (PFET). The run time package is written in assembler. Differen. If you want negative one, write it as 0-1. The type real is not supported. The type char is not supported, but see type alfa below. The type alfa can hold eight characterers. Alfas can be assigned and compared just like integers (just don't try to do math on them!). All relational operators are defined using the ASCII collating sequence. Length can't enter into the compariosn because alfas are always eight characters long (it's up to you to supply padding). Alfas may be passed as paramet be in the range -32768 to 32767. There are no standard functions such as abs, sqr, trunc, etc. The constant maxint is not defined by the compiler. The type integer is identical to type word. The following operations are defined on integers: * multiply / divide and truncate (why use div? int's are all you've got!) + add - subtract Multiplication and division are presently implemented with repeated addition and subtraction (gag!). This makes the order of the operands critical. If one d illegal) to give a function return type in the function declaration. The case statement is limited in that it cannot accept multiple case labels on the same statement. On the other hand, it has been extended to allow an else statement which is executed when none of the case labels match the expression value. See the syntax graphs for the syntax. Single dimensional arrays of integers and alfas (the two "built-in" types) are allowed. You can also declare arrays of subrange or enumerated tynces from "standard" Pascal ================================== This section will detail the ways in which ppc deviates from standard Pascal as defined in "Pascal User Manual and Report", second ed., K. Jensen and N. Wirth. Two additional reserved words have been defined: get and put. The following words are not now considered reserved, but are in standard Pascal, so they should be avoided: file, goto, in, label, nil, packed, set, and with. The ASCII tab character is an acceptable white spters. Since files are not supported, the program heading is not needed, and in fact, is not allowed. The first thing the compiler expects to see are the global constant declarations. Goto statements are not supported, therefore label declarations are not needed and not permitted. Constant declarations are pretty much the same as in regular Pascal, except that leading signs are not allowed and character constants can be only one character in length. A minor extension is that I put in limit!  pes, but these are treated as arrays of integers and take the same amount of storage. Of course, arrays of arrays are not allowed, as that would be more than one dimension. If a simple alfa variable appears with a subscript after it, it is treated as though it were an array of integers. This fact can be used to get at the individual characters of an alfa variable. For example, if "a" is a simple (not an array) alfa variable, then a[0] refers to the first two characters. The least significant eparameters, as well as in the declaration. This is very easy to forget an a real nuisance at times. Somebody please fix. It is possible to forward declare procedures an functions, but as with var parameters, there is a minor syntactic kludge to make the compiler's life easier. The forward part is handled in the normal way except that you D-O-N-'-T give the parameter list (the compiler never checks procedure calls against their declarations anyway!). When you actually want to declare the proced decimal value of the expression. If no pound sign follows the expression, the low eight bits of the expression are sent as one character. The input and output files mentioned above can be either disk files or console input and output. Which is used depends on what is typed on the command line following the compiled .com file when it is executed. If the first filename following the .com file name is blank or '*', then input characters are taken from the console. If it is the name of a disk file, EX 1.4 - 11/20/82 Thanks to Joe Cutler, Stan Hanson, and Ron Fowler for EX.* and the information used to create this version. This file and the source for EX14 are based upon the previous EX*.* files. EX 1.4 is a maintenance update to EX 1.2 and EX 1.3 (never released). Problem: BASCOM would not execute under EX. Reason: BASCOM is doing system integrity checks using the BDOS+1 address. EX was not preserving the required information so that BASCOM would execute. ight bits would contain the first character and the most significant eight bits would contain the second character. Record types are not allowed. Therefore, there is no need for a with statement. There is no set type. (However, it shouldn't be too hard to implement a 64-bit set type using the p-instructions already around for alfa variables . . . ). There are no pointer types, and consequently, no new function. There are no files and no read or write statements. All input and ouure, use the form procedure foo(); backward; This gives the compiler a hint it can't miss that this procedure was forward declared earlier! Extensions we would love to see!!!!!!!!!!!!!!!!!! A Z80 version of the whole works. A CP/M86 version.  then input comes from that disk file. A similar rule applies to the second filename following the command and the destiny of the output characters. Var parameters are different in that if one parameter to a procedure is to be var, then all parameters must be var parameters. This is a silly restriction that should be easily removed by any talented compiler hacker. There is a also a small kludge to make the compiler's job easier; the word var must appear in the call to all procedures with var  Resolution: See next problem resolution. Problem: Unpredictable results when executing MBASIC under EX. Reason: MBASIC (and others) were not subtracting 6 from the BDOS+1 address when determining available memory. Resolution: EX now refreshes the storage in the 6 bytes below the BDOS+1 address during any warmboot request. The enhancements added with EX 1.2 are: ^: EX runtime re-execution function ^? EX runtime wait for carriage return `Xsub Already Presentput is done with the put and get statements. These are only vaguely similar to the standard Pascal put and get. GET#0 gets one character from the input file. PUT#0 sends its output to the output file. PUT#1 sends its output unconditionally to the console. The arguments to the put statements consist of a series of expressions separated by commas. If an expression evaluates to an alfa, all eight characters of the alfa are printed. Integer expressions followed by a pound sign ('#') will print the"  t' logic Input/EX buffer overlap detection EX runtime recursion prevention (Ex Already Present) EX runtime prompt mode character logic The enhancements added with EX 1.1 are: ;; EX only comment support ^. Print suppression toggle ^<..^> Immediate print function ^# EX message suppression toggle ^| Carriage return/line feed function ^$ Default parameters' support Logic to prevent ZCPR re-entrance to EX.COM (EX.COM is not reentrant) --Larry Scuted as if was entered from the console. EX14.COM may be terminated during execution by entering control-C from the console. EX14.COM submit file conventions are: [note: unless otherwise stated, the `<.......>' sequences are used only to indicate character strings that must be replaced with the values described.] ^ generates the corresponding control character. Lowercase letters a thru z are converable on CP/MIG XA1 ACCESS database] The files used to test EX14.COM are: EX14.COM EX14.TST (must be renamed to .SUB before executing test) XSUB.COM The files used to execute EX14.COM are: EX14.COM SUB.COM (used to generate simple *.SUB files) [note: Any good CP/M editor may be used to create *.SUB files] (cr is carriage return) EX14.COM may be invoked two ways: 1. EX14 cr This form will cause EX to prompt with a line number an ^ control support, $<1 thru 9> parameter substitution, and $ escape support continues during this display mode. (Example: ^<^[ETest EX 1.4^|^> will generate the sequence to clear the screen on the H/Z19 terminal and display `Test EX 1.4' at the upper-lefthand corner of the screen and the cursor will be on the next line.) ^: causes EX to re-execute the .SUB file from the beginning. ^? causes EX to wait for a carriage return response from thteeger [70315,1120] on CompuServe [note: The changes from file EXFIX.DOC have been incorporated into EX12.*] EX is a nifty and fast way of executing .SUB files, (uses ram as the SUB file buffer rather than spreading it out on disk). EX also allows batch entry of a series of commands which it stores in memory for subsequent continuous execution. EX relocates itself and its buffer to high memory just below CCP and adjusts the CP/M BDOS entry to protect itself. -ted to uppercase. $<1 thru 9> generates parameter <1 thru 9> substitution the same as SUBMIT, unless `^$' is being used as described below. ^$ will generate a list of parameters that will be used in the $<1 thru 9> parameter substitution if the user does not provide any parameters or only some of the parameters on the EX command line. ;; generates an EX only comment (the ;; and the remainder of the cd `:' for each command line to be executed. A carriage return entered by itself terminates the prompting and starts execution of the command lines that have been entered. 2. EX14 cr This form will cause EX to load the into memory and perform substitution the same as SUBMIT, with the addition of the `^$' support for missing parameters. After all parameters have been substituted the text from the file is exee console. Control-C will terminate EX at this point also. $$ generates the $ (dollar-sign). $^ generates the ^ (caret or up-arrow). $| generates the | (broken vertical bar). EX14.COM(.BIN or .OBJ) was generated from EX14.ASM using EX14.SUB and the files mentioned above. --Larry Steeger 11/20/82 BIN or .OBJ) was generated from EX14.ASM using-Stan Hanson 05/24/82 EX replaces the functions of both SUBMIT.COM and XSUB.COM from Digital Research, Inc. --Larry Steeger 08/06/82 The files used to assemble EX14.ASM using EX14.SUB are: ED.COM EX14.ASM EX14.SUB MAC.COM RELS.UTL (or REL.UTL see note in EX14.SUB) SID.COM SUBMIT.COM and XSUB.COM (or a previous version of EX.COM may be used) [note: REL.UTL is available on CP/MUG Volume #38] [note: RELS.UTL is availurrent line are not moved to the EX command buffer.). | generates a Carriage Return. ^| generates a Carriage Return and Line Feed. |,cr,lf,1AH(EOF) will eliminate all characters from the last | thru this sequence. ^. toggles print suppression for characters from SUBMIT file. (Example: DIR ^.*.COM^. will execute DIR *.COM but only DIR will be echoed to the console.) ^< forces immediate display of the characters following it until ^> is encountered.#   Using CRC Type CRC to verify all the files on this disk. Type CRC *.* F to generate CRC's for an entire disk and create a CRC file (CRCKLIST.CRC) for checking the CRC's of a copy of the disk etc. Omitting the F will suppress creation of a CRCKLIST.CRC file. *.* can be replaced with an unambiguous file name for checking just one file. *#"ɯ2i2}! "!"]]2 s : ~# ++FILE NOT FOUND++$: F*}’">͇†]<  CANNOT CLOSE CRCFILE$CRCKLISTCRCSK FULL: CRCFILE$  w# !]͐ DONE$!e S!]Q !eZ @ --> FILE: XXXXXXXX.XXX CRC = oS) \<‘@ ++OPEN FAILED++ !" !" * | ʹ) \!~2 #" Ý: ) > T : ) @ ++FILE READ Eth file - ! ~T #M M 2 2 2 2 ! >2 3o: : @ ***No CRC Files found***$> ʉ ʉw#: <2 P6: .6@ Can not parse string ! ~ʽT #ñM ! > 6 #6^#6! ~T #! 4M #x] #e w~ T #>2 @ - s M@ File not found ! 4 >2 o: G: „: G: „@ *Match* 2 ! 4@ <-- is, was --> : ) > T : ) M 2 ! 4<2 ~# @ Not a space between CRC values<2 G-CATALOG??? Documentation for Using the Pascal Pascal Compiler Disk+++++++++++++++++ Read the documentation on the compiler itself (PPC.DOC) before attempting to use the compiler. Examine PASYNTAX.DOC before writing a Pascal program for this compiler. The other .DOC files are primarily for information about the compiler for those who wish to modify it or understand its operation in more detail. Do not reassemble the runtime package without first consulting REGEN.DOC Documentation Files: PPC.DOCRROR++ <* |): o% |g}o" 2  ; 0T ~T #~A > T > _h : F{͇2h2|: ʲ !\   :\2 ! \  \ ! \  \! \  \<7=Ɓo&   ]  2h2|2   ~$#~# x  : F} *}= ">͇1 ].”#””͡”››tK››͸›* =: =͔="  ʳ ª~#.  ¿~  #~  .+~#0:0~#!A.O.Gy~#0M0 K MMɷ:m2 FSÄCRCKLIST$$$››tK›, › **}|!"*{z*~]*"Ü  DISK FULL: CRCFILE$!"*~ This is the users manual for the compiler. The file also discusses the limitations of the compiler, the operation of the compiler and deviations from stan- dard Pascal. POPS.DOC This file describes the p-code generated by the compiler. PSTACK.DOC This is documentation on the stack operation of the run-time P-machine. REGEN.DOC This file describes the recompilation procedure for the compiler and the reassembly of the run time package. PASYNTAX.DOC Syntax charts for writin#CRC.COM 5.0 6/18/82CRCKFILE???!9" 1 M @ CRC Ver 5.0 CTL-S pauses, CTL-C aborts :] O@ ++Searching for CRCKLIST file++@ Now searching for "CRCKFILE" file++ !  1 .) F!  ͡]͸! ͔0CRCKLIST???CRCKFILE???!9" M à*,*.}|ډ!".*,{z{** u*.".G*.",!".***,}>*.#".ɯ22)! ",". <  NO FILECRC FILE$!   >. @ Checking wi match - : ̓ : J M @ Quantity of lines failed parse test - : ̓ : ~ M @ Quantity of file(s) not found - : ̓ * d͔  ͔ 0T  Җ Wyʩ 0T 0ztiil$  g Pascal programs for this compiler. The Compiler Package PPC.COM Executable Pascal Pascal Compiler. PPC.PAS Pascal source code for the compiler which can be compiled by the compiler. PFET.COM The p-code to 8080 machine code translator. PFET.PAS Pascal source code for the translator which can be compiled by PPC.COM. RTP.COM The assembled run time package which must precede the output of PFET to complete the executable Pascal program. RTP.ASM Assembly language sourceOther Programs COMPARE.COM A program for comparing to files. A must for compiler writers and modifiers. VALIDATE.SUB A submit file to test a modified compiler. Makes the compiler compile itself and then compares the two. Described in REGEN.DOC. EX14.DOC EX14.COM A replacement for submit.com. XA.PCO This is the compiler output for EQ.PAS included as an example of a p-code file. XA.OCO This the PFET output for the above file as an example of the object code output of PFET.COM --> FILE: PC .SUB CRC = D4 F2 --> FILE: XA .PCO CRC = E6 B1 --> FILE: COMPARE .COM CRC = AA 48 --> FILE: FWD .PAS CRC = AF 52 --> FILE: HW5 .PAS CRC = D7 52 --> FILE: HW5DATA . CRC = 18 A3 --> FILE: EX14 .COM CRC = 02 E3 --> FILE: PFET .COM CRC = 55 19 --> FILE: PFET .PAS CRC = 07 C5 --> FILE: PLAYKAL .PAS CRC = 0A EE --> FILE: PLAYDATA. CRC = 02 EF --> FILE: PPC .COM CRC = CD 59 --> FILE: PPC .PAS CRC = 9F E9 --> FILE: REGEN for the run time package. PC.SUB A submit file for automatically compiling, translating, and creating a .COM file from Pascal source code. Sample Pascal Programs EQ.PAS Pascal program to display all solutions to the 8 queens chess problem. FWD.PAS Pascal program illustrating forward procedure declarations. HW5.PAS Pascal program that builds an optimal search tree to decode a message. This program and PLAYKAL (below) were included to demonstrate how to build trees when you Kaypro Disk #16 Pascal Pascal Compiler From CP/M Users Group And Bob Van Valsah This is a compiler for writing in Pascal. As it now stands, it supports only a subset of Standard Pascal but since the source code is provided for everything, any one may extend the compiler, it compiles itself! The compiler generates p-code from Pascal source code. The p-code is translated to 8080 object code by another program on this disk. PIP.COM is then us. CRC.COM CRC.DOC This is a cyclic redundancy checker for verifying files. +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++  .DOC CRC = 83 1C --> FILE: RTP .ASM CRC = 4D DE --> FILE: RTP .COM CRC = 53 08 --> FILE: PASYNTAX.DOC CRC = A3 24 --> FILE: POPS .DOC CRC = 50 09 --> FILE: PSTACK .DOC CRC = 9C D6 --> FILE: EQ .COM CRC = F3 4F --> FILE: STIRLING.PAS CRC = 3F 6B --> FILE: TESTER .PAS CRC = 08 C3 --> FILE: VALIDATE.SUB CRC = 83 9F --> FILE: XA .OCO CRC = 7F 39 --> FILE: EQ .PAS CRC = C9 F2 --> FILE: POWTWO .PAS CRC = 15 1A --> FILE: DISK .DOC CRC = FC  don't have pointers and simulate Pascal records. HW5DATA. Data for above program. PLAYKAL.PAS Pascal program that determines the best moves for a game called Kalah. PLAYDATA. Data for above program. POWTWO.PAS Pascal program that prints the negative powers of 2. STIRLING.PAS Pascal program that prints the Stirling numbers. Included as an example of one way to do formatting. TESTER.PAS A Pascal program for testing a compiler. See REGEN.DOC for a description of its use. ed to concatenate the object file from the compiler with a run time package on this disk to create a .COM file. The compiler and the p-code to 8080 translator are written in Pascal. The run time package is written in assembly language and the source for that is on this disk as well. See PASCAL.DOC for a description of the files on this disk and a directory of the documentation provided. To verify the files on this disk enter: CRC %  7C --> FILE: STIRLING.COM CRC = 41 22 --> FILE: HW5 .COM CRC = 48 E8 --> FILE: PPC .DOC CRC = 24 7A --> FILE: EX14 .DOC CRC = 9B 8F --> FILE: CRC .DOC CRC = E5 81 --> FILE: CRC .COM CRC = B2 07 --> FILE: PASCAL .DOC CRC = B2 C4 --> FILE: 16-DISK .DOC CRC = C7 68&  '