IMD 1.16: 6/09/2007 9:59:26 80 stuff interpreter  @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ 80STUFF9 CALC.TEXTmʝ2 CPMIO.TEXTm:28 CPMINC.TEXTm:8< NOFPT.TEXTm9<PFPI.TEXTm:Pn ARITH.TEXTm:n VARS.TEXTmFPT.TEXTmٜFPL.TEXTmٜ BOOT.TEXTmٜ SET2.TEXTmٜ SET1.TEXTm@STP.TEXTm @Z INTERP.TEXTm*Zv PROC2.TEXTmv PROC1.TEXTm INCLUDET.TEXTm9INCLUDENT.TEXTm9 ASMZ80.CODEO^m A, NUMERIC: SET OF CHAR; NUM, ANSWER: REAL; SOURCE: STRING; TOKENTYPE: TOKENKINDS; NAMETABLE: ARRAY[0..TABLESIZENTEGER; BEGIN I:=TOTALIDS; NAMETABLE[0].NAME:=IDTEXT;(*DON'T CHANGE--THIS IS USED AINSIDE OF PRIMARY!!*) WHILE N] OF RECORD NAME: IDKIND; CASE ISVAR: BOOLEAN OF TRUE: (VALUE: REAL) END; TEMP: REAL; AMETABLE[I].NAME<>IDTEXT DO I:=I-1; LOOKUP:=I END (*OF LOOKUP*); BEGIN (*GETID*) ID:=IDBLANKS; I:=0; REPEAT IF ITSOK,GAVEERR: BOOLEAN; PROCEDURE GETCHAR; BEGIN J:=J+1; (*J IS INDEX INTO SOURCE*) IF J<=LENGTH(SOURCE) THEN CH:=SOUR I<=IDLENGTH THEN ID[I]:=CH; I:=I+1; GETCHAR UNTIL NOT(CH IN ['A'..'Z','0'..'9']); DONTEAT:=CH<>' '; (*DONT GET NEXTCE[J] ELSE CH:='#'; (*EOF SOURCE CHAR*) IF (CH>='a') AND (CH<='z') THEN CH:=CHR(ORD(CH)-32) (*CHANGE TO UPPER CASE*) END (*OF GETCHAR*); PROCEDURE SCANNER; VAR DONTEAT: BOOLEAN; PROCEDURE GETCONSTANT; (*Real number scanner RJH 9 July 77*) VAR WHOLEPART: REAL; DODECIMAL: BOOLEAN; FUNCTION NUMBER (FRACTION: BOOLEAN): REAL; (*Returns number as whole or fraction*) VAR SUM, COUNT: REAL; BEGIN COUNT:=1; SUM:=0; REPEAT IF SUM < 0.9E37 (*MAXREAL*) THEN BEGIN SUM:=10*SUM + ORD(CH) - ORD('0'); COUNT:=10*COUNT END; GETCHAR UNTIL NOT (CH IN NUMERIC); IF FRACTION THEN NUMBER:=SUM/COUNT ELSE NUMBER:=SUM END (*NUMBER*); BEGIN (*GETCONSTANT*) TOKENTYPE:=CONSTV; IF CH <> '.' THEN BEGIN WHOLEPART: PROGRAM CALCULATOR;(*WRITTEN BY DALE ANDER JULY 8, 1977 6MODIFIED JULY 17, 1977*) CONST IDLENGTH = 7; &TABLESIZE = 35; (*TA=NUMBER(FALSE); IF CH='.' THEN GETCHAR; DODECIMAL:=(CH IN NUMERIC); END ELSE BEGIN WHOLEPART:=0; BLESIZE IS MEMORYSIZE*) &IDBLANKS = ' '; &LASTX = 'LASTX '; TYPE TOKENKINDS = (CONSTV, EOFV, FUCIDENV, LINEV, LPAREN GETCHAR; DODECIMAL:=(CH IN NUMERIC); IF NOT DODECIMAL THEN TOKENTYPE:=UNRECSYMV END; IF DODECIMAL THEN NUM:V, MINUSV, PLUSV, RPARENV, SLASHV, STARV, UNRECIDV, UNRECSYMV, UPARROWV, VARIDENV, EQU=WHOLEPART + NUMBER(TRUE) ELSE NUM:=WHOLEPART; DONTEAT:=CH<>' '; (*DONT EAT NEXT IF CH IS NONBLANK DA 7/11/77*) ALV, LASTXV); &IDKIND = PACKED ARRAY[0..IDLENGTH] OF CHAR; VAR CH: CHAR; J, TOTALIDS, INDEX: INTEGER; OPERATORS, ALPHEND (*OF GETCONSTANT*); PROCEDURE GETID; VAR ID: IDKIND; I: INTEGER; FUNCTION LOOKUP(IDTEXT: IDKIND):INTEGER; VAR I: I PRESS(VAR ANS: REAL): BOOLEAN ; VAR OK, CHANGESIGN: BOOLEAN; RSLT1, RSLT2: REAL; SAVEOP: TOKENKIND; FUNCTION TERM(VAR A 7: IF ARG<0 THEN BEGIN WRITE('Undefined SQRT'); GAVEERR:=TRUE END ELSE ANS:=SQRT(ARG); 10: IF (ROUND(ARG)>33) ORNS: REAL): BOOLEAN ; VAR OK: BOOLEAN; SAVEOP: TOKENKIND; RSLT1, RSLT2: REAL; FUNCTION FACTOR(VAR ANS: REAL): BOOLEAN ;  (ROUND(ARG)<0) THEN BEGIN WRITE('Cannot calculate factorial GTR 33'); GAVEERR:=TRUE END ELSE VAR OK: BOOLEAN; RSLT1, RSLT2: REAL; FUNCTION PRIMARY(VAR ANS: REAL): BOOLEAN ; (*REWRITTEN BY RJH 12 JULY 77 #REREWRITTENBEGIN TEMP:=1; FOR I:=2 TO ROUND(ARG) DO TEMP:=TEMP*I; ANS:=TEMP END E BY DA 7/14/77*) VAR FUCNUM, SAVEINDEX: INTEGER; SAVEID: IDKIND; SAVETOK: TOKENKINDS; FUNCTION PARENEXPRESSION(VAR AND (*OF CASE*) ELSE EVALU8:=FALSE; IF GAVEERR THEN EVALU8:=FALSE END (*OF EVALU8*); BEGIN (*PRIMARY*) PRIMARY:=FALSE; INS: REAL): BOOLEAN ; BEGIN PARENEXPRESSION:=FALSE; IF TOKENTYPE=LPARENV THEN BEGIN SCANNER; F TOKENTYPE=CONSTV THEN (*CONSTANT*) BEGIN ANS:=NUM; (*GLOBAL SET BY GETCONSTANT*) PRIMARY:=TRUE; SCANNER  IF EXPRESS(ANS) THEN IF TOKENTYPE=RPARENV THEN BEGIN SCANNER; PARENEXPRESSION:=TRUE END ELSE  END ELSE IF TOKENTYPE IN [VARIDENV, UNRECIDV] THEN BEGIN SAVETOK:=TOKENTYPE; SAVEID:=NAMETABLE[0 IF CH IS NONBLANK*) IF ID=LASTX THEN TOKENTYPE:=LASTXV ELSE BEGIN INDEX:=LOOKUP(ID); IF INDEX>0 THEN IF TOKENTYPE<>EOFV THEN BEGIN GAVEERR:=TRUE; WRITE ('")" missing') END END ELSE IF TOKENTYPE IN [UNRECIDV IF NAMETABLE[INDEX].ISVAR THEN TOKENTYPE:=VARIDENV ELSE TOKENTYPE:=FUCIDENV ELSE TOKENTYPE:=UNRECIDV END END, UNRECSYMV] THEN BEGIN GAVEERR:=TRUE; WRITE ('Illegal symbol') END ELSE IF TOKENTYPE<>EOFV THEN BEGIN G (*OF GETID*); BEGIN (*SCANNER*) DONTEAT:=FALSE; IF CH IN ALPHA THEN GETID ELSE IF CH IN NUMERIC+['.'] THEN GETCONSTAAVEERR:=TRUE; WRITE ('"(" missing') END END (*OF PARENEXPRESSION*); FUNCTION EVALU8 (VAR ANS: REAL): BOOLEAN; VAR ARG, TEMP: RENT ELSE IF CH IN OPERATORS THEN CASE CH OF '+': TOKENTYPE:=PLUSV; '-': TOKENTYPE:=MINUSV; AL; I: INTEGER; BEGIN EVALU8:=TRUE; IF PARENEXPRESSION (ARG) THEN CASE FUCNUM OF 1: ANS:=SIN(ARG); 2: AN '*': TOKENTYPE:=STARV; '/': TOKENTYPE:=SLASHV; '\': TOKENTYPE:=LINEV; '^': TOKENTYPE:=UPARROWV; '(': TOKENTYPE:=LS:=COS(ARG); 3: IF COS(ARG)=0 THEN BEGIN WRITE('Undefined TAN'); GAVEERR:=TRUE END ELSE ANS:=SIN(ARG)/COS(ARG); PARENV; ')': TOKENTYPE:=RPARENV; '=': TOKENTYPE:=EQUALV; '#': BEGIN TOKENTYPE:=EOFV; DONTEAT:=TRUE END END 4: IF ARG<=0 THEN BEGIN WRITE('Undefined LOG'); GAVEERR:=TRUE END ELSE ANS:=LOG(ARG); 5: IF ARG<=0 THEN BEGIN WRITE('U ELSE TOKENTYPE:=UNRECSYMV; IF NOT DONTEAT THEN REPEAT GETCHAR UNTIL CH<>' ' (*GETNONBLANK*) END (*OF SCANNER*); FUNCTION EXndefined LN'); GAVEERR:=TRUE END ELSE ANS:=LN(ARG); 6: ANS:=ABS(ARG);   BEGIN WRITE('Table full. Not done'); GAVEERR:=TRUE END; IF SAVEINDEX<>0 THEN BEGIN NAMETABLE[SAVEINDEX].VALUE:=ANS;ANS:=RSLT1; TERM:=OK END (*TERM*); BEGIN (*EXPRESS*) OK:=TRUE; IF TOKENTYPE IN [PLUSV,MINUSV] THEN  PRIMARY:=TRUE END END END ELSE IF SAVETOK=UNRECIDV THEN BEGIN WRITE('Unrecognized ID'); GAVEER BEGIN CHANGESIGN:=(TOKENTYPE=MINUSV); SCANNER END ELSE CHANGESIGN:=FALSE; IF TERM(RSLT1) THEN BEGIN IF CHANGESR:=TRUE END ELSE BEGIN PRIMARY:=TRUE; ANS:=NAMETABLE[SAVEINDEX].VALUE END END ELSE IF TOKENTYPE=FIGN THEN RSLT1:=-RSLT1; WHILE OK AND (TOKENTYPE IN [PLUSV,MINUSV]) DO BEGIN SAVEOP:=TOKENTYPE; UCIDENV THEN (*FUNCTION*) BEGIN FUCNUM:=INDEX; (*INDEX SET BY GETIDENT*) SCANNER; PRIMARY:=EVALU8 (ANS) END ELS SCANNER; IF TERM(RSLT2) THEN CASE SAVEOP OF PLUSV: RSLT1:=RSLT1+RSLT2; MINUSV: RSLT1:=RSLT1-RSLT2E IF TOKENTYPE=LASTXV THEN BEGIN SCANNER; ANS:=ANSWER; PRIMARY:=TRUE END ELSE PRIMARY:=PARENEXPRESSION (ANS) END ELSE OK:=FALSE END END ELSE OK:=FALSE; EXPRESS:=OK; IF OK THEN ANS:=RSLT1 END (*OF EXPRESS*); END (*OF PRIMARY*); BEGIN (*FACTOR*) OK:=TRUE; IF PRIMARY(RSLT1) THEN WHILE OK AND (TOKENTYPE=UPARROWV) DO  PROCEDURE INITABLES; BEGIN ALPHA:=['A'..'Z']; NUMERIC:=['0'..'9']; OPERATORS:=['+','=','*','-','/','\','^','(',')','#']; BEGIN SCANNER; IF PRIMARY(RSLT2) THEN *IF RSLT1<=0 THEN ,BEGIN WRITE('Cannot calculate power'); OK:=FALSE; GAVEERR:=TR WITH NAMETABLE[1] DO BEGIN NAME:='SIN '; ISVAR:=FALSE END; WITH NAMETABLE[2] DO BEGIN NAME:='COS '; ISVAR:=UE END *ELSE RSLT1:=EXP(RSLT2*LN(RSLT1)) ELSE OK:=FALSE END ELSE OK:=FALSE; IF OK THEN ANS:=RSLT1; FACTOR:=OK END FALSE END; WITH NAMETABLE[3] DO BEGIN NAME:='TAN '; ISVAR:=FALSE END; WITH NAMETABLE[4] DO BEGIN NAME:='LOG (*OF FACTOR*); BEGIN (*TERM*) OK:=TRUE; IF FACTOR(RSLT1) THEN WHILE OK AND (TOKENTYPE IN [STARV, SLASHV, LINEV]) DO '; ISVAR:=FALSE END; WITH NAMETABLE[5] DO BEGIN NAME:='LN '; ISVAR:=FALSE END; WITH NAMETABLE[6] DO ].NAME; (*PUT THERE BY LOOKUP IN GETID*) SAVEINDEX:=INDEX; (*GLOBAL SET IN GETID*) SCANNER; IF TOKENTYPE BEGIN SAVEOP:=TOKENTYPE; SCANNER; IF FACTOR(RSLT2) THEN CASE SAVEOP OF STARV: RSLT1:=RSLT1*RSLT2; SLAS=EQUALV THEN (*MEMORY ASSIGNMENT*) BEGIN SCANNER; IF EXPRESS(ANS) THEN BEGIN HV: IF RSLT2=0 THEN BEGIN OK:=FALSE; GAVEERR:=TRUE; WRITE('Division by zero') END ELSE RSLT1:=RSL IF SAVETOK=UNRECIDV THEN IF TOTALIDS+1<=TABLESIZE THEN BEGIN TOTALIDS:=TOTALIDS+1; SAVEINDEX:=TOTALIT1/RSLT2; LINEV: IF ROUND(RSLT2)=0 THEN BEGIN OK:=FALSE; 7GAVEERR:=TRUE; WRITE('MOD by zero') DS; WITH NAMETABLE[SAVEINDEX] DO BEGIN ISVAR:=TRUE; NAME:=SAVEID END END ELSE  END ELSE RSLT1:=ROUND(RSLT1) MOD ROUND(RSLT2) END (*CASE*) ELSE OK:=FALSE END ELSE OK:=FALSE; IF OK THEN  BLE[8] DO BEGIN NAME:='E '; ISVAR:=TRUE; VALUE:=2.718282 END; WITH NAMETABLE[9] DO BEGIN NAME:='PI '; ISVAR:=TRUE; VALUE:=3.141593 END; WITH NAMETABLE[10] DO BEGIN NAME:='FAC '; ISVAR:=FALSE END; TOTALIDS:=10 (*BUILD IN NUMBER OF FUNCS & VARS*) END (*INITABLES*); BEGIN (*CALCULATOR*) ANSWER:=0; INITABLES; REPEAT GAVEERR:=FALSE; J:=0; (.IF ~LSTIO ).NOLIST (.ELSE ).LIST (.ENDC   ;Copyright (c) 1978 by the  ; Regents of the University of California   WRITE('->'); READLN(SOURCE); IF LENGTH(SOURCE)=0 THEN EXIT(PROGRAM); REPEAT GETCHAR UNTIL CH<>' '; (*GETNONBLANK; San Diego Campus   ; Start of file CPMIO   ;**********************************************************   ABORT JP *) SCANNER; ITSOK:=EXPRESS(TEMP) AND (TOKENTYPE=EOFV); IF NOT ITSOK THEN BEGIN IF (TOKENTYPE=EOFV) AND NOT GA ABORT    ;******************UNITIO    MAXU .EQU 07H  INBIT .EQU 01H  OUTBIT .EQU 02H  CLRBIT .VEERR THEN WRITE ('Unexpected end of expression') ELSE IF NOT GAVEERR THEN WRITE('Illegal Symbol'); WRITELN('EQU 04H  ALLBIT .EQU INBIT|OUTBIT|CLRBIT   ; the unittable unithandler vectors   UNITBL .EQU $-04H (.WORD A: Try Again') END ELSE BEGIN WRITELN(' ',TEMP); ANSWER:=TEMP END UNTIL FALSE; END (*EXPRESSION*).  LLBIT ; Unit 1: CONSOLE: (.WORD CHDRVR (.WORD ALLBIT ; Unit 2: SYSTERM: (non-echoing keyboard) (.WORD O^ CHDRVR (.WORD 00H,00H ; Unit 3: GRAPHICS: (.WORD ALLBIT ; Unit 4: drive 0 (.WORD DR0DRVR (.WORD AL:LBIT ; Unit 5: drive 1 (.WORD DR1DRVR (.WORD OUTBIT|CLRBIT ; Unit 6: PRINTER: (.WORD CHDRVR1 (.WORD ALLBIT ; Unit 7: REMOTE: (.WORD CHDRVR1   UPTR .WORD 0000H ;points into UNITBL for specific unit  UREQ .BYTE 00H ;denotes read or write operation  UNIT .BYTE 00H ;set to LUN of operation  UBUF .WORD 0000H ;user's buffer address  ULEN .WORD 0000H ;user's buffer length  UBLK .WORD 0000H ;block number, for disk BEGIN NAME:='ABS '; ISVAR:=FALSE END; WITH NAMETABLE[7] DO BEGIN NAME:='SQRT '; ISVAR:=FALSE END; WITH NAMETA  LD A,CLRBIT (LD (UREQ),A (LD HL,BACK1 (LD (URTN),HL (CALL GETU (JP CALLIO  SYSRD LD H HL,HL (LD BC,1AH ; Q,R := LSN div,mod 26 (CALL DIVPOS ; HL=R, DE=Q (PUSH HL (PUSH DE (L,00H (EX (SP),HL (LD A,INBIT (JP SYSIO  UWRITE LD A,OUTBIT (JP UIO  UREAD LD A,INBIT  ULD A,E (INC A (LD (DTRK),A (LD C,A (LD L,1EH ;BIOS/SETTRK (CALL BIOS (POP DE (LD I/O  UASY .WORD 0000H ;async boolean  ASNCBIT .EQU 01H ;applies to the async param  DRCTBIT .EQU 02H ;aIO LD HL,BACK1  SYSIO LD (UREQ),A (LD (URTN),HL (POP HL ; junk async param pplies to the async param  URTN .WORD 0000H ;   IOC ; IO check - bomb for user IO error if IORSLT <> 0 (LD (LD (UASY),HL (POP HL ; put others in param space (LD (UBLK),HL (POP HL (LD (ULEN),HL (POP HL,(IORSLT) (LD A,L (OR H (JP Z,BACK (JP UIOERR   IOR ; IO result - return IORSLT (LD HL,(I HL (LD (UBUF),HL (CALL GETU ; get unit number, form table adrs CALLIO INC HL ; get driver adrs from tablORSLT) (PUSH HL (RETURN    GETU ;get logical unit number and validate (XOR A ;assume operation is going e (INC HL (LD E,(HL) (INC HL (LD D,(HL) (LD HL,(ULEN) ; check for no bytes (LD A,H (OR to be valid (LD (IORSLT),A (POP HL ; get LUN from under the retn adrs (EX (SP),HL (LD A,L ;0 < L L (JP Z,IOXIT (EX DE,HL (JP (HL) ; GO FOR IT || IOXIT LD HL,(URTN) (JP (HL) ; Be see'nUN <= MAXU ... (AND A (JP Z,BLUN (CP MAXU+1 (JP NC,BLUN (LD (UNIT),A ;save for driver  you. ;********* DISK DRIVER FOR CPM *************************** BYPS .EQU 80H ;Bytes per sector DSCT0 .BYTE 0(ADD A,A ;times UNITBL elt size (ADD A,A (LD H,00H (LD L,A (LD DE,UNITBL ;index into UNITBL (AD0H DSCT .BYTE 00H DTRK .BYTE 00H DR0DRVR LD C,00H ;select drive (JP DSK0 DR1DRVR LD C,01H DSK0 LD HL,DE (LD (UPTR),HL ; save this also (LD A,(UREQ) ; validate request (AND (HL) (RET NZ ; and reD L,1BH ;BIOS/SELDSK (CALL BIOS (LD A,(UREQ) (AND CLRBIT (JP Z,$10 (LD L,18H ;BIOS/HOME (turn  BDIR LD A,03H ; bad I/O direction (JP BOMIT  BLUN LD A,02H ; bad unit number  BOMIT LD CALL BIOS (JP XDSK $10 ;Start initializing for the loop (LD HL,(ULEN) ;HI(ULEN) = # sectors to do  (IORSLT),A (POP HL (JP BACK1   UBUSY LD HL,00H ; assume false ... (EX (SP),HL ; and insert under LU(ADD HL,HL (INC H ;adjust for predecr in loop (LD (ULEN),HL (LD HL,(UBUF) (LD C,L (LDN (PUSH HL  UWAIT LD A,INBIT|OUTBIT (LD (UREQ),A (CALL GETU (JP BACK1 ;Boy that was easy.  UCLEAR B,H (LD L,24H ;BIOS/SETDMA (CALL BIOS (LD HL,(UBLK) ;LSN := 4*BLOCK (ADD HL,HL (ADD   B,H (LD L,24H ;BIOS/SETDMA (CALL BIOS (JP $80 $60 LD A,(UREQ) ;what happened to the fraction (LD C,A (LD L,21H ;BIOS/SETSEC (CALL BIOS (JP $50 ;--------KEEP ON TRUCKIN'. XDSK JP IOXIT ? (AND OUTBIT (JP NZ,XDSK ;lots to do if read though (LD HL,(UBUF) (LD DE,-BYPS (ADD HL,DE  ;*** ALL PURPOSE BIOS LINKER *** BIOS LD A,(0002H) ; do YOU believe this will work (LD H,A (JP (HL) (EX DE,HL (LD HL,0000H (ADD HL,SP (LD A,(ULEN) (RRA (LD B,A $70 LD A,(HL) (LD (DE),A ;************* DRIVER FOR ALL CHARACTER ORIENTED DEVICES ON CPM ************** CLAST .BYTE 0 CIVECT .BYTE 0 COVECT  (INC HL (INC DE (DEC B (JP NZ,$70 (LD HL,BYPS (ADD HL,SP (LD SP,HL (JP XDSK .BYTE 0 CTABLE .BYTE 00H,00H (.BYTE 09H,0CH,09H,0CH ;BIOS/CONIN,CONOUT (.BYTE 00H,00H,00H,00H,00H,0H (.BYTE$80 LD A,(UREQ) ;now finally do the I/O request (AND OUTBIT (JP Z,$90 (LD L,2AH ;BIO 00H,0FH,15H,12H ;BIOS/LIST,READER,PUNCH CHDRVR LD A,(UREQ) (AND CLRBIT (JP Z,CH01 (; clear out c A,06H ; S0 := 6*Q (LD HL,0000H $20 ADD HL,DE (DEC A (JP NZ,$20 (LD BC,1AH S/WRITE (JP $100 $90 LD L,27H ;BIOS/READ $100 CALL BIOS (AND A ;test for I/O e ; S0 := S0 mod 26 +1+(R>12) (CALL DIVPOS (INC HL (POP DE ;get R (LD A,E (CP 0CH+1 (Jrrors from CPM (JP Z,$110 (LD A,04H (LD (IORSLT),A $110 LD HL,(UBUF) (LD DE,BYPS (ADD HL,DEP C,$30 (INC HL $30 LD A,L (LD (DSCT0),A (ADD A,E ; S := S0+2*R-1 mod 26 +1 (ADD  (LD (UBUF),HL (LD C,L (LD B,H (LD L,24H ;BIOS/SETDMA (CALL BIOS (LD A,(DSCT)  A,E (DEC A $40 SUB 1AH (JP NC,$40 (ADD A,1AH+1 (LD (DSCT),A (LD C,A  ; S := S+1 mod 26 +1 (ADD A,02H (CP 1BH (JP C,$120 (SUB 1AH $120 LD HL,DSCT0 ; if S = S0 t(LD L,21H ;BIOS/SETSEC (CALL BIOS $50 ;--------LOOP ON SECTORS, Gross Control, Kludge. hen (CP (HL) (JP NZ,$150 (INC A ; S := S+1 (RRCA ; if odd(s) then (RLA ((LD HL,(ULEN) (DEC H (LD (ULEN),HL (JP NZ,$80 (LD A,L (RRCA (JP C,$60 (AND A (JP JP NC,$140 (ADD A,04H ; S := S+4 mod 26 (CP 1AH+1 (JP C,$130 (SUB 1AH $130 PUSH  Z,XDSK (INC H (INC L (LD (ULEN),HL (LD A,(UREQ) ;do whole sector anyway on output (AND OUTBIT AF ; T := T+1 (LD A,(DTRK) (INC A (LD (DTRK),A (LD C,A  (JP NZ,$80 (LD HL,-BYPS ;fractional read, oh shoot. (ADD HL,SP (LD SP,HL (LD C,L (LD (LD L,1EH ;BIOS/SETTRK (CALL BIOS (POP AF $140 LD (DSCT0),A ; S0 := S $150 LD (DSCT),A (JP NZ,$30 (CALL ECHO (LD A,(UASY) (AND DRCTBIT (JP NZ,$30 LD A,(SYEOF) ; if eofO^ char, zero out rest of request buffer (CP (HL) (JP NZ,$30  INC DE  $25 LD (HL),0 (DEC D:E (INC HL  LD A,E (OR D (JP NZ,$25  JP CHX  $30 INC HL (JP $10 CHX  JP IOXIT  ECHO ;char in the Creg is interpreted and output (LD A,(UASY) (AND DRCTBIT (JP Z,$10 (CALL CBOS (JP $40 $10 LD A,(CLAST) (CP 10H ;DLE- blank expansion (JP NZ,$30 (LD A,C (SUB 20H (LD (CLAST),A $20 LD A,(CLAST) (DEC A (JP M,$40 (LD (CLAST),A (LD C,20H (CALL CBOS (JP $20 $30 LD A,C ;output done here (LD (CLAST),A (CP 10H (JP Z,$40 (CALL CBOS (LD A,(CLAST) (CP 0DH ;CR- requires an LF (JP NZ,$40 (LD A,0AH (LD (CLAST),A (LD onsole input stream (XOR A (LD (CLAST),A (CALL CHCLR (JP CHX CHDRVR1 LD A,(UREQ) (AND CLRBIT (JP C,A (CALL CBOS $40 RET CHCLR LD L,06H ;BIOS/CONST (CALL BIOS (AND A (RET Z (LD L,09H  NZ,CHX CH01 CALL SETVECT ; set up BIOS in and out vectors (LD HL,(ULEN) ;prepare for loop  ;BIOS/CONIN (CALL BIOS (JP CHCLR SETVECT LD HL,(UNIT) ;compute BIOS vector (LD H,00H (ADD HL,(EX DE,HL (LD HL,(UBUF) $10 LD A,E ;---LOOP--- length zero yet ? (OR D (JP Z,CHX (DEC HL (LD DE,CTABLE (ADD HL,DE (LD A,(HL) (LD (CIVECT),A (INC HL (LD A,(HL) (LD (COVECT),A  DE (LD A,(UREQ) ;which direction (AND OUTBIT (JP Z,$20 (LD C,(HL) ;do output (CALL (RET ;routines called by the character driver. CBIS LD A,(CIVECT) (JP CBIS1 CBOS LD A,(COVECT) CBIS1 P ECHO (JP $30 $20 CALL CBIS ;do input (LD C,A (LD (HL),A (LD A,(UNIT) (CP 01H USH HL (PUSH DE (LD L,A (CALL BIOS (POP DE (POP HL (RET  ; end of file CPMIO ( (   .EQU 0 ; address of interpreter variables (Not ; yet meaningful Z80 .EQU OFF ; CPU type and particular model CPM .EQU ON DDT .EQU OFF  TEK .EQU OFF  CML .EO^QU OFF NMS .EQU OFF  ; Listing controls LSTINT .EQU ON ; Interpreter main root section  LSTVARS .EQU OFF ; Variable loading, storing, moving, indexing LSTARIT .EQU OFF ; Simple top-of-stack arithmetic and comparisons LSTSET .EQU OFF ; Set arithmetic and comparisons LSTFP .EQU OFF ; Basic floating point stuff LSTFPT .EQU  OFF ; Transendental floating point routines LSTPROC .EQU OFF ; Procedure calling, returning, segment loading,  ; unloading, relocation, and jumps LSTSTP .EQU OFF ; Standard procedure caller and misc. standard procs. LSTIO .EQU OFF ; Unit io and BIOS callers LSTBOOT .EQU OFF ; Pascal-level bootstrap ( (.INCLUDE INTERP.TEXT (.INCLUDE VARS.TEXT (.INCLUDE ARITH.TEXT (.INCLUDE SET1.TEXT (.INCLUDE SET2.TEXT (.INCLUDE FPL.TEXT (.INCLUDE FPI.TEXT (.INCLUDE NOFPT.TEXT (.INCLUDE PROC1.TEXT (.INCLUDE (.IF ~LSTFPT ).NOLIST (.ELSE ).LIST (.ENDC (  ; Copyright (c) 1978 by the Regents of the University of Califormia  ; S PROC2.TEXT (.INCLUDE STP.TEXT (.INCLUDE CPMIO.TEXT (.INCLUDE BOOT.TEXT ( (.END  an Diego   ; Beginning of file NOFPT   SIN ; sin standard procedure  COS ; cos standard procedure  EXP ; ex .PROC INTERP   OFF .EQU 0 ; definitions for conditionals ON .EQU ~OFF  ROM .EQU  100H ; address definition for interpreter code MAXADR .EQU 0D7FEH ; highest possible memory byte  RAM   BC *LD (%1 + 2),HL *EX DE,HL *LD (%1),HL ) .IF "%2" <> "JUNK" +PUSH DE +PUSH HL *.ENDC ).ENDC (.ENDM  p standard procedure  ATAN ; atan standard procedure  SQT ; sqrt standard procedure  LOG ; log base 10  LN ; log base e  JP NOTIMP (   ; End of file NOFPT   (.IF ~LSTFP ( .NOLIST .ELSE ).LIST (.ENDC ( ;Copyright (c) 1978 ; by the Regents of the University of California, San Diego  ; Beginning of file FPI   ; ************ Macros...   .MACRO FPMPUSH ; push the fp # residing at addr given )LD HL,(%1 + 2) )PUSH HL )LD HL,(%1) )PUSH HL (.ENDM ( (.MACRO FPMPOP ; pop the fp tos into addr given )POP HL )LD (%1),HL )POP HL )LD (%1 + 2),HL (.ENDM  (.MACRO FPMSAVE ; save to fp tos into addr given )POP DE ; leaves fp on tos, and in LHED )POP HL )LD (%1 + 2),HL )EX DO^E,HL )LD (%1),HL )PUSH DE )PUSH HL (.ENDM ( ); adjust stack which contains a ret addr ); and one fp. leave fp in: LHED. If addr ); specified put arg into it. If "junk" ); specified (only legal if addr given) ); then don't leave fp on stack. ).MACRO FPMADJ ; Adjust stack, which contains a ret. addr. ).IF "%1" = "" ; and one fp. Leave fp in LHED. If addr. *POP BC ; passed to macro stick fp in it, too. If *POP HL ; "junk" passed (only legal is addr. is *POP DE ; given) then don't leave fp as tos, but *PUSH BC ; toss it away. *PUSH DE *PUSH HL ).ELSE ) POP BC *POP DE *POP HL *PUSH    FPFRND ; round(x: real): integer (FPMADJ (LD A,H ; get sign info, so know to add 0.5 (AND 80H ; power of ten table...typed in by hand. (; 1E0..1E9 (.BYTE 81H, 00H, 00H, 00H, 84H, 20H, 00H, 00H (.BYTE 87H ; or -0.5 (LD H,A ; construct high mantissa (LD L,80H ; set up exp (LD DE,0000H ; , 48H, 00H, 00H, 8AH, 7AH, 00H, 00H (.BYTE 8EH, 1CH, 40H, 00H, 91H, 43H, 50H, 00H (.BYTE 94H, 74H, set up low order mantissa (PUSH DE (PUSH HL (CALL FPFADD (CALL FPFFIX  24H, 00H, 98H, 18H, 96H, 80H (.BYTE 9BH, 3EH, 0BCH, 20H, 9EH, 6EH, 6BH, 28H (; 1E10..1E19 (.BYTE 0A2H, POP DE ; can't hang around here too long (POP HL (PUSH DE (JP (HL) ( FPFINV ; computes 15H, 02H, 0F9H, 0A5H, 3AH, 43H, 0B7H (.BYTE 0A8H, 68H, 0D4H, 0A5H, 0ACH, 11H, 84H, 0E7H (.BYTE 0AFH, 35H, 0 (.MACRO FPMDUP ; duplicate tos ).IF "%1" = "LHED" *PUSH DE *PUSH HL ).ENDC ).IF "%1" = "EDCB" *PUSH DE  1/x (POP HL ; ret addr. (POP DE (POP BC (PUSH HL (LD HL,0 ; low mantissa of 1.*PUSH HL ).ENDC ).IF "%1" = "" *POP HL *POP DE *PUSH DE *PUSH HL *PUSH DE *PUSH HL ).ENDC (.ENDM ( (.MACRO0  PUSH HL (LD HL,0081H ; high mantissa, sign, and exp (PUSH HL (PUSH BC (PUSH DE (CALL  FPMFRET ; the complement to FPMADJ. leaves )POP DE ; function result on stack and in EDCB, )POP  FPFDIV (FPMFRET ; eyb-eyb (  FPFPOT ; pwroften(i:integer): real (; returns 10 ^ i, 0 <= i <= 38 (POP BC ; and returns from function )POP HL )PUSH BC )PUSH DE )JP (HL) (.ENDM ( (  DE ; ret addr (POP HL ; HL := power (PUSH DE (LD E,L ; save a sec (LD  ;***** Floating point simple callable routines   FPFNEG ; -x (POP HL ; ret addr  POP DE (P D,H (LD BC,-39 ; check validity of power (ADD HL,BC (JP C,$99 (EX DE,HL ; multiply power by 4 (ADDOP BC (LD A,D ; get sign (XOR 80H ; flip it (LD D,A (PUSH BC (PUSH DE (JP  HL,HL (ADD HL,HL (LD DE,TENTBL+3 ; point HL at highest byte of right number (ADD HL,DE (LD B,(HL) (HL) ; and get out of here (very negative vibes) (  FPFABS ; abs(x) (POP HL ; ret addr (PO ; and put fp in EDCB (DEC HL (LD C,(HL) (DEC HL (LD D,(HL) (DEC HL (LD E,(HL) P DE (POP BC (LD A,D (AND 7FH ; clear sign (LD D,A (PUSH BC (PUSH DE (JP (HL(POP HL ; get out ret addr back (PUSH BC (PUSH DE (JP (HL) $99 POP HL ;Mexi) ; we are absolutely done (  FPFSQR ; sqr(x: real): real (FPMADJ (FPMDUP LHED (CALL FPFMUL (FPMFRET (  can (LD DE,0000 (PUSH DE (PUSH DE (LD A,1 (LD (FPERROR),A JP (HL)  TENTBL  16H, 76H, 09CH   ; ********* Low level support routines used by the fp instructions   FPLBEG ; used by instructions be FPLCBEG ; csp fp set...doesn't do a savipc (CALL FPFFIX (JP FPLCHK RND ; round real (CALL FPLCBEG fore routine called... (SAVIPC ; save the ipc...  FPLCBEG ; (entry point for CSP routines) (CLRA  CALL FPFRND (JP FPLCHK   POT CALL FPLCBEG (CALL FPFPOT (JP FPLCHK   REALC ; compare t ; ...and clear error flag (LD (FPERROR),A (RET (  FPLCHK ; exit point for all fp instructions and CSP's (LD he real numbers on the top of stack (POP HL (LD (RETADR),HL (POP BC (POP HL (POP DE (PUSH DE (; C A,(FPERROR) (TSTA (JP Z,BACK1 (JP FPIERR (   ;********** Simple fp instructions and standard procedures ompare signs (LD A,D (AND 80H (LD D,A (LD A,B (AND 80H (CP D (JP NZ,$30 (TSTA (JP   FLT ; float the top of stack (CALL FPLBEG ; don't care about FPERROR, but need to savipc (CALL FPFFLOA Z,$10 (; comparing negative numbers, so switch before comparing (LD E,C (LD D,B (POP BC (EX (SP),HL T (JP BACK1 FLO ; float the integer under the real on top of stack REAL1 .EQU WORD1 REAL2 .EQU WORD2 (CALL(JP $20 $10 POP DE $20 ; check exps (LD A,E (CP C (JP NZ,$40 (; high mantissa bytes (LD  FPLBEG (POP HL (LD (REAL1),HL (POP HL (LD (REAL2),HL (CALL FPFFLOAT (LD HL,(REAL2) (PUSH  A,D (CP B (JP NZ,$40 (; low two bytes (POP DE (LD A,E (CP L (JP NZ,$50 (LD A,D E6H, 21H, 0B2H, 63H, 5FH, 0A9H (.BYTE 0B6H, 0EH, 1BH, 0CAH, 0B9H, 31H, 0A2H, 0BDH (.BYTE 0BCH, 5EH, 0BH, 6C HL (LD HL,(REAL1) (PUSH HL (JP BACK1 ABR ; Real absolute value (CALL FPLBEG (CALL FPFABS  H, 0C0H, 0AH, 0C7H, 24H (; 1E20..1E29 (.BYTE 0C3H, 2DH, 78H, 0EDH, 0C6H, 58H, 0D7H, 28H  JP BACK1  ADR ; Add reals (CALL FPLBEG ; saves ipc and sets FPERROR to false (CALL FPFADD (JP (.BYTE 0CAH, 07H, 86H, 79H, 0CDH, 29H, 68H, 17H (.BYTE 0D0H, 53H, 0C2H, 1DH, 0D4H, 04H, 59H, 52H (.BYTE  FPLCHK ; checks FPERROR and bombs if necessary SBR ; Subtract reals (CALL FPLBEG (CALL FPFSUB (JP F 0D7H, 25H, 6FH, 0A7H, 0DAH, 4EH, 0CBH, 91H (.BYTE 0DEH, 01H, 3FH, 3BH, 0E1H, 21H, 8FH, 0AH (; 1E30..1E38 PLCHK MPR ; Multiply reals CALL FPLBEG (CALL FPFMUL (JP FPLCHK  SQR ; Square reals (CALL FPL(.BYTE 0E4H, 49H, 0F2H, 0CDH, 0E7H, 7CH, 6FH, 80H (.BYTE 0EBH, 1DH, 0C5H, 0B0H, 0EEH, 45H, 37H, 1CH (.BYTE BEG (CALL FPFSQR (JP FPLCHK DVR ; Divide reals (CALL FPLBEG (CALL FPFDIV (JP FPLCHK  0F1H, 76H, 84H, 0E3H, 0F5H, 1AH, 13H, 0EH (.BYTE 0F8H, 40H, 97H, 0D2H, 0FBH, 70H, 0BDH, 0C7H (.BYTE 0FFH, NGR ; Negate real (CALL FPLBEG (CALL FPFNEG (JP BACK1 TNC ; truncate real and convert to integer (CALL   .IF ~LSTARIT ).NOLIST (.ELSE ).LIST (.ENDC  ;Copyright (c) 1978  ; by the Regents of the University of California, San Diego   ; start of file ARITH    ;*************** TOP OF STACK ARITHMETIC ****************;    ;***** Logical   LAND ; Logical AND (POP DE (POP HL (LD A,E (AND L (LD L,A (LD A,D (AND H (LD  H,A (PUSH HL (JP BACK   LOR ; Logical OR (POP HL (POP DE (LD A,L (OR E (LD L,A (LD A,H (OR D (LD H,A (PUSH HL (JP BACK   NOT ; Logical NOT (POP HL (LD A,L (CPLO^ (LD L,A (LD A,H (CPL (LD H,A (PUSH HL (JP BACK    ;***** Integer   ABI ; Integer absol:ute value (POP HL (LD A,H (TSTA (JP P,$10 (CLRA (SUB L (LD L,A (LD A,00H (SBC A,H (AND 7FH ; in case of -32768 (LD H,A  $10 PUSH HL (JP BACK   ADI ; Add integers (POP DE (POP HL (ADD HL,DE (PUSH HL (JP BACK   DVI ; Divide integers (SAVIPC (POP BC  ; divisor (POP DE ; dividend (CALL DIVD (PUSH DE ; quotient (JP BACK1   (CP H (JP $50 $30 POP HL $40 POP HL $50 LD HL,(RETADR) (JP (HL) ; End of file FPI  (  MODI ; Remainder of integer division (SAVIPC (POP BC (POP DE (CALL DIVD (PUSH HL (JP BACK1   MPI  $30  $20 RR E  $30 JP NC,$40 )ADD HL,BC  $40 SLA C )RL B )JP $10  ; Integer multiply (SAVIPC (POP DE (POP BC (CALL MULT (PUSH HL (JP BACK1   SQI ; Square inte $50 JP NC,$60 )ADD HL,BC  $60 RET (.ENDC  (.IF ~Z80 )EX DE,HL ; make HL multiplicand )Lgers (SAVIPC (POP DE (LD C,E (LD B,D (CALL MULT (PUSH HL (JP BACK1   NGI ; Negate integerD DE,0000H ; and DE product )LD A,C ; A := lower 8 bits of multiplier  $10 LD C,B  (POP HL (CLRA (SUB L (LD L,A (LD A,00H (SBC A,H (LD H,A (PUSH HL (JP BACK   SBI  ; set up next 8 bits for next time around )LD B,08H ; B := shift count  $20 RRA )JP NC,$30 )EX  ; Subtract integers (POP DE (POP HL (SUBHLDE (PUSH HL (JP BACK #  CHK ; Check number against limi DE,HL ; add in the partial product )ADD HL,DE )EX DE,HL  $30 ADD HL,HL ; shift multiplicts (range-checking) (POP HL ; max (POP DE ; min (EX (SP),HL and left )DEC B )JP NZ,$20 )LD A,C ; get high order byte of multiplier )TSTA )JP NZ,$10 )EX (; HL = num, DE = min, (SP) = max (LD A,D (XOR H (JP M,$10 (LD A,L (SUB E (LD A,H (SBC  DE,HL ; put the product in HL to meet specs )RET (.ENDC #  DIVPOS ; Divide two positive integers (; Entry BC = A,D (JP P,$20 (JP $98  $10 AND D (JP P,$98  $20 POP DE ; max (PUSH Hdivisor, HL = dividend (; Exit BC = divisor, HL = remainder (; DE = quotient  SHFTCT .EQU BYTE1 (.IF Z80 )LD L ; put num back (; HL = num, DE = max (LD A,D (XOR H (JP M,$30 (LD A,E ; is m DE,0000H )LD A,01H  $10 INC A )SLA C )RL B )JP P,$10  $20 SCF )RL E )RL D ax >= num ? (SUB L (LD A,D (SBC A,H (JP P,BACK (JP $99  $30 AND H (JP M,BACK (JP )SBC HL,BC )JP NC,$30 )ADD HL,BC )DEC DE  $30 SRL B )RR C )DEC A )JP NZ,$20 )RL C  $99  $98 EX (SP),HL ; leave num on stack to help person debug  $99 SAVIPC (JP INVNDX   ;)RL B )RET (.ENDC  (.IF ~Z80 ); make HL divisor, DE dividend while shifting divisor left )EX DE,HL )LD H,B ***************TEMPORARY EXPEDIENT   MULT ; Two's complement integer multiply routine (; Entry BC = multiplicand, DE = m)LD L,C )CLRA  $10 INC A ; A is shift count )ADD HL,HL )JP NC,$10 ); for main loop, BC = dultiplier (; Exit HL = product (.IF Z80 )LD HL,0000H  $10 SRL D )JP NZ,$20 )RR E )JP Z,$50 )JPivisor, DE = what's left of dividend, ); HL = quotient so far )LD C,L )LD B,H )LD HL,0000H  $20 LD ( IV 3 = 2, 7 MOD 3 = 1 (; 6 DIV 3 = 2, 6 MOD 3 = 0 (RET  $40 ; divide negative by positive (LD A,E ; dieturn_address (PUSH DE ; leave dividend on stack... (JP DIVZER ; ...and bomb.   ;***** Word cvidend := -dividend-1 (CPL (LD L,A (LD A,D (CPL (LD H,A (CALL DIVPOS omparisons. pop b; pop a; push (a b)   EQUI ; Compare for = (POP DE (POP HL (LD A,L (SUB E (; now set realquotient := -quotient-1 (; realremainder := divisor-remainder-1 (; -7 DIV 3 = -3, -7 MOD 3 = 2 (; -6 (JP NZ,PSHFLS (LD A,H (SBC A,D (JP Z,PSHTRU  PSHFLS LD HL,0000H (PUSH HL (JP BACK   GESHFTCT),A )LD A,B ; shift divisor right )RRA )LD B,A )LD A,C )RRA )LD C,A )ADD HL,HL DIV 3 = -2, -6 MOD 3 = 0 (LD A,E (CPL (LD E,A (LD A,D (CPL (LD D,A (; now for the remainder (SCF (L ; shift quotient left )LD A,E ; dividend := dividend-divisor )SUB C )LD E,A )LD A,D )SBC D A,C (SBC A,L (LD L,A (LD A,B (SBC A,H (LD H,A (RET  $50 ; divide by negative. make div A,B )LD D,A )JP NC,$30 )EX DE,HL ; shit. restore dividend )ADD HL,BC )EX DE,HL )CLRCF isor positive. (CLRA (SUB C (LD C,A (LD A,00H (SBC A,B (LD B,A (LD A,D ; check di ; for shifting divisor right )JP $40  $30 INC HL ; subtract was okay vidend sign (TSTA (JP M,$80 (JP NZ,$60 (OR E (JP Z,$80 ; makes things cleanest, believe it  $40 LD A,(SHFTCT) )DEC A )JP NZ,$20 )EX DE,HL ; satisfy exit conditions specified above )RETor not  $60 EX DE,HL ; divide positive by negative (DEC HL (CALL DIVPOS (; now set realquotient := (.ENDC   DIVD ; Two's complement divide - mathematically correct even! (; NOTE WELL. Does not return values as specifie -quotient-1, (; realremainder := remainder+1-divisor (; 7 DIV -3 = -3, 7 MOD -3 = -2 (; 6 DIV -3 = -2, 6 MOD -3 = 0 d in J & W. (; Entry BC = divisor, DE = dividend (; Exit HL = remainder, DE = quotient (CLRA ; make sure (LD A,E (CPL (LD E,A (LD A,D (CPL (LD D,A  $70 SUBHLBC (INC HL (RET divisor isn't 0 or -32768 (OR C (JP NZ,$10 (OR B (JP Z,$99 (XOR 80H (JP Z,$99  $10  $80 ; divide negative or zero by negative (CLRA ; make dividend positive (SUB E (LD L,A (L LD A,B ; check divisor sign (TSTA (JP M,$50  $20 OR D ; check dividend sign (JD A,00H (SBC A,D (LD H,A (CALL DIVPOS (; now set realremainder := -realremainder (; -7 DIV -3 = 2, -7 MOD P M,$40  $30 EX DE,HL ; divide positive by positive (CALL DIVPOS (; no adjustment necessary. 7 D-3 = -1 (CLRA (SUB L (LD L,A (LD A,00H (SBC A,H (LD H,A (RET  $99 POP HL ; r mpiler restricts you  ; to = and <> on certain types.  ; The opcode tells what relation is being tested  ; the next byte  Lexicographic string compare (; Compare up to min(length(a), length(b)). if still equal, (; compare sizes  LENA .EQUindicates the type of the things being compared  ; if arrays are being compared, the next GBDE is the array size  ; Tests al BYTE1 (POP HL (POP DE (EX (SP),HL (EX DE,HL ; lowed...  ; Boolean: all relations. stuff is on the stack.  ; Real: all relations. stuff is on the stack. HL = ^b, DE = ^a, (SP) = return_address (; See if either HL or DE (but not both at the same time) is (; really a single char ; Set: =, <>, <= (subset), >= (superset). stuff is on the stack.  ; String: all relations. pointers to stuff are on s...handle as in SAS (LD A,H (TSTA (JP NZ,$03 ; HL is a disguised character ! (LD A,L (LD (LTSTRtack.  ; Arrays and records: =, <>. pointers to stuff on stack  ;  ; after CSETUP flags are result of a-b.   CEQU CANG+1),A (LD HL,LTSTRNG (JP $06  $03 LD A,D  TSTA (JP NZ,$06 (; DE is a char (LD A,E LL CSETUP (JP Z,PSHTRU1  PSHFLS1 LD HL,0000H (PUSH HL (JP BACK1   CNEQ CALL CSETUP (JP Z,PSHFLS1  PSHTRU1(LD (LTSTRNG+1),A (LD DE,LTSTRNG  $06 LD C,(HL) ; C := length(b) QI ; Compare for >= (POP DE (POP HL  GEQ0 LD A,D (XOR H (JP M,GEQ1 (LD A,L (SUB E ( LD HL,0001H (PUSH HL (JP BACK1   CGTR CALL CSETUP (JP C,PSHFLS1 (JP NZ,PSHTRU1 (JP PSHFLS1  LD A,H (SBC A,D (JP P,PSHTRU (JP PSHFLS  GEQ1 AND H (JP P,PSHTRU (JP PSHFLS    CLEQ CALL CSETUP (JP C,PSHTRU1 (JP NZ,PSHFLS1 (JP PSHTRU1   CLSS CALL CSETUP (JP C,PSH GTRI ; Compare for > (POP DE (POP HL  GTR0 LD A,D (XOR H (JP M,GEQ1 (LD A,E (SUB LTRU1 (JP PSHFLS1   CGEQ CALL CSETUP (JP C,PSHFLS1 (JP PSHTRU1 "  ; Find out the type of things bein (LD A,D (SBC A,H (JP C,PSHTRU (JP PSHFLS   NEQI ; Compare for <> (POP DE (POP HL (LD g compared, jump to  ; proper routine which follows the compare stuff and set flags.  CSETUP LD A,(BC) ; A := A,L (SUB E (JP NZ, PSHTRU (LD A,H (SBC A,D (JP Z,PSHFLS  PSHTRU LD HL,0001H (PUSH HL  type of stuff to compare (INC BC (SAVIPC (LD E,A ; branch off to proper routine (LD D,00H (JP BACK   LEQI ; Compare for <= (POP HL (POP DE (JP GEQ0   LESI ; Compare for < (POP HL (LD HL,CMPTBL (ADD HL,DE (LD E,(HL) (INC HL (LD D,(HL) (EX DE,HL (JP (HL)   CMPTBL .(POP DE (JP GTR0    ;***** Comparisons of complex things "  ; Beware that many comparisons work only because coEQU $-2 (.WORD REALC (.WORD STRGC (.WORD BOOLC (.WORD POWRC (.WORD BYTEC (.WORD WORDC "  STRGC ;  GBDE ; DE := number of bytes to compare (SAVIPC (LD C,E (LD B,D (JP GPTRS   WORDC ; Word aTH   rray or multiple word record compare (CALL GBDE ; DE := number of words to compare (SAVIPC (EX DE,HL  ; DE := # bytes to compare (ADD HL,HL (LD C,L (LD B,H  GPTRS ; Set DE := ^a, HL := ^b (POP HL (POP DE (EX (SP),HL (EX DE,HL (JP SWEQ "  ; Scan while equal.  ; DE = ^b, HL = ^a, BC = # bytes to compare  ; Scans until unequal comparison or compared all the bytes.  ; Flags left set by last comparison " (.IF Z80  SWEQ1 INC DE  SWEQ LD A,(DE) )CPI )JP PO,$20 ; if Parity Odd, BC = 0 and things @; are equal throughout )JP Z,SWEQ1 ; if Zero, both bytes were equal  $20 DEC HL  ; set flags as result of last compare )CP (HL) )RET (.ENDC " (.IF ~Z80  SWEQ CALL NEGBC ; BO^C := -BC  $10 LD A,(DE) )CP (HL) )RET NZ )INC HL )INC DE )INC C ; loop control )JP(LD A,(DE) ; B := (LENA) := length(a) (LD (LENA),A (LD B,A (CP C ; B := min(lengt NZ,$10 )INC B )JP NZ,$10 )CLRA ; equal, so set flags accordingly )RET (.ENDC   BOOLC ; Bh(a), length(b)) (JP C,$10 (LD B,C (LD A,C  $10 TSTA ; check for min = 0 (JP oolean compare. Only look at bit 0. (POP HL ; HL := a, DE := b (POP DE (EX (SP),HL (LD A,E Z,$30  $20 INC HL (INC DE (LD A,(DE) (CP (HL) (RET NZ (DJNZM $20  $30 ; Strings are ; get low bit of b (AND 01H (LD E,A (LD A,L ; same for a (AND 01H (CP E  equal up to length of smallest, so compare sizes (LD A,(LENA) (CP C (RET   BYTEC ; Byte array compare (CALL (RET   "  NEGBC CLRA (SUB C (LD C,A (LD A,00H (SBC A,B (LD B,A (RET   ; End-of-File ARI  ;***** Local vars   SLDL ; Short load local word (ADD A,52H ; get displacement from opcode (LD E,A  ; DE := displacement (LD D,00H (LD HL,(MPD0) (ADD HL,DE ; compute address of var (LD  E,(HL) ; load the data (INC HL (LD D,(HL) (PUSH DE (JP BACK   LLA ; Load local address (CALL GBDE (LD HL,(MPD0) (ADD HL,DE (ADD HL,DE (PUSH HL (JP BACK "  LDL ; Load local word (CALL GBDE (LD HL,(MPD0) (ADD HL,DE (ADD HL,DE (LD E,(HL) (INC HL (LD D,(HL) (PUSH DE (JP (.IF ~LSTVARS ).NOLIST (.ELSE ).LIST (.ENDC  ;Copyright (c) 1978  ; by the Regents of the University of California, San BACK "  STL ; Store local word (CALL GBDE (LD HL,(MPD0) (ADD HL,DE (ADD HL,DE (POP DE (LD  Diego   ; start of file VARS    ;********** LOADING, STORING, INDEXING, AND MOVING **********;    ;****The rest of (HL),E (INC HL (LD (HL),D (JP BACK "   ;***** Global vars   SLDO ; Short load global word - just  the load constant word instructions   LDCI ; Load constant word (LD A,(BC) ; low byte (LD L,A (INC like SLDL (ADD A,32H (LD E,A (LD D,00H (LD HL,(BASED0) (ADD HL,DE (LD E,(HL) (INC HL  BC (LD A,(BC) ; high byte (LD H,A (INC BC (PUSH HL (JP BACK   LDCN ; Load constant(LD D,(HL) (PUSH DE (JP BACK   LAO ; Load global address (CALL GBDE (LD HL,(BASED0) (ADD H nil pointer (LD HL,NIL (PUSH HL (JP BACK    GBDE ; get a big (possibly two byte) constant from code intL,DE (ADD HL,DE (PUSH HL (JP BACK "  LDO ; Load global word (CALL GBDE (LD HL,(BASED0) (ADD o DE (LD A,(BC) (INC BC (LD E,A ; assume 1-byte...by far the most common case (LD D,00H (TSTHL,DE (ADD HL,DE (LD E,(HL) (INC HL (LD D,(HL) (PUSH DE (JP BACK #  SRO ; Store global worA (RET P ; if bit 7 is zero, assumtion was correct (AND 7FH ; clear bit 7 (LD D,A d (CALL GBDE (LD HL,(BASED0) (ADD HL,DE (ADD HL,DE (POP DE (LD (HL),E (INC HL (LD (HL) ; this is the high order byte (LD A,(BC) ; get lower (INC BC (LD E,A (RET    index and load word (POP HL ; get array base address (ADD A,10H ; calculate index from opcode ro) )LD C,A )LD A,00H )SBC A,D )LD B,A )POP HL ; HL := ^source )POP DE ; DE(LD E,A (LD D,00H (ADD HL,DE ; calculate address (LD E,(HL) ; and load the value (INC := ^dest  $10 LD A,(HL) ; move a word )INC HL )LD (DE),A )INC DE )LD A,(HL) )INC HL ),D (JP BACK  #  ;***** Intermediate vars   GETIA ; Get intermediate address into HL. Routine used by LDA, LOD, ST HL (LD D,(HL) (PUSH DE (JP BACK   STIND ; Static index and load word (POP HL ; base R (LD A,(BC) ; # of lex levels to chain (always > 1) (INC BC (LD HL,(MP)  $10 LD E,(HL) address (CALL GBDE ; get index from code (ADD HL,DE (ADD HL,DE (LD E,(HL) ; load the wor ; go up static links till reach proper MSCW (INC HL (LD D,(HL) (EX DE,HL (DEC A (JP NZ,$10 (CAd (INC HL (LD D,(HL) (PUSH DE ; and stick it on the stack (JP BACK "  IXA ; Index array LL GBDE ; get displacement... (ADD HL,DE ; ...and calculate address (ADD HL,DE (; Given an array element_size in code stream, (; an index and array base address on stack, (; compute the indexed addr(LD DE,DISP0 (ADD HL,DE (RET   LDA ; Load intermediate address (CALL GETIA (PUSH HL (JP BACK "ess and push it. (CALL GBDE ; DE := element_size (SAVIPC (POP BC ; BC := index (LD H,B   LOD ; Load intermedate word (CALL GETIA (LD E,(HL) (INC HL (LD D,(HL) (PUSH DE (JP BACK   ; Check if element_size = 1 (LD L,C (LD A,E (DEC A (OR D (CALL NZ,MULT (ADD HL,HL   STR ; Store intermediate word (CALL GETIA (POP DE (LD (HL),E (INC HL (LD (HL),D (JP BACK  ; make into word offset (POP BC ; get array base (ADD HL,BC (PUSH HL (JP BACK1 "    ;***** Indirect, Records, Arrays, and Indexing   INCR ; Increment (SP) by literal (CALL GBDE (POP HL (AD MOV ; Move words (CALL GBDE ; DE := number of words to move (SAVIPC  (.IF Z80 )LD A,E D HL,DE (PUSH HL (JP BACK   STO ; Store indirect (POP DE ; value (POP HL ; BC := number of bytes to move )ADD A,A )LD C,A )LD A,D )ADC A,D )LD B,A )POP HL ; HL : ; address (LD (HL),E (INC HL (LD (HL),D (JP BACK   SIND0 ; Short index and load word, index=0 (loa= ^source )POP DE ; DE := ^dest )LDIR ; move the stuff in one swell foop )JP BACK1 (.Ed indirect) (POP HL (LD E,(HL) (INC HL (LD D,(HL) (PUSH DE (JP BACK "  SIND ; Short static NDC  (.IF ~Z80 )CLRA ; BC := -number of words to move )SUB E ; (allows counting up to ze ry (LD L,A ; HL := ^word following source (LD H,00H (ADD HL,HL (ADD HL,DE  $10 DEC HL ; BC := -number bytes to move )SUB E )LD C,A )LD A,00H )SBC A,D )LD B,A )POP HL  ; get words from dest... (LD D,(HL) (DEC HL (LD E,(HL)  ; ^source )POP DE ; ^dest  $10 LD A,(HL) ; move the stuff )INC HL )LD (DE),A (PUSH DE ; ...and put them on the stack. (DEC A (JP NZ,$10 (JP BACK "  STM ; Store mult)INC DE )INC C ; loop control )JP NZ,$10 )INC B )JP NZ,$10 (.ENDC (JP BACK1   IXBiple words (LD A,(BC) ; Number of words to transfer (INC BC (TSTA (JP Z,$20 ; Again, just i ; Index byte array (POP DE ; DE := index (POP HL ; HL := array base address (ADD Hn case! (LD L,A ; HL := ^dest (the pointer is buried under all (LD H,00H ; the words that nL,DE (PUSH HL (JP BACK  "  ;***** String vars   ; A String is... LD (DE),A )INC DE )INC C ; loop control )JP NZ,$10 )INC B )JP NZ,$10 )JP BACK1 (.Eeed to be transferred) (ADD HL,HL (ADD HL,SP (LD E,(HL) (INC HL (LD D,(HL) (EX DE,HL  $10 NDC "    ;***** Multiple word vars (sets and reals)  POP DE ; Transfer stuff from stack... (LD (HL),E ; ...to dest. (INC HL (LD (HL),D (I LDC ; Load multiple word constant (constant is backwards in code stream) (LD A,(BC) ; A := number of words NC HL (DEC A (JP NZ,$10  $20 POP HL ; junk ^dest (JP BACK "   ;***** Character long (LD HL,0002H ; put HL on a word boundary (ADD HL,BC (LD B,A ; B := # words to move (LDvars, and byte array vars   LDB ; Load byte (POP HL ; HL := ^char (LD E,(HL) (LD D,00H (PU A,L (AND 0FEH (LD L,A  $10 LD E,(HL) ; transfer the stuff from code... (INC HL (LD SH DE (JP BACK   STB ; Store byte (POP DE ; E := char  D,(HL) (INC HL (PUSH DE ; ...to stack (DJNZM $10 (LD C,L ; fix up IPC (LD B,H(POP HL ; HL := ^dest (LD (HL),E ; store it (JP BACK   MVB ; Move bytes (CALL  (JP BACK "  LDM ; Load multiple words (no more than 255) (POP DE ; DE := ^source (LD A,(BC)GBDE ; DE := number of bytes to move (SAVIPC  (.IF Z80 )LD C,E )LD B,D )POP HL ; HL := ; A := number of words to transfer (INC BC (TSTA (JP Z,BACK ; just in case...supposedly unnecessa ^source )POP DE ; DE := ^dest )LDIR ; transfer the stuff (.ENDC  (.IF ~Z80 )CLRA   ; Skip over characters (LD C,A (LD A,00H (ADC A,B (LD B,A (JP BACK !  IXS ; Index string )DEC C )JP NZ,$30 (.ENDC (JP BACK1  $99 POP HL ; junk ^dst (JP S2LONG "  BYT pointer (; Given index, ^string, compute ^string[index] (POP DE ; index (POP HL ; ^string .EQU BACK ; comvert word to byte address "  S1P ; String to packed array on top of stack (POP DE (INC (CLRA ; Make sure 1 <= index <= 255 (OR D (JP NZ,$99 (OR E (JP Z,$99  DE ; just point pointer past length byte (PUSH DE (JP BACK "  S2P ; String to packed array of c(CP (HL) ; make sure index <= current length (JP C,$20 (JP NZ,$99  $20 ADD HL,DE har under tos (POP HL (POP DE (INC DE (PUSH DE (PUSH HL (JP BACK    ;***** Packed arrays and r ; Perform indexing (PUSH HL (JP BACK  $99 INC HL (PUSH HL ; leave ^string[1] on top of ecord   IXP ; Index a packed array (; Given... (; elements_per_words, bits_per_element in code stream, (; instack (SAVIPC (JP INVNDX "  SAS ; String assignment (; On stack can be either (; ^src_string, ^dst_string ordex, base address of array on stack (; Compute... (; right_bit_number, bits_per_element, ^indexed_word  (; a character, ^dst_string  MAXLEN .EQU BYTE1 (LD A,(BC) ; Save declared_size of dest (LD (MAXLE ELTLEN .EQU WORD1 ( (LD A,(BC) ; E := elements_per_word (LD E,A (INC BC (LD A,(BC) N),A (INC BC (SAVIPC (POP HL ; get the source (LD A,H ; and see if char or ^string (T ; (ELTLEN) := bits_per_element (LD (ELTLEN),A (INC BC (SAVIPC (POP HL ; HL := index (LD  ; The first byte contains the current number of characters  ; in the string. (0..declared_size)  ; The next bytes aSTA ; char has zero upper byte (JP NZ,$10 (LD A,L (LD (LTSTRNG+1),A ; turn the char intore those characters, with garbage fill  ; out to the declared_size of the string.  ;  ; Declared_size (<= 255) is in th a string (LD HL,LTSTRNG ; and point HL at it  $10 LD C,(HL) ; make sure source is not longer  $2e instruction stream for instructions  ; that need to know.   LCA ; Load constant string address (; The string is0 LD A,(MAXLEN) ; than declared_size of dest (CP C (JP C,$99  in the code. Put its address on (; the stack and move the IPC past it (PUSH BC ; Address of string (LD (POP DE ; DE := ^dst_string (.IF Z80 )LD B,00H )INC BC ; include length byte )LDIR (. A,(BC) ; Get number of characters in string (INC BC ; Skip over length byte (ADD A,C ENDC (.IF ~Z80 )INC C ; include length byte  $30 LD A,(HL) )LD (DE),A )INC HL )INC DE  ed word  $10 LD A,(ELTLEN) ; HL := bits_per_element (LD L,A (LD H,00H (PUSH HL (LD B,L  BACK1 "  STP ; Store into a packed field (; Given data, right_bit_number, bits_per_element, ^target (SAVIPC (POP  ; Compute right_bit_number := (CLRA ; remainder*bits_per_element  $20 ADD A,E (DJNZM $ DE ; DE := data (POP BC ; A := right_bit_number (LD A,C (POP BC ; BC := 20 (LD L,A (PUSH HL ; push right_bit_number (JP BACK1 "  LDP ; Load a packed field (; getCLRMSK[bits_per_word] (LD HL,CLRMSK (ADD HL,BC (ADD HL,BC (LD C,(HL) (INC HL (LD B,(HL) (; lef the field described by (; right_bit_number, (; bits_per_element (; ^word. all info is on the stack " t shift data and mask (SUB 08H ; shift >= 8 bits ? (JP C,$10 (LD L,A ; save future # o(SAVIPC (POP DE ; B := right_bit_number (LD B,E (POP DE ; C := bits_per_element (LD f bits to shift (LD H,B ; swap bytes of mask (LD B,C (LD C,H (LD H,D ; and of da C,E (POP HL ; DE := word field is in (LD E,(HL) (INC HL (LD D,(HL) (; position the fielta. (LD D,E (LD E,H (JP NZ,$20 ; go on to shifting if necessary (JP $30  $10 ADD A,08d by a bunch of right shifting (LD A,B ; see if shift >= 8 bits (SUB 08H (JP C,$10 (LD B,A H ; right_bit_number < 8, so restore (JP Z,$30 ; see if = 0  ; B := future right_bit_number (LD L,D ; swap bytes (LD D,E (LD E,L (JP NZ,$20 (LD L,A ; and stick into loop control variable (CLRCF  $20 ; do the shifting (.IF Z80 )SLA E )RL  ; if amount left to shift>0, do it (JP $30  $10 ADD A,08H ; restore amount to shift, and test i D )SLA C )RL B (.ENDC (.IF ~Z80 )LD A,E )RLA )LD E,A )LD A,D )RLA )LD D,A )LD A,C )RLAf zero (JP Z,$30  $20 ; do the actual shifting (.IF Z80 )SRL D )RR E (.ENDC (.IF ~Z80 )LD A,D )RRA )LD C,A )LD A,B )RLA )LD B,A (.ENDC (DEC L (JP NZ,$20  $30 POP HL ; HL = ^wo )LD D,A )LD A,E )RRA )LD E,A (.ENDC (DJNZM $20  $30 LD HL,CLRMSK ; clear out all the junk rd (LD A,C ; insert low byte (CPL (AND (HL) (OR E (LD (HL),A (INC HL ; insC,E ; BC := elements_per_word (LD B,00H (CALL DIVPOS ; HL := index in words, DE := remainder (EXin high order bits (ADD HL,BC (ADD HL,BC ; HL = ^CLRMSK[bits_per_element] (LD A,(HL) (AND E  DE,HL (ADD HL,HL ; HL := ^indexed word (POP BC (ADD HL,BC (PUSH HL ; push ^index(LD E,A (INC HL (LD A,(HL) (AND D (LD D,A (PUSH DE ; push the cleaned field (JP  (.IF ~LSTFPT ).NOLIST (.ELSE ).LIST (.ENDC (  ; Copyright (c) 1978 by the Regents of the University of Califormia  ; S  ; Common sub-expression and common code routines   FPFHALV ; tos * 0.5 (POP HL (POP DE (INC E (DEC E ert high byte (LD A,B (CPL (AND (HL) (OR D (LD (HL),A (JP BACK1 "  CLRMSK .WORD 0000H  BITTan Diego   ; Beginning of file FPT   ; Floating point transendental functions package.    ; Constants...  FPCHALF .BER .WORD 0001H ; used by set stuff (.WORD 0003H (.WORD 0007H (.WORD 000FH (.WORD 001FH (.WORD YTE 80H, 00H, 00H, 00H ; 0.5  FPC1 .BYTE 81H, 00H, 00H, 00H ; 1.0  FPC2 .BYTE 82H, 00H, 00H, 00H ; 003FH (.WORD 007FH (.WORD 00FFH (.WORD 01FFH (.WORD 03FFH (.WORD 07FFH (.WORD 0FFFH (.WORD 1FFFH (.2.0  FPC6 .BYTE 83H, 40H, 00H, 00H ; 6.0  FPC9 .BYTE 84H, 10H, 00H, 00H ; 9.0  FPC10 .BYTE 84H, 20H, WORD 3FFFH (.WORD 7FFFH (.WORD 0FFFFH   ; End-of-File VARS  ( 00H, 00H ; 10.0  FPC14 .BYTE 84H, 60H, 00H, 00H ; 14.0  FPC17 .BYTE 85H, 08H, 00H, 00H ; 17.0  FPCE O^ .BYTE 82H, 2DH,0F8H, 54H ; the number e (approx. 2.718281828)  FPCPI4 .BYTE 80H, 49H, 0FH,0DBH ; pi/4 (approx. 0.785398163)  FPCPI2 .BYTE 81H, 49H, 0FH,0DBH ; pi/2 (approx. 1.570796327)  FPCPIP .BYTE 7FH, 12H, 1FH,0B5H  ; pi/4 - 0.5 (approx. 0.285398163)  FPCLN2 .BYTE 80H, 31H, 72H, 18H ; ln(2) (approx. 0.693147181)  FPCLOG2 .BYTE 7FH, 1AH, 20H, 9BH ; log(2) (approx. 0.301029996)  FPCLOGE .BYTE 7FH, 5EH, 5BH,0D9H ; log(e) (approx. 0.434294482)   ; Globals...  FPGX .EQU TFPT ; the number to transcend upon  INTN .EQU TFPT+20.  ; trunc(abs(FPGX)/FPCPI4) {used in sin,cos}  FPGN .EQU TFPT+4 ; float(INTN)  FPGN1 .EQU TFPT+8  ; FPGN + 1.0  FPGR .EQU TFPT+12. ; f and r are local variables in lots of  FPGF .EQU TFPT+16. ; the routines below  EFSAVE .EQU TFPT+22. ; exponent field save  LOGSGN .EQU TFPT+24. ; log sign    ns (FPMPUSH FPGX (CALL FPFABS (FPMPUSH FPGN (CALL FPFHALV (CALL FPFSUB (FPMPUSH FPGN (FPMPUSH FPCPIP n(INTN) then sex2 else sex3 (; used by sin, cos functions (FPMADJ (CALL FPFABS ; compute INTN (FPMPUSH FPCPI4 ((CALL FPFMUL (CALL FPFSUB (CALL FPFABS (FPMFRET (  FPLSEX3 ; Sub-expression 3 (): real (; computes FPLSEX3 := abCALL FPFDIV (CALL FPFFIX (POP HL ; do the mod 8 stuff now (PUSH HL (LD A,L (AND 07H (LDs((abs(FPGX)-FPGN1*0.5)-FPGN1*PIP) (; used by sin, cos functions  FPMPUSH FPGX (CALL FPFABS (FPMPUSH FPGN1 (CALL (INTN),A (CALL FPFFLOAT ; compute FPGN (FPMSAVE FPGN (FPMPUSH FPC1 (CALL FPFADD ; compute FPGN1  FPFHALV (CALL FPFSUB (FPMPUSH FPGN1 (FPMPUSH FPCPIP (CALL FPFMUL (CALL FPFSUB (CALL FPFABS (FPMFRET (  (FPMPOP FPGN1 (; is INTN even or odd ? (LD A,(INTN) (AND 01H (JP NZ, $10 (CALL FPLSEX2 (JP Z,$10 (DEC E ; don't worry about underflow  $10 PUSH DE (JP (HL) (  FPFDOUB ; tos FPLSI ; si(x:real): real (; var r, f: real (; computes... (; r := -sqr(x) (; f := sex1(r) (; si := x*f*2.0/(f*f-r) (; * 2.0 (POP HL (POP DE (INC E (DEC E (JP Z,$10 used by sin, cos functions  FPMADJ (; sneakily leave a copy of x around "for later" (FPMDUP LHED (CALL FPFSQR ((INC E ; don't worry about overflow  $10 PUSH DE (JP (HL) ( (  FPLSEX1 ; Sub-expression 1 (rCALL FPFNEG (FPMSAVE FPGR (CALL FPLSEX1 (FPMSAVE FPGF (CALL FPFMUL ; multiply x*f (CALL FPFDOUB (FPMP: real): real (; computes FPLSEX1 := 2.0+r/(6.0+r/(10.0+r/14.0)) (; actually expression has been rearranged to compute (; r/(USH FPGF (CALL FPFSQR (FPMPUSH FPGR (CALL FPFSUB (CALL FPFDIV (FPMFRET (  FPLCO ; co(x:real): real (; var rr/(r/14.0+10.0)+6.0)+2.0 (; used by si, co, and ex support routines (FPMADJ (; put 2 more copies of r on stack "for later" (,f2: real (; computes... (; r := -sqr(x) (; f2 := sqr(sex1(r)) (; co := (f2+r)/(f2-r) (; used by sin, cos functions FPMDUP LHED (FPMDUP LHED  FPMPUSH FPC14 (CALL FPFDIV ; use one copy of r (FPMPUSH FPC10 (CALL FPFA FPMADJ (CALL FPFSQR  CALL FPFNEG (FPMSAVE FPGR (; "for later"...see Bored of the Rings for origin ofDD  CALL FPFDIV ; use second (FPMPUSH FPC6 (CALL FPFADD (CALL FPFDIV ; use third (FPMPUS quote (FPMDUP LHED (CALL FPLSEX1 (CALL FPFSQR (FPMSAVE FPGF (CALL FPFADD ; pull dem "laters" out! (FPH FPC2 (CALL FPFADD (FPMFRET ; return from fp function (  FPLSEX2 ; Sub-expression 2 (): real (; computeMPUSH FPGF (FPMPUSH FPGR (CALL FPFSUB (CALL FPFDIV (FPMFRET ( (  FPLSEX69 ; function Sub-code&expression 69 (x:reas FPLSEX2 := abs((abs(FPGX)-FPGN*0.5)-FPGN*PIP) (; takes no arguments, but uses globals FPGN, FPGX (; used by sin, cos functiol):real (; computes INTN := trunc(abs(x)/pi4) (; FPGN := float(INTN) (; FPGN1 := FPGN + 1.0 (; INTN := INTN mod 8 (; if eve  ; all done.    FPFCOS ; cos(x: real): real (; computes (; val := sex69(x) (; if INTN IN [0,3,4,7] then val := co(x) el ; need I say it ? (CALL FPFFIX (POP HL (PUSH HL (LD (INTN),HL (CALL FPFFLOAT (CALL FPFSUB se val := si(x) (; if 2 <= INTN <= 5 then val := -val (FPMADJ FPGX (CALL FPLSEX69 (; call either si or co (CALL FPLEX (LD HL,(INTN) (PUSH HL (CALL FPLEPWR (CALL FPFMUL (LD A,(FPGX+1) ; get the sign of (LD A,(INTN) (AND 03H (JP Z,$10 (CP 3 (JP NZ,$20  $10 CALL FPLCO (JP $30  $20 x (TSTA (JP P,$10 (CALL FPFINV  $10 FPMFRET ( (  FPFATAN ; atan(x: real): real (; var r, f: real (; comp CALL FPLSI  $30 ; should we negate ? (LD A,(INTN) (SUB 2 (CP 4 (JP NC,$40 (CALL FPFNEG  $4utes... (; r := sqr(x) (; if abs(x) >= 1.0 then r := 1.0/r (; f := 17.0 {2*i+1} (; for i := 8 downto 1 do (; f := (2*i-1)0 FPMFRET    FPLEPWR ; epwr(n: integer): real (; computes e ^ n (POP HL ; ret addr (POP DE  + (sqr(i)*r/f) (; if abs(x) >= 1.0 then atan := pi2-1.0/(x*f) else atan := x/f (FPMADJ FPGX (CALL FPFSQR  ; n (Should be in 0..110) (PUSH HL (LD A,E (FPMPUSH FPC1  TSTA  JP Z,$20 ; (LD A,E ; get exp (use neat properties of x^2)  CP 81H ; if exp >= 81, number is >= are we done before we really start?  $10 LD (INTN),A (FPMPUSH FPCE (CALL FPFMUL (LD A,(INTN) (DEC A (1.0 (JP C,$10 (CALL FPFINV  $10 FPMPOP FPGR (; f := 17.0, set up loop  LD HL,(FPC17) (LD (JP $20  $10 CALL FPLSEX3  $20 FPMFRET  ( (  FPFSIN ; sin(x:real):real (; computes (; val := FPLSEJP NZ,$10 $20 FPMFRET  (  FPLEX ; ex(r: real): real (; computes e ^ r, but only used if r is "small" (; var X69(x) (; if INTN in [0,3,4,7] then val := si(val) else val := co(val) (; if INTN >= 4 then val := -val (; if x < 0 then val f: real; (; f := sex1(sqr(x)) (; ex := (f+r)/(f-r) (FPMADJ FPGR (; you guessed it..."for later" (FPMDUP LHED (CALL FP:= -val (FPMADJ FPGX (CALL FPLSEX69 (; is INTN = 0,3,4, or 7 ? (LD A,(INTN) (AND 03H ; now is INTN =FSQR (CALL FPLSEX1 (FPMSAVE FPGF (CALL FPFADD ; you will notice, observant reader, it is @; now "later"  0 or 3 ? (JP Z,$10 ; if ZERO set, INTN = 0 (CP 3 (JP NZ,$20  $10 CALL FPLSI (JP $30 (FPMPUSH FPGF (FPMPUSH FPGR (CALL FPFSUB (CALL FPFDIV (FPMFRET (   FPFEXP ; exp(x: real): real (; computes e ^   $20 CALL FPLCO  $30 ; is INTN >=4 ? (LD A,(INTN) (CP 4 (JP C,$40 (CALL FPFNEG  $40 ; x, by doing fractional part, then integral part (; INTN := trunc(abs(x)) (; exp := ex(abs(x)-INTN) * epwr(INTN) (; if x < 0 tis x < 0 ? (LD A,(FPGX+1) ; grab sign byte (TSTA (JP P,$50 (CALL FPFNEG  $50 FPMFRET hen exp := 1/exp (; save x (actually we only need the sign bit for later use) (FPMADJ FPGX (CALL FPFABS (FPMDUP  (CALL FPFDIV (CALL FPFADD (FPMPOP FPGF (LD HL,(INTN) (DEC L (JP NZ,$20 (; and now, the grand fin the val on the stack, and return 0.0 (POP HL (POP HL (POP HL ; ret addr (LD DE,0 (PUSH DEale... (; (and the grand illusion, if you really think all this will work!) (LD A,(FPGX) ; get exp (CP 81H (PUSH DE (JP (HL) ; note that for fast and accurate answers, @; it is best to only compute sqrt(0.0) !   (JP C,$30 (; atan := pi2-1.0/(x*f) (FPMPUSH FPCPI2 (FPMPUSH FPGX (FPMPUSH FPGF (CALL FPFMUL $30 ; ahhh...a decent sort of number, worthy of our esteemed consideration (CP 81H ; x < 1.0 ? (exp still (CALL FPFINV (CALL FPFSUB (JP $40  $30 ; atan := x/f (FPMPUSH FPGX (FPMPUSH FPGF (CALL FPFDIV  $40in A) (JP NC,$40 (CALL FPFINV ; yes. invert it.  $40 POP HL ; get expfield again (L FPMFRET    FPFSQRT ;sqrt(x: real): real (; {algorithm scales x down to a reasonable size, takes the (; sqrt viaD A,L ; calc efsave, and scale tos (SUB 81H ; 128 bias, and 0.1a => 1.a conversion (AND  simple succesive approximations, then scales (; back up...sqrt(x'*2^(2*n)) = sqrt(x') * 2^n} (; computes...  ; if0FEH ; make even (LD (EFSAVE),A (LD E,A (LD A,L (SUB E (LD L,A  x < 0 then error (; else if x = 0.0 then sqrt := 0 (; else begin (; if x < 1.0 then y := 1.0/x else y := x (; {scale y (LD (SQRTLY),HL ; and save tos (POP HL (LD (SQRTLY+2),HL (; push original approximation, and also save it such that 1.0 <= y < 4.0} (; efsave := (x.expfield - 81) and 8E#16 {even power of two} (; y.expfield := y.expfield - efsav(LD HL,(FPC2+2) (PUSH HL (LD (SQRTLZ+2),HL (LD HL,(FPC2) (PUSH HL (LD (SQRTLZ),HL (LD A,8 e  ; z := 2.0 {our first approximation} (; for i := 1 to 8 do z := 0.5*(z+y/z) (; {scale answer back up} (; ; prime the loop  $50 LD (INTN),A (FPMPUSH SQRTLY (FPMPUSH SQRTLZ (CALL FPFDIV (CALL FPFADD (CA z.expfield := z.expfield + (efsave div 2) (; if x < 1.0 then sqrt := 1.0/z else sqrt := z (; end  SQRTLY .EQU TFPTLL FPFHALV (FPMSAVE SQRTLZ (LD A,(INTN) (DEC A (JP NZ,$50 (; rescale tos (POP HL (LD A,(EFSAV (FPGF ),HL (LD HL,(FPC17+2) (LD (FPGF +2),HL (LD HL,8  $20 LD (INTN),HL (ADD HL,HL +12.  SQRTLZ .EQU TFPT+16.  FPMADJ FPGX (LD A,H ; is number negative ? (TSTA  ; calculate 2*i-1 (DEC L (PUSH HL (CALL FPFFLOAT (LD HL,(INTN) ; calculate i*i (EX DE,HL (LD (JP P,$10 (; it most assuredly is...tell the dumbshit. (LD A,1 (LD (FPERROR),A (JP $20 ;  C,E (LD B,D  CALL MULT (PUSH HL (CALL FPFFLOAT (FPMPUSH FPGR (CALL FPFMUL (FPMPUSH FPGF pretend we just found out x = 0.0  $10 LD A,L ; is number 0.0 ? (TSTA (JP NZ,$30  $20 ; junk E) (RRCA ; sneaky divide by two..low bit is zero (ADD A,L (LD L,A (PUSH HL (; invert if x < tive ? (TSTA (JP M,$10 (LD A,L ; is arg 0.0 ? (TSTA (JP NZ,$20  $10 ; bummer. return 1.0 (LD A,(FPGX) ; get exp once more (CP 81H (JP NC,$60 (CALL FPFINV  $60 FPMFRET   FPLLNgarbage. (LD A,1 (LD (FPERROR),A (JP $40  $20 ; is arg < 1.0 ? (CP 81H ; set flags X ; calculates ln(x), where x is "small" (; (in this case 1.0 <= x < 2.0)  ; algorithm... (; r := x-1.0 (; f := 1(LD A,0 ; and assume bigger than 1.0 (LD (LOGSGN),A (JP NC,$30 (; our assumtion was wrong... (7.0 (* 2*8+1 *) (; for i := 8 downto 1 do (; f := i + sqr((i+1) div 2)*r/f (; lnx := r/f  FPMADJ CALL FPFINV (LD A,80H (LD (LOGSGN),A  $30 POP HL ; get exp once more ! (LD A,L (FPMPUSH FPC1 ; calculate r (CALL FPFSUB (FPMPOP FPGR (LD HL,(FPC17) ; and start off f (LD ( ; and scale tos down to size (SUB 81H (LD (EFSAVE),A ; stash exponent in a safe place (LD L,81H (PUFPGF ),HL (LD HL,(FPC17+2) (LD (FPGF +2),HL (LD A,8 ; prime loop  $10 LD (INTN),A (LD SH HL (CALL FPLLNX  $40 FPMFRET (  FPFLN ; natural log (base e, for all you non-organic types) (FPMADJ (CALL  L,A ; push float(i) (LD H,0 (PUSH HL (CALL FPFFLOAT (LD A,(INTN) (INC A ; FPLBLOG ; let others do all the hard work... (; ... while we simply multiply results by a few constants  calculate sqr((i+1) div 2) (CLRCF (RRA (LD C,A (LD B,0 (LD E,C (LD D,B (CALL MULT (PUSH HL ((; ln := blog + efsave*ln(2) (LD HL,(EFSAVE) (LD H,0 (PUSH HL (CALL FPFFLOAT (FPMPUSH FPCLN2 (CALL FPFCALL FPFFLOAT (FPMPUSH FPGR (CALL FPFMUL (FPMPUSH FPGF (CALL FPFDIV (CALL FPFADD (FPMPOP FPGF (LD A,MUL (CALL FPFADD (POP HL ; now stick in proper sign (LD A,(LOGSGN) (OR H (PUSH HL (FPMFRE(INTN) (DEC A (JP NZ,$10 (FPMPUSH FPGR (FPMPUSH FPGF (CALL FPFDIV (FPMFRET (  FPLBLOG ; function blog(x: T (  FPFLOG ; log base 10 (FPMADJ (CALL FPLBLOG (; log := blog*log(e) + efsave*log(2) (FPMPUSH FPCLOGE (CALL FPFMUreal): real (* plus side-effects *)  ; does stuff common to both logs...  ; algorithm... (; if x <= 0.0 thenL (LD HL,(EFSAVE) (LD H,0 (PUSH HL (CALL FPFFLOAT (FPMPUSH FPCLOG2 (CALL FPFMUL (CALL FPFADD (POP  blog := x (* garbage *) (; else (; begin (; sgn := plus (; if x < 1.0 then begin x := 1/x; sgn := minus end  HL (LD A,(LOGSGN) (OR H (PUSH HL (FPMFRET ( (  SIN ; sin standard procedure (CALL FPLCBEG (CAL(; efsave := x.expfield-81#16 (; x.expfield := 81#16 (; blog := lnx(x) (FPMADJ (LD A,H ; is arg negaL FPFSIN (JP FPLCHK (  COS ; cos standard procedure (CALL FPLCBEG (CALL FPFCOS (JP FPLCHK (  EXP  A B WGYGO^ng point package...  ; FPCa Floating point constant a.  ; FPMa Floating point macro a. Some of these macros leave  ; well-specified stuff in registers.  ; FPFa Floating point function a. Takes argument(s) on tos,  ; leaves result on tos, and also in EDCB (except for  ; FPFFIX, FPFDOUB, FPFHALV).  ; exp standard procedure (CALL FPLCBEG (CALL FPFEXP (JP FPLCHK (  ATAN ; atan standard procedure (CALL  FPLCBEG (CALL FPFATAN (JP FPLCHK (  SQT ; sqrt standard procedure (CALL FPLCBEG (CALL FPFSQRT (JP FPLCHK (  LOG ; log base 10 (CALL FPLCBEG (CALL FPFLOG (JP FPLCHK (  LN ; log base e (CALL FPLCBEG (CALL FPFLN (JP FPLCHK (   ; End of file FPT   (.IF ~LSTFP ).NOLIST (.ELSE ).LIST (.ENDC  ;Copyright (c) 1978 ; by the Regents of the University of California, San Diego ; Beginning of file FPL   ; Floating point stuff...including basic stuff like the four math  ; functions, fix, and float; and much more esoteric stuff, like  ; transcendental functions. All routines of any general interest  ; are callable.  ; Hopefully in the near future there will be an arithmetic vector table,  ; so you people adding assembly procedures to your system will  ; be able to make use of all this wonderful software.    ; Naming conventions used throughout the floati ; Currently only simple rounding is used...true rounding to be implemented  ; sometime in the future.   big exp (INC HL ; move to mantissas (INC DE (; Compute result sign. If add, sign of mantissa with larg; Any operation causing overflow or underflow will store a 01H into (FPERROR)   ; (I know error handling in these low-level rer exp. (; If non-swapped subtract, sign of larger exp mantissa, else CPL (; of sign of larger exp mantissa. Done by (swaoutines could be simplified,  ; but error-protocol was changed after this stuff was adapted to be  ; used in the P-machine, pped XOR sign of (; larger mantissa). (LD A,(DE) (LD E,A ; save sign of larger exp mantissa (XOR and it was easier to put in small fixes.)  FPLSETUP ; for fpadd, fpmul, fpdiv, fpsub (; set HL = ^b, DE = ^a, A = # bytes of B (RLCA ; put computed result sign in bit 0 (LD D,A ; and save it.  operands (; stack is ret. addr. in fp. | ret. addr. | b | a (LD HL,0004H (ADD HL,SP (LD E,L (LD D,H (; Compute difference of signs. if add, XOR of signs; if subtract, (; CPL of XOR of signs. (LD A,E ; sign(INC E (INC DE (INC E (INC DE (LD A,8 (CLRCF RET  FPFADD CALL FPLSETUP (PUSH AF  of larger exp mantissa (INC B (XOR B (XOR (HL) (XOR D ; merge with result sign (AND 80H  ; FPLa Floating point low level function. Not necessarily  ; directly callable, and probably not of i ; save stack cutting info and error info. (LD A,02H ; indicate 'add' (JP FPLSUM FPFSUB CALL FPLSETnterest to  ; the user.  ; FPGa Floating point global variable a.  ; aLb Floating point locaUP (PUSH AF (LD A,7FH ; indicate 'subtract' FPLSUM LD B,A ; save add/subtract info (LD A,(l variable b for function a.  ; FPRa Floating point relational function a. Returns  ; Z = false, NZ = DE) ; A := arg1.exp - arg2.exp (SUB (HL) (JP NC,$10 (EX DE,HL ; arg2.exp larger, so switch args... true (not yet meaningful).     ;***************** BASIC FLOATING POINT ARITHMETIC *************; ; Based on an 8080(INC B ; ...indicate so in add/subtract info... (NEGA ; ...and negate exp diff. $10 L floating point package by John Lamping ; Numbers are four byte quantities represented as... ; [exp] [sabc v] [w x] [y z] ; sD C,A ; save exp diff (LD A,(HL) ; is arg2 = 0 ? (TSTA (JP NZ,$20 (INC C , a, b, c are bits, v, w, x, y, z are hex digits. ; Exponent is biased by 128. Mantissa is always normalized, and includes ; ; yes. is arg1.exp = arg2.exp (= 0) ? (DEC C (JP Z,FPLZERO ; if so, result is 0. (LD C,25 ; o "invisible" bit just in front of a. ; If exp = 0, number value is zero. ; number value = (1-2*s) * .1abcvwxyz * 2^(exp-128) nly arg2 zero, so set exp diff ( ; past floating point precision. $20 PUSH DE ; save addr of C,$40 (LD E,D ; yep. shift registers. (LD D,C (LD C,B (LD B,00H (JP $30 ; tr ; subtract lowest byte from 0 (SUB E (LD E,A (LD A,(HL) (SBC A,D (LD D,A (DEC y that trick again. $40 ADD A,8 (LD L,A (JP Z,$60 $50 ; shift mantissa right one place (.IF Z80  HL (LD A,(HL) (SBC A,C (LD C,A (DEC HL (LD A,(HL) (RLA ; turn on hidden bit ( SRL B ( RR C ( RR D ( RR E (.ENDC (.IF ~Z80 ( CLRCF ( LD A,B ( RRA ( LD B,A ( LD A,C ( (SCF (RRA (SBC A,B (LD B,A FPLSUMX JP NC,FPLNRM ; if subtracted smaller from bigger normalize (POP HRRA ( LD C,A ( LD A,D ( RRA ( LD D,A ( LD A,E ( RRA ( LD E,A (.ENDC (DEC L ; doneL ; blew it. change answer sign. (INC H (PUSH HL (CLRA (LD H,A (SUB E ; and comp shifting ? (JP NZ,$50 $60 INC H ; test sign diff (P signs same, M signs differ) (DEC H (Element mantissa (subtracted (LD E,A ; larger from smaller) (LD A,H (SBC A,D (LD D,A X (SP),HL ; save result sign, get ^big arg (LD A,(HL) ; A := answer exp (EX (SP),HL ; Store (LD L,A (LD A,H (SBC A,C (LD C,A (LD A,H (SBC A,B (LD B,A (JP FPLNRM FPFMUL CALL FPLSETUP  ; sign (EX (SP),HL ; and exp (INC HL ; point HL to low mantissa byte of big arg (INC (PUSH AF ; save stack cutback, error info (LD A,(DE) ; load exp's (LD B,A (LD C,(HL) (TSTA HL (INC HL (JP M,$70 ; jump if signs were different (; Do Addition. (LD A,D ; Add manti ; if either arg zero, result is zero (JP Z,FPLZERO (INC C (DEC C (JP Z,FPLZERO (INC ssas (ADD A,(HL) (LD D,A (DEC HL (LD A,C (ADC A,(HL) (LD C,A (DEC HL (LD A,(HL) (RL DE ; move pointers to mantissas (INC HL (LD A,(DE) ; Compute answer sign (in bit zero) (XOR (H(XOR D (LD E,A ; save it (LD A,(HL) ; Load mantissa of smaller arg into BCDE (OR 80H A ; turn on hidden bit (SCF (RRA (ADC A,B (LD B,A (POP HL ; get sign, exp  ; Put in hidden bit (LD B,A (LD A,C (INC HL (LD C,(HL) (INC HL (LD D,(HL) (LD H,E (JP NC,FPLRND (; gotta shift down one place (.IF Z80 ( RR B ( RR C ( RR D ( RR E (.ENDC (.IF ~Z80  ; move sign information (LD E,00H ; clear rest of mantissa (; position smaller mantissa (CP 26 ( RRA ( LD B,A ( LD A,C ( RRA ( LD C,A ( LD A,D ( RRA ( LD D,A ( LD A,E ( RRA ( LD E,A ( ; limit shifts to 25 (JP C,$30 (LD A,25 $30 SUB 8 ; at least 8 shifts ? (JP .ENDC (INC L ; Increment result exp, and (JP FPLRND ; go round result (; Do subtraction $70 CLRA  ; should be between 80 and 17F (hex) (POP BC ; get back sign info (JP M,$10 ; check exp sum ouC A,H (LD C,A (LD A,B (ADC A,E $50 ; shift sum right one bit (RRA (LD B,A (.IF Z80 ( RR C t (JP NC,FPLUND (JP $20 $10 JP C,FPLOVRX $20 ADD A,81H ; everything's cool. bias exp( RR D ; carry on if bit shifted out (.ENDC (.IF ~Z80 ( LD A,C ( RRA ( LD C,A ( LD A,D ( R sum. (LD C,A ; and save with sign info (PUSH BC RA ( LD D,A (.ENDC (EX (SP),HL ; get multiplier, count (DEC L (JP NZ,$30 (LD A,H ; (LD A,(DE) ; load first two bytes of arg1 (putting in (OR 80H ; hidden bit) and save on stack (LD save previous carries out (POP HL ; get more multiplier (EX (SP),HL (PUSH AF ; save car B,A (INC DE (LD A,(DE) (LD C,A (PUSH BC (INC DE ; load last byte of arg1 (LD A,(ries (LD A,H ; Check for done - we are if high bytes of (OR L ; multiplier are zero (JP DE) (LD B,A (LD A,(HL) ; load E,H,L with arg two mantissa (OR 80H (INC HL (LD D,(HL) (INC HL Z,$60 (POP AF ; junk carry stuff (LD A,L ; shift to next byte (LD L,H  LD E,(HL) (EX DE,HL (LD E,A (LD C,8 ; Set up (PUSH BC ; first mult(LD H,00H (EX (SP),HL ; save shifted bytes (PUSH HL ; save multiplicand (LD L,8 iplier (EX (SP),HL ; and count (LD BC,0000 ; Clear answer (LD D,B (; Main Multiply Loop (; BCD holds 24 ; set count (JP $40 $60 POP AF ; get carries out (POP HL ; junk multiplicand (bit accumulated sum, E (SP) is multiplicand (; L is loop count, (SP+2) is high order bytes of multiplier (; H is low order bytRRA ; put carries into E (LD E,A FPLMULX POP HL ; get sign, exp (INC B e of multiplier and extra bits of (; precision of sum $30 LD A,H ; get multiplier and previous shift outs ; test sign of answer (DEC B (JP FPLNRMX ; normalize it FPFDIV CALL FPLSETUP (PUSH AF ; s $40 RRA ; get low bit, save previous shift out (LD H,A ; put multiplier back ave stack cutback, error info (LD A,(DE) ; get exp1 (LD C,A (INC DE ; get arg1 sign in case div (LD A,B ; get B in case no add (EX (SP),HL ; get back multiplicand (JP NC,$50 ; jump ifby zero (LD A,(DE) (RLCA (LD B,A (LD A,(HL) ; get arg2.exp (TSTA ; check for zero (JP L) (RLCA (PUSH AF ; and save it (LD A,B ; get exp sum (DEC A (ADD A,C  no add necessary (LD A,D ; add multiplicand to acculumated sum (ADD A,L (LD D,A (LD A,C (AD   A,B ; compare magnitudes (CP E (JP C,$40 (JP NZ,$50 (LD A,C (CP H (JP th and 26th bits in high part (RRCA ; of E (RRCA (LD E,A (JP FPLMULX ; go normalize answer F C,$40 (JP NZ,$50 (LD A,L (CP D (CCF ; so we remember what if we subtracted (JP PFFLOAT ; convert integer tos to fp number  POP HL ; return_address  Z,FPLOVRX ; divide by zero (INC C ; check for dividend zero (DEC C (JP Z,FPLZERO (LD  NC,$50 $40 LD A,L ; subtract divisor from remainder (SUB D (LD L,A (LD A,H (SBC  B,A ; save arg2.exp (LD A,(DE) ; compute and save result sign (INC HL (XOR (HL)  A,C (LD H,A (LD A,E (SBC A,B (LD E,A (SCF ; so we remember we subtracted $50 (RLCA ; put in bit 0 (PUSH AF (LD A,C ; get exp diff (SUB B (POP BC  EX (SP),HL ; Record if we subtracted (LD A,L (RLA (LD L,A (JP NC,$70 ; Jump if byte not full ; get back result sign again (JP M,$10 ; check for over or underflow (JP C,FPLUND (JP $20  (EX DE,HL ; Get some elbow room (PUSH HL (LD HL,0005 ; Point to most significant result byte (ADD HL,S$10 JP NC,FPLOVRX $20 ADD A,81H ; bias exponent (LD C,A ; save future exp with signP (LD A,(HL) ; If non-zero we are done (TSTA (JP NZ,$80  info (PUSH BC (LD BC,0000 ; set up answer (PUSH BC (INC C ; put 1 in low bit so know when we (DEC HL ; move answer bytes up one byte (LD A,(HL) (LD (HL),D (INC HL (LD (HL),A (LD have ( ; shifted 8 times (PUSH BC (PUSH HL ; save ^arg2 (EX DE,HL ; Load E D,E (LD E,01 ; set up 8 more loops (TSTA ; if high byte now non-zero, only need (JP ,H,L with arg1.mantissa (LD A,(HL) (OR 80H ; put in hidden bit (INC HL (LD D,(HL) (INC H Z,$60 ; two more loops for 26-bit precision. (24 for (LD E,40H ; answer, 1 if high bit 0, 1 for roundingL (LD E,(HL) (EX DE,HL (LD E,A (EX (SP),HL ; load B,C,D with arg2.mantissa (LD A,(HL) (OR 8) $60 POP HL ; give back elbow room (EX DE,HL $70 EX (SP),HL ; get back remainder (ADD 0H (LD B,A (INC HL (LD C,(HL) (INC HL (LD D,(HL) (POP HL (; Main Divide Loop  HL,HL ; shift remainder left one bit (LD A,E (RLA (LD E,A (JP $30 ; go for it again $80 POP (; EHL remainder, BCD divisor, (SP) (SP+2) quotient so far $30 JP C,$40 ; jump if carry shifted out (LD  BC ; junk remainder (POP BC (POP BC ; get rest of answer (LD A,E ; put 25! $10 LD BC,8000H ; load -maxint-1 $20 PUSH BC (LD A,1 ; signify error (LD (FPERROR A,B ( LD B,A (.ENDC (JP P,$20 FPLRND LD A,E ; jump if round up unnecessary (RLA (JP NC,FPLSIGN (I),A (JP (HL) ; and return $30 CP -16 ; max of 16 shifts (JP NC,$40 (LD A,-16 $40 NC D (JP NZ,FPLSIGN (INC C (JP NZ,FPLSIGN (INC B (JP NZ,FPLSIGN (LD B,80H (INC L  LD E,A ; save shift count $50 ; shift mantissa right one bit (.IF Z80 ( SRL B ( RR C (.ENDC ( ; bump up exp (JP FPLSIGN FPLZERO CLRA ; load a zero .IF ~Z80 ( CLRCF ( LD A,B ; shift mantissa down ( RRA ( LD B,A ( LD A,C ( RRA ( LD C,A (.END(JP FPLSET ; and propagate it FPLOVRX LD H,B ; position sign info FPLOVR LD A,0FFH (JP FPLABN FPLUND CLRAC (INC E (JP NZ,$50 (INC D ; test result sign (DEC D (JP P,$70 (CLRA  FPLABN POP HL ; indicate error (INC L (PUSH HL (LD B,A ; propagate A through mant(POP BC ; arg to float (PUSH HL (XOR A ; tell FPSTOR to cut stack back zero bytes, (PU ; negate result (SUB C (LD C,A (LD A,00H (SBC A,B (LD B,A $70 PUSH BC ; pushSH AF ; and that no error has occurred. (LD DE,0090H ; set sign (PUSH DE ; and ex answer (JP (HL) ; and return FPLNRM POP HL ; get sign info and exponent (JP NZ,FPLNRponent (LD E,D ; clear rest of mantissa (LD A,B ; set carry and sign flags if sign negative MX ; jump if semi-normalized (high byte non-zero) (LD A,E ; check mantissa for zero (OR D (CLRCF (RLA (JP FPLSUMX ; negate if necessary, then normalize FPFFIX POP HL ; return_address (; l(OR C (JP Z,FPLZERO (LD A,L ; get exp $10 SUB 9 ; exp big enough to move 8 bits? (JP C,oad high bytes of mantissa into BC, sign into D, exp into E (POP DE ; D := high byte mantissa, E := exp (LD FPLUND (INC A (LD B,C ; shift mantissa one byte (LD C,D (LD D,E (LD E,00 (INC B  A,D (OR 80H ; turn on hidden bit (POP BC ; C := middle byte mantissa (LD B,A (LD  ; check new high byte (DEC B (JP Z,$10 (LD L,A ; put back exp FPLNRMX JP M,FPLRND $ A,E ; (only need 16 bits of man) if EXP >= 90H (SUB 90H (JP C,$30 (; Overflow! check sign bit of an20 DEC L ; decr exp (JP Z,FPLUND (; Shift mantissa lift one bit (.IF Z80 ( SLA E ( RL D ( RL C ( RL swer (INC D (DEC D (JP M,$10 (LD BC,7FFFH ; load maxint. (JP $20  B (.ENDC (.IF ~Z80 ( EX DE,HL ( ADD HL,HL ( EX DE,HL ( LD A,C ( RLA ( LD C,A ( LD A,B ( ADC"  high bits..they don't count (LD L,A (LD A,(FPERROR) ; flip error on if error occured (OR L (LD (FPERROR),A (LD L,H ; calculate new tos (LD H,00H (ADD HL,SP (LD SP,HL (PUSH BC (PUSH DE (LD HL,(RETADR) (JP (HL)   ; End of file FPL  ( ( (.IF ~LSTBOOT ).NOLIST (.ELSE ).LIST (.ENDC  ;Copyright (c) 1978  ; by the Regents of the University of California, San Diego   ; Beginning of file BOOT   ;****************BOOTSTRAP LOADER****************;   ; This is a Pascal-system loader, it assumes that  ;the complete interpreter and booter have been  ;loaded by the host machine. It assumes that on  ;unit 4 ,block 2 is a directory with the pascal  ;operating system 'SYSTEM.PASCAL'. The booter  ;reads this, initializes the interpreissa... FPLSET LD C,A (LD D,A (LD L,A ; and exp (TSTA ; see if we just put in zero's (JP Z,FPLSTOR FPLSIGN INC L ; last chance for overflow (DEC L (JP Z,FPLOVR (LD O^A,H ; set answer sign (INC A (RRCA (AND 80H (XOR B FPLSTOR ; result is LACD. put into a good format (ie. EDCB), cut the stack (; back, and push result (LD B,D (LD D,A (LD E,L (POP HL ; get cutback and error info (EX (SP),HL (LD (RETADR),HL (POP HL (LD A,L (AND 01H ; junk all the# ment zero  ; 5: set up machine state for seg 0 proc 1  ; 6: GO FOR IT.  (.ALIGN 2 ;These decs are for Step ; STEP5 of booter (JP STEP5 ; COWABUNGA !!!!!    BOOT ;Start here and follow the yellow brick r 2.  INTEND ;Marks the end of the core resident interpreter  SYSTLE .BYTE 0DH ;length byte of String oad. (LD SP,RELSEG+1000H ;if that doesn't do it I'll be (.IF CPM )LD HL,(0001H) ;BIOS JUMP VECTOR )LD (.ASCII "SYSTEM.PASCAL" ;characters of String  DENTSZ .EQU 1AH ;directory entry size, bytes  DTITLE .EQU  DE,-11H ; leave some space for shitty (Tarbell) BIOS )ADD HL,DE )LD (MEMTOP),HL (.ENDC   ; Step 1  ; 06H ;offset of title in an entry  DENTP .WORD 0 ;gets set by this Step   SYSBLK .WORD 0 Initialize all I/O drivers. (.IF CML )LD A,0C3H ; set up keyboard interrupt vecto )LD (38H),A )LD HL,CH SEGCNT .BYTE 0       QWIK ; Assume p-code at 2000H, move to high core (LD HL,(2006H) ; Get code INT )LD (39H),HL (.ENDC    ; Step 2  ;read directory from abs block 2 into  ;memory just above the interp length (bytes) (EX DE,HL (LD HL,(MEMTOP) ; Get maximum memory address (SUBHLDE ; Get address ;find system.pascal and leave the  ;address of its direntry in DENTP   ; read in the directory (LD HL,(SYSUNT) to transfer program to (LD SP,HL ; Stack grows from here (LD DE,2200H ; Address of start of p-code ;unit number for booting (PUSH HL (LD HL,NRPTOP ;I/O buffer, way out there (PUSH HL (LD HL,04H*20 (LD BC,(2006H) ; Set byte counter to # of bytes to transfer (CLRA ; Get (SUB C 0H ;length, 4 blocks (PUSH HL (LD HL,02H ;DIR starts at block 2 (PUSH HL (CALL SYSRD ;  ; negative (LD C,A ; byte (LD A,00H ; count (SBC A,B ; (LD B,that does it folks  ; search dir (LD HL,FSTENT ;skip over entry 0, disk name (LD (DENTP),HL (LD A   $10 LD A,(DE) ; Get byte to transfer (LD (HL),A ; Move byte to new home C,00H  ; ;(DENTP)=^DIR ENTRY, HL=^DIR.TITLE, DE=^SYSTITLE, C=counter  $20 ;outer, loop on each dir entry (L(INC DE ; Bump address (INC HL ; Bump destination address (INC C ; IncremD DE,DTITLE ;inc HL to .TITLE in entry (ADD HL,DE (LD DE,SYSTLE ;set DE to title for comparison (LDter to enter  ;the system outer block and goes to it.   ; Six easy steps toward the realization of Pascal.  ; 1: initient lower part of byte count (JP NZ,$10 ; Overflow into upper byte ? (INC B ; Yes, increment ualize all I/O drivers  ; 2: read directory, find 'SYSTEM.PASCAL'  ; 3: read block zero and set up SEGTBL  ; 4: read in segpper one, too (JP NZ,$10 ; Are we done (BC=0) ? (DEC HL ; Yes, adjust HL for (DEC HL $  ;loop control (LD (SEGCNT),A (LD DE,SEGTBL (LD HL,RELSEG  $50 LD A,(SYSUNT) ;set SEGTBp 5  ; Initialize all P-machine registers including  ;SP, NP, MP, BASE, IPC, JTAB, SEG.  B,0EH ;comp for length of title  $30 ;inner, loop on characters (LD A,(DE) (CP (HL) (JP NL.UNIT := 4 (LD (DE),A (INC DE (XOR A (LD (DE),A (INC DE (LD C,(HL) ;BC := RELSEG.DISKZ,$40 (INC DE (INC HL (DJNZM $30 (JP FOUND  $40 ; No match here - go to next dir entry ADR (INC HL (LD B,(HL) (INC HL (PUSH HL ;calc abs block num (LD HL,(SYSBLK) (ADD HL,(LD HL,(DENTP) (LD DE,DENTSZ (ADD HL,DE (LD (DENTP),HL (DEC C (JP NZ,$20  $45 JP $BC (EX DE,HL (LD (HL),E (INC HL (LD (HL),D (INC HL (EX DE,HL ;restore pointers (POP45 ; We didn't find it. Maybe one of this days @; we'll put out an error message here.  FOUND ;adrs left in D HL (LD A,(HL) ;set SEGTBL.LENGTH := RELSEG.CODELEN (LD (DE),A (INC DE (INC HL (LD A,(HENTP     ; Step 3  ;RELSEG .EQU NRPTOP+800H ;address to read block 0 at, above dir  ;SYSBLK .WORD 0 L) (LD (DE),A (INC DE (INC HL (LD A,(SEGCNT) ;do this 16 times (DEC A (LD (SEGCNT),A  ;amount to make rel seg blk nos absolute  ;SEGCNT .BYTE 0  (;do the read (LD HL,(SYSUNT) ;unit (PUSH (JP NZ,$50     ; Step 4  ; read segment zero, pointed at by SEGTBL[0],  ;into the highest memory address pos HL (LD HL,RELSEG ;buffer (PUSH HL (LD HL,40H ;length, 16 entries (PUSH HL (LD HL,(DENTsible, up  ;to MAXADR. Also set SP at bottom of code read in.  (LD HL,SEGTBL+04H ;get len of seg zero (LD E,(HLP) ;block, from directory (LD C,(HL) (INC HL (LD B,(HL) (PUSH BC (LD L,C (LD H,B (LD ) (INC HL (LD D,(HL) (LD HL,(MEMTOP) (INC HL (INC HL (SUBHLDE (LD SP,HL (LD A,(SYSUNT)  (SYSBLK),HL (CALL SYSRD (;put stuff into SEGTBL  ; HL => RELSEG: array [0..15] of  ;  ;unit (LD C,A (LD B,00H (PUSH BC (PUSH HL ;buffer (PUSH DE ;length (LD  DISKADR, relative block number  ; CODELEN length in bytes  HL,(SEGTBL+02H) ; block (PUSH HL (CALL SYSRD   ; Fill in internal seg table (LD HL,INTSEGT+4 (LD BC,-< ; DE => SEGTBL: array [0..15] of  ; UNIT, device index  ; MAXSEG*4> (CLRA  $60 LD (HL),A (INC HL (INC C (JP NZ,$60 (INC B (JP NZ,$60 (LD HL,1  BLOCK, absolute  ; LENGTH same as above (LD A,10H  ; initialize entries for op sys (LD (INTSEGT),HL (LD HL,(MEMTOP) (LD (INTSEGT+2),HL (   ; Ste%  ;set all MSCW pointers (LD (BASE),HL (LD BC,DISP0 (ADD HL,BC (LD (MPD0),HL (LD (BASED0),HL (LD HL,INTEND ;set NP (LD (NP),HL     ; Step 6  ; enable interrupts and do other junky stuff   (RESTORE      NRPTOP .EQU $  RELSEG .EQU NRPTOP+800H  FSTENT .EQU NRPTOP+DENTSZ (.END GOLOC (.IF ~LSTSET ( .NOLIST (.ELSE ).LIST (.ENDC (  ; Copyright (c) 1978 by the  ; Regents of the University of California,  ;you learn to pray. (  ; End of file BOOT, and end of interpreter !  ( San Diego   ; start of file SET2    ;***** Set building and size adjusting "  SGS ; Build a singleton set, the set ;Create an initial stack frame and MSCW including  ;the automagic ^SYSCOM parameter.  (LD HL,(MEMTOP)  STEP5 LD  (SEGP),HL (DEC HL ;set JTAB := SEG^[-1] (LD B,(HL) (DEC HL (LD C,(HL) (SUBHLBC  ; self relative (LD (JTAB),HL (DEC HL ;set IPCSAV := JTAB^[-1] (LD B,(HL) (DEC HL (LD  C,(HL) (SUBHLBC ; self relative (LD (IPCSAV),HL (LD HL,(JTAB) ;new stack frame (LD O^ BC,DATASZ (ADD HL,BC ; SP := SP-JTAB^[-8] (LD C,(HL) (INC HL (LD B,(HL) (XOR A (SUB C (LD L,A (LD A,00H (SBC A,B (LD H,A (ADD HL,SP (LD SP,HL (LD DE,SYSCOM ;^SYSCOM parameter (PUSH DE (PUSH HL ;create MSCW, dummy save state (LD HL,-04H ;address of an ABORT opcode (ADD HL,SP (PUSH HL (LD HL,00D6H ; an ABORT opcode (PUSH HL (PUSH HL (LD HL,-04H ;STAT and DYN must be self referencing (ADD HL,SP (PUSH HL (PUSH HL (LD (MP),HL &  ; BEGIN push(xx); xx := ; t := t-1 END  ; push(j DIV 16 +1) (* set size *)   ; Actual code is sli E,(HL) ; DE := bitter[jmod] (INC HL (LD D,(HL) (SUB B ; A := jdiv-idiv (; WHILE t >ghtly more efficient.   ; In the following,  ; idiv = i DIV 16, imod = 2*(i MOD 16),  ; jdiv = j DIV 16, jmod = 2*(j MO i DIV 16 stuff... (JP Z,$30 (PUSH DE (LD DE,0FFFFH (JP $20  $10 PUSH DE  $20 DEC A (JD 16)  (; currently BC = i, DE = j. (; Compute C := imod, B := idiv (.IF Z80 )LD HL,IDIV ; set up rotate digitP NZ,$10  $30 ; DE := DE AND unbitter[imod] (LD A,B ; save idiv for a second (LD B,00H  environment )LD (HL),C )LD A,B )RRD ; Presto chango. A = i MOD 16, (IDIV) = idiv )RLA (LD HL,UNBITR (ADD HL,BC (LD B,A ; restore idiv (LD A,E (AND (HL) (LD E,A (INC  ; A := imod )LD C,A )LD B,(HL) ); Compute HL := BITTER+jmod ); (JDIV) := jdiv; A = jdiv )LD (HL),E  HL (LD A,D (AND (HL) (LD D,A (; WHILE t >= 0 DO stuff... (PUSH DE (LD DE,0000H (LD A,B (TST ; JDIV=IDIV, so HL already set up )LD A,D )RRD )RLA ; A = jmod, (JDIV) = jdiv )LD E,A )LA (JP Z,$50  $40 PUSH DE (DJNZM $40  $50 LD A,(JDIV) ; push set size (INC A (LD LD D,00H )LD A,(HL) )LD HL,BITTER )ADD HL,DE (.ENDC  (.IF ~Z80 )LD A,C )AND 0FH )RLA )LD L,A,A (LD H,00H (PUSH HL (JP BACK1  $90 LD HL,0000H ; push the null set (set_size = 0) (PUSH H [i] (POP DE (PUSH DE (PUSH DE "  SRS ; Build a subrange set, the set [i..j]  IDIV .EQU BYTE1  JDIV  ; L = imod )LD A,B )RLA )RLA )RLA )RLA  .EQU BYTE1 (SAVIPC (; are i,j valid ? (POP DE ; DE := j (POP BC ; BC := i (LD A)LD H,A ; H = 4 high bits of idiv, low 4 bits are 0 )LD A,C )AND 0F0H )RRA )RRA )RRA )RRA ,B ; is i<0 ? (TSTA (JP M,$99 (LD HL,0F010H ; is j >= 16*255 ? (ADD HL,DE (JP C,$99 ; A = 4 low bits of idiv, high 4 bits are 0 )OR H ; put 'em together )LD B,A )LD C,L ); (LD A,E ; is ji DIV 16 DO  ; BEGIN push(xx); xx := ; t := t-1 END  ; xx := xx AND unbitr[i MOD 16]; t := i DIV 16  ; WHILE t >= 0 DO RA )RRA )OR H ; A = jdiv )LD (JDIV),A )LD H,00H )LD DE,BITTER )ADD HL,DE (.ENDC  (LD ' e of the set on the stack  SVDIF .EQU WORD1 (; Algorithm...  ; szfinal := GETBYTE; pop(szorig);  )ADD HL,SP )EX DE,HL ; DE := sp, HL := -(szfinal-szorig) )ADD HL,SP ; HL := sp-(szfinal-szorig ; .IF szfinal <> szorig THEN  ; .IF szorig > szfinal THEN  ; BEGIN (* crunch set *)  ; dst := SP+szorig-1; src) )LD SP,HL )EX DE,HL ; all set up for transfer )LD A,C ; but skip if szorig=0 )OR B  := SP+szf-1;  ; THRU szfinal DO  ; BEGIN dst^ := src^; dst := dst-1; src := src-1 END;  ; SP := dst+)JP Z,$20 )LDIR ; move stuff  $20 LD A,(SVDIF) ; set BC := szfinal-szorig )CPL )LD 1  ; END  ; ELSE (* expand set *)  ; BEGIN  ; src := SP; dst := SP-(szfinal-szorig); SP := dst;  ;  C,A )LD A,(SVDIF+1) )CPL )LD B,A )INC BC )LD A,00H ; Do zero filling... )LD (DE),A THRU szorig DO  ; BEGIN dst^ := src^; dst := dst+1; src := src+1 END;  ; THRU (szfinal-szorig) DO BEGIN ds)LD L,E ; Block move trickiness )LD H,D )INC DE )DEC BC )LDIR )JP BACK1 (.ENDC  (.IF ~Z8t^ := 0; dst := dst+1 END ;  ; END  ; NOTE: no zero checking on the part of the set that is crunched out.  (.IF Z80 0 (; for 8080, things are done in words rather than bytes )LD A,(BC) ; A := szfinal )INC BC )POP HL )LD A,(BC) )INC BC )LD L,A )LD H,00H )ADD HL,HL )EX DE,HL )POP HL )ADD HL,HL ; HL  ; L := szorig )CP L ; szfinal-szorig )JP Z,BACK )PUSH HL ; so it doesn't get mes:= szorig (in bytes) )SUBHLDE ; compare szorig-szfinal )JP Z,BACK )ADD HL,DE )SAVIPC )JP M,$10 sed up )SAVIPC )POP HL )JP NC,$10 ); Crunch the set )LD B,A ; B := # words to transfer )ADD HL,(; Crunch set )LD C,E ; BC := # bytes to move )LD B,D HL ; HL := sp+szorig (dst+1) )ADD HL,SP )EX DE,HL )ADD HL,HL )ADD HL,SP ; HL = src+1, DE = )ADD HL,SP ; Compute dst := sp+szorig-1 )DEC HL )EX DE,HL ; DE := dst )ADD HL,SP dst+1,  $05 DEC HL ; B = # words to transfer )DEC DE )LD A,(HL) )LD (DE),A )DEC HL )DEL (JP BACK1  $99 LD HL,0000H (PUSH HL (JP INVNDX "  UNBITR .WORD 0FFFFH (.WORD 0FFFEH (.WORD ; Compute src := sp+szfinal-1 )DEC HL ; HL := src )LDDR ; move the stuff )EX DE,HL  0FFFCH (.WORD 0FFF8H (.WORD 0FFF0H (.WORD 0FFE0H (.WORD 0FFC0H (.WORD 0FF80H (.WORD 0FF00H (.WORD 0FE00H  ; and cut back the stack )INC HL )LD SP,HL )JP BACK1  $10 ; Expand set )LD C,L ; BC :=(.WORD 0FC00H (.WORD 0F800H (.WORD 0F000H (.WORD 0E000H (.WORD 0C000H (.WORD 08000H "  ADJ ; Fix the siz # bytes to move )LD B,H )SUBHLDE )LD (SVDIF),HL ; (SVDIF) := -(szfinal-szorig) )EX DE,HL )LD HL,0000H( C DE )LD A,(HL) )LD (DE),A )DEC B )JP NZ,$05 )EX DE,HL ; now fix up SP )LD SP,HL )JP ; A = i mod 16, (IDIV) = i div 16 )LD B,(HL) )LD C,A )LD A,B (.ENDC  (.IF ~Z80  BACK1  $10 ; Expand the set )LD B,L ; B := # words to move )SUB L  ; drag... )LD A,C )AND 0FH )LD L,A ; L = i mod 16 )LD A,B )RLA )RLA )RLA )RLA )LD H,A )LD C,A ; C := # words to zero fill )CPL )INC A ; A := -(szfinal-szorig) )LD L,A )LD A,C ; H = i div 16, high 4 bits )AND 0F0H )RRA )RRA )RRA )RRA )OR H )LD B,A )LD C,L  ; HL := A, sign extended )LD H,0FFH )ADD HL,HL )ADD HL,SP ; HL = SP-(szfinal-szorig) )EX DE,HL(.ENDC  (CP E ; is set big enough to contain i ? (JP NC,$20 (LD A,C ; DE := bit  )LD HL,0000H )ADD HL,SP )EX DE,HL ; DE := SP )LD SP,HL )LD A,B ; check for szorigoffset in byte (AND 07H (LD E,A (LD D,00H (LD HL,INMASK =0 )TSTA )JP Z,$30  $20 LD A,(DE) ; move stuff )LD (HL),A )INC DE )INC HL )LD A,(DE)(ADD HL,DE ; HL = ^INMASK[i mod 8] (LD A,(HL) (PUSH AF ; save mask for a bit (LD L,B )LD (HL),A )INC DE )INC HL )DEC B )JP NZ,$20  $30 LD A,00H ; now do zero filling  $ ; HL := ^needed byte of set_a (LD H,00H (INC HL (INC HL ; take care of extra 2 word on40 LD (HL),A )INC HL )LD (HL),A )INC HL )DEC C )JP NZ,$40 )JP BACK1 (.ENDC   INN ;  stack (ADD HL,HL (LD A,C ; now add 1 to address if in high byte of word (AND 08H ; is b ------------------------------------------------- (; ! sza ! set_a ! i ! rest of stack (; --------------------------it 3 of i mod 16 on ? (JP Z,$10 (INC HL  $10 ADD HL,SP (POP AF (AND (HL) ; AND that by----------------------- (; is i in set_a ?  (SAVIPC (POP HL ; E := sza (LD E,L (ADD HL,HL te and the mask (JP Z,$20 ; decide what to do now (POP HL (LD SP,HL (LD HL,0001H (PUSH HL (ADD HL,SP ; HL = ^i (LD C,(HL) ; BC := i (INC HL (LD B,(HL) (INC HL (PUSH HL (JP BACK1  $20 POP HL (LD SP,HL (LD HL,0000H (PUSH HL (JP BACK1  $99 POP HL (LD  ; (SP) := ^rest of stack (LD HL,0F010H ; is i >= 16*255 or < 0 ? (ADD HL,BC (JP C,$99 (; SP,HL (LD HL,0000H (PUSH HL ; after cleaning up stack... (JP INVNDX ; bomb the program  convert i to word and bit within word (; B := word, C := bit (.IF Z80 )LD HL,IDIV )LD (HL),C )LD A,B )RRD   INMASK .BYTE 01H (.BYTE 02H (.BYTE 04H (.BYTE 08H (.BYTE 10H (.BYTE 20H (.BYTE 40H (.BYTE 80H ( ) L  ;  ; B = szb, A = sza  (SAVIPC (POP HL ; return_address (EX (SP),HL ; HL := szb (LD B,L ; B := szb (INC HL ; skip over return_addr on stack (ADD HL,HL ; HL := ^sza (ADD HL,SP (LD A,(HL) ; A := sza (LD (NEWSP),HL ; keep future SP around (INC HL (INC ; End-of-File SET2 (   (.IF ~LSTSET ).NOLIST (.ELSE ( .LIST (.ENDC  ;Copyright (c) 1978  ; by the Regents of the University of California, San Diego   ; start of file SET1    ;************************************************  ;*************** Set arithmetic *****************   SETUP ; routine to give needed information about sets on (; stack to INT, DIF, and UNI set operators.  ; before -------------------------------------------------------------  ; ! ret ! szb ! set_b ! sza ! set_a ! rest of stack  ; -------------------------------------------------------------  ; !  ; SP  ;  ; aftO^er -------------------------------------------------------------  ; ! set_b ! sza ! set_a ! rest of stack  ;  -------------------------------------------------------------  ; ! ! !  ; SP (NEWSP) H*  SETUP (CP B ; B := min(sza,szb) (JP NC,$10 (LD B,A  $10 LD A,B (TSTA (JP Z,op. (DEC DE (LD A,(HL) (LD (DE),A (DEC HL (DEC DE (LD A,(HL) (LD (DE),A (DJNZM $60 ($30  $20 POP DE ; difference loop (LD A,E (CPL (AND (HL) (LD (HL),A (INC HL (LD ; DE = ^result_set (EX DE,HL (LD SP,HL (PUSH BC (JP BACK1    "  A,D (CPL (AND (HL) (LD (HL),A (INC HL (DJNZM $20  $30 LD HL,(NEWSP) (LD SP,HL (JP  POWRC ; set compares. very gross. (; (see SETUP below for picture of two sets on a stack)  ALEQB .EQU BYTE1  BACK1   UNI ; Set union (CALL SETUP (CP B ; decide what kind of union to do... (JP C,$30  ; boolean filled by PCSETUP (POP HL ; junk return address - each comparison will @; push a result (; fi(LD A,B ; Uniona. Union set_b into set_a. (TSTA (JP Z,$20  $10 POP DE ; Uniona lnd what rel_op to do (DEC BC ; A := p-machine op that got us here (DEC BC (LD A,(BC) (ADD A,A oop. (LD A,E (OR (HL) (LD (HL),A (INC HL (LD A,D (OR (HL) (LD (HL),A (INC HL (DJN ; A := index into PCTBL (SUB 5EH (LD E,A ; HL := ^jump address (LD D,00H (LD HL,P HL (RET   INT ; Set intersection. AND set_b into set_a, then zero-fill (; set_a if sza>szb (CALL SETUP (SUBZM $10  $20 LD HL,(NEWSP) (LD SP,HL (JP BACK1  B ; B := min(sza,szb), C := max(sza-szb, 0) (JP NC,$10 (ADD A,B (LD B,A (CLRA  $10 LD $30 ; Unionb. Szb>sza, so union set_a into set_b, then move set_b (; up to newly created top of stack (LD C,A  C,A (LD A,B ; if min(sza,szb)=0, skip intersection loop (TSTA (JP Z,$30  $20 POP DE  ; C := sza (PUSH BC ; push szb (EX DE,HL ; DE := ^set_a (LD HL,0002H ; HL ; intersection loop (LD A,E (AND (HL) (LD (HL),A (INC HL (LD A,D (AND (HL) (LD  := ^set_b (ADD HL,SP (LD B,C (LD A,B (TSTA (JP Z,$50  $40 LD A,(DE) ; Unionb loop. (HL),A (INC HL (DJNZM $20  $30 LD A,C (TSTA ; if sza <= szb, no zero-fill (JP Z,$50(OR (HL) (LD (HL),A (INC DE (INC HL (LD A,(DE) (OR (HL) (LD (HL),A (INC DE (INC  (LD B,A (CLRA  $40 LD (HL),A (INC HL (LD (HL),A (INC HL (DJNZM $40  HL (DJNZM $40  $50 ; DE = ^just past set_a (LD HL,(NEWSP) ; HL := ^just past set_b (POP BC  $50 LD HL,(NEWSP) (LD SP,HL (JP BACK1   DIF ; Set difference. AND (NOT set_b) into set_a. (CALL  ; szb is number of words to move (LD C,B ; C := result_set size  $60 DEC HL ; move lo+ (INC HL ; HL := ^sza (ADD HL,HL (ADD HL,SP (LD C,(HL) ; C := sza (INC HL ise (POP HL (LD (RETADR),HL (CALL PCSETUP (JP Z,$20  $10 POP DE (LD A,E (CP (HL) ( ; HL := ^set_a (INC HL (PUSH HL (LD E,C ; HL := newsp (LD D,00H (ADD HL,DE (ADD JP NZ,$40 (INC HL (LD A,D (CP (HL) (JP NZ,$40 (INC HL (DJNZM $10  $20 ; so  HL,DE (LD (NEWSP),HL (POP HL ; HL := ^set_a again (LD E,0 ; aleqb := false (LD far sets are equal. make sure larger has zeroes from here on. (LD A,(ALEQB) (TSTA (JP NZ,$30 (; set_a is larger A,B ; A := szb-sza (SUB C (JP C,$10 ; B := min(sza, szb) (INC E ; aleqb := t(CALL ZERCHKA (JP $50  $30 ; set_b is larger (CALL ZERCHKB (JP $50  $40 LD C,00H  $5rue (LD B,C  $10 LD C,A ; C := szb-sza (LD A,E ; Store aleqb (LD (ALEQB),A 0 LD HL,(RETADR) (JP (HL)   ; At last, the comparison operators reached via PCTBL  PCEQL CALL PCEQSN (J(LD A,B ; Zero flag := (B = 0) (TSTA (RET   ZERCHKA ; insure rest of set_a is zeroes (POP DE P PCRSLT   PCNEQ CALL PCEQSN (LD A,01H ; want NOT C as result (XOR C (LD C,A  PCRSLT L ; return_address (LD SP,HL (CLRA ; negate C, cause it tells how much set_b is (SUB C D HL,(NEWSP) (LD SP,HL (LD B,00H (PUSH BC (JP BACK1   PCLEQ ; see if set_a subset_of set_b, ie., ; bigger than set_a (LD C,A (EX DE,HL (JP ZER0  ZERCHKB ; insure rest of set_b is zeroes  (set_a - set_b) = null_set (CALL PCSETUP (JP Z,$20  $10 POP DE (LD A,E (CPL (AND (HL) (JP (; SP = ^place to start, C = # of words to check (; return C = 1 (yep, only zeroes), or 0 (nope)  RETADR2 .EQU WORD1 (PO NZ,PCFALSE (INC HL (LD A,D (CPL (AND (HL) (JP NZ,PCFALSE (INC HL (DJNZM $10  $20 ; so CTBL (ADD HL,DE (LD E,(HL) ; HL := jump address (INC HL (LD D,(HL) (EX DE,HL (JP (HL)P HL  ZER0 LD (RETADR2),HL (LD A,C ; need to check anything ? (TSTA (JP Z,$20 (; yep...    PCTBL .WORD PCEQL (.WORD PCGEQ (.BLOCK 6 (.WORD PCLEQ (.BLOCK 4 (.WORD PCNEQ   ; Routines used i(LD B,C ; ...set up loop control... (LD C,00H ; ...and assume we're not going to make it (CLRn comparisons of sets...  PCSETUP ; return HL = ^set_a, SP = ^set_b (; B = min(sza,szb), C = szb-sza, Zero flag set ifA  $10 POP DE (OR E (OR D (JP NZ,$30 (DJNZM $10  $20 LD C,01H ; we did make  B = 0 (POP HL ; return_address (EX (SP),HL ; B := HL := szb (LD B,L it...set is zero filled  $30 LD HL,(RETADR2) (JP (HL)   PCEQSN ; return c = 1 if set_a = set_b, C = 0 otherw, CRSLT  PCFALSE LD C,00H (JP PCRSLT   PCGEQ ; see if set_a superset_of set_b, ie., (set_b - set_a) = null set (CALL PCSETUP (JP Z,$20  $10 POP  DE (LD A,(HL) (CPL (AND E (JP NZ,PCFALSE (INC HL (LD A,(HL) (CPL (AND D (JP NZ,PCFALSE (INC HL (DJNZM $10  $20 ; everything's alright so far. check zeroes (LD A,(ALEQB) ; If set_b is bigger, zerocheck it (TSTA (CALL NZ,ZERCHKB (JP PCRSLT (  ; End-of-File SET1 (   (.IF ~LSTSTP ).NOLIST (.ELSE ).LIST (.ENDC  ;Copyright (c) 1978  ; by the Regents of the University of California, San Diego   ; start of file STP    ;********************************************************  ;*****************Standard Procedures*******************;   CSP ; Call standard procedure (; extension opcodes and assembly intrinsics. (LD A,(BC) ;get proc number (INC BC (SAVIPC ;for simplicity (LD E,A ;index CSPTBL and jump indirect (LD D,00H (LD HL,CSPTBL (ADD HL,DE (ADD HL,DE (LD E,(HL) (INC HL (LD D,(HLO^) (EX DE,HL (JP (HL)   CSPTBL ;Standard Procedure transfer table (.WORD IOC ; 0 (.WORD NEW (. WORD MVL (.WORD MVR (.WORD EXIT (.WORD UREAD ; 5 (.WORD UWRITE (.WORD IDS (.WORD TRS (.WORD TIM (.WORD FLC ; 10 (.WORD SCN (.WORD 0 (.WORD 0 (.WORD 0 (.WORD 0 ; 15 (.WORD 0 far nothing is amiss (LD A,(ALEQB) ; if set_a is bigger, zerocheck it (TSTA (CALL Z,ZERCHKA (JP P-  (HL),D (RETURN   RLS ; release(VAR i: ^integer) store contents of i into NP (POP HL (LD E,(HL) (INC )LD D,H )INC DE )LDIR (.ENDC (.IF ~Z80 )CALL NEGBC ; negate count for easier loop control )JP P,BA HL (LD D,(HL) (EX DE,HL (LD (NP),HL (LD HL,NIL ; GDIRP := NIL (LD (GDIRP),HL (RETURN  CK1 ; and check for count <= 0  $10 LD (HL),E )INC HL )INC C )JP NZ,$10 )INC B )JP NZ,$(.WORD 0 (.WORD 0 (.WORD 0 (.WORD 0 ; 20 (.WORD GSEG (.WORD RSEG (.WORD TNC (.WORD RND (.  NEW ; new(VAR p: ^; size_p: integer) (; p := NP; NP := NP+size_p (CALL CGDIRP ; release GDIRP if necessary WORD SIN ; 25 (.WORD COS (.WORD LOG (.WORD ATAN (.WORD LN (.WORD EXP ; 30 (.WORD SQT(POP BC ; BC := size_p (POP DE ; DE := ^p (LD HL,(NP) ; p := NP (EX DE,H (.WORD MRK (.WORD RLS (.WORD IOR (.WORD UBUSY ; 35 (.WORD POT (.WORD UWAIT (.WORD UCLEAR (.WORDL (LD (HL),E (INC HL (LD (HL),D (EX DE,HL ; then extend heap (ADD HL,BC (ADD HL,BC  HLT (.WORD MEMA ; 40 (   MEMA ;function MEMAVAIL: integer (* # words of memory left *) ; (LD HL,(N(LD (NP),HL (CALL STKCHK ; check for stack overflow (JP NC,BACK1 (JP STKOVR   CGDIRP ;Check GP) ;compute SP-NP (XOR A (SUB L (LD L,A (LD A,00H (SBC A,H (LD H,A (ADD HL,SP (ANlobal Directory Pointer (;Roger Ramjet strikes again (LD HL,(GDIRP) (LD A,L ;THIS CODE RELIES ON NIL===D A ;convert to words (LD A,H (RRA (LD H,A (LD A,L (RRA (LD L,A (PUSH HL 1.!.!.!.!.!.!. (DEC A (OR H (RET Z ;if eql nil then nothing special (LD (NP),HL ;els ;return function value (JP BACK1    TIM ; Time(var hitime, lotime:integer) - Roger Ramjet strikes again (;e release GDIRP from heap (LD HL,NIL (LD (GDIRP),HL (RET   ;**********Editor Intrinsics********* (.IF Z80  TST Presumably the real-time clock increments the two words (; LOTIME and HITIME every 1/60th of a second (POP DE CNT LD A,B )TSTA )JP M,$10 )OR C ;zero count is also no good )JP Z,$10 )RET  $10 (LD HL,(LOTIME) (EX DE,HL (LD (HL),E (INC HL (LD (HL),D (POP DE (LD HL,(HITIME) (EX  POP HL )JP BACK1 (.ENDC   FLC ; fillchar(buffer: ^; count: integer; ch: char) (POP DE (POP BC (PO DE,HL (LD (HL),E (INC HL (LD (HL),D (RETURN   MRK ; mark(VAR i: ^integer) store NP in i (CALL CP HL (.IF Z80 )CALL TSTCNT ; no work to do if count <= 0 )LD (HL),E ;fill one byte )DEC BC )GDIRP ; release GDIRP if necessary (POP DE (LD HL,(NP) (EX DE,HL (LD (HL),E (INC HL (LD LD A,B ;are we done? )OR C )JP Z,BACK1 )LD E,L ;if not then propagate char . (.ENDC (.IF ~Z80 )CALL NEGBC )JP P,BACK1 )LD A,C ; move word at a time )AND 01H )JP NZ,$20 20 (RET  $30 LD A,E ; A := ch  $40 CP (HL) (RET Z (DEC HL (INC C  $10 DEC HL )DEC DE )LD A,(HL) )LD (DE),A )INC C  $20 DEC HL )DEC DE )LD A,(HL) )L(JP NZ,$40 (INC B (JP NZ,$40 (RET  SCPST ;scanpast(........ (CALL SPARMS  SCPSTX LD A,B D (DE),A )INC C )JP NZ,$10 )INC B )JP NZ,$10 (.ENDC (RESTORE   SCN ; scan(maxdisp: integer; f ; which way to scan ? (TSTA (JP M,$70 (CALL NEGBC (RET P ; done if maxdisp = 0 (LD A,E orpast: (forch, pastch); ch: char; (; start: ^; mask: PACKED ARRAY[0..7] of boolean): integer (; scan until either (;  $60 CP (HL) (RET NZ (INC HL (INC C (JP NZ,$60 (INC B (JP NZ,$60 (RET  $70 LD  maxdisp characters examined, or (; a match (if forpast=forch) or non-match (if forpast=pastch) occurs. (; as function valu A,E  $80 CP (HL) (RET NZ (DEC HL (INC C (JP NZ,$80 (INC B (JP NZ,$80 (RET  SPA10 (.ENDC (RESTORE   MVBS ; movebytes(source, dest: ^; length:integer); (POP BC (POP DE (POP HL (LD e return end_position-start (POP HL ; junk the mask (fuckin' Richard)  A,L ; moveleft or moveright ? (SUB E (LD A,H (SBC A,D (JP C,RMOV (JP LMOV  MVL ;m(POP HL ; HL := start (POP DE ; E := ch (POP AF ; Carry flag set if scan poveleft (POP BC (POP DE (POP HL  LMOV ; entry point if from generalized movebytes (.IF Z80 )CALL TSTCNT ast (POP BC ; BC := maxdisp (PUSH HL ; (SP) := start, so as to make function @; value easy t)LDIR (.ENDC (.IF ~Z80 )CALL NEGBC )JP P,BACK1 )LD A,C ; move word at a time for extra speed )AND o calculate later (JP NC,$10 (CALL SCPSTX (JP SCOUT  $10 CALL SCFORX  SCOUT ; function return HL_fina 01H )JP NZ,$20  $10 LD A,(HL) )LD (DE),A )INC HL )INC DE )INC C  $20 LD A,(HL) )LDl-HL_initial (POP DE ;saved initial (SUBHLDE (PUSH HL (RESTORE   SCFOR ; scanfor(maxdisp:integer; c (DE),A )INC HL )INC DE )INC C )JP NZ,$10 )INC B )JP NZ,$10 (.ENDC (RESTORE h: char; start: ^; (; mask: PACKED ARRAY[0..7] OF boolean): integer (CALL SPARMS  SCFORX INC B  MVR ;moveright (POP BC (POP DE (POP HL  RMOV ; entry from movebytes (EX DE,HL ; start a ;test for scan up or down (DEC B (JP M,$30 (CALL NEGBC (RET P ; maxdisp = 0 ? (LD At other end of arrays (ADD HL,BC (EX DE,HL (ADD HL,BC (.IF Z80 )CALL TSTCNT )DEC HL )DEC DE )LDDR ,E ; A := ch  $20 CP (HL) (RET Z (INC HL (INC C (JP NZ,$20 (INC B (JP NZ,$/ range (* index into symbufarray *);  ; sy: symbol (* symbol = (ident..othersy), set by info in reswrdtable *);  ; op: op " (.WORD 6., 15. (.ASCII "DOWNTO " (.WORD 8., 15. (.ASCII "ELSE " (.WORD 13., 15. (.ASCII "END " (.WOerator (* more info from reswrdtable *);  ; id: alfa (* packed array [1..8] of char, gets filled with first 8 chars  ; RD 9., 15. (.ASCII "EXTERNAL" (.WORD 53., 15. (.ASCII "FOR " (.WORD 24., 15. (.ASCII "FILE "  of token isolated by IDSRCH if token is an identifier *);   ; Isolate token, converting to upper case.  ; If token in r(.WORD 46., 15. (.ASCII "FORWARD " (.WORD 34., 15. (.ASCII "FUNCTION" (.WORD 32., 15. (.ASCII "GOTO " (.WORD eswrdtable set sy and op from table,  ; else set st := ident, and put first 8 chars (left-justified) of  ; token into id.   26., 15. (.ASCII "IF " (.WORD 20., 15. (.ASCII "IMPLEMEN" (.WORD 52., 15. (.ASCII "IN " (.WORD 41.,14; symcursor is left pointing to the last char of the token   SYMCUR .EQU WORD1 ; index into symbufarray  SYMBU. (.ASCII "INTERFAC" (.WORD 51., 15. (.ASCII "LABEL " (.WORD 27., 15. (.ASCII "MOD " (.WORD 39., 4 (.ASCIIFP .EQU WORD2 ; ^symcursarray  RESWRDP .EQU WORD3 ; ^reswrdtable  IDEND .EQU WORD4 ;  "NOT " (.WORD 38., 0 (.ASCII "OF " (.WORD 11., 15. (.ASCII "OR " (.WORD 40., 7 (.ASCII "PACKED "loop control  TOKEN .EQU BLOCK1 ; first 8 chars of isolated token goes here   RESTBL ; reswrdtable  (.WORD 43., 15. (.ASCII "PROCEDUR" (.WORD 31., 15. (.ASCII "PROGRAM " (.WORD 33., 15. (.ASCII "RECORD " (.WORD(; TYPE table = RECORD (; indexes: ARRAY ['A'..succ('Z')] OF integer; (; tokens: ARRAY [0..#] O 45., 15. (.ASCII "REPEAT " (.WORD 22., 15. (.ASCII "SET " (.WORD 42., 15. (.ASCII "SEGMENT " (.WORD 33., RMS ; get params for scanfor or scanpast (; (SP) := SCOUT; (SP+2):=HL:=start; E:=ch; BC:=maxdisp (POP HL ; rF RECORD (; tokenname: alfa; (; tokentype: symbol; (; eturn_addr (POP DE ; junk mask (POP DE ; DE := start (POP BC ; A := ch (L optype: operator (; END (; END;  ; Index part (.WORD 0, 2, 3, 5, 8, 11., 15., D A,C (POP BC ; BC := maxdisp (PUSH DE (PUSH HL (EX DE,HL (LD E,A (RET     ;*16., 16. (.WORD 20., 20., 20., 21., 22., 23., 25., 28., 28. (.WORD 30., 33., 36., 39., 40., 42., 42., 42., 42.  ; Array par*********Compiler Intrinsics******   ; idsearch(VAR symcursor: cursrange; symbufp: ^symbufarray)  t (.ASCII "AND " (.WORD 39., 2 (.ASCII "ARRAY " (.WORD 44., 15. (.ASCII "BEGIN " (.WORD 19., 15. (.ASCII ; The following declaration order for the compiler is assumed, as IDSCH is  ; passed only ^symcursor.  ; symcursor: curs "CASE " (.WORD 21., 15. (.ASCII "CONST " (.WORD 28., 15. (.ASCII "DIV " (.WORD 39., 3 (.ASCII "DO 0 (.ASCII "USES " (.WORD 49., 15. (.ASCII "VAR " (.WORD 30., 15. (.ASCII "WHILE " (.WORD 23., 15. (.ASCII 41H+26. ; 'Z' (JP C,$60  $50 CP 30H ; '0' (JP C,SCDONE (CP 39H+1H ;  "WITH " (.WORD 25., 15.   ; Initialize: put passed and synthesized parameters into fixed locations  ; and blank-fi'9' (JP NC,SCDONE  $60 ; this is an okay character (DEC B (JP M,$70 (INC HL (LD (HL),A  $70 ll TOKEN.   IDS LD HL,RESTBL ;old version entry point (JP IDSRCHX  IDSRCH POP HL  IDSRCHX LD  INC DE ;inc source pointer (JP $30   ; we have an identifier...  (RESWRDP),HL (POP HL (LD (SYMBUFP),HL (POP HL (LD (SYMCUR),HL (LD HL,TOKEN (LD A,20H  SCDONE LD HL,(SYMBUFP) ;calc new SYMCUR := DE-1-(SYMBUFP) (SCF (LD A,E (SBC A,L (LD E,A (LD A ; ' ' (LD B,07H ; blank-fill last 7 chars  $10 INC HL (LD (HL),A (DJNZM $10  (; Copy t,D (SBC A,H (LD D,A (LD HL,(SYMCUR) ;stash new index (LD (HL),E (INC HL (LD (HL),D   ; he first 8 chars of the token into TOKEN and set SYMCUR (; to point at the very last character. (LD HL,(SYMCUR) ; DLocate TOKEN in reswrdtable if possible (LD A,(TOKEN) ;first char as index (CALL CALCAD ; HL := ^start E := ^beginning of token (LD E,(HL) (INC HL (LD D,(HL) (LD HL,(SYMBUFP) (ADD HL,DE (EX DE,HL looking record (PUSH HL (LD A,(TOKEN) ; succ(first char) as index (INC A (CALL CALCAD ; (IDEND(LD HL,TOKEN ; HL := ^dest (; HL^ := translate(DE^); DE := DE+1; B := 7; ) := ^stop looking record (LD (IDEND),HL (POP DE  $100 LD A,L ; done looking yet ? (SUB E (; WHILE translate(DE^) IN ['A'..'Z', '0'..'9'] DO (; BEGIN (; IF B>0 THEN (; BEGIN B := B-1; HL := HL+1; HL^ :(JP NZ,$110 (LD A,H (SBC A,D (JP Z,NOTOKE  $110 PUSH DE ; save for next time around (= translate(DE^) END; (; DE := DE+1 (; END (LD B,7 (LD A,(DE) (AND 7FH (CP 60H (JP C,$20 (SLD B,7 ;comp for 7 chars (first is okay) (LD HL,TOKEN+1  $120 INC DE (LD A,(DE) (CP UB 20H  $20 LD (HL),A (INC DE  ; the identifier scan loop  $30 LD A,(DE) ;get cha (HL) (JP NZ,$130 (INC HL (DJNZM $120 (JP IDMATCH 15. (.ASCII "SEPARATE" (.WORD 54., 15. (.ASCII "THEN " (.WORD 12., 15. (.ASCII "TO " (.WORD 7., 15. (.Ar (AND 7FH ;mask bit 7 out (CP 5FH ;Underscore _ is ignored (JP Z,$70 (CP 60H SCII "TYPE " (.WORD 29., 15. (.ASCII "UNIT " (.WORD 50., 15. (.ASCII "UNTIL " (.WORD 10., 15.  ;translated to upper case (JP C,$40 (SUB 20H  $40 CP 41H ; 'A' (JP C,$50 (CP 1 . ; size of indexes (LD HL,(RESWRDP) (ADD HL,DE (ADD HL,BC ;do final indexing, leave junk in HL E,(HL) ;get link (INC HL (LD D,(HL) (LD A,E ;test for NIL link (DEC A (OR D  $130 POP DE ; ^record we just looked at (LD HL,0CH ; size of each record (ADD HL,DE ( (RET     ; treesearch(rootp: ^node; VAR foundp:^node; VAR target: alfa): integer   ; TYPE node = RECORD  ; EX DE,HL (LD HL,(IDEND) (JP $100   IDMATCH POP HL ; junk ^record we're looking at (LD  key: alfa;  ; rlink: ^node;  ; llink: ^node  ; END;  ; function returns. HL,(SYMCUR) ;match, now return type and op (INC HL (INC HL ; HL = ^sy, DE = ^tokentype (in table) -..  ; 0: foundp points to matching node  ; +1: foundp points to a leaf, and target>foundp.key 1 (LD B,04H  $150 INC DE (LD A,(DE) (LD (HL),A (INC HL (DJNZM $150 (JP BACK1   NOTOKE ; -1: foundp points to a leaf, and target*4   ; General  .BLOCK 4H (.ENDC (   .IF NMS  ;Stuff for Northwest Micro disk densitys use reusable temporaries  WORD1 .WORD 0  WORD2 .WORD 0  WORD3 .WORD 0  WORD4 .WORD 0  BLOCK1 .BLOCK  .BLOCK 3 ;to align with I.4  FLGLF .BYTE 0FFH  FMTD0 .BYTE 0  FMTD1 .BYTE 0 (.BLOCK 7H 08H  BYTE1 .WORD 0   ; Transcendental fp temporaries  TFPT .BLOCK 26.   ; Procedure temporaries  TPROC .BL5 (.BYTE 08H ; [BS] - left (.BYTE 1CH ; [FS] - right  SYEOF .BYTE 03H ; ^C  FLUSH  INVNDX LD L,01H ; Invalid index (JP XEQERR  NOPROC LD L,02H ; Non-existent segment (JP .BYTE 06H ; ^F  BREAK .BYTE 00H  STOP .BYTE 13H ; ^S (.BYTE 08H ; ^H - cha XEQERR  NOEXIT LD L,03H ; Exitting procedure never called (JP XEQERR  STKOVR LD HL,INTEND rdel (.BYTE 3FH ; ? - badch (.BYTE 7FH ; [del] - linedel (.BYTE 1BH ; [esc] - altmo ; stack overflow (LD (NP),HL ; prevent recursive overflow (LD L,04H (JP XEQERR de (.BLOCK 06H ; expansion  SEGTBL .BLOCK 2*3*    !  ;********************** I - FETCH ****** INTOVR LD L,05H ; Integer overflow (JP XEQERR  DIVZER LD L,06H ; Divide by zero (JP *****************; %  BACK1 GETIPC (JP BACK   SLDCI ; Short load constant word (RRA (LD L,A (LD H,00 XEQERR  BADMEM LD L,07H ; Bad memory access (PDP-11 error only) (JP XEQERR  UBREAK LD L,08H H (PUSH HL   BACK LD A,(BC) ; get opcode (INC BC ; increment IPC (ADD A,A (JP  ; User break (JP XEQERR  SYIOER LD L,09H ; System IO error (JP XEQERR  UIOERR LD L,0A NC,SLDCI ; if bit 7 zero push constant (; else decode op and jump to routine (LD H,ROM/100H (LD L,A H ; User IO error (JP XEQERR  NOTIMP SAVIPC ; Instruction not implemented (LD L,0BH (J ; HL points to routine address in jump table (LD E,(HL) ; get address (INC HL (LD D,(HL) P XEQERR  FPIERR LD L,0CH ; Floating point error (JP XEQERR  S2LONG LD L,0DH ; Stri(EX DE,HL (JP (HL) ; and go there      ;**************** RUN-TIME ERROR SUPPORT ****************ng too long (JP XEQERR  HLT SAVIPC ; Unconditional halt (LD L,0EH (JP XEQERR  BPTHLT L; "  XEQERR ; a run-time error has occured. pass some parameters (; through syscom, then do a CXP 0,2 (PROCEDURE execerrorD L,0FH ; Conditional halt or breakpoint (JP XEQERR "   BPT ; Conditional halt or breakpoint (CALL) (LD H,00H ; HL = error # (LD (XERRCD),HL (LD HL,-14. ; size of execerror stack frame (MSCW GBDE (EX DE,HL ; save line number (LD (HLTLINE),HL (EX DE,HL (SAVIPC (LD A,(BUGSTA) +with temp) (ADD HL,SP (LD (BOMBP),HL ; (BOMBP) := ^exerror MSCW (LD HL,(IPCSAV) (LD (BOMIPC),HL (L(CP 3 (JP P,BPTHLT (; not in stepping mode, so check for breakpoint (LD HL,BRKPTS (LD B,4  $10 LD D BC,CXP02 (NOP ; leave here - handy for debugging (JP BACK  CXP02 .BYTE 77.+128., 0, 2   A,E (CP (HL) (INC HL (JP NZ,$20 (LD A,D (CP (HL) (JP Z,BPTHLT  $20 INC HL (DJN6  ; get back ipc, bu don't touch DE (EX DE,HL ; HL := ^seg just read in  $20 LD (NEWSEG),HL (CALL BLDXNL ; build a MSCW (JP CIPXNL ; then set up stat link  (  READSEG ; read in segment from disk, setting newseg, segbot (; use seg_num as index into segment directory... (LD HL,(SEGNUM) ; HL := 6*seg_nuZM $10 (JP BACK1   ; End-of-File INTERP   ; Copyright (c) 1978  ; by Regents of the University of California  ; San Diego   ; Start of file PROC2   CXP ; Call external (different segment) procedure (; Find or read in desired seg, then CIP it (LD A,(BC) ; A := seg_num (INC BC (LD HL,(SEGP) ; are we already in this seg. (can happen (CP (HL) ; when op sys does calls to read, etc.) (JP Z,CIP (AND A ; is this a call to the op sys (seg 0) ? (JP NZ,$10 (; this IS a call to op sys (INC A ; indicate CXP via a 1 in A... (PUSH AF ; ...and push Carry BLDS BLDE O^= false, to inidicate no @; code has been read in (LD HL,(INTSEGT) ; bump up refcount, and set (INC HL  ; (NEWSEG) := MEMTOP (LD (INTSEGT),HL (LD HL,(MEMTOP) (JP $20  $10 ; Call to arbitrary, different segment (SAVIPC (; A = segnumber, so (CALL GETSEG ; get segment into memory (LD A,1 ; indicate this is a CXP call (PUSH AF ; carry flag set or reset by GETSEG (GETIPC 7 DEC HL (DEC HL (DEC HL (LD B,(HL) (DEC HL (LD C,(HL) (PUSH BC (LD HL,04H ; beg(; Given newseg = ^segment, segbot = ^ bottom of segment, (; rlbased0 = ^ base to use in base relocation (; Each proc has iinning address (ADD HL,SP (PUSH HL (PUSH DE ; seg_len (LD HL,(SEGTP) ; block on disk code its own entric to relocate pc relative stuff. (; While we're at it, turn all assembly self-relative entrics (; into absolute s at (DEC HL (LD B,(HL) (DEC HL (LD C,(HL) (PUSH BC (CALL SYSRD (LD A,(IORSLT) ;validataddresses ( (; A := # of procedures in seg (LD HL,(NEWSEG) (INC L (LD A,(HL) (DEC L ; leave the code (AND A (JP NZ,SYIOER (LD HL,(NEWSEG) (LD A,(SEGNUM) (CP (HL) (JP NZ,NOPROC (RET e HL = 2 + ^proc 1 jtab pointer  $10 ; relocate one procedures worth (PUSH AF ; save number of procs left  ; everything appears to be okay ( "  RLLIST ; relocate a bunch of locations pointed to by a list of (; DE := ^jtab for proc. (DEC HL (LD D,(HL) (DEC L (LD A,L (SUB (HL) (LD E,A (LD A,H (SB(; self-relative pointers to memory. (; Passed DE = (^number of nodes) + 2 (; HL = relocation delta (amount to add tC A,D (LD D,A (PUSH HL ; save ^proc jtab pointer (; is relocation needed ? proc # = zero means assemm (LD H,00H (ADD HL,HL (LD E,L (LD D,H (ADD HL,HL (ADD HL,DE (LD DE,SEGTBL+04H ; HL := o each mem loc) (; Returns HL = ^last node (LD (RLDELTA),HL (EX DE,HL (DEC HL ; BC := number of n^seg_len (ADD HL,DE (LD (SEGTP),HL (LD E,(HL) ; DE := seg_len (INC HL (LD D,(HL) (LD odes in list (LD B,(HL) (DEC L (LD C,(HL)  $10 LD A,C ; done yet ? (OR B (RET A,E ; if seg_len = 0 then seg non-existent (OR D (JP Z,NOPROC (LD HL,0 ; (NEWSEG) := SPZ (; nope. set DE := ^word that needs relocating (DEC HL (LD D,(HL) ; nodes are self-relative pointers (D, as that is where proc (ADD HL,SP ; table will end up (remember ret addr.) (LD (NEWSEG),HL EC L (LD A,L (SUB (HL) (LD E,A (LD A,H (SBC A,D (LD D,A (PUSH HL ; save n(POP BC ; grab ret addr. (SUBHLDE ; extend stack by seg_len (INC L ; compeode pointer until next time around (EX DE,HL ; do the relocation (LD A,(RLDELTA) (ADD A,(HL) (LD nsate for ret. addr. messing up (INC HL ; above calculations (LD SP,HL (PUSH BC ; res (HL),A (INC HL (LD A,(RLDELTA+1) (ADC A,(HL) (LD (HL),A (POP HL ; get back node pointetash ret addr. (LD (SEGBOT),HL (; push parameters on stack for read routine... (LD HL,(SEGTP) ; unit number (r... (DEC BC ; ...and try another round (JP $10   RLSEG ; Relocate an entire segment. 8 L,(SEGBOT) (CALL RLLIST (; relocate proc relative stuff (EX DE,HL (LD HL,(PROCBOT) (CALL RLLIST (; that wa handy later (CALL READSEG ; bring in the segment off disk (; Decide how to calc base relocation info... sn't so bad. get back old proc pointer, and # of procs  $20 POP HL (POP AF (DEC A (JP NZ,$10 (; w(; if we are loading in a base segment procedure, (; then calc future base, (; else use current base, as will not chat a relief. All done (RET (   GETSEG ; callable routine to insure a segment is in memory (; takes: A = segnum (; retuhange when seg is called (LD HL,(NEWSEG) (DEC HL ; DE := ^proc1's jtab (LD D,(HL) (DEC L (LDrns: DE = ^seg, carry set if code read in ( (; look in internal table to get refcount for seg (; if refcount > 0, seg in memo A,L (SUB (HL) (LD E,A (LD A,H (SBC A,D (LD D,A (; if assembly procedure then relocate againstry, and so increment refcount. (; otherwise we have to open a space on the stack, read in seg, (; relocate any assembly lang old BASE (; (note that seg 1 disallowed from having BASE relocate stuff (; so it doesn't matter how its base stuff is reluage stuff according to strange and (; mysterious conditions, make the refcount for the seg 1, and ocated) (EX DE,HL (LD A,(HL) (TSTA (JP Z,$05 (; look at proc 1's lex level, if zero then this is a BASE proc(; fill in the entry telling where the seg is. ( ( (POP HL ; save return address (LD (RETADR2),HL (LDedure (INC HL ; point HL at lex level (LD A,(HL) (TSTA (JP Z,$10  $05 ; use current base as  (SEGNUM),A (LD L,A ; calc address of desired refcount (LD H,0 (ADD HL,HL (ADD HL,HL (LD relocation (LD HL,(BASE) (JP $20  $10 ; calculate what base will be (; (Crystal Ball, so many things I need to DE,INTSEGT+1 ; HL := 1 + ^intsegt[segnum].refcount (ADD HL,DE (LD A,(HL) (LD D,A ; save hig know. --Styx) (LD DE,-6 ; HL := 1 + ^parmsize (ADD HL,DE bly proc. (EX DE,HL (LD A,(HL) (TSTA (JP NZ,$20 (; too bad. Change entric to an absolute mem address, andh byte, on the offchance refcount > 0 (DEC L (OR (HL) (JP Z,GSGREAD (; whew...segment is in core. (LD E, store (; that address in (PROCBOT) (DEC HL (DEC L (LD A,L (SUB (HL) (LD (HL),A (LD E,A (HL) ; increment refcount (INC DE (LD (HL),E (INC L (LD (HL),D (INC HL ; now se(INC L (LD A,H (SBC A,(HL) (LD (HL),A (LD D,A (DEC L (EX DE,HL (LD (PROCBOT),HL (;t DE = ^seg (LD E,(HL) (INC L (LD D,(HL) (CLRCF ; indicate no code read in (JP GSGXIT  relocate base relative stuff (LD HL,(RLBASE) (CALL RLLIST (; relocate seg relative stuff (EX DE,HL (LD H GSGREAD ; need to bring in seg off disk (; HL points to low byte of refcount (LD (REFP),HL ; so stash HL, as info9 (LD C,(HL) (EX DE,HL ; set HL := SP-(datasz+parmsize+mscwsize) (ADD HL,BC (LD BC,MSCWSIZE (ADD; otherwise... (; calculate parent of (BASE), ie., MSCW of PROGRAM pascalsystem. (; BC := (MP) (; repeat (; if BC  HL,BC (CLRA (SUB L (LD L,A (LD A,0 (SBC A,H (LD H,A (ADD HL,SP  $20 LD (RLBASE)= system MSCW then die for exitting procedure not called (; change IPC of this MSCW to point to exit code for proc ,HL ; and stash information in a safe place (CALL RLSEG ; relocate the sucker. (; fill in intsegt entries cor(; done := proc and seg of this MSCW match passed parameters (; BC := MSDYN(BC) (; until done;  PROCNUM .EQU WOrectly (LD HL,(NEWSEG) (EX DE,HL (LD HL,(REFP) (INC (HL) ; refcount := 1 (INC L (INC RD1  SYSMSCW .EQU WORD2 (POP HL ; param_proc_num (LD (PROCNUM),HL (POP HL ; param_ HL (LD (HL),E ; and point at new seg (INC L (LD (HL),D  SCF ; and indicaseg_num (LD (SEGNUM),HL (; fix IPC of current proc (LD HL,(JTAB) ; HL := ^exitic (LD DE,EXITIC (ADD te that code was read in  GSGXIT ; leave routine  LD HL,(RETADR2) (JP (HL)     GSEG ; Standard p HL,DE (LD E,(HL) ; DE := exitic (unmodified) (INC HL (LD D,(HL) (SCF ; negativerocedure getseg. (; loads in a segment if it isn't in already (; segnum is on tos. (POP HL (LD A,L  self-relative (LD A,L (SBC A,E (LD L,A (LD A,H (SBC A,D (LD H,A (LD (IPCSAV),HL (; don(CALL GETSEG ; With A = segnum (CALL STKCHK ; make sure we didn't wipe out heap (JP BACK1 (  Re yet ? (LD HL,(JTAB) ; check proc num (LD A,(PROCNUM) (CP (HL) (JP NZ,$10 (LD HL,(SEGP) SEG ; Standard procedure releaseseg  ; bumps down refcount, then junks seg if count goes to 0  POP HL ; check seg num (LD A,(SEGNUM) (CP (HL) (JP Z,BACK1  $10 LD HL,(BASE) ; (SYSMSCW) := ^PA (LD A,L (CALL DECREF ; Decrement refcount for segment # HL  JP NZ,BACK1 (; HL = ^entry in intSCALSYTEM MSCW (LD E,(HL) (INC HL (LD D,(HL) (EX DE,HL (LD (SYSMSCW),HL segt (INC HL ; refcount = 0. set DE := ^seg (LD E,(HL) (INC L (LD D,(HL) (EX DE,HL (LD HL,(MP) ; start at current proc (LD C,L (LD B,H  $20 LD HL,(SYSMSCW)  ; then set SP := ^seg+2 (INC L (INC HL (LD SP,HL (JP BACK1    EXIT ; Exit a specified proc; about to exit pascalsystem ? (LD A,L (SUB C (JP NZ,$30 (LD A,H (SBC A,B (JP Z,NOEXIT  $3(LD D,(HL) ; DE := parmsize, BC := datasz (DEC L (LD E,(HL) (DEC HL (LD B,(HL) (DEC L edure (; fix IPC of current executing procedure to point to exit code. (; if current proc is the one to exit from, JP BACK1 (: PROCEDURE CALLS ; ;***************************************************************; ;***** Jumps ; JTAB format below...see procedure operators EFJ ; Equal false jump (jump if not equal) POP DE POP HL LD 0 ; nope, it's cool. change this MSCW's IPC (LD HL,MSJTAB ; DE := ^proc_num (ADD HL,BC (LD E,(HL) (INC HL (LD D,(HL) (PUSH DE ; for later use (LD HL,EXITIC ; DE := eO^xitic (unmodified) (ADD HL,DE (LD E,(HL) (INC HL (LD D,(HL) (SCF ; DE := exitic (self-relatived) (LD A,L (SBC A,E (LD E,A (LD A,H (SBC A,D (LD D,A (LD HL,MSIPC  ; HL := ^MSIPC (ADD HL,BC (LD (HL),E ; stash new IPC (INC HL (LD (HL),D (DEC HL  ; HL := ^MSSEG (DEC HL (DEC HL (EX DE,HL (; done yet ? (POP HL ; HL = ^proc_num (LD A,(PROCNUM) (CP (HL) (JP NZ,$40 (EX DE,HL ; HL := ^MSSEG (LD E,(HL) (INC HL (LD D,(HL) (EX DE,HL (LD A,(SEGNUM) (CP (HL) (JP Z,BACK1 ; (yea!)  $40 ; go up dynamic link (LD L,C (LD H,B (INC HL (INC HL (LD C,(HL) (INC HL (LD B,(HL) (JP $20  ( (; end of file PROC2 ( (  .IF ~LSTPROC .NOLIST .ELSE ).LIST (.ENDC ; Copyright (c) by Regents of the University of California, San Diego   ;***************************************************************; ; PROGRAM FLOW - JUMPS AND ;  ADD HL,BC ; HL = ^jump entry LD E,(HL) INC HL LD D,(HL) SELREL ccount else jump ADD HL,HL ; and set HL = case table[index] EX DE,HL LD HL,(IPCS ; entry is self-relative JP BACK XJP ; Case jump ; Index is (SP) AV) ADD HL,DE LD C,(HL) INC HL LD B,(HL) DEC HL SUBHLBC  ; In the code, starting on a word boundary, ; are 3 words... ; min index for table  ; entry is negative self relative again. LD C,L LD B,H JP BACK ;***** Pr ; max index ; else jump (point IPC here if index out of table range) ocedure calling and returning ; Variables used... SEGBOT .EQU TPROC ; pointer to bottom of segment RLBASE .EQU  ; ...and the case table jump addresses INC BC ; put HL on word boundary LD  TPROC+2 ; base relocation amount REFP .EQU TPROC+4 ; pointer to relevant refcount PROCBOT .EQU TPROC+ A,L SUB E JP NZ,UJP LD A,H SBC A,D JP NZ,UJP JP NOJ A,C AND 0FEH LD L,A LD H,B LD C,(HL) ; BC = min INC HL  NFJ ; Not equal false jump (jump if equal) POP DE POP HL LD A,L SUB E LD B,(HL) INC HL LD E,(HL) ; DE = max INC HL LD D,(HL) INC H JP NZ,NOJ LD A,H SBC A,D JP NZ,NOJ JP UJP FJP ; False jump L LD (IPCSAV),HL ; save addr of else jump POP HL ; get index EX DE,HL  POP AF ; Sneaky but quick. Carry is bit zero. JP NC,UJP NOJ INC BC  ; HL = max, DE = index, BC = min LD A,D XOR H JP M,$10 LD A,L  JP BACK UJP ; Unconditional jump LD A,(BC) ; get jump offset INC BC  ; decide if index too large... SUB E LD A,H SBC A,D JP P,$20 JP TSTA ; if small then short relative jump JP M,$10 ADD A,C ; BC = BC + A BACK1 $10 AND D JP P,BACK1 $20 EX DE,HL ; ...or too small. LD A,B  LD C,A LD A,00H ADC A,B LD B,A JP BACK $10 LD HL,(JTAB XOR H JP P,$30 AND H JP M,BACK1 ) ; use offset as index in JTAB LD C,A LD B,0FFH ; BC = sign extended offset,0FFH $30 SUBHLBC ; and put index-min in HL JP M,BACK1 INC HL ; take in to a< c table) pointer MSJTAB .EQU +04H ; Caller's jtab pointer MSDYN .EQU +02H ; Dynamic link - pointe LD (BASE),HL ; restore previous base environment LD DE,DISP0 ADD HL,DE LD r to caller's MSCW MSSTAT .EQU +00H ; Static link - pointer to parent's MSCW MSBASE .EQU -02H ; Ba (BASED0),HL ; then fall into RNP RNP ; Return from normal procedure LD HL,(MPD0) ; DE := old sse link (only if CBP) - pointer ; to base MSCW of caller ; Jump table (JTAB) format ; .p (didn't want to index) LD E,(HL) INC HL LD D,(HL) LD A,(BC) ; A :=EQU +01H ; lex level of proc ; .EQU 00H ; proc-num ENTRIC .EQU -02H ; address  Number of words to return ADD A,A ; Double for bytes JP Z,$20 ; No value to retuof entry point (self-relative) EXITIC .EQU -04H ; address of exit code (self-relative) rn LD C,A ; BC := # bytes to return LD B,00H LD HL,(MPD0) ; HL := ^lastPARMSZ .EQU -06H ; number of bytes of parameters DATASZ .EQU -08H ; number of bytes of local data  byte of where params go ADD HL,BC INC HL .IF Z80 DEC DE ; do the move segment ; -0AH to -08H-2*(# of long jumps) self-relative jump address ;Proc table (pointed to by msseg) format ; .EQ LDDR INC DE ;EITHER WAY TO $20 , DE = NEW SP .ENDC .IF ~Z80 $10 LD A,(HL) DEC U +01H ; number of procs in segment ; .EQU 00H ; seg_num ;-02H to -2*(number of procs) self DE DEC HL LD (DE),A LD A,(HL) DEC DE DEC HL 6 ; pc relative (proc) relocation amount RLDELTA .EQU TPROC+8 ; the relocation abount for the relocation -relative pointers to each procs JTAB ; Seg table (part of syscom) format: ; 00H ; unit number code  ; currently being done. SEGNUM .EQU TPROC+10. ; segment # currently being called for seg is on ; +02H ; block # code for seg starts at ; +04H ; segment length  SEGTP .EQU TPROC+12. ; ^segtable entry for segment  NEWSEG .EQU TPROC+14. ; new SEGP  NEWJTB .EQU T(in bytes) ; Operator formats: ; RBP,RNP: number of words to return (0..2) ; CBP,CGP,CLP,CIP: proc_num ; CXP: seg_num, prPROC+16. ; new JTAB pointer  ; Mark stack control word (MSCW) format: MSSP .EQU +0AH ; Caller's top oc_num RBP ; Return from base procedure LD HL,(MP) ; HL := old base DEC HL LDof stack MSIPC .EQU +08H ; Caller's IPC (return address) MSSEG .EQU +06H ; Caller's segment (pro D,(HL) DEC HL LD E,(HL) EX DE,HL =  ; HL := dyn link LD (MP),HL ; new local MSCW := dyn link LD BC,DISP0 ADD HL,BCntry point for BLDMSCW if CXP is doing call POP HL ; (RETADR) := return_address LD (RETADR),HL  LD (MPD0),HL POP HL ; rest should be obvious LD (JTAB),HL ; well...it used to JP BLD3 BLDMSCW ; Build a MSCW, copy down parameters, and set up proper environment ; for called procedure be obvious. See if current seg same as old POP HL LD A,(SEGP) CP L JP NZ,$3 LD HL,(SEGP) LD (NEWSEG),HL POP HL ; (RETADR) := return_address LD 0 LD A,(SEGP+1) CP H JP Z,$40 $30 ; it is different. Decrement refcount for curren (RETADR),HL XOR A ; indicate no code read in, not a CXP call PUSH AF BLD3 LD At segment. PUSH HL LD HL,(SEGP) LD A,(HL) CALL DECREF ; decrements refc,(BC) ; A := proc_num INC BC SAVIPC NEGA ; DE := -proc_num (need to indeount for seg A POP HL $40 LD (SEGP),HL POP BC ; ipc x proc table LD E,A ; backward...segp^[-proc_num] = ^jtab) LD D,0FFH LD HL, EX DE,HL ; restore SP LD SP,HL JP BACK  DECREF ; Decrements refcount for seg # A. (NEWSEG) ADD HL,DE ADD HL,DE LD E,(HL) ; DE := ^jtab INC HL LD(; if count becomes 0, return Zero flag set (LD L,A (LD H,0 (ADD HL,HL (ADD HL,HL (LD BC,INTSEGT+1 D,(HL) ; entry is negative self-relative .IF Z80 SCF SBC HL,DE .ENDC . (ADD HL,BC " LD B,(HL) (DEC L (LD C,(HL) (DEC BC (LD (HL),C (INC L (LD (HL),B IF ~Z80 SCF LD A,L SBC A,E LD L,A LD A,H SBC A,D (LD A,C (OR B (RET "  STKCHK ; check for stack overflow (LD HL,(NP) EX DE,HL LD  LD H,A .ENDC LD (NEWJTB),HL ; is it an assembly language proc ? LD A,(HL)HL,-60. ; leave a 30-word evaluation stack ADD HL,SP LD A,L SUB E LD A,H  TSTA JP NZ,$40 ; it is. See if CXP and take special action if necessary, (; leave BACK1 as ret a LD (DE),A DEC C DEC C JP NZ,$10 .ENDC $20 ; use info in MSCW to r SBC A,D RET ( ( (; The callable routine used to build a mark stack control word... (; each actual procedureestore machine state LD HL,(MP) LD SP,HL POP HL ; junk stat link POP HL  opcode uses it as a basis, then does some (; other stuff (usually setting the static chain pointer correctly).  BLDXNL ; e> ms JP $60 $50 ; code was read in, so extend by parmsz+datasz EX DE,HL ; HL := datasz ment for called procedure LD HL,0000H ; (MP) := SP ADD HL,SP LD (MP),HL LD ddress, and jump to it ! POP AF ; See if this was a CXP call TSTA (JP Z,$35  ; o ADD HL,BC ; + parmsz CLRA ; HL := SP-datasz-parmsz ops. it was. this means we bumped ref pointer, but will never (; execute a nice return instruction to bump down the pointer.  SUB L LD L,A LD A,00H SBC A,H LD H,A ADD HL,SP  EX DE,HL ; save ^jtab (LD HL,(SEGNUM) ; To fix, we will just zero that refcount (LD H,0 LD SP,HL ; SP := SP-datasz-parmsz EX DE,HL ; DE := ^parma dest LD HL,(NEWSE (ADD HL,HL (ADD HL,HL (LD BC,INTSEGT (ADD HL,BC (DEC (HL) ; just wipe out low...high shoulG) ; HL := ^params INC HL INC HL $60 LD A,C ; see if parsz = 0 OR d be zero (EX DE,HL  $35 LD DE,BACK1 PUSH DE DEC HL LD D,(HL) DEC B JP Z,$80 ; copy the params down .IF Z80 LDIR .ENDC .IF ~Z80 CLRA L LD E,(HL) EX DE,HL JP (HL) $40 ; Regular procedure...now get datasz and parmsz  ; BC := -BC SUB C LD C,A LD A,00H SBC A,B LD  LD DE,DATASZ ; HL := ^datasz ADD HL,DE LD E,(HL) ; DE := daB,A $70 LD A,(HL) LD (DE),A INC HL INC DE LD A,(HL) LD (tasz INC HL LD D,(HL) INC HL LD C,(HL) ; BC := parmsz DE),A INC HL INC DE INC C INC C JP NZ,$70 INC B  INC HL LD B,(HL) POP AF ; now extend stack in proper manner... JP  JP NZ,$70 .ENDC ; now build a MSCW as if this were a CLP $80 PUSH HL ; mssp  C,$50 ; code not read in, so extend by datasz CLRA ; HL := SP-datasz SUB E LD  LD HL,(IPCSAV) ; msipc PUSH HL LD HL,(SEGP) ; msseg PUSH HL LD L,A LD A,00H SBC A,D LD H,A ADD HL,SP LD SP,HL  HL,(JTAB) ; msjtab PUSH HL LD HL,(MP) ; msdyn PUSH HL PUSH HL  ; SP := SP-datasz EX DE,HL ; DE := ^param dest ADD HL,DE ; HL := ^para ; msstat ;check for stack overflow CALL STKCHK JP C,STKOVR ; set up environ?  HL,(MPD0) LD (BASED0),HL LD HL,(MP) LD (BASE),HL EX DE,HL ; Use s the found mscw LD C,E ; set up IPC again LD B,D JP BACK the old base's statlink... LD C,(HL) INC HL LD B,(HL) EX DE,HL ; ...as our own statlink LD (HL),C INC HL LD (HL),B  POP BC ; get back IPC JP BACK CIP ; Call intermediate procedure CALL BLD DE,DISP0 ADD HL,DE LD (MPD0),HL LD HL,(NEWSEG) LD (SEGP),HL LD MSCW ; then try to point statlink at parent CIPXNL PUSH BC ; save IPC for awhile LD HL,(MP HL,(NEWJTB) LD (JTAB),HL ; DE := entric DEC HL LD D,(HL) DEC HL ) ; BC := ^new MSCW LD C,L LD B,H LD HL,(JTAB) ; A := lex level of called p LD E,(HL) LD A,L ; negative self-relative, asusual SUB E LD C,A roc INC HL LD A,(HL) DEC A JP P,$10 ; if lex level <= 0, base proced LD A,H SBC A,D LD B,A LD HL,(RETADR) JP (HL)  ure POP BC ; get back ipc (JP CBPXNL ; and do call base proc stuff ( (; find first pro CLP ; Call local procedure CALL BLDMSCW ; Does everything for CLP JP BACK CGP ; Calc with lex level one less than ours $10 ; see if this is the MSCW that has the goods we need LD HL,MSJTAB+1 l global procedure CALL BLDMSCW POP HL ; Junk stat pointer BLDMSCW gave us... LD HL,(BA ; HL := ^msjtab (high byte) ADD HL,BC LD D,(HL) ; DE := ^jump table DEC HL SE) PUSH HL ; ... and make stat point to BASE JP BACK CBP ; Call base procedure  LD E,(HL) DEC HL ; BC := msdyn, ^ next mscw LD B,(HL) DEC HL  CALL BLDMSCW ; and then make this a BASE MSCW CBPXNL LD HL,(BASE) ; save old base pointer PUS LD C,(HL) EX DE,HL ; get lexl from jtab INC HL CP (HL) JP H HL PUSH BC ; save new IPC EX DE,HL ; then make this MSCW the new base LD  NZ,$10 POP DE ; get IPC POP HL ;junk old stat link PUSH BC ; new msstat i@  .PROC INTERP (; Includes for the Z80/8080 Interpreter (.INCLUDE Z8080:INTERP.TEXT (.INCLUDE Z8080:VARS.TEXT (.INCLUDE Z8080:ARITH.TEXT (.INCLUDE Z8080:SET1.TEXT (.INCLUDE Z8080:SET2.TEXT (.INCLUDE Z8080:FPL.TEXT (.INCLUDE Z8080:FPI.TEXT (.INCLUDE Z8080:FPT.TEXT (.INCLUDE Z8080:PROC1.TEXT (.INCLUDE  Z8080:PROC2.TEXT (.INCLUDE Z8080:STP.TEXT (.INCLUDE Z8080:CPMIO.TEXT (.INCLUDE Z8080:BOOT.TEXT ( (.END  O^O^A  Z8080:PROC2.TEXT (.INCLUDE Z8080:STP.TEXT (.INCLUDE Z8080:CPMIO.TEXT (.INCLUDE Z8080:BOOT.TEXT BB;PPBBERROR #B BءDB"BZ80B.ERRORS" file not aroundB( (.END  ڂ<󄓡;PPERROR # ءC"Z80.ERRORS" file not around ((šE(dit,,ٶáEeÍ&3! " % # ظ  á<'< >7Ʉ B* Bt(٨ǀɍp Location * *&n" $n3PSYSTEMLETLA **@؂-@؂@ 7á INITIALISYMTBLDUPROCEND ASSEMBLEPRINTERR C "ˡ."ء&'ȡvؤˡd%BB>>>>>Bؤ<󄓡(>>>>>ؤؤ ' <BB B BPAGE - B CCOPYRIGHT (C) 1978 REGENTS OF UNIVERSITY OF CALIFORNIA AT SAN DIEGOB BUB FILE:B<BB BBBBj>09ō6  á6 á6<9.2á'< >7áɡEEE  .PROC INTERP (; Includes for the Z80/8080 Interpreter (.INCLUDE Z8080:INTERP.TEXT (.INCLUDE Z8080:VAR >á6!~q|3?Bp  v\EL "$&(*,.0246S.TEXT (.INCLUDE Z8080:ARITH.TEXT (.INCLUDE Z8080:SET1.TEXT (.INCLUDE Z8080:SET2.TEXT (.INCLUDE 8:<>@BDFHJLNPRBx-~}cy ƄjƅZ8080:FPL.TEXT (.INCLUDE Z8080:FPI.TEXT (.INCLUDE Z8080:NOFPT.TEXT (.INCLUDE Z8080:PROC1.TEXT (.INCLUDEƄBƅnBƁn   ŧ8  KáƄjƄBB.XB:F#$ \B EB| BB| BEOšO;áB#BBz!á yz!á xx ˡ  _Jz!á yyB BBáE:T BءWá$B*B*á'BǀĶȄ z!á wcj w١*y؄ǀ B B áHB* B*B*B*áNB ١=z!á yy؄ǀȄ  z!áڧwc{{!ç{ç B  B  B B B  /šE@á ,š,{˄O١=z!á yy؄ǀȄ  z!áڧ١0.z!@@//00@/ؿ//0/..-š.-:á7ȡ0E삥*E* yڧ{á{{{{ˡ  QBB{<󄓡E á@ȡ9E0E0E0E   ٨{"?ACE7 =?wc][@{  ;P3B*#ápȡiE* ɡ"E삥* E*ˡ$E*E*E $ *#$%#$#$á:3/"#!% *#$3BoP5 6 áȡ{E* ɡ+E0E 0E 0ˡ-E0E0E06?á/? ë;Oɡ;;? %á? 19ō1E :  : J.*77á#jؚj٨jša?˧? ˄?,áP ? ؂? ;Í ?D˥* ˄*,á .EDwwc*򥂮x"á5xx ˡ P * ؂* ;˄6 Q ç9,P ? ؂Pɡ; ؂؂5 ˄Pɡ; *wc{{!ç{ç{˄E{á{{{{ˡ  *Aá 6 6š ? * , Í;ÍCšF ? F * ؂u{{||.|{{|{(})"cegi w?6 b ç9EPɡ; š ? * ˡ Pɡ;Aá 6 %%cI_c@  .x"á1.6%š *%á*%ç12*% ë;Oɡ;;%%*% ;á5P *% ؂PɡC ܤ ܤwܤ!ܤW 뚹ܤ뻹á ܤ ܤwc wؤ ==-><! ؤ6ENDM Я bš&?wáwcܤ!ܤWܤSá ܤ;ȡ1ȡ ܤܤۂ? ˡ*% ˡ%% 95Í5á" Oá3#观ˡ%30 P P ˄!0ܤ ܤWwc w˄&"á w&xܤ&ܤ!ܤWYYPY0ǠYP á#"%!B P#%9<󄓡<;PP<*%;؞؂%؂% U ç91/P *% ؂Pɡ; ؂%؂% ˡPɡ;Aá  ܤ$˄ ܤ ܤ"˄ ܤ ܤ!"wc w˄ wxRV *ō˄ J59˄ {ܤW뚹áˡܤܤܤܤWˡ" 뚶á#á  òWÄ&S|~$0t:<>@BDFHJLNPRTVXZ\^`bdfhlnprzyòWÄ_!뚹 %vxz|~ l4- P PAFȄ09Ȅ6Aġ -7-0zy ááġWáWWPW-ǠWP ÍHá$.á áBá 6S-ڹšPٳ س  Äڳ<<ڹ Íݢۂ ˡݢɡWW-PWǠWPV VVVVš|ɡWW-PWǠWP Äݢە ˡݢ ܡ ݢۍܡ ݢۄzܡݢۓۄbܡ ݢۏQܡ ݢWWȡ$ق š  ق ń ÄɡW@ܡ ݢێ/(tT-  ^ áLW-PWǠWPWWȡقšVV V VVVVW?$6# SnWš[ɡWW-PWǠWPWWȡ'قš VٕقV&q    twc2 2}ܤ뻹áP$*á<á *_&"N  ЩAZȄ09Ȅɡ؂ á-==ɄD =&&=B'á (3'Q' "'' ''Q;:Ä 6 R9 Щ ; WORD Щ 7 EXPAND Щ V MACRO Щ A ENDM Щ U PP "PɄ ˄6򿥁,,P,Ǡ,Pá 9١ؑ ؂ ؂ á9)PIF ЩBENDC Щ=ELSE Щ>REF ЩDEF Щš*x9ë;; ;P á ; á9     ORG Щ?INCLUDE ЩOLIST ЩGNOLIST ЩHASECT Щ9$$á 09ō6  á6 á6IPSECT ЩJTITLE ЩMEND ЩKPAGE ЩL >á6!~q|3?Bp  v\EL "$&(*,.0246ȡQU=ȡ$قQٓ؄ؓǀǀٓ؄ؓǀ8:<>@BDFHJLNPRBx-~}cy Ƅjƅ٤=˄ꥈQ ==2Opcode declared twice=Q.ꥈQ U U > RQ ЩAZȄ09Ȅ_ÍɡQ؂ =ȡڂƄBƅnBƁn   ŧ8  KáƄjƄBB.XB:F#$ \Q؂ړلٓǀǀړلٓǀڤ=˄ꥈQ ==짂5  .< !@"""$>09ō6  á6 á6  $   #  mf_ N#F' >á6!~q|3?Bp  v\EL "$&(*,.0246  "$&(*,.02\@B[ꥈQ ڤڤꚹT#áNš %8:<>@BDFHJLNPRBx-~}cy Ƅjƅ5 ˡ ?9  ;&:á =P"ÍP&Ȅd !"ƄBƅnBƁn   ŧ8  KáƄjƄBB.XB:F#$ \#z$u%p&k'f(a)\*W+R,M-H.C/>09142/(kheb_\YVSPMJGDA>;852ALIGN Щ3ASCII Щ@BLOCK Щ6BYTE Щ8CONST Щ46  2VTQ Щ09ȄɡQ؂ á'=&=&'Ʉ&Q FEQU ЩCFUNC Щ<PUBLIC ЩDPRIVATE ЩE PROC E #1:AB - Absolute LB - Label UD - Undefined MCdg"fewcP 2913>:U Щ P(BPAGE - B B - MacroBB=RF - Ref DF - Def PR - Proc FC - FuncBB,PB - Public PV - Prj *LINKER.INFO<󄓡< 0>U*wfj A .ivate CS - ConstsBBBá1 ------| Pá1----| PZPBá o&Po.PoP2Output file for assembled listing: ( for none)P 8CONSOLE:ا0ɡ`.š@áق,šق, "á@á0/ا0š.š .á"آ,á"آjˡB@áق,šق, ,ġ "á@,,á,"á@á0/ا0/ AB P LB P PR P FC P PB P PV P RF Pu DF Ph UD P[ 7ˡg-ȡN--á5ȡ*-ܤˡ.-ܤ  MC PN#Fp  "$&(*,.026tidYB !ÍB| ȡ ܤˡ.ܤ  -m }ˡ -ȡ B1ç<ç<B7áˡ~ t Ká ;P 䥃ؤˡ&BB>>>>>B<󄓡#>>>>>- F- Щޢޢ̀ʀȡrܤˡ]N#F   "$&(*,.02?-x-n-d-Z- P- F@>  "$&(*,.02nzh٤٤ꚲUU 54"#6%9' APUƁ,́ƁZ80Ɓ.OPCODES ACEGIKMOQZPSYMBOLTABLE DUMPP áB>AB - Absolute LB - Label UD - Undefined MCƁP,́Ɓ*Ɓ,QƁPU,"ˡ*, not on vol&Óʁȡق;P - MacroBB=RF - Ref DF - Def PR - Proc FC - FuncBB,PB - Public PV - PrZ80 Assembleŕʁȡ:ق E:*0123456789ABCDEFЩ/ A .ivate CS - ConstsBBBá1 ------| Pá1----| PZPBá o&Po.PoP2Output file for assembled listing: ( for none)P 8CONSOLE:!V 06 ̀ʀȡrܤˡ]N#F   "$&(*,.02?F ˡ-á4B B<󄓡)-- - - * )} ( š*Ɓ-j *LINKER.INFOj .+;á 4á - - - - --- - -F>e ˡ> áYU  á Sˡ   E:95˄95˄ ;P "$&(*,.02L"DD  "$&(*,.02vxz|~@B"Ɓ-Ɓ3&\ݢ ݣÄɡ3ڕġ$ڕ fj8- *LINKER.INFO ˧˄-- ȡ/-á-šš"šޣ Ą ޣ ݣ ˡPݣ %ݢ@ݢݢBݣ ܮܧ0-6Current available space is (  words"ˡݣ ˄ݢBۂ"ˡ\ݣ ݣ šݢݣ ݢ<ݣݣ ݣ ݣݣńݢ<ݣݢݢݢˡݢݢj-0/./ wc.+  ] .+.+AP!ث@Aݢ>ܚ E / x P  z!áڧwc{{!ç{ç{˄O١=ȡ@ UB B blocks for procedure code B( B words leftB<z!á yy؄ǀȄ  z!áڧ١0.z!á y  blocks for procedure code (  words left< >ڧ{á{{{{ˡ  QBB{<󄓡{0.- ,/] @á<> ` Ɓ-ƂYƁƂ1Ƃa@# š Ká RáAP ړ ˡ> Ráۯ. I2;á,.. ̂bʂbġ ٥]ڤ  ٫/@áڂ ʁ-Ɓ-Ɓ-Ɓ *LINKER.IۯX95˄95˄ Q Щ;P5á  OšNFO"áƁ@á@ "á@á @ǀ  á;P+.áQ Щɡ QقQIF Я )QENDC Я ɡ   HÔbʂbȡڂYH"áá8<B 8BƁ&Assembly cاåQELSE Я اåQENDC Я W  *Q Щ Oš á;P`N-- - --ˡB-á-- omplete:  lines " Errors flagged on this AssemblyP  G ǀ Ä ;F ˡL f QCá7á l %á        D á(ɡȡ   dsmga[FT       ػ  ` \á    5Ä +.áQ Щɡ QقQIF Я )QENDC Я ɡ  اåQE "$&(*,.02468:<>@BDFHJLNmiw 4ˡCˡ 5á+ á Sáآ  NDC Я   ٟˡb0٢؂٢٢Ʉjj٨j٢٫آ  ˡ"\ Rá ꥁP. "$&L ˡIj rPá_"ˡ>á  ;á  ! >꫄Aٟ˄N>ˡP áD   ˡO áM-HL Я    ˡMá,>&"ˡ ,& !&&& Pá Cˡ٧&š      SP з  á    H  ác SP ٕȡ   : Rá<ȡ)˄ ;P؂   :  з Q ˡM ˡN HL Я   á   VDE Я ,  ˡN V4á,"ˡ > !꫄A Cˡ >>> á A kwc Ywáx"á?AHL з RAF Я     A Я N ˡN6á   ! !4wá&{!ç{ç{˄ A !?A A A AˡA!á AA >Q #ǀ  HL Я C  ˡN AF з     páhˡ= ! 5 #?  ? á6Q Щ1š?  Oš?  ˡN HL з AF з  á    4   á;P+.áQ Щɡ Q؂QENDM Я ȡ? ? ? "1 A Я M ˡN5á    @   \HL Я I    _Qá  ?áǀȡ  ?ˡN AF з      >á   )ǀ @ t á  ? Ä ;F ˡ B b á  I   V Uá  @AF з     á   H $    %2áM 4áá "  kHL Я  "  PA b,1<'< >  @-8   .@#F з  C    A Я  2     ( 4áá  ˡ7BMemory after initialization:B( B PQÍȍNč 2Ȅ95˄O|háMFá p    )ǀ6     -.     ɡ   HL Я d ˡM ˡN>á p   %ǀ6     !"}#y$u%q&m,iMbz|[YWUSQOMKIGECA?= hBC Я DE Я Eá   ˡM ˡN A з V (( ;975:<!'!ˡ95˄95˄ >5áe%     YˡP%á   Ä   ˡM' ˡNfáˡ   Há @ ػ   +ǀ  ػ    yy  (~Ä]šS á ! ( 0 8ˡˡP 4ÄN  ˡO" F ػ   áM4ÄWyy   yy   já(     áˡ  1áˡ á F ػ    ˡM 0á&2:  áM ;Ä(           ˡA Я  ˡ  ) ˡN ágY٦HL Я *  áM+ K ػ  N ˡPVá)á  @ ٻ  T (ء#  ǀ  áM áM á%٦SP Я     ZHL Я 4Ä ٦SP Я   %2   ˡPáKˡT  áM á A   U  Sǀ  ػ     *  ˡN !  Aˡ;ˡP*  á>áM    A з V    !  " 7M l+ á's4álá)`AF з *Fá+<á4   ˡN %F V ^   P#     8A з V &  9ˡHá     &Ä      I <󄓡/;PP ݢ ݣÄz!á yy؄ǀȄ  z!áڧ١0.z!á yɡ3ڕġ$ڕšš"šޣ Ą ޣ ڧ{á{{{{ˡ  QBB{<󄓡{ ˡPݣ %ݢ@ݢݢBݣ "ˡݣ ˄ݢBۂ"ˡ\ݣ ݣ šݢݣ ݢ<ݣݣ ݣ ݣݣń RáAP ړ ˡ> Ráۯ. I2;á,..<ݣݢݢݢˡݢݢۚݢ>ܚ E / xɡ  اåQENDC Я ۯX95˄95˄ Q Щ;P5á  Oš  ٟˡb0٢؂٢٢Ʉjj٨j٢٫Ij á;P+.áQ Щɡ QقQIF Я )QENDC Я ɡ   rPá_"ˡ>á  ;á  ! >꫄Aٟ˄N>á,>اåQELSE Я اåQENDC Я W  *Q Щ Oš á;P&"ˡ ,& !&&& Pá Cˡ٧&šٕȡ+.áQ Щɡ QقQIF Я )QENDC Я ɡ  اåQE * )} ( š*Ɓ-j *LINKER.INFOj .+;á 4NDC Я   ٟˡb0٢؂٢٢Ʉjj٨j٢٫B @z8 $ b ^ ~ | ,*.~R6vN\ .95˄ˡ> áYU  á Sˡ   E:95˄95˄ ;P -.     ɡ"Ɓ-Ɓ3&\ݢ ݣÄɡ3ڕġ$ڕ  !"}#y$u%q&m,iMbz|[YWUSQOMKIGECA?=šš"šޣ Ą ޣ ݣ ˡPݣ %ݢ@ݢݢBݣ ;975:<!'!ˡ95˄95˄ >5áe%"ˡݣ ˄ݢBۂ"ˡ\ݣ ݣ šݢݣ ݢ<ݣݣ ݣ ݣݣńݢ<ݣݢݢݢˡݢݢƁ.́DƁDZ80ƁD.ERRORS ƁDƁC "ˡw0BB;PPBBBݢ>ܚ E / x P  z!áڧwc{{!ç{ç{˄O١=J ٕȡ   : Rá<ȡ)˄ ;P؂   :  з Q ˡM ˡN HL Я   á   VDE Я ,  ˡN V4á,"ˡ > !꫄A Cˡ >>> á A kwc Ywáx"á?AHL з RAF Я     A Я N ˡN6á   ! !4wá&{!ç{ç{˄ A !?A A A AˡA!á AA >Q #ǀ  HL Я C  ˡN AF з     páhˡ= ! 5 #?  ? á6Q Щ1š?  Oš?  ˡN HL з AF з  á    4   á;P+.áQ Щɡ Q؂QENDM Я ȡ? ? ? "1 A Я M ˡN5á    @   \HL Я I    _Qá  ?áǀȡ  ?ˡN AF з      >á   )ǀ @ t á  ? Ä ;F ˡ B b á  I   V Uá  @AF з     á   ǀ Ä ;F ˡL f QCá7á l %á        D á(ɡȡ   dsmga[FT       ػ  ` \á    5Ä  "$&(*,.02468:<>@BDFHJLNmiw 4ˡCˡ 5á+ á Sáآ       YˡP%á   Ä   ˡMآ  ˡ"\ Rá ꥁP. "$&L ˡ yy  (~Ä]šS á ! ( 0 8Ij rPá_"ˡ>á  ;á  ! >꫄Aٟ˄N>ˡP áD   ˡO áM-HL Я    ˡMá,>&"ˡ ,& !&&& Pá Cˡ٧&š      SP з  á    H  ác SP K ˡˡP 4ÄN  ˡO" F ػ   áM4ÄW -.     ɡyy   yy   já(     áˡ  1áˡ á F ػ    ˡM 0á&2:  áM ;Ä(           ˡA Я  ˡ  ) ˡN ágY٦HL Я *  áM+ K ػ  N ˡPVá)á  @ ٻ  T (ء#  ǀ  áM áM á%٦SP Я     ZHL Я 4Ä ٦SP Я   %2   ˡPáKˡT  áM á A   U  Sǀ  ػ     *  ˡN !  Aˡ;ˡP*  á>áM    A з V    !  " 7M l+ á's4álá)`AF з *Fá+<á4   ˡN %F V ^   P#     8A з V &  9ˡHá     &Ä      $    %2áM 4áá "  kHL Я  "  PA b,1<'< >  @-8   .@#F з  C    A Я  2     ( 4áá  ˡ7BMemory after initialization:B( B PQÍȍNč 2Ȅ95˄O|háMFá p    )ǀ6     -.     ɡ   HL Я d ˡM ˡN>á p   %ǀ6     !"}#y$u%q&m,iMbz|[YWUSQOMKIGECA?= hBC Я DE Я Eá   ˡM ˡN A з V (( ;975:<!'!ˡ95˄95˄ >5áe%' ˡNfáˡ   Há @ ػ   +ǀ  ػ   B @z8 $ b ^ ~ | ,*.~R6vN\ .95˄L &"ˡ ,& !&&& Pá Cˡ٧&šٕȡ<ݣݢݢݢˡݢݢۚݢ>ܚ E / xɡ  اåQENDC Я 7BMemory after initialization:B( B PQÍȍNč 2Ȅ95˄  ٟˡb0٢؂٢٢Ʉjj٨j٢٫Ij -.     ɡ rPá_"ˡ>á  ;á  ! >꫄Aٟ˄N>á,>  !"}#y$u%q&m,iMbz|[YWUSQOMKIGECA?=&"ˡ ,& !&&& Pá Cˡ٧&šٕȡ  !"}#y$u%q&m,iMbz|[YWUSQOMKIGECA?=;975:<!'!ˡ95˄95˄ >5áe%;975:<!'!ˡ95˄95˄ >5áe%B @z8 $ b ^ ~ | ,*.~R6vN\ .95˄Ɓ.́DƁDZ80ƁD.ERRORS ƁDƁC "ˡw0BB;PPBBB -.     ɡ<󄓡/;PP ݢ ݣÄ  !"}#y$u%q&m,iMbz|[YWUSQOMKIGECA?=ɡ3ڕġ$ڕšš"šޣ Ą ޣ ;975:<!'!ˡ95˄95˄ >5áe% ˡPݣ %ݢ@ݢݢBݣ "ˡݣ ˄ݢBۂ"ˡ\ݣ ݣ šݢݣ ݢ<ݣݣ ݣ ݣݣńƁ.́DƁDZ80ƁD.ERRORS ƁDƁC "ˡw0BB;PPBBB<ݣݢݢݢˡݢݢۚݢ>ܚ E / xɡ  اåQENDC Я <󄓡/;PP ݢ ݣÄ  ٟˡb0٢؂٢٢Ʉjj٨j٢٫Ijɡ3ڕġ$ڕšš"šޣ Ą ޣ  rPá_"ˡ>á  ;á  ! >꫄Aٟ˄N>á,> ˡPݣ %ݢ@ݢݢBݣ "ˡݣ ˄ݢBۂ"ˡ\ݣ ݣ šݢݣ ݢ<ݣݣ ݣ ݣݣń