TITLE ZAP -- New Z-Language Assembler ; ZAP version 3 - Expanded word table to 96 words ; MARC/JMB - 1/7/82 .DECSAV SUBTTL ACS O=0 A=1 B=2 C=3 D=4 E=5 F=6 G=7 ZCHR=7 H=10 FRMT=10 I=11 J=12 ;called J only during word-frequency pass ;acs below this point are used for special purposes AB=12 ;pointer into argument table ARGBUF Z=13 ;pointer into output buffer OUTBUF ZPC=14 ;pc FREE=15 ;free storage pointer for symbol tables TP=16 ;pointer into token table TOKENS P=17 ;stack %FWDCT==512.-16. ;bits in symbol table words %UNDEF==400000 ;undefined symbol; right half will be ptr to references %VAR==200000 ;symbol is a variable %BITS==600000 ;all defined bits in symbol table ;bits in reference words %RBYTE==400000 ;byte refs are flagged %RJUMP==200000 ;as are jump refs ;random macros DEFINE MSG M HRROI A,[ASCIZ /!M!/] TERMIN DEFINE NXTARG N ADD TP,[<2*N>,,<2*N>] TERMIN LOC 140 SUBTTL PSEUDO-OPS AND OPCODES %PSEUD==400000 ;pseudo-op ;pseudo-op definition macro DEFINE DISP SYM 440700,,[ASCIZ /.!SYM/] %PSEUD,,Z!SYM TERMIN %PRED==200000 ;predicate inst. %VAL==100000 ;value inst. %JUMP==40000 ;jump inst. %STR==20000 ;string instr. %XARG==10000 ;?? ;opcode definition macro DEFINE DEFOP OP,OPCODE,FLAGS 440700,,[ASCIZ /OP/] FLAGS,,OPCODE TERMIN SUBTTL PSEUDOS OPS: PSUTBL: DISP BYTE DISP END DISP ENDI DISP ENDT DISP EQUAL DISP FALSE DISP FSTR DISP FUNCT DISP GSTR DISP GVAR DISP INSERT DISP LEN DISP OBJECT DISP PDEF DISP PROP DISP SEQ DISP STR DISP STRL DISP TABLE DISP TRUE DISP WORD DISP ZWORD OPRTBL: DEFOP ADD,20.,%VAL DEFOP BAND,9.,%VAL DEFOP BCOM,143.,%VAL DEFOP BOR,8.,%VAL DEFOP BTST,7.,%PRED DEFOP CALL,224.,%VAL DEFOP CRLF,187. DEFOP DEC,134. DEFOP DIV,23.,%VAL DEFOP DLESS?,4.,%PRED DEFOP EQUAL?,1.,%PRED+%XARG DEFOP FCLEAR,12. DEFOP FIRST?,130.,%PRED+%VAL DEFOP FSET,11. DEFOP FSET?,10.,%PRED DEFOP FSTACK,185. DEFOP GET,15.,%VAL DEFOP GETB,16.,%VAL DEFOP GETP,17.,%VAL DEFOP GETPT,18.,%VAL DEFOP GRTR?,3.,%PRED DEFOP IGRTR?,5.,%PRED DEFOP IN?,6.,%PRED DEFOP INC,133. DEFOP JUMP,140.,%JUMP OPJMP=.-1 ;full opcode for jump DEFOP LESS?,2.,%PRED DEFOP LOC,131.,%VAL DEFOP MOD,24.,%VAL DEFOP MOVE,14. DEFOP MUL,22.,%VAL DEFOP NEXT?,129.,%PRED+%VAL DEFOP NEXTP,19.,%VAL DEFOP NOOP,180. DEFOP POP,233. DEFOP PRINT,141. DEFOP PRINTB,135. DEFOP PRINTC,229. DEFOP PRINTD,138. DEFOP PRINTI,178.,%STR DEFOP PRINTN,230. DEFOP PRINTR,179.,%STR DEFOP PTSIZE,132.,%VAL DEFOP PUSH,232. DEFOP PUT,225. DEFOP PUTB,226. DEFOP PUTP,227. DEFOP QUIT,186. DEFOP RANDOM,231.,%VAL DEFOP READ,228. DEFOP REMOVE,137. DEFOP RESTART,183. DEFOP RESTORE,182.,%PRED DEFOP RETURN,139. DEFOP RFALSE,177. DEFOP RSTACK,184. DEFOP RTRUE,176. DEFOP SAVE,181.,%PRED DEFOP SET,13. DEFOP SUB,21.,%VAL DEFOP USL,188. DEFOP VALUE,142.,%VAL DEFOP VERIFY,189.,%PRED DEFOP ZERO?,128.,%PRED OPCNT==<.-OPS>/2 ;number of pseudos and operators altogether SUBTTL START UP -- READ JCL AND OPEN INPUT FILE START: RESET MOVE P,[-77,,PDL] SETZ A, RSCAN JFCL JUMPE A,NOJCL ; NO JCL, FLUSH ;read jcl line MOVN C,A MOVEI A,.PRIIN MOVE B,[440700,,FILBUF] SIN ; READ JCL ;parse jcl line MOVE B,[440700,,FILBUF] NAMLOP: ILDB A,B CAILE A,40 JRST NAMLOP NAMDON: CAIE A,^M CAIN A,^J JRST NOJCL MOVEM B,FILPTR ;should be file spec start ILDB A,B CAIL A,40 JRST .-2 MOVEI A,0 DPB A,B MOVE B,FILPTR PUSHJ P,OPEN ;open file JRST BEGIN ;here if no jcl, read file name from tty NOJCL: PUSHJ P,TOPEN JRST BEGIN SUBTTL FILE NAME READING AND FILE OPENING OPEN: PUSHJ P,FOPEN JRST TOPEN ;open failed, try from tty POPJ P, ;read file name from tty TOPEN: MSG [ File: ] PSOUT MOVEI A,GTJFNT MOVEI B,0 PUSHJ P,FOPEN1 JRST TOPEN POPJ P, ;open a file ; b/ file name ;skips if wins FOPEN: MOVEI A,GTJFNB PUSH P,B GTJFN SKIPA JRST FOPEN2 MOVEI A,GTJFNX MOVE B,(P) JRST FOPEN0 FOPEN1: PUSH P,B FOPEN0: GTJFN JRST NOFILE FOPEN2: TLZ A,-1 MOVEM A,IJFN ; SAVE CURRENT INPUT JFN MOVE B,[070000,,240000] OPENF ; HAS TO BE OPEN JRST NOFIL1 POP P,B AOS (P) POPJ P, ;gtjfn failed for some reason NOFILE: MOVE B,A MSG [Open failed?] NOFIL4: PSOUT POP P,C JUMPE C,NOFIL3 MSG [ (] PSOUT MOVE A,C NOFIL2: PSOUT MSG [)] PSOUT NOFIL3: MSG [: ] PSOUT ;print error string ERPRNT: HRRZI A,-1 HRLI B,400000 MOVEI C,0 ERSTR ; PRINT ERROR POPJ P, ;UNDEFINED ERROR. POPJ P, ;CHOMPING DEST. POPJ P, ;WON. POPJ P, ;openf failed for some reason NOFIL1: MOVE B,A MSG [Can't OPENF file?] JRST NOFIL4 SUBTTL BEGIN ASSEMBLING ;print filename being assembled BEGIN: SKIPN DOFREQ JRST BEGINF MSG [Counting ] SKIPA BEGINF: MSG [Assembling ] PUSHJ P,PFNAME ;tell name of file being read ;find out release number since it's alway wrong in the ZAP file MSG [Time Mode?: ] PSOUT PBIN SETZ B, CAIE A,"T CAIN A,"Y JRST [TRO B,%TIMESL MSG [ ] JRST .+2] MSG [ ] PSOUT PUSHJ P,PCRLF ; MSG [Byte Swapped?: ] ; PSOUT ; PBIN ; CAIE A,"T ; CAIN A,"Y ; TRO B,%BYTSWP ; PUSHJ P,PCRLF MOVEM B,FLGWRD MSG [Release: ] PSOUT MOVEI A,.PRIIN MOVEI C,10. SETOM RELEAS NIN JRST GETFNM ;lost, use default JUMPL B,GETFNM MOVEM B,RELEAS ;save and use instead of supplied ;get goodies so can open correct output file GETFNM: MOVE A,OUTPTR MOVE B,IJFN MOVE C,[222000,,JS%PAF] ;output dev:name. JFNS MOVEM A,OUTPTR ;save for outputting other exts. SKIPE DOFREQ JRST BEGLUP ;do frequency assembly MOVE Z,[441000,,OUTBUF] ;byte ptr to output buffer MOVEI ZPC,0 ;pc initially zero PUSHJ P,SCRIPT ;open script channel if asked PUSHJ P,GLBINI ;initialize global symbol table PUSHJ P,LCLINI ;initialize local symbol table ;here to create references to the first n words, which are special MOVE A,ZAPID PUSHJ P,OUTBYT MOVE A,FLGWRD PUSHJ P,OUTBYT SKIPGE A,RELEAS ;user gave a release number? JRST NORELE PUSHJ P,OUTWRD JRST DEFWDS NORELE: HRROI B,[ASCIZ /.WORD ZORKID /] HRROI A,BUFFER MOVEI C,0 SOUT PUSHJ P,ASSEM ;output always defined words DEFWDS: HRROI B,[ASCIZ /.WORD ENDLOD,START,VOCAB,OBJECT,GLOBAL,IMPURE,0,0,0,0,WORDS /] HRROI A,BUFFER ;copy to buffer MOVEI C,0 SOUT PUSHJ P,ASSEM ;assemble it BEGWDS: MOVEI A,0 PUSHJ P,OUTWRD CAIGE ZPC,100 JRST BEGWDS BEGLUP: PUSHJ P,RDLINE ;read a line, no skip if done JRST DONE SKIPE PDEBUG PUSHJ P,PINPUT PUSHJ P,ASSEM ;assemble line SKIPE PDEBUG CAMN Z,SAVZ JRST BEGLUP PUSHJ P,OPC JRST BEGLUP PINPUT: PUSH P,A PUSH P,B PUSH P,C MOVE A,PDEBUG MOVEI C,0 HRROI B,[ASCIZ / ;/] SOUT HRROI B,BUFFER SOUT ;print it (for debugging) MOVEM ZPC,SAVZPC MOVEM Z,SAVZ JRST POPCBA SUBTTL DONE - FINISH UP, PRINT STATS, ETC. DONE: SKIPE DOFREQ JRST FILEND PUSHJ P,UNDGLB ;print undefined globals MSG [ ] PSOUT MOVEI A,.PRIOU MOVE B,ZPC MOVEI C,10. NOUT JFCL MSG [ bytes. ] PSOUT MOVEI A,.PRIOU MOVE B,OBJTOT MOVEI C,10. NOUT JFCL MSG [ objects. ] PSOUT MOVEI A,.PRIOU MOVE B,GLBTOT MOVEI C,10. NOUT JFCL MSG [ globals. ] PSOUT SKIPE TWOPAS ;don't bother if two pass assembly JRST OUTPUT MOVEI A,.PRIOU MOVE B,SHRIMP MOVEI C,10. NOUT JFCL MSG [ wasted long jumps. ] PSOUT ;here to force pc to value in A SETZPC: MOVE ZPC,A MOVE Z,[441000,,OUTBUF] EXCH A,Z ADJBP Z,A POPJ P, ;here to output date stuff for serial number in ascii ;a/ number OUTDAT: PUSH P,B IDIVI A,10. ADDI A,"0 PUSHJ P,OUTBYT MOVEI A,"0(B) PUSHJ P,OUTBYT POP P,B POPJ P, ;here to output the data OUTPUT: MOVEM Z,SAVZ MOVEM ZPC,SAVZPC MOVEI A,32 ; where the length lives PUSHJ P,SETZPC MOVE A,SAVZPC ; get back the final top pc LSH A,-1 ; make it in words PUSHJ P,OUTWRD MOVEI A,77 ; start at byte 100 octal PUSHJ P,SETZPC SETZ D, ; zero the checksum OUTCL: CAMN ZPC,SAVZPC ; loop until through the entire file JRST OUTCHK ILDB B,Z ; get the byte ADD D,B ; and add it into checksum AOJA ZPC,OUTCL OUTCHK: MOVEI A,34 ; where the checksum lives PUSHJ P,SETZPC MOVE A,D ANDI A,177777 ; only 15 bits worth, though PUSHJ P,OUTWRD MOVEI A,22 ; where serial number lives PUSHJ P,SETZPC MOVNI B,1 ODCNV ; get current time/date HLRZ A,B ; here's the year SUBI A,1900. ; we will take only the mod 100 part PUSHJ P,OUTDAT HRRZ A,B ; here's the month (starting at 0) ADDI A,1 ; so fix it up here PUSHJ P,OUTDAT HLRZ A,C ; here's the day (starting at 0) ADDI A,1 ; so fix it up here PUSHJ P,OUTDAT MOVE Z,SAVZ MOVE ZPC,SAVZPC MOVE A,[440700,,[ASCIZ /.ZIP/]] MOVE B,OUTPTR ILDB 0,A IDPB 0,B JUMPN 0,.-2 MOVSI A,(GJ%SHT+GJ%FOU) HRROI B,OUTFIL GTJFN JRST ERPRNT HRRZ A,A MOVE B,[440000,,OF%WR] OPENF JRST ERPRNT ;blat out stupid gcdump header HRRM ZPC,HEADER+5 MOVEI C,3(Z) SUBI C,OUTBUF HRLM C,FOOTER+1 ADDI C,2006 HRRM C,FOOTER+1 SUBI C,2006-2 MOVEM C,HEADER MOVEM C,HEADER+1 MOVEM C,HEADER+2 MOVE B,[444400,,HEADER] MOVNI C,7 SOUT ;blat out data MOVE B,[444400,,OUTBUF] MOVEI C,1(Z) SUBI C,OUTBUF MOVN C,C SOUT ;blat out stupid footer MOVE B,[444400,,FOOTER] MOVNI C,2 SOUT ;close up and go home CLOSF JFCL SKIPE A,PDEBUG CLOSF HALTF HALTF ;print name of IJFN file, takes prefix string in A PFNAME: PSOUT MOVEI A,.PRIOU MOVE B,IJFN MOVE C,[222220,,JS%PAF] JFNS PUSHJ P,PCRLF POPJ P, SCRIPT: SKIPL PDEBUG POPJ P, MOVE A,[440700,,[ASCIZ /.SCRIPT/]] MOVE B,OUTPTR ILDB 0,A IDPB 0,B JUMPN 0,.-2 MOVSI A,(GJ%SHT+GJ%FOU) HRROI B,OUTFIL GTJFN JRST ERPRNT HRRZ A,A MOVEM A,PDEBUG MOVE B,[070000,,OF%WR] OPENF JRST ERPRNT POPJ P, SUBTTL READ A LINE FROM INPUT FILE RDLINE: SKIPN A,IJFN ;no eof yet? POPJ P, ; eof, return PUSH P,B HRROI B,BUFFER MOVEI C,512.*5 MOVEI D,^J ;stop on crlf SIN ;read a line ERJMP RDEOF MOVEI A,0 ;terminate with nul IDPB A,B ;zero byte POP P,B POPJ1: AOS (P) CPOPJ: POPJ P, RDEOF: MOVE A,IJFN CLOSF ;close input file JRST ERPRNT SETZM IJFN ;eof found POP P,B JRST POPJ1 ;parse a line into tokens; may require reading more lines if it's a string GTLINE: MOVE A,[440700,,TOKEN] MOVEM A,TOKPTR MOVE TP,TPDL GTLIN1: PUSHJ P,GTOKEN ;get a token PUSH TP,B ;push string PUSH TP,A ;push terminator JUMPN A,GTLIN1 PUSH TP,[0] ;end of line, push zeros PUSH TP,[0] ;end of line, push zeros POPJ P, ;print a token PTOKEN: SKIPN TDEBUG POPJ P, EXCH A,B SKIPE A PSOUT ;string part EXCH A,B JUMPE A,PCRLF PBOUT ;terminator part POPJ P, PCRLF: MSG [ ] PSOUT MOVEI A,0 POPJ P, SUBTTL PARSE A TOKEN FROM INPUT LINE ;returns a/ break char, b/ ptr to token GTOKEN: MOVE B,TOKPTR GTOKE1: ILDB A,C JUMPE A,RTERM CAIG A,40 JRST GTOKE1 ;skip over leading junk JRST RTOK3 RTOKEN: ILDB A,C RTOK3: CAIG A,40 JRST RTERM CAIE A,": ;label CAIN A,"+ ;sum JRST RTERM CAIE A,"= ;definition CAIN A,"/ ;then jump JRST RTERM CAIE A,"\ ;else jump CAIN A,", ;separator JRST RTERM CAIE A,"> ;assignment CAIN A,"' ;quoting JRST RTERM CAIN A,"; ;start of comment JRST RCOMNT ; ignore comment CAIN A,"" ;start of string JRST RSTRNG ;read string ;else part of token RTOK1: IDPB A,B ;build token JRST RTOKEN ;loop ;here to read a string RSTRNG: CAME B,TOKPTR ;anything read yet? JRST RSTR3 ; yes RSTR1: ILDB A,C JUMPE A,[PUSHJ P,MORSTR JRST RSTR1] ;need to read another line from file CAIN A,"" ;end of string JRST RSTRQ RSTR2: IDPB A,B JRST RSTR1 RSTR3: DPB C ;here if string bung up against other token MOVEI A,40 ;fake a space JRST RTERM ;and return ;here to check for "" RSTRQ: MOVE 0,C ILDB A,C JUMPE A,[PUSHJ P,MORSTR JRST RSTRQ] CAIN A,"" JRST RSTR2 ;is ", ship it MOVE C,0 ;restore bptr MOVEI A,"" ;pretend was " JRST RTERM ;not a ", return ;here to snarf another line for multi-line strings MORSTR: PUSHJ P,RDLINE JRST STRERR MOVE C,[440700,,BUFFER] POPJ P, STRERR: MSG [String not terminated at eof.] PUSHJ P,ERROR POPJ P, ;here to read and ignore a comment RCOMNT: MOVEI A,0 RTERM: CAMN B,TOKPTR CAIN A,"" ;allow empty strings SKIPA JRST RNONE MOVEI 0,0 IDPB 0,B ;asciz EXCH B,TOKPTR POPJ P, ;here for nothing read RNONE: MOVEI B,0 POPJ P, SUBTTL SYMBOL LOOKUP FOR CONSTANT TABLES ;takes: a/ symbol to lookup ;retns +2 won, b/ value ; +2 lost LOOKUP: MOVNI C,1 ;low bound MOVEI E,OPCNT ;high bound LOOKLP: MOVE D,C ADD D,E TRZ D,1 ;make it an even number MOVE B,OPS(D) HRLI B,440700 PUSHJ P,COMPAR ; a/ token b/ table JRST LOOKWN ; a=b JRST LOOKLS ; a>b LSH D,-1 MOVE C,D ; ab ;+2 skip: ab AOS -4(P) ;a for x not : ;global label GLBLBL: SKIPE FZ ;time for function second pass? PUSHJ P,FPASS2 ; yes MOVE B,(TP) ;global label MOVE C,ZPC ;label is current pc PUSHJ P,DEFGLB ;define it JRST BDMDGL ;multiply defined global label NXTARG 2 ;move over label and colons JRST AOP ;local label LCLLBL: SKIPN A,FUNCT ;is there a function these days? JRST GLBLBL ;else it might as well be a global MOVE B,(TP) ;get token MOVE C,ZPC ;label is current pc PUSHJ P,DEFLCL ;define it JRST BDMDLL ;multiply defined local label NXTARG 1 ;move over local label JRST AOP BDLABL: MSG [Multiply defined label] BDLAB1: MOVE B,(TP) PUSHJ P,ERRMSG ;shout lossage JRST AOP ;but continue BDLBSY: MSG [Label followed by :, non-colon] JRST BDLAB1 ;here we have reached an opcode or pseudo after flushing label AOP: SKIPN A,(TP) SKIPE 1(TP) SKIPA POPJ P, PUSHJ P,LOOKUP ;takes symbol in A JRST AEQUAL ; not any sort of op. JUMPL B,APSEUDO ;pseudo JRST AOPER ;regular op ;here not oper or pseudo ;see if it's an atom=foo AEQUAL: SKIPE A,1(TP) CAIE A,"= JRST AATOM MOVE B,2(TP) ;value PUSHJ P,FIXQ JRST BDEQUA ;FOO=? MOVE C,B MOVE B,(TP) PUSHJ P,DEFGLB JRST BDEQU1 ;already defined? SKIPN 4(TP) SKIPE 5(TP) JRST BDEQU2 ;too many args to equal? POPJ P, ;see if it's an atom AATOM: PUSHJ P,AWORD JFCL POPJ P, SUBTTL ASSEMBLE WORDS AND BYTES ;get value of symbol ; returns A/ terminator B/ value ALCL: PUSH P,C MOVEI C,0 ;symbol is a zero MOVE B,(TP) PUSHJ P,REFLCL MOVE B,SYMVAL(A) JRST AGNEXT AGET: PUSH P,C MOVEI C,0 ;symbol is a zero AGLOOP: MOVE B,(TP) PUSHJ P,FIXQ JRST [MOVE B,(TP) PUSHJ P,REFSYM SKIPGE B,SYMVAL(A) MOVSI B,%UNDEF JRST .+1] AGNEXT: ADD C,B ;accumulate value NXTARG 1 SKIPN A,-1(TP) ;terminator? JRST AGEXI1 ;no skip if last thing on line CAIN A,"+ JRST AGLOOP AGEXIT: AOS -1(P) AGEXI1: MOVE B,C POP P,C POPJ P, AWORD: SETZM WRDBYT ;means working on word PUSHJ P,AGET SOS (P) MOVE A,B TLZ A,%BITS PUSHJ P,OUTWRD AOS (P) POPJ P, ABYTE: SETOM WRDBYT ;means working on byte PUSHJ P,AGET SOS (P) MOVE A,B TLZ A,%BITS PUSHJ P,OUTBYT AOS (P) POPJ P, SUBTTL OUTPUT WORDS ;output a word ; a/ word OUTWRD: CAILE A,177777 ;check size JRST WRDBIG ; lose, too big OUTWR1: LSHC A,-8. PUSHJ P,OUTBY1 ;output first byte MOVEI A,0 ROTC A,8. PUSHJ P,OUTBY1 ;output second byte POPJ P, ;add a value to an already output word (used for fixups) ; a/ word ADDWRD: CAILE A,177777 ;too big? JRST WRDBIG ; yes, lose LSHC A,-8. PUSHJ P,ADDBYT ;add first byte MOVEI A,0 ROTC A,8. PUSHJ P,ADDBYT ;add second byte POPJ P, ;output word reference ; a/ word OUTWRF: CAILE A,177777 ;too big? JRST WRDBIG ; yes, lose LSHC A,-8. PUSHJ P,OUTBY1 MOVEI A,0 ROTC A,8. PUSHJ P,OUTBY1 POPJ P, ;error, word is too large WRDBIG: MSG [Word too large] PUSHJ P,ERROR MOVEI A,0 JRST OUTWR1 SUBTTL OUTPUT BYTES ;output a byte ; a/ byte OUTBYT: CAILE A,377 ;too big? JRST BYTBIG ; too big, lose ;enter here to just output the byte directly OUTBY1: IDPB A,Z ;output byte ADDI ZPC,1 ;increment pc MOVE 0,(P) SKIPN TABLE CAIL 0,SLOOK POPJ P, SKIPN PASS2 AOS CODLEN' POPJ P, ;output byte reference ; a/ byte OUTBRF: CAILE A,377 ;too big? JRST BYTBIG ; yes, lose PUSHJ P,OUTBY1 POPJ P, ;same as outbyt, but adds in new value (for fixup) ; a/ byte ADDBYT: CAILE A,377 JRST BYTBIG PUSH P,B ILDB B,Z ;pick up current contents ADD A,B ;add new stuff in DPB A,Z ;put it back out ADDI ZPC,1 POP P,B POPJ P, ;here byte was too large (>255.) BYTBIG: MSG [Byte too large] PUSHJ P,ERROR MOVEI A,0 JRST OUTBY1 SUBTTL PRINT BYTES AND PCS (FOR DEBUGGING) OBYTE: PUSH P,A PUSH P,B PUSH P,C MOVE B,A MOVE A,PDEBUG MOVEI C,8 HRLI C,(NO%LFL+NO%ZRO)+3 NOUT JFCL MOVEI B," BOUT JRST POPCBA OPC: PUSH P,A PUSH P,B PUSH P,C MOVE B,SAVZPC MOVE A,PDEBUG MOVEI C,8 NOUT JFCL HRROI B,[ASCIZ !/ !] MOVEI C,0 SOUT OBYLUP: ILDB A,SAVZ PUSHJ P,OBYTE CAME Z,SAVZ JRST OBYLUP JRST POPCBA SUBTTL VARIOUS ERRORS BDMDGL: MSG [Multiply defined global label] JRST BDERRO BDMDLL: MSG [Multiply defined local label] JRST BDERRO BDMDLV: MSG [Multiply defined local variable] JRST BDERRO BDEQUA: MSG [Something assigned to non-fix] JRST BDERRO BDEQU1: MSG [Something already assigned] JRST BDERRO BDEQU2: MSG [Too many args to equal] BDERRO: PUSHJ P,ERROR POPJ P, SUBTTL IS IT A FIX? ;given string pointer, skips if it's a number ;returns number in B FIXQ: PUSH P,C PUSH P,D MOVE C,B MOVEI B,0 SETZ D, FIXQ1: ILDB A,C JUMPE A,FIXEND CAIN A,"- JRST [SETO D, JRST FIXQ1] CAIL A,"0 CAILE A,"9 JRST [POP P,D POP P,C POPJ P,] SUBI A,"0 IMULI B,10. ADD B,A JRST FIXQ1 FIXEND: CAILE B,177777 JRST FIXBIG SKIPE D MOVN B,B ANDI B,177777 FIXEN1: POP P,D POP P,C JRST POPJ1 FIXBIG: MSG [Fix too big for a word] PUSHJ P,ERROR MOVE B,177777 JRST FIXEN1 SUBTTL PSEUDO-OPS ;dispatch for pseudo-ops APSEUD: SKIPE FZ ;time for a function second pass? PUSHJ P,FPASS2 ; yes, go do it APSEU1: SETZM PASS2 HRRZ B,B CAIN B,ZFUNCT ;if not .funct, skip PUSHJ P,UNDLCL JRST (B) SUBTTL .END .INSERT AND .ENDI ;end of assembly ZEND: MOVE A,IJFN CLOSF JRST ERPRNT SETZM IJFN POPJ P, ;insert another file ZINSER: SKIPE OJFN JRST ZINSIN MOVE A,3(TP) CAIE A,"" JRST ZINSTR ;not a string MOVE A,IJFN MOVEM A,OJFN MOVE B,2(TP) PUSHJ P,OPEN MSG [Inserting ] PUSHJ P,PFNAME POPJ P, ZINSIN: MSG [Already in .INSERT?] PUSHJ P,ERROR POPJ P, ZINSTR: MSG [Argument to .INSERT not string?] PUSHJ P,ERROR POPJ P, ;end an insertion ZENDI: SKIPN B,OJFN JRST ZENDLS MOVE A,IJFN CLOSF JRST ZENDCL SETZM OJFN MOVEM B,IJFN POPJ P, ZENDLS: MSG [.ENDI not in .INSERT?] PUSHJ P,ERROR POPJ P, ZENDCL: MSG [.ENDI close failed?] PUSHJ P,ERROR POPJ P, SUBTTL TABLES ZTABLE: MOVEM ZPC,TABLE SETOM TABLEN NXTARG 1 SKIPN B,(TP) POPJ P, PUSHJ P,FIXQ JRST ZTNOTF MOVEM B,TABLEN POPJ P, ZTNOTF: MSG [Argument to .TABLE not fix] PUSHJ P,ERROR POPJ P, ZENDT: SKIPN TABLE JRST ZETNOT SKIPGE A,TABLEN JRST ZENDTX ADD A,TABLE CAML A,ZPC JRST ZENDTX MSG [Table too large] PUSHJ P,ERROR POPJ P, ZENDTX: SETZM TABLE SETZM TABLEN POPJ P, ZETNOT: MSG [.ENDT not after .TABLE] PUSHJ P,ERROR POPJ P, ZEQUAL: SKIPN B,4(TP) JRST ZEQTFA PUSHJ P,FIXQ JRST ZEQANF MOVE C,B PUSHJ P,DEFNAM JRST ZEQMDG POPJ P, ZEQMDG: MSG [Already defined] PUSHJ P,ERROR POPJ P, ZEQANF: MSG [Second argument to .EQUAL not fix] PUSHJ P,ERROR POPJ P, ZEQTFA: MSG [Too few arguments to .EQUAL] PUSHJ P,ERROR POPJ P, SUBTTL NAMED THINGS: FUNCTIONS, GLOBAL STRINGS, VARIABLES, OBJECTS ;define a named thing, value in C DEFNAM: MOVE B,2(TP) ;pname PUSHJ P,DEFGLB ;define symbol JRST DEFMLT ;already defined NXTARG 2 ;move over pseudo and name AOS (P) POPJ P, ;complain about multiply defined thing DEFMLT: MSG [Multiply defined ] MOVE B,(TP) PUSHJ P,ERRMSG POPJ P, ;force a word boundary WRDBDY: TRNN ZPC,1 POPJ P, PUSH P,A MOVEI A,0 PUSHJ P,OUTBYT POP P,A POPJ P, SUBTTL FUNCTIONS ZFUNCT: PUSHJ P,WRDBDY ;force word boundary SKIPN 2(TP) JRST ZFNONE ;no name? MOVE C,ZPC LSH C,-1 ;functions are always on word bdy. MOVEM C,FSYM ;save symbol value of last function PUSHJ P,DEFNAM POPJ P, MOVE A,LSTSYM ;pick up last defined symbol MOVEM A,FUNCT ;new function ;print functions and locs if asked for SKIPE FDEBUG PUSHJ P,PFUNCT ;here hack arguments MOVEI D,0 ;current lval MOVE E,Z ;save current bptr IDPB D,Z ;start with zero ADDI ZPC,1 ZFLOOP: SKIPN B,(TP) ;is there one? JRST ZFDONE ;nope, done ADDI D,1 ;bump arg count MOVE C,D ;which local? TLO C,%VAR PUSHJ P,DEFLCL ;define it as a local JRST BDMDLV SKIPE A,1(TP) CAIE A,"= JRST ZFNEXT NXTARG 1 ;move over variable name SKIPN B,(TP) JRST ZFNOEQ PUSHJ P,AWORD ;assemble word JFCL JRST ZFLOOP ZFNEXT: MOVEI A,0 PUSHJ P,OUTWRD ;bind it to 0 NXTARG 1 ;move over variable name JRST ZFLOOP ZFDONE: IDPB D,E ;now fake output of argument count ;save goodies for function pass two ;can be called on its own, be careful! FMARK: MOVE A,IJFN RFPTR HALTF MOVEM B,FPOS ;save file pointer MOVEM Z,FZ ;save output pointer MOVEM ZPC,FZPC ;save pc MOVE A,SHRIMP MOVEM A,OSHRIM POPJ P, ZFNONE: MSG [No name given to function?] PUSHJ P,ERROR POPJ P, ZFNOEQ: MSG [Argument = not followed by value?] PUSHJ P,ERROR POPJ P, ;here to set up second pass over functions with short jumps FPASS2: SKIPN TWOPASS ;skip if two pass assembly of functions POPJ P, ;else return immediately CAMN ZPC,FZPC JRST [PUSHJ P,FMARK POPJ P,] SETOM PASS2 MOVE A,OSHRIM ;count of wasted long jumps ;CAML A,SHRIMP ; what it was when function started ;POPJ P, ;resume, false alarm MOVEM A,SHRIMP MOVE A,IJFN MOVE B,FPOS SFPTR HALTF MOVE Z,FZ MOVEM Z,SAVZ ;fool debugging printer MOVE ZPC,FZPC SETZM FPOS ;file pointer of start of function SETZM FZ ;z at start of function SETZM FZPC ;zpc at start of function SETZM FSHORT ;count of short jumps POP P,0 ;flush call to fpass2 POPJ P, ;return from caller ;.FSTR -- like .GSTR but adds to table of frequent strings ZFSTR: SKIPN A,4(TP) JRST TFARG PUSHJ P,WLOOK SKIPA JRST ZFDUP ;duplicate of frequent string? lose! ;here to add new string to table MOVE A,TABPTR TLNN A,400000 JRST [HRLI A,440700 ADDI A,1 JRST .+1] MOVE H,A MOVE B,4(TP) MOVEI C,0 SOUT ;copy string to buffer IDPB C,A MOVEM A,TABPTR ;update table pointer PUSH P,G MOVE G,WRDTAB SUB G,[2,,2] MOVEM G,WRDTAB POP P,G ;make a slot for new entry HRRZ A,WRDTAB HRLI A,2(A) BLT A,-1(G) ;put out new entry MOVEM H,-1(G) ;string AOS H,FSTRS MOVEM H,-2(G) ;count CAIG H,%FWDCT JRST ZFSTR1 MSG [Too many .FSTRs] ZFERR: PUSHJ P,ERROR POPJ P, ZFDUP: MSG [Duplicate .FSTR] JRST ZFERR ZFSTR1: PUSHJ P,WRDBDY MOVE C,ZPC LSH C,-1 PUSHJ P,DEFNAM POPJ P, SKIPN A,(TP) JRST TFARG PUSHJ P,MAKFST POPJ P, ;.GSTR -- global string ZGSTR: PUSHJ P,WRDBDY MOVE C,ZPC LSH C,-1 PUSHJ P,DEFNAM POPJ P, SKIPN A,(TP) JRST TFARG PUSHJ P,MAKSTR POPJ P, ZGVAR: AOS GLBTOT AOS C,GLBCNT CAILE C,255. ;real high limit JRST TMGLB TLO C,%VAR PUSHJ P,DEFNAM POPJ P, ;multiply defined PUSHJ P,AWORD POPJ P, POPJ P, TMGLB: MSG [Too many globals] PUSHJ P,ERROR POPJ P, ZOBJEC: AOS OBJTOT ;how many he tried to make AOS C,OBJCNT CAILE C,255. JRST TMOBJ ;more than 255 objects PUSHJ P,DEFNAM POPJ P, ;multiply defined ;process parts of object line PUSHJ P,AWORD JRST TFAOBJ PUSHJ P,AWORD ;flags JRST TFAOBJ PUSHJ P,ABYTE JRST TFAOBJ PUSHJ P,ABYTE JRST TFAOBJ PUSHJ P,ABYTE JRST TFAOBJ PUSHJ P,AWORD ;property table ptr JRST TFAOBJ POPJ P, TFAOBJ: MSG [Too few arguments to .OBJECT] PUSHJ P,ERROR POPJ P, TMOBJ: MSG [Too many objects] PUSHJ P,ERROR POPJ P, ZLEN: POPJ P, ZPDEF: PUSHJ P,WRDBDY ;guarantee word boundary POPJ P, ZPROP: SKIPN TABLE JRST ZPROPL NXTARG 1 PUSHJ P,AGET ;get property length JFCL TLZ B,%BITS CAILE B,0 CAILE B,8 JRST ZPOFL ;property length out of range MOVE C,B PUSHJ P,AGET ;get property number JFCL TLZ B,%BITS CAILE B,0 CAIL B,40 JRST ZPOFR ;property number out of range SUBI C,1 ;length minus one LSH C,5 ;left shifted ADD C,B ;plus number MOVE A,C PUSHJ P,OUTBYT ;output it POPJ P, ZPOFR: MSG [Property out of range] SKIPA ZPOFL: MSG [Property length too long] PUSHJ P,ERROR POPJ P, ZPROPL: MSG [Property definition not during table?] PUSHJ P,ERROR POPJ P, ZSEQ: MOVEI D,0 NXTARG 1 ZSEQL: SKIPN B,(TP) POPJ P, MOVE C,D PUSHJ P,DEFGLB JRST ZSEMDG ZSEQN: AOJA D,ZSEQL ZSEMDG: MSG [Multiply defined global] PUSHJ P,ERROR JRST ZSEQN SUBTTLE STRING PSEUDOS ZSTR: SKIPN A,2(TP) JRST TFARG PUSHJ P,MAKSTR POPJ P, ZSTRL: MOVEI A,0 PUSHJ P,OUTBYT PUSH P,Z ;save bptr PUSH P,ZPC ;save pc PUSHJ P,ZSTR POP P,A ;restore pc POP P,B ;restore bptr SUBM ZPC,A TRNE A,1 ADDI A,1 ;round up LSH A,-1 ;convert to words DPB A,B ;output length of string POPJ P, ZZWORD: NXTARG 1 SKIPN A,(TP) JRST TFARG PUSHJ P,MAKZWD POPJ P, TFARG: MSG [Too few arguments] PUSHJ P,ERROR POPJ P, SUBTTL SIMPLE THINGS: TRUTH, WORDS, BYTES ZTRUE: MOVEI A,1 PUSHJ P,OUTWRD POPJ P, ZFALSE: MOVEI A,0 PUSHJ P,OUTWRD POPJ P, ZWORD: NXTARG 1 ;flush .WORD ZWORD1: PUSHJ P,AWORD POPJ P, SKIPN (TP) SKIPE 1(TP) JRST ZWORD1 POPJ P, ZBYTE: NXTARG 1 ;flush .BYTE ZBYTE1: PUSHJ P,ABYTE POPJ P, SKIPN (TP) SKIPE 1(TP) JRST ZBYTE1 POPJ P, SUBTTL OPERAND ASSEMBLY ;assembly of real opers AOPER: SETOM NOREF ;don't produce references, just do lookups MOVEM B,OPER ;save operand (and bits!) SETOM PRED ;not pred instruction TLNE B,%PRED SETZM PRED ; yes it is! SETZM SENSE ;initialize jump sense SETOM VAL ;not val instruction TLNE B,%VAL SETZM VAL ; yes it is! MOVEI F,0 ;first count arguments ;set up buffer for arguments MOVE AB,[ARGBUF,,ARGBUF+1] SETOM ARGBUF BLT AB,ARGBUF+12 MOVEI AB,ARGBUF MOVE B,OPER TLNE B,%JUMP ;don't skip if it's a jump JRST AOPERJ NXTARG 1 ;move over op {;now hack arguments AOPER1: SKIPN (TP) SKIPE 1(TP) SKIPA JRST AOPERN ;done, no more args MOVE A,1(TP) ;pick up terminator ;here for string CAIE A,"" JRST AOPERQ MOVE A,OPER TLNN A,%STR ;must be string operator JRST AOPSTR ;string given to non-string operator HRRZ A,A PUSHJ P,OUTBYT MOVE A,(TP) PUSHJ P,MAKSTR SKIPN 2(TP) SKIPE 3(TP) JRST TMAPRI POPJ P, TMAPRI: MSG [Too many arguments to PRINTI] PUSHJ P,ERROR POPJ P, AOPSTR: MSG [String given to non-string operator?] PUSHJ P,ERROR POPJ P, ;here for quoted variable name AOPERQ: CAIE A,"' ;quoted variable? JRST AOPERP ADDI F,1 ;that's an argument NXTARG 1 SKIPN (TP) JRST AOPQUT ;bad variable name PUSHJ P,AGET JFCL TLNN B,%VAR JRST AOPQUT TLZ B,%VAR ;quoting devariablizes variables JRST AOPOUT AOPGET: PUSHJ P,AGET ;get value if any JFCL AOPOUT: MOVEM B,(AB) ;put out theory on arg MOVE B,-2(TP) MOVEM B,1(AB) ;put out symbol ADDI AB,2 JRST AOPER1 ;here arg is nothing special AOPERC: AOJA F,AOPGET AOPERJ: MOVEI G,0 JRST AOPERK ;here for predicate jump AOPERP: CAIE A,"/ ;'then' predicate? CAIN A,"\ ;'else' predicate? SKIPA JRST AOPERV MOVEI G,0 CAIN A,"/ TRO G,100000 MOVEM G,SENSE AOPERK: NXTARG 1 SKIPN (TP) JRST AOPQUT ;bad variable name PUSHJ P,ALCL ;get value if any JFCL MOVEM B,PRED MOVE B,-2(TP) MOVEM B,PRED+1 JRST AOPER1 ;here for value variable AOPERV: CAIE A,"> ;term. for assignment JRST AOPERC NXTARG 1 SKIPN (TP) JRST AOPQUT ;bad variable name PUSHJ P,AGET ;get value if any JFCL MOVEM B,VAL MOVE B,-2(TP) MOVEM B,VAL+1 JRST AOPER1 AOPQUT: MSG [Bad variable name after value or predicate] PUSHJ P,ERROR POPJ P, ;here we know how many args, so frotz with operand value appropriately ;f/ # of args. AOPERN: SKIPE ODEBUG ;print theory of operator PUSHJ P,OPRNT ; if odebug is non-zero SKIPE TWOPASS ;if non two pass, then can make refs SKIPE PASS2 ;can't make refs in pass 1 SETZM NOREF ;can make refs now MOVEI AB,ARGBUF MOVE B,OPER ;pick up operator ANDI B,377 ;flush various funny bits ;dispatch on operand value CAIL B,300 ;ext? JRST OUTEXT ; yes, this one is always an ext CAIL B,260 ;0op? JRST OUT0OP ; yes CAIL B,200 ;1op? JRST OUT1OP ; yes ;falls through ;remainder are all 2op (but can be ext!) OUT2OP: CAIE F,2 JRST TMA2OP MOVEI C,0 MOVE A,(AB) JUMPL A,CNVEXT ;if undefined, must be ext. TLNE A,%VAR JRST CHK1VR CAIL A,0 CAIL A,400 JRST CNVEXT ;if long immediate, must be ext. SKIPA ;arg 1 is immediate CHK1VR: TRO B,100 ;arg 1 is a variable CHK2ND: MOVE A,2(AB) JUMPL A,CNVEXT ;if undefined, must be ext. TLNE A,%VAR JRST CHK2VR CAIL A,0 CAIL A,400 JRST CNVEXT ;if long immediate, must be ext. SKIPA ;arg 2 is immediate CHK2VR: TRO B,40 ;arg 2 is a variable ;here it's really a 2op MOVE A,B PUSHJ P,OUTBYT ;output operator HRRZ A,(AB) PUSHJ P,OUTBYT HRRZ A,2(AB) PUSHJ P,OUTBYT JRST OUTPV ;go do value and pred ;here if wrong number of arguments (might be 4 arg EQUAL?) TMA2OP: MOVE B,OPER TLNN B,%XARG ;4 arg equal?, so convert to ext. JRST TMA2O1 ;real wna, too bad ;here to convert a 2op to an ext CNVEXT: MOVE B,OPER ADDI B,300 ;convert to ext MOVEM B,OPER ANDI B,377 MOVEI AB,ARGBUF JRST OUTEXT TMA2O1: MSG [Too many arguments to 2op] PUSHJ P,ERROR POPJ P, ;here to output a 1op instruction OUT1OP: MOVE B,OPER TLNE B,%JUMP ;special case jumps JRST OUTJMP CAIE F,1 ;one arg? JRST TMA1OP ;no, lose! MOVE A,(AB) ;pick up argument TLNN A,%VAR ;variable? JRST 1OPI ; no. TRO B,40 ;variable arg bit 1OPBYT: EXCH A,B HRRZ A,A PUSHJ P,OUTBYT ;output oper HRRZ A,B PUSHJ P,OUTBYT ;output variable byte JRST OUTPV OUTJMP: JUMPG F,TMA1OP HRRZ A,B PUSHJ P,OUTBYT ;output it for now MOVE B,OPER JRST OUTP1 1OPI: CAIL A,0 CAIL A,400 ;will it fit in one word? JRST 1OPNO TRO B,20 ;immediate bit JRST 1OPBYT ;output oper and imm. byte 1OPNO: EXCH A,B HRRZ A,A PUSHJ P,OUTBYT ;output oper. JUMPL B,1OPREF 1OPNO1: HRRZ A,B PUSHJ P,OUTWRD ;output long arg. JRST OUTPV ;here single arg is reference to unknown 1OPREF: MOVE B,1(AB) ;must make an appropriate fixup PUSHJ P,REFSYM MOVE B,(AB) ;output what we have of value JRST 1OPNO1 TMA1OP: MSG [Too many args to 1op instruction] PUSHJ P,ERROR POPJ P, ;here to output extended op OUTEXT: CAILE F,4 JRST TMAEXT MOVE A,B PUSHJ P,OUTBYT ;operator MOVEI A,0 PUSHJ P,OUTBYT ;ext byte (will be filled in later) MOVE G,Z ;save output ptr MOVEI D,0 ;ext byte under construction MOVEI E,4 ;max arguments ;here loop through args to ext instruction EXTLUP: MOVE A,(AB) ;get arg TLNN A,%VAR ;variable? JRST EXTIMM TRO D,2 ;yes, turn on variable bit EXTBYT: HRRZ A,A PUSHJ P,OUTBYT ;output variable byte JRST EXTNXT EXTIMM: CAIL A,0 ;immediate? CAIL A,400 JRST EXTLIM ;no, long TRO D,1 ;turn on immediate bit JRST EXTBYT ;output immediate byte EXTLIM: JUMPL A,EXTREF ;undefined? HRRZ A,A ;no, output full word PUSHJ P,OUTWRD JRST EXTNXT EXTREF: MOVE B,1(AB) PUSHJ P,REFSYM HRRZ A,(AB) PUSHJ P,OUTWRD EXTNXT: SOJE E,EXTEXT ;if done four args, leave SUBI F,1 ;reduce count ADDI AB,2 ;move to next LSH D,2 ;update ext byte JUMPG F,EXTLUP ;if still args, do them TRO D,3 ;turn on last arg bits JRST EXTNXT ;if not, loop filling ext byte with 3 EXTEXT: DPB D,G ;output ext word JRST OUTPV ;go output val and pred stuff TMAEXT: MSG [Too many arguments to EXT instruction] PUSHJ P,ERROR POPJ P, ;here to output a 0op instruction OUT0OP: JUMPG F,TMA0OP ;better not have any args! MOVE A,B ;pick up operand from B PUSHJ P,OUTBYT ;here to output value and predicate stuff for instructions OUTPV: MOVE B,OPER TLNN B,%VAL JRST OUTP MOVE A,VAL CAMN A,[-1] JRST NOVAL JUMPL A,OUTVRF ;reference to value HRRZ A,A PUSHJ P,OUTBYT OUTP: TLNN B,%PRED+%JUMP POPJ P, ;comes here from outputting jump instruction OUTP1: MOVE A,PRED CAMN A,[-1] JRST NOPRED MOVE C,A JUMPL A,OUTPRF ;reference to predicate ;produce jump offset TRNN A,37776 ;check for /true /false jump JRST OUTPSH ;short SUB A,ZPC TLNE B,%JUMP ANDI A,177777 ;16 bit jump inst. TLNN B,%JUMP ANDI A,37777 ;14 bit pred. jumps ;determine whether short or long jump CAIGE A,77 ;test if pred jump is short JRST OUTPSH CAMN B,OPJMP ;jump instruction can take larger "shorts" CAIL A,377 ;small enough? JRST OUTPLN ; no, long jump. sigh. ;short jump: ++ ; such are always forward jumps of less than 64 bytes OUTPSH: CAMN B,OPJMP JRST OUTSJ ;output short jump byte TRO A,100 ;short jump MOVE C,SENSE TRNE C,100000 TRO A,200 ;move jump sense to second byte OUTPS1: ANDI A,377 ;and make it a byte PUSHJ P,OUTBYT POPJ P, OUTSJ: PUSH P,A HRRZ A,B TRO A,20 ;turn on immediate bit DPB A,Z POP P,A JRST OUTPS1 ;long jump OUTPLN: MOVE C,SENSE TRNE C,100000 TRO A,100000 PUSHJ P,OUTWRD POPJ P, ;here when predicate jump is a forward reference OUTPRF: SETOM JMPREF ;say it's a jump reference SKIPE TWOPAS SKIPE FZ JRST OUTPRL HRRZ A,A ;get value part of ref SUB A,ZPC SUB A,FSHORT TLNE B,%JUMP ANDI A,177777 ;16 bit jump inst. TLNN B,%JUMP ANDI A,37777 ;14 bit pred. jumps ;determine whether short or long jump TLNN B,%JUMP ;real jumps are always long CAIL A,77 ;test if pred jump is short JRST OUTPRL ;long jump. sigh. ;here short jump reference MOVEI A,100 ;short jump MOVE C,SENSE TRNE C,100000 TRO A,200 ;move jump sense to second byte HRRM A,PRED ;save it ;make the reference SETOM WRDBYT ;say it's a byte ref MOVE B,PRED+1 PUSHJ P,REFLCL SETZM JMPREF SETZM WRDBYT ;output the byte HRRZ A,PRED PUSHJ P,OUTBRF AOS FSHORT POPJ P, OUTPRL: MOVE B,PRED+1 PUSHJ P,REFLCL ;all jumps are local SETZM JMPREF MOVE A,SENSE PUSHJ P,OUTWRF ;output reference POPJ P, NOPRED: MSG [Predicate instruction lacks predicate] PUSHJ P,ERROR POPJ P, OUTVRF: MSG [Value indefined] SKIPA NOVAL: MSG [Value instruction lacks value] PUSHJ P,ERROR POPJ P, TMA0OP: MSG [Too many args to 0op instruction] PUSHJ P,ERROR POPJ P, OPRNT: PUSH P,A PUSH P,B PUSH P,C PUSH P,D HRROI A,BUFFER PSOUT MOVEI A,^M PBOUT MOVEI A,^J PBOUT MOVEI D,0 OPLOOP: MOVE A,ARGBUF(D) CAMN A,[-1] JRST OPPV MOVE A,ARGBUF+1(D) PSOUT MOVEI A,^I PBOUT MOVE B,ARGBUF(D) PUSHJ P,NUM PUSHJ P,CRLF ADDI D,2 JRST OPLOOP CRLF: MOVEI A,^M PBOUT MOVEI A,^J PBOUT POPJ P, NUM: PUSH P,A PUSH P,C JUMPGE B,OPNV MOVEI A,"? PBOUT MOVEI A," PBOUT TLZ B,%UNDEF OPNV: TLNN B,%VAR JRST OPNUM MOVEI A,"# PBOUT TLZ B,%VAR OPNUM: MOVEI A,.PRIOU MOVEI C,8. NOUT JFCL POP P,C POP P,A POPJ P, OPPV: MOVE A,VAL CAMN A,[-1] JRST OPPRED MOVEI A,"> PBOUT MOVE A,VAL+1 PSOUT MOVEI A,^I PBOUT MOVE B,VAL PUSHJ P,NUM PUSHJ P,CRLF OPPRED: MOVE B,PRED CAMN B,[-1] JRST OPPEX MOVEI A,"\ MOVE B,SENSE TRNE B,100000 MOVEI A,"/ PBOUT MOVE A,PRED+1 PSOUT MOVEI A,^I PBOUT MOVE B,PRED PUSHJ P,NUM PUSHJ P,CRLF OPPEX: POP P,D POP P,C POP P,B POP P,A POPJ P, SUBTTL SYMBOL HACKING ; symbols look like: ; SYMNAM ,, ; SYMVAL ; SYMREF ; where ; if for a defined symbol ; includes ; %VAR,, if the symbol is for a variable (local or global) ; and ; if for an undefined symbol ; includes ; %UNDEF,, ; a reference chain consists of ; ,, ; ; where ; includes ; %RBYTE if the reference is a byte reference ; %RJUMP if the reference is a jump reference ;look up a symbol in a symbol list ; a/ symbol table, b/ symbol ; +1 a/ table loc of symbol, won ; +2 a/ potential table loc of symbol, lost SLOOK: PUSH P,B PUSH P,C PUSH P,D PUSH P,E ;hash the symbol SETZ C, HASH1: ILDB E,B JUMPE E,HASH2 ROT C,3 XOR C,E JRST HASH1 HASH2: TLZ C,400000 IDIVI C,BUCKN ;number of buckets to D IMULI D,BUCKL ;length of buckets HRL D,D ADDM A,D SKIPL D HALTF ;symbol table overflow ;look for it MOVE A,-3(P) ;pick up symbol being looked for SLKLUP: SKIPN B,SYMNAM(D) ;symbol here? JRST SLKLOS ; nothing here HLR B,B HRLI B,440700 ;produce byte pointer PUSHJ P,COMPAR ;compare JRST SLKWON ;same, win JFCL ADDI D,SYMSIZ ;move to next symbol JRST SLKLUP ;and loop SLKLOS: MOVE A,D ; rtn ptr to symbol slot in A POP P,E POP P,D POP P,C POP P,B JRST POPJ1 SLKWON: HLR B,SYMNAM(D) ;found it, stuff it for future use HRLI B,440700 MOVEM B,LSTSYM MOVE A,D ; return ptr POP P,E POP P,D POP P,C POP P,B ; return ptr to cell POPJ P, ; insert symbol in table ; a/ where (as returned by SLOOK) ; b/ symbol ; c/ value SINSRT: PUSH P,A PUSH P,B PUSH P,C PUSH P,D HRLZM FREE,SYMNAM(A) ;symbol will be copied here MOVEM C,SYMVAL(A) ;value ;copy symbol into appropriate symbol area MOVE A,FREE HRLI A,440700 ;bptr to output MOVE D,A ;save a copy SETZM (A) ;make sure its zero MOVEM A,LSTSYM ;most recent symbol defn. ILDB C,B IDPB C,A JUMPN C,.-2 CAMN A,D ;not a nul symbol? HALTF ; should be no nul symbols HRRZI FREE,1(A) ;update free pointer POP P,D POP P,C POP P,B POP P,A POPJ P, SUBTTL SYMBOL TABLE DEBUGGING ;print a symbol list, takes it in A SPRNT: PUSH P,A PUSH P,B SKIPN B,A JRST SPRNT2 SPRNT1: HLRZ A,SYMNAM(B) JUMPE A,SPRNT3 HRLI A,-1 PSOUT MOVEI A,"? SKIPGE SYMVAL(B) PBOUT ;? if undefined MOVEI A,", PBOUT SPRNT3: HRRZ B,SYMNAM(B) JUMPN B,SPRNT1 SPRNT2: HRROI A,[ASCIZ / /] PSOUT POPBAJ: POP P,B POP P,A POPJ P, ;print the global symbol table GPRNT: PUSH P,A MOVE A,GLBLST PUSHJ P,SPRNT POP P,A POPJ P, ;print the local symbol table LPRNT: PUSH P,A MOVE A,LCLLST PUSHJ P,SPRNT POP P,A POPJ P, SUBTTL INITIALIZE SYMBOL TABLES ;initialize global symbol table GLBINI: PUSH P,A MOVEI A,GLBBUF MOVEM A,GLBPTR SETZM GLBLST SETZM GLBTAB MOVE A,[GLBTAB,,GLBTAB+1] BLT A,GLBEND POP P,A POPJ P, ;initialize local symbol table LCLINI: PUSH P,A PUSH P,B PUSH P,C MOVEI A,LCLBUF MOVEM A,LCLPTR SETZM LCLLST SETZM LCLTAB MOVE A,[LCLTAB,,LCLTAB+1] BLT A,LCLEND ;local tables start with these three symbols in them MOVE B,[440700,,[ASCIZ /FALSE/]] MOVEI C,0 PUSHJ P,DEFLCL JFCL MOVE B,[440700,,[ASCIZ /TRUE/]] MOVEI C,1 PUSHJ P,DEFLCL JFCL MOVE B,[440700,,[ASCIZ /STACK/]] MOVSI C,%VAR PUSHJ P,DEFLCL JFCL JRST POPCBA SUBTTL PRINT UNDEFINED LOCALS ;print names of undefined locals in function ;done whenever a function is finished UNDLCL: SKIPN FUNCT ;skip if was assembling a function POPJ P, PUSH P,A PUSH P,B PUSH P,C PUSH P,D MOVE C,LCLLST UNDLC2: SKIPL D,SYMVAL(C) ;value slot JRST UNDLC1 ;defined symbol SKIPN A,FUNCT ;undefined symbol JRST UNDLC3 ;don't print function name PSOUT ;print function name MSG [ ] PSOUT SETZM FUNCT ;zero it since one print is enough ;here to print undefined symbol and pcs at which it is referenced UNDLC3: MSG [ ] PSOUT HLRO A,SYMNAM(C) ;bptr to symbol PSOUT MSG [ undefined: ] PSOUT PUSH P,C MOVEI C,10. HRRZ D,SYMREF(C) JRST UNDLC5 UNDLC4: MOVEI A,.PRIOU HLRZ B,(D) ;pc at which referenced TRZ B,%RBYTE+%RJUMP NOUT ;output pc JFCL MSG [, ] PSOUT UNDLC5: HRRZ D,(D) ;move to next pc JUMPN D,UNDLC4 ;and leave if last PUSHJ P,PCRLF POP P,C UNDLC1: HRRZ C,SYMNAM(C) ;move to next symbol JUMPN C,UNDLC2 ;or leave if it was last ;produce symbol table if asked SKIPN SYMFLG JRST UNDLCX MOVE A,LCLLST PUSHJ P,SYMTAB MOVE B,FCNPTR SUBI A,SYMBUF MOVEM A,(B) MOVE A,FSYM ;last function defined MOVEM A,1(B) ADDI B,2 MOVEM B,FCNPTR ;do rest of cleanup UNDLCX: PUSHJ P,LCLINI ;reinit local symbol table JRST POPDA SUBTTL PRINT UNDEFINED GLOBALS ;print undefined globals UNDGLB: PUSH P,A PUSH P,B PUSH P,C PUSH P,D MOVE C,GLBLST UNDGL2: SKIPL D,SYMVAL(C) ;value slot JRST UNDGL1 HLRO A,SYMNAM(C) ;bptr to symbol PSOUT MSG [ global undefined: ] PSOUT PUSH P,C MOVEI C,10. HRRZ D,SYMREF(C) JRST UNDGL5 UNDGL4: MOVEI A,.PRIOU HLRZ B,(D) ;pc at which referenced TRZ B,%RBYTE+%RJUMP NOUT ;output pc JFCL MSG [, ] PSOUT HRRZ D,(D) ;move to next pc UNDGL5: JUMPN D,UNDGL4 ;and leave if last PUSHJ P,PCRLF POP P,C UNDGL1: HRRZ C,SYMNAM(C) ;move to next symbol JUMPN C,UNDGL2 ;or leave if it was last ;produce symbol table if was asked SKIPN SYMFLG JRST POPDA MOVE A,GLBLST PUSHJ P,SYMTAB SUBI A,SYMBUF MOVEM A,SYMBUF ;ptr to global symbol table ;sort function table and copy it into symbol area MOVE A,FCNPTR SETZM (A) AOS FCNPTR MOVEI A,FCNBUF PUSHJ P,SSORT HRLI A,FCNBUF HRR A,SYMPTR SUBI A,SYMBUF HRRZM A,SYMBUF+1 ;ptr to function symbol table ADDI A,SYMBUF MOVE B,FCNPTR SUBI B,FCNBUF ADD B,SYMPTR MOVEM B,SYMPTR BLT A,(B) ;output symbols file OUTSYM: MOVE A,[440700,,[ASCIZ /.SYMS/]] MOVE B,OUTPTR ILDB 0,A IDPB 0,B JUMPN 0,.-2 MOVSI A,(GJ%SHT+GJ%FOU) HRROI B,OUTFIL GTJFN JRST ERPRNT HRRZ A,A MOVE B,[440000,,OF%WR] OPENF JRST ERPRNT MOVE B,[444400,,SYMBUF] MOVEI C,SYMBUF SUB C,SYMPTR SOUT ;close up and go home CLOSF JFCL POPDA: POP P,D JRST POPCBA SUBTTL OUTPUT SYMBOL TABLES SYMTAB: PUSH P,B PUSH P,C PUSH P,D MOVE C,A MOVE D,A ;copy strings SYMCPY: HLR A,SYMNAM(C) HRLI A,440700 HRRZ B,SYMPTR SUBI B,SYMBUF HRLM B,SYMNAM(C) ADDI B,SYMBUF HRLI B,440700 ILDB A IDPB B JUMPN .-2 HRRZI B,1(B) MOVEM B,SYMPTR HRRZ C,(C) JUMPN C,SYMCPY MOVE C,D ;copy symbols themselves SYMCP1: HLR A,SYMNAM(C) HRLI A,440700 MOVEM A,(B) MOVE A,SYMVAL(C) MOVEM A,1(B) ADDI B,2 HRRZ C,(C) JUMPN C,SYMCP1 SETZM (B) ADDI B,1 EXCH B,SYMPTR MOVE A,B PUSHJ P,SSORT ;sort the table POP P,D POP P,C POP P,B POPJ P, ;sort a symbol table by value words ; a/ ptr to symbol table SSORT: PUSH P,A PUSH P,B PUSH P,C PUSH P,D SSORT1: SKIPN (A) JRST POPDA MOVE C,A ;save destination MOVE D,A ;ptr to best candidate SSORT0: ADDI A,2 ;ptr to first test SKIPN (A) ;better be a test... JRST SSORT2 ; zero, end of table MOVE B,1(D) CAMLE B,1(A) ;test better than best? MOVE D,A ;new best JRST SSORT0 ;move to next SSORT2: CAMN D,C ;must move one? JRST SSORT3 MOVE A,(D) EXCH A,(C) MOVEM A,(D) MOVE A,1(D) EXCH A,1(C) MOVEM A,1(D) SSORT3: MOVEI A,2(C) JRST SSORT1 SUBTTL GLOBAL SYMBOL REFERENCE AND DEFINITION DEFGLB: MOVE A,GLBOBL ;look it up in global symbol table PUSHJ P,SLOOK JRST DEFOLD ;already there ;symbol not in global table INSGLB: MOVE FREE,GLBPTR PUSHJ P,SINSRT ;insert it MOVEM FREE,GLBPTR HRR 0,GLBLST ;chain together all globals HRRM 0,(A) MOVEM A,GLBLST ;by consing into a list SKIPN SDEBUG JRST POPJ1 ;print symbol table here if debugging PUSH P,A MOVE A,GLBLST PUSHJ P,SPRNT POP P,A JRST POPJ1 ;here to define a symbol that already has been referenced DEFOLD: MOVE B,A ;move ptr to symbol SKIPL SYMVAL(B) ;is it undefined? JRST CPOPJ ; if defined, lose MOVE A,C ;save value MOVEM C,SYMVAL(B) ;define it MOVE C,SYMREF(B) ;pick up reference chain to C PUSHJ P,FIXUP ;fix up references already accumulated JRST POPJ1 SUBTTL LOCAL SYMBOL REFERENCE AND DEFINITION DEFLCL: MOVE A,LCLOBL ;look it up in local symbol table PUSHJ P,SLOOK JRST DEFOLL ;here for forward references ;here to add symbol to local symbol table INSLCL: MOVE FREE,LCLPTR PUSHJ P,SINSRT MOVEM FREE,LCLPTR HRR 0,LCLLST HRRM 0,(A) MOVEM A,LCLLST JRST POPJ1 ;here to define already referenced local symbol DEFOLL: SKIPN TWOPAS JRST DEFOLD SKIPN PASS2 ;only do fixups if pass 2 JRST DEFOL1 ; do usual thing in pass 1 ;do hair in pass 2 MOVEM C,SYMVAL(A) ;redefine local label ;fix up for short jumps MOVE C,SYMREF(A) ;get reference chain MOVE A,SYMVAL(A) ;get value to be fixed up PUSHJ P,FIXUP JRST POPJ1 ;here to "define" local symbol during pass one DEFOL1: MOVE B,A SKIPL SYMVAL(B) ;should be undefined JRST CPOPJ ; if defined, lose MOVE A,C ;save value HRRM C,SYMVAL(B) ;pretend to define it JRST POPJ1 BPASS2: MSG [Label inconsistency, pass 2] PUSHJ P,ERROR JRST POPJ1 SUBTTL REFERENCE AND DEFINE SYMBOLS ;reference a symbol ; takes b/ symbol ; returns a/ ptr to cell for symbol REFSYM: PUSH P,B PUSH P,C MOVE A,LCLOBL ;look up as local first PUSHJ P,SLOOK JRST [SKIPL SYMVAL(A) ;skip if undefined JRST POPCB ;has a value, return it JRST REFLLD] ;refer to old local MOVE A,GLBOBL MOVE B,-1(P) PUSHJ P,SLOOK JRST [SKIPL SYMVAL(A) JRST POPCB ;has a gval, return it JRST REFGLD] ;refer to old global MOVE B,-1(P) PUSHJ P,REFGLB POPCB: POP P,C POP P,B POPJ P, ;reference a global ; b/ symbol REFGLB: PUSH P,B PUSH P,C MOVE A,GLBOBL MOVE B,-1(P) PUSHJ P,SLOOK JRST REFGLD ;refer to old global MOVE B,-1(P) HRLZI C,%UNDEF ;undefined PUSHJ P,INSGLB HALTF REFGLD: SKIPE NOREF JRST POPCB MOVE FREE,GLBPTR HRRZ B,SYMREF(A) ;get pc chain HRRM FREE,SYMREF(A) ;and put new cell in symbol cell SKIPE WRDBYT TLO B,%RBYTE ;indicate byte reference MOVEM B,(FREE) MOVEM ZPC,1(FREE) ;pc MOVEM Z,2(FREE) ;bptr ADDI FREE,3 MOVEM FREE,GLBPTR JRST POPCB ;reference a local ; b/ symbol REFLCL: PUSH P,B PUSH P,C MOVE A,LCLOBL MOVE B,-1(P) PUSHJ P,SLOOK JRST REFLLD ;refer to old local MOVE B,-1(P) HRLZI C,%UNDEF ;undefined PUSHJ P,INSLCL HALTF REFLLD: SKIPE NOREF JRST POPCB MOVE FREE,LCLPTR ;get free storage from local area HRRZ B,SYMREF(A) ;get ptr to reference chain HRRM FREE,SYMREF(A) ;and update chain ptr SKIPE WRDBYT TLO B,%RBYTE SKIPE JMPREF TLO B,%RJUMP ;indicate jump reference MOVEM B,(FREE) ;put it in right half of new ref MOVEM ZPC,1(FREE) ;put out pc of ref MOVEM Z,2(FREE) ;put of bptr of ref ADDI FREE,3 MOVEM FREE,LCLPTR ;update free ptr JRST POPCB SUBTTL FIXUPS ;fixup forward references ; a/ value ; c/ ptr chain FIXUP: TRNN C,-1 ;if empty fixup chain, return immediately POPJ P, ; only happens for local labels PUSH P,SAVZPC PUSH P,SAVZ PUSH P,ZPC PUSH P,Z ;fix up references PUSH P,A FIXUPL: HRRZ A,(P) ;pick up value to output MOVE Z,2(C) ;pick up reference output ptr MOVEM Z,SAVZ MOVE ZPC,1(C) MOVEM ZPC,SAVZPC MOVE B,(C) TLNE B,%RJUMP ;jump ref? JRST FIXUPJ ; yes JUMPGE B,[PUSHJ P,ADDWRD JRST FIXUPN] PUSHJ P,ADDBYT FIXUPN: SKIPE PDEBUG PUSHJ P,PFIXUP HRRZ C,(C) ;move to next one JUMPN C,FIXUPL FIXUPX: POP P,A POP P,Z POP P,ZPC POP P,SAVZ POP P,SAVZPC POPJ P, ;here to fix up jumps FIXUPJ: MOVE 1(C) ;pc of ref SUB A,0 ;pc difference (true/false and pc diff cancel?) TLNE B,%RBYTE ;byte ref? JRST FIXSHJ ; means short jump ANDI A,177777 ;and it down (two's comp.) CAIGE A,77 ;skip if couldn't have been short AOS SHRIMP ;keep count of short jumps PUSHJ P,ADDWRD MOVE A,(P) ;get value back JRST FIXUPN ;and continue ;here to fix up short jumps FIXSHJ: ADDI A,1 ;pc offset ANDI A,177777 ;max size of a reference CAILE A,77 ;can it be a short jump? HALTF ; better be! ANDI A,377 ;and it down just ofr good measure PUSHJ P,ADDBYT ;output byte MOVE A,(P) ;resnarf value JRST FIXUPN ;and loop ;when debugging, print fixups when they are done PFIXUP: PUSH P,A PUSH P,B PUSH P,C MOVE A,PDEBUG MOVEI B,"{ BOUT PUSHJ P,OPC MOVEI C,0 HRROI B,[ASCIZ /} /] SOUT JRST POPCBA SUBTTL ERROR MESSAGES ERROR: PUSH P,B SETZ B, PUSHJ P,ERRMSG POP P,B POPJ P, ;takes message in A, token in B ERRMSG: PUSH P,A PUSH P,B PUSH P,C MOVEI A,.PRIOU MOVE B,ZPC MOVEI C,8 NOUT JFCL SKIPN FUNCT JRST ERRMS1 MSG [ (in ] PSOUT MOVE A,FUNCT PSOUT MSG [)] PSOUT ERRMS1: MSG [ ] PSOUT MOVE A,-2(P) PSOUT MOVE B,-1(P) JUMPE B,ERREND MOVEI A,[ASCIZ /: /] PSOUT MOVE A,B PSOUT PUSHJ P,PCRLF HRROI A,BUFFER PSOUT SKIPA ERREND: PUSHJ P,PCRLF POP P,C POP P,B POP P,A POPJ P, SUBTTL STRING ASSEMBLY ;zstrings from strings ; a/ ptr to string to translate MAKFST: SETOM MKFSTR' SETOM ZWDFLG JRST MAKS MAKZWD: SETOM ZWDFLG' SETOM MKFSTR JRST MAKS MAKSTR: SETZM ZWDFLG SETZM MKFSTR MAKS: SKIPE ZDEBUG JRST [PUSH P,A MOVEI A,^M PBOUT MOVEI A,^J PBOUT MOVE A,(P) PSOUT MOVEI A,40 PBOUT POP P,A JRST .+1] MOVEI ZCHR,0 ; initialize ZCHR byte SKIPA FRMT,[%FSPC+%FCAP]; at start, default is cap + space MAKSTL: MOVEI FRMT,%FSPC ; except at start, default is space MOVEM FRMT,FRMDFL ; set up default MOVE C,A ILDB B,C ; get first character JUMPE B,MAKSTE ; done PUSHJ P,BALPHA ; check for alphabetic JRST MAKS1 ; no. goto ascii escape MAKST0: MOVEI FRMT,%FCAP CAIG B,"Z CAIGE B,"A TRZ FRMT,%FCAP ; turn off capitalize bit if not upper case SKIPN MKFSTR ; don't bother with freq stuff for fstrs PUSHJ P,WFREQ ; lookup word in table (a is updated) JRST MAKS2 ; not there, loser! PUSH P,C ; save the word number SKIPE INZASC PUSHJ P,ENZASC PUSHJ P,MAKFRM ; setup the format for the word CAME FRMT,FRMDFL' ; if it's the default, don't bother PUSHJ P,OUTFRM ; output the format POP P,C ; restore the word number SKIPE ZDEBUG JRST [PUSH P,A MOVEI A,"W PBOUT POP P,A JRST .+1] CAIL C,240. JRST [SUBI C,240. PUSH P,C MOVEI C,%FNXT ; output next 256-word byte PUSHJ P,OUTBYC POP P,C JRST .+2] ADDI C,16. ; frob with word number PUSHJ P,OUTBYC JRST MAKSTL ; and loop MAKS1: MOVEI C,%FASC SKIPN INZASC PUSHJ P,OUTBYC MAKS1L: ILDB B,A JUMPE B,MAKSTX PUSHJ P,BALPHA JRST MAKS1A MAKSEZ: SETOM INZASC' PUSHJ P,BACKA MOVEI FRMT,%FSPC ; except at start, default is space MOVEM FRMT,FRMDFL ; set up default JRST MAKST0 BACKA: MOVNI B,1 ADJBP B,A MOVE A,B POPJ P, MAKS1A: PUSHJ P,MAKZBT JRST MAKS1L MAKS2: MOVEI C,%FASC ; escape to ZASCII SETZM MAKSAF' SKIPE MKFSTR JRST MAKS2L SKIPN INZASC PUSHJ P,OUTBYC MAKS2L: ILDB B,A ; get next character JUMPE B,MAKSTX CAIN B,"' JRST MAKS2A PUSHJ P,BALPHA CAIA JRST MAKS2A SETOM MAKSAF PUSHJ P,MAKZBT JRST MAKS2L MAKS2A: SKIPE MAKSAF JRST MAKSEZ PUSHJ P,MAKZBT JRST MAKS2L ENZASC: JUMPN ZCHR,ENZAS1 MOVEI C,0 PUSHJ P,OUTBYC SETZM INZASC POPJ P, ENZAS1: MOVEI 0,0 PUSHJ P,ADDZCH SETZM INZASC POPJ P, %FEOS==0 %FSPC==1 %FCOM==2 %FCAP==4 %FFLG==8 %FESS==5 %FNXT==4 %FESN==3 %FEOL==2 %FASC==1 CHR1T: "e ? "t ? "s ? "a ? "o ? "n ? "r ? "i "l ? "d ? "h ? "u ? "g ? 0 CHR2T: "c ? "b ? "m ? "w ? "y ? "p ? "f ? "k "v ? "z ? "j ? "x ? "q ? 40 ? "! ? "? MAKZBT: MOVEI D,CHR1T MAKZL1: SKIPN C,(D) JRST MAKZB1 CAME C,B AOJA D,MAKZL1 MOVEI 0,-CHR1T+3(D) PUSHJ P,ADDZCH POPJ P, MAKZB1: MOVEI D,CHR2T MAKZL2: SKIPN C,(D) JRST MAKZB2 CAME C,B AOJA D,MAKZL2 MOVEI 0,1 PUSHJ P,ADDZCH MOVEI 0,-CHR2T(D) PUSHJ P,ADDZCH POPJ P, MAKZB2: MOVEI 0,2 PUSHJ P,ADDZCH PUSH P,B LSH B,-4 MOVE 0,B PUSHJ P,ADDZCH POP P,B ANDI B,17 MOVE 0,B PUSHJ P,ADDZCH POPJ P, ADDZCH: JUMPN ZCHR,ADDZC1 MOVE ZCHR,0 POPJ P, ADDZC1: LSH ZCHR,4 ADD ZCHR,0 MOVE C,ZCHR PUSHJ P,OUTBYC SKIPE ZDEBUG JRST [PUSH P,A PUSH P,B PUSH P,C MOVEI A,"( PBOUT MOVE B,ZCHR LSH B,-4 MOVEI A,.PRIOU MOVEI C,10. NOUT JFCL MOVEI B,"+ BOUT MOVE B,ZCHR ANDI B,17 NOUT JFCL MOVEI B,") BOUT MOVEI B,40 BOUT POP P,C POP P,B POP P,A JRST .+1] MOVEI ZCHR,0 POPJ P, MAKSTX: PUSHJ P,ENZASC MAKSTE: MOVEI C,%FEOS ; strings end with EOS SKIPE ZWDFLG POPJ P, MOVE 0,LSTFRM CAIE 0,%FFLG+%FESS PUSHJ P,OUTBYC POPJ P, OUTBYC: EXCH A,C ; output byte in c, saving a SKIPE ZDEBUG PUSHJ P,PROUTB PUSHJ P,OUTBYT MOVE A,C SKIPN PASS2 AOS FSTRCT' POPJ P, PROUTB: PUSH P,A PUSH P,B PUSH P,C MOVE B,A MOVEI A,.PRIOU MOVEI C,10. NOUT JFCL MOVEI A,40 PBOUT POP P,C POP P,B POP P,A POPJ P, OUTFRM: TRO FRMT,%FFLG ; set the format bit MOVEM FRMT,LSTFRM' SKIPE ZDEBUG JRST [PUSH P,A MOVEI A,"F PBOUT POP P,A JRST .+1] MOVE C,FRMT ; save A SKIPN ZWDFLG PUSHJ P,OUTBYC ; output the format byte POPJ P, MAKFRM: PUSH P,A ; save text pointer ILDB B,A ; get separator CAIN B,". JRST MAKFPR CAIN B,", ; check for comma JRST MAKFCM CAIN B,40 ; check for space JRST MAKFSP CAIN B,^M JRST MAKFEL MAKFNR: POP P,A ; restore A to get separator into string POPJ P, MAKFEL: ILDB B,A ; read LF MOVEI C,%FEOL PUSHJ P,OUTBYC MOVE FRMT,FRMDFL JRST POPPO MAKFPR: MOVE C,A ILDB B,C JUMPE B,[MOVEI C,%FESS JRST MAKFPS] CAIE B,40 JRST MAKFNR MOVEI C,%FESN MAKFPS: PUSHJ P,OUTBYC MOVE FRMT,FRMDFL MOVE A,C JRST POPPO MAKFSP: TRO FRMT,%FSPC POPPO: POP P,0 POPJ P, MAKFCM: TRO FRMT,%FCOM ; set the comma next bit MOVE C,A ILDB B,C ; get next character CAIN B,40 ; is it a space? JRST [MOVE A,C TRO FRMT,%FSPC JRST .+1] POP P,0 ; we're all set now with updated A POPJ P, ;lookup word in word table ; a/ word ; +1: not found, loc to add in (A) ; +2: found, word is at (A) WFREQ: PUSH P,B PUSH P,F PUSH P,G PUSH P,H SKIPL G,WRDTAB JRST WFREQX HRRZ G,G ;initial center point HRRZ F,G ;initial low point MOVEI H,WRDTND ;initial high point ;calculate test point WFREQ1: CAML F,H ;not hit yet? JRST WFREQX SUB G,F ;minus low point LSH G,-1 ;divide by two TRZ G,1 ;must be multiple of two (size of entries) ADD G,F ;plus low ;test MOVE B,1(G) ;get test PUSHJ P,SFREQ JRST WFREQQ ;found it SKIPA H,G ;sample before MOVEI F,2(G) ;sample after MOVE G,H ;high point JRST WFREQ1 WFREQQ: AOS -4(P) MOVE C,(G) ;value WFREQX: POP P,H POP P,G POP P,F POP P,B POPJ P, ;a/ sample ;b/ word from table ; +1: = ; +2: a>b ; +3: b>a SFREQ: PUSH P,A PUSH P,C SETZM SFREQ1' FREQN: ILDB C,B JUMPE C,FREQQ ILDB 0,A SKIPN SFREQ1 JRST [CAIL 0,"A CAILE 0,"Z CAIA ADDI 0,32. JRST .+1] SETOM SFREQ1 CAME 0,C JRST FREQD JRST FREQN FREQQ: MOVE C,A ILDB B,C CAIN B,"' JRST FREQD1 PUSHJ P,BALPHA JRST FREQQ1 JRST FREQD1 FREQQ1: POP P,C POP P,0 POPJ P, FREQD: CAML 0,C FREQD1: AOS -2(P) AOS -2(P) POP P,C POP P,A POPJ P, SUBTTL STRING ASSEMBLY DEBUGGING ;print zstring being assembled ;only called if CDEBUG is not 0 ; a/ bptr to string CSTRNG: PUSH P,A PUSH P,B PUSH P,C SKIPN A,PDEBUG ;pick up script channel MOVEI A,.PRIOU ;or tty MOVEI C,0 HRROI B,[ASCIZ / "/] SOUT MOVE B,-2(P) SOUT HRROI B,[ASCIZ /" /] SOUT JRST POPCBA ;print character being produced for a zstring ;only called if CDEBUG is not 0 ; b/ character COUT: PUSH P,A PUSH P,B PUSH P,C MOVE B,C SKIPN A,PDEBUG ;pick up script channel MOVEI A,.PRIOU ;or tty if there is no script MOVEI C,8 ;radix 8 HRLI C,(NO%ZRO+NO%LFL)+2 ;always print two column, pad with 0 NOUT JFCL MOVEI B,40 ;terminate with space BOUT POPCBA: POP P,C POP P,B POP P,A POPJ P, SUBTTL ROUTINE FOR PRINTING CURRENT ZFUNCTION NAME AND CURRENT PC PFUNCT: PUSH P,A PUSH P,B PUSH P,C HRROI A,[ASCIZ / Len = /] PSOUT MOVEI A,.PRIOU MOVE B,ZPC SUB B,ZPCLF' PUSH P,B MOVEM ZPC,ZPCLF MOVEI C,10. NOUT JFCL HRROI A,[ASCIZ / Str = /] PSOUT MOVEI A,.PRIOU MOVE B,FSTRCT ADDM B,FSTRTT' MOVEI C,10. NOUT JFCL HRROI A,[ASCIZ / (/] PSOUT POP P,B MOVE A,FSTRCT IMULI A,100. IDIV A,B MOVE B,A MOVEI A,.PRIOU MOVEI C,10. NOUT JFCL HRROI A,[ASCIZ /%)/] PSOUT SETZM FSTRCT MOVEI A,^M PBOUT MOVEI A,^J PBOUT MOVE A,FUNCT PSOUT MOVEI A,^I PBOUT MOVEI A,.PRIOU MOVE B,ZPC MOVEI C,10. NOUT JFCL POP P,C POP P,B POP P,A POPJ P, SUBTTL WORD FREQUENCY PASS GOODIES GO HERE FREQ: MOVE A,1(TP) CAIE A,": JRST FREQ1 NXTARG 1 JRST FREQ FREQ1: SKIPN A,(TP) SKIPE 1(TP) SKIPA POPJ P, PUSHJ P,LOOKUP POPJ P, JUMPL B,FPSEUDO JRST FOPER FOPER: TLNN B,%STR POPJ P, NXTARG 1 MOVE D,(TP) PUSHJ P,NEWWRD POPJ P, FPSEUD: HRRZ B,B SETZM FPSVFL CAIE B,ZINSER CAIN B,ZENDI JRST (B) CAIN B,ZZWORD JRST FPSEUV CAIE B,ZSTRL CAIN B,ZSTR JRST FPSEU1 CAIE B,ZGSTR POPJ P, FPSEUV: SETOM FPSVFL' JRST FPSEU1 FPSEU2: NXTARG 1 FPSEU1: NXTARG 1 SKIPN D,(TP) JRST TFARG PUSHJ P,NEWWRD POPJ P, ;main entry to count frequency of words in a particular string ; called with string pointer in D NEWWRD: JUMPE D,CPOPJ MOVE E,[440700,,WRDBUF] MOVEI J,0 ;count of bytes NXTWRD: ILDB A,D JUMPE A,CPOPJ PUSHJ P,ALPHA JRST NXTWRD CAIG A,"Z CAIGE A,"A CAIA ADDI A,40 WRDLP: IDPB A,E ADDI J,1 MOVE F,D ;save this pointer ILDB A,D JUMPE A,WRDEOS CAIG A,"Z CAIGE A,"A CAIA ADDI A,40 CAIN A,"' JRST WRDLP PUSHJ P,ALPHA JRST WRDEND ;not alphabetic JRST WRDLP WRDEOS: MOVEI D,0 ;end of input string JRST WRDEN2 WRDEND: MOVE D,F ;recover non-spaced bptr WRDEN3: MOVEI A,0 WRDEN2: IDPB A,E MOVE A,[440700,,WRDBUF] PUSHJ P,WLOOK JRST WRDADD ;not there, go add it AOS (G) ;add to its usage count JRST NEWWRD WRDADD: SKIPN WDEBUG JRST WRDAD1 MSG ["] PSOUT MOVE A,[440700,,WRDBUF] PSOUT MSG [" ] PSOUT WRDAD1: MOVE A,TABPTR TLNN A,400000 JRST [HRLI A,440700 ADDI A,1 JRST .+1] MOVE H,A MOVE B,[440700,,WRDBUF] MOVEI C,0 SOUT ;copy string to buffer IDPB C,A MOVEM A,TABPTR ;update table pointer PUSH P,G MOVE G,WRDTAB SUB G,[2,,2] MOVEM G,WRDTAB POP P,G ;make a slot for new entry HRRZ A,WRDTAB HRLI A,2(A) BLT A,-1(G) ;put out new entry MOVEM H,-1(G) ;string MOVEI H,1 HRL H,J ;size of string in bytes MOVEM H,-2(G) ;count JRST NEWWRD ;here when all done FILEND: PUSHJ P,BYTES PUSHJ P,SORT ;here to output the data MOVE A,[440700,,[ASCIZ /FREQ.ZAP/]] MOVE B,OUTPTR ILDB 0,A IDPB 0,B JUMPN 0,.-2 MOVSI A,(GJ%SHT+GJ%FOU) HRROI B,OUTFIL GTJFN JRST ERPRNT HRRZ A,A MOVEM A,OJFN MOVE B,[070000,,OF%WR] OPENF JRST ERPRNT ;output the goodies MOVE G,WRDTAB HRLI G,-<2*%FWDCT> PUSHJ P,PTAB MOVE A,OJFN HRROI B,[ASCIZ / WORDS:: .TABLE/] MOVEI C,0 SOUT MOVE G,[-%FWDCT,,1] FWTBLL: MOVE A,OJFN HRROI B,[ASCIZ / FSTR?/] MOVEI C,0 SOUT HRRZ B,G MOVEI C,10. NOUT JFCL AOBJN G,FWTBLL MOVE A,OJFN HRROI B,[ASCIZ / .ENDI /] MOVEI C,0 SOUT CLOSF JFCL HALTF ;calculate bytes saved BYTES: MOVE A,WRDTAB SETZM XTWRDS' BYTES1: HRRZ B,(A) ADDM B,XTWRDS HRLM B,(A) ADD A,[2,,2] JUMPL A,BYTES1 POPJ P, ;sort word table by bytes saved SORT: MOVE A,WRDTAB ;next slot of table SORTM: MOVE B,A SETZB C,D SETZ E, ;next try for largest number SORTN: CAMLE C,(B) JRST SORTL ;pick up new candidate MOVE C,(B) MOVE D,1(B) MOVE E,B SORTL: ADD B,[2,,2] JUMPL B,SORTN ;end of pass JUMPE C,SORTO EXCH C,(A) MOVEM C,(E) EXCH D,1(A) MOVEM D,1(E) ;move to next slot SORTO: MOVE C,(A) SORTP: ADD A,[2,,2] JUMPGE A,CPOPJ CAMN C,(A) JRST SORTP JRST SORTM NEXT31: MOVE A,WRDTAB ADD A,[76,,76] MOVEM A,WRDTAB N31LUP: HRRZ B,(A) HLRZ C,(A) IDIV C,B SUBI C,1 HRLM C,(A) ADD A,[1,,1] AOBJN A,N31LUP PUSHJ P,BYTES PUSHJ P,SORT POPJ P, PSAVED: MSG [31 words: ] PSOUT MOVEI A,.PRIOU MOVE B,D MOVEI C,10. NOUT JFCL MSG [ zbytes saved, ] PSOUT MOVEI A,.PRIOU MOVE B,E NOUT JFCL MSG [ uses. ] PSOUT POPJ P, PTABS: MOVEI A,101 MOVEM A,OJFN MOVE G,WRDTAB HRLI G,-76 PUSHJ P,PTAB PUSHJ P,PSAVED PUSHJ P,NEXT31 MOVE G,WRDTAB HRLI G,-76 PUSHJ P,PTAB PUSHJ P,PSAVED PUSHJ P,NEXT31 MOVE G,WRDTAB HRLI G,-76 PUSHJ P,PTAB PUSHJ P,PSAVED POPJ P, PTABLE: PUSH P,G MOVE G,WRDTAB PUSHJ P,PTAB POP P,G POPJ P, PTAB: PUSH P,A PUSH P,B PUSH P,C SETZB D,E MOVEI F,0 PTLOOP: ADDI F,1 MOVE A,OJFN HRROI B,[ASCIZ / .FSTR FSTR?/] MOVEI C,0 SOUT MOVE B,F MOVEI C,10. NOUT JFCL MOVE A,OJFN HRROI B,[ASCIZ /,"/] MOVEI C,0 SOUT MOVE B,1(G) SOUT HRROI B,[ASCIZ /" ;/] SOUT MOVE A,OJFN HLRZ B,(G) ADD D,B MOVEI C,10. NOUT JFCL MOVEI B,15 BOUT MOVEI B,12 BOUT ADD G,[2,,2] JUMPL G,PTLOOP PUSHJ P,PT512 POP P,C POP P,B POP P,A POPJ P, PT512: HRROI B,[ASCIZ / ; Top 512 Words: /] MOVEI C,0 SOUT MOVE A,OJFN MOVE B,D MOVEI C,10. NOUT JFCL HRROI B,[ASCIZ / uses (/] MOVEI C,0 SOUT MOVE A,OJFN MOVE B,D IMULI B,100. IDIV B,XTWRDS MOVEI C,10. NOUT JFCL HRROI B,[ASCIZ /%) /] MOVEI C,0 SOUT POPJ P, ;lookup word in word table ; a/ word ; +1: not found, loc to add in (g) ; +2: found, word is at (g) WLOOK: SKIPL G,WRDTAB POPJ P, HRRZ G,G ;initial center point HRRZ F,G ;initial low point MOVEI H,WRDTND ;initial high point ;calculate test point LOOK1: CAML F,H ;not hit yet? POPJ P, SUB G,F ;minus low point LSH G,-1 ;divide by two TRZ G,1 ;must be multiple of two (size of entries) ADD G,F ;plus low ;test MOVE B,1(G) ;get test PUSHJ P,SCOMP JRST LOOKEQ ;found it SKIPA H,G ;sample before MOVEI F,2(G) ;sample after MOVE G,H ;high point JRST LOOK1 LOOKEQ: AOS (P) POPJ P, ;a/ sample ;b/ word from table ; +1: = ; +2: a>b ; +3: b>a SCOMP: PUSH P,A PUSH P,C COMPN: ILDB 0,A ILDB C,B CAME 0,C JRST COMPD JUMPE 0,COMPX JRST COMPN COMPX: POP P,C POP P,A POPJ P, COMPD: CAML 0,C AOS -2(P) AOS -2(P) JRST COMPX ALPHA: CAIL A,"A CAILE A,"Z SKIPA JRST ALPHA1 CAIL A,"a CAILE A,"z POPJ P, ALPHA1: AOS (P) POPJ P, BALPHA: CAIL B,"A CAILE B,"Z SKIPA JRST BALPH1 CAIL B,"a CAILE B,"z POPJ P, BALPH1: AOS (P) POPJ P, PUNCT: CAIE A,", CAIN A,". POPJ P, CAIE A,"! CAIN A,"? POPJ P, AOS (P) POPJ P, SUBTTL VARIABLES AND BUFFERS ;debugging flags SDEBUG: 0 ;if non-0, print symbol table PDEBUG: 0 ;if non-0, print lines as they are read TDEBUG: 0 ;if non-0, print tokens after parsing them ODEBUG: 0 ;if non-0, print opers info CDEBUG: 0 ;if non-0, print strings in "zascii" ZDEBUG: -1 FDEBUG: 0 ;if non-0, print functions as they are found STOP: 0 ;if non-0, location to halt at (for changing flags) SYMFLG: 0 ;if non-0, output symbol table ;flags for word frequency pass DOFREQ: 0 ;if non-0, this is word frequency run, not assy. WDEBUG: 0 ;if non-0, print new words during frequency pass ;i/o goodies ;gtjfn block for normal file opening GTJFNB: GJ%OLD ;flags .NULIO,,.NULIO ;jfns 0 ;device 0 ;dir -1,,[ASCIZ /ZIPTEST/] ;name -1,,[ASCIZ /ZAP/] ;ext 0 ;prot 0 ;acct 0 ;jfn ;gtjfn block for normal file opening GTJFNX: GJ%OLD ;flags .NULIO,,.NULIO ;jfns 0 ;device 0 ;dir -1,,[ASCIZ /ZIPTEST/] ;name -1,,[ASCIZ /XZAP/] ;ext 0 ;prot 0 ;acct 0 ;jfn ;gtjfn block for reading file name from tty GTJFNT: GJ%OLD+GJ%EXT ;flags .PRIIN,,.PRIOU ;jfns 0 ;device -1,,[ASCIZ /INFOCOM.ZORK/] ;dir -1,,[ASCIZ /ZIPTEST/] ;name -1,,[ASCIZ /ZAP/] ;ext 0 ;prot 0 ;acct 0 ;jfn 0 ;f2 0 ;input copy 0 ; -1,,[ASCIZ /File/] 0 0 ;output gtjfn OUTPTR: 440700,,OUTFIL OUTFIL: BLOCK 20 OJFN: 0 ;old input jfn, for when .INSERT done IJFN: 0 ;input jfn FILBUF: BLOCK 20. FILPTR: 0 JOBNAM: ASCIZ /MUDDLE/ PDL: BLOCK 100 ;stack ZAPID: 3 ;zap id number (assembly language version) FLGWRD: 0 ;1 if byte swapped (not implemented) %BYTSWP==1 ;flag word bit for byte-swapped mode %TIMESL==2 ;flag word bit for 'time' status line RELEAS: -1 ;release number ;various assembler variables SAVZPC: 0 ;saved pc used mostly by debugging printers SAVZ: 0 ;saved output ptr ditto TABLE: 0 ;if in table, holds pc of table start TABLEN: 0 ;if in table, holds max length or -1 if none GLBTOT: 0 ;how many globals he made (limit is 255-20) GLBCNT: 17 ;current global (1-17 are really locals) OBJTOT: 0 ;how many objects he made (limit is 255) OBJCNT: 0 ;current object FUNCT: 0 ;non-zero during function assy. FSYM: 0 ;symbol value of last function LSTSYM: 0 ;last symbol defined WRDBYT: 0 ;-1 if assembling byte, 0 if word JMPREF: 0 ;-1 if assembling jump, 0 otherwise SHRIMP: 0 ;long jumps that were wasted OSHRIM: 0 ;saved count of wasted long jumps ;goodies for instruction assembly NOREF: 0 ;-1 if not to assemble references (as instruction operands ;are moved into ARGBUF) OPER: 0 ;operator is saved here ARGBUF: BLOCK 14 ;args to operators, pairs of values and strings SENSE: 0 ;sense of predicate jump PRED: 0 ;value of predicate byte 0 ;ptr to string defining it VAL: 0 ;value of value byte 0 ;string defining it LSTRWD: 0 ;Z at last string word output saved here for stop bit addition ;junk for second pass over functions TWOPAS: -1 ;-1 if two pass assembly PASS2: 0 ;-1 if doing second pass FPOS: 0 ;saved file pointer FZ: 0 ;saved z FZPC: 0 ;saved zpc FSHORT: 0 ;count of short jumps saved ZCSET: 0 ;char set of last character looked at ;parsing information of various sorts BUFFER: BLOCK 1000 ;read in buffer TOKEN: BLOCK 1000 ;buffer for parsed tokens TOKPTR: 0 ; ptr into same TPDL: -100.,,TOKENS-1 ;stack for pairs of token/terminator TOKENS: BLOCK 100. ; points to here ;junk to unsuccessfully fool GC-READ (joel is a twit) ;this stuff is modified by OUTPUT HEADER: 1305 ;object plus type word 1305 1305 122 ; ?? 41 ; ?? 51,,5374 ;type,,length 41000,,2006 ;bptr to start FOOTER: 40003,,0 ;bytes 1303,,3311 ;length,,self ;get these out of the way VARIAB CONSTA SUBTTL SYMBOL TABLES SYMPTR: SYMBUF+2 ;ptr to symbol table buffer FCNPTR: FCNBUF ;ptr to function table buffer SYMSIZ==3 ;size of a symbol entry SYMNAM==0 ;offset of name slot SYMVAL==1 ;offset of value slot SYMREF==2 ;offset of references slot BUCKN==201. ;how many buckets BUCKL==25.*SYMSIZ ;how long buckets are ;local symbol goodies LCLLST: 0 ;list of local symbols LCLPTR: LCLBUF ;ptr to free space in local symbol buffer LCLBUF: BLOCK 10000 ;local symbol pnames buffer LCLOBL: -,,LCLTAB ;ptr to local symbol hash table LCLTAB: BLOCK BUCKN*BUCKL ;local symbol hash table LCLEND: 0 ;end of same ;global symbol goodies GLBLST: 0 ;list of global symbols GLBPTR: GLBBUF ;ptr to free space in global symbol buffer GLBBUF: BLOCK 40000 ;global symbol pname buffer starts here GLBOBL: -,,GLBTAB ;ptr to global symbol hash table GLBTAB: BLOCK BUCKN*BUCKL ;global symbol hash table GLBEND: 0 ;end of same ;word frequency hack stuff is here FREQST: 0 ;-1 when assembling string that can have fstrs FSTRS: -1 ;count of .FSTRs seen WRDBUF: BLOCK 10. WRDTLN==20000. WRDTND==700000+WRDTLN-2 WRDTAB: WRDTND TABPTR: 440700,,.+1 LOC .+1000 ;output buffer OUTBUF==<.+77777>&-100000 ;lies at 100000*n ;symbol table hacks FCNBUF==OUTBUF+200000 ;function symbol tables made here SYMBUF==FCNBUF+10000 ;symbol tables made mapped here END START