.SBTTL KERNEL/INTERPRETER INTERFACE .DSABL AMA ;<01> THE FOLLOWING CODE MUST BE ;<01> RELOCATABLE ; ; INTL99: .WORD ; CONST INTERPRETERLENGTH = ...; ; ; $1 = . - ZERO ; "ENSURE BLOCK ALIGNMENT" $2 = <$1 + 63.> / 64. ; $2 = <$2 * 64.> - $1 ; .BLKB $2 ; ; ; USER99: .BLKB .PROCREF ; USER = USER99 ; TABL99: .WORD CONSTA-USER,LOCALA-USER,GLOBAL-USER,PUSHCO-USER .WORD PUSHLO-USER,PUSHGL-USER,PUSHIN-USER,PUSHBY-USER .WORD PUSHRE-USER,PUSHSE-USER,FIELD -USER,INDEX -USER .WORD POINTE-USER,VARIAN-USER,RANGE -USER,COPYBY-USER .WORD COPYWO-USER,COPYRE-USER,COPYSE-USER,COPYTA-USER .WORD COPYST-USER,NEW -USER,NEWINI-USER,NOT -USER .WORD ANDWOR-USER,ANDSET-USER,ORWORD-USER,ORSET -USER .WORD NEGWOR-USER,NEGREA-USER,ADDWOR-USER,ADDREA-USER .WORD SUBWOR-USER,SUBREA-USER,SUBSET-USER,MULWOR-USER .WORD MULREA-USER,DIVWOR-USER,DIVREA-USER,MODWOR-USER .WORD BUILDS-USER,INSET -USER,LSWORD-USER,EQWORD-USER .WORD GRWORD-USER,NLWORD-USER,NEWORD-USER,NGWORD-USER .WORD LSREAL-USER,EQREAL-USER,GRREAL-USER,NLREAL-USER .WORD NEREAL-USER,NGREAL-USER,EQSET -USER,NLSET -USER .WORD NESET -USER,NGSET -USER,LSSTRU-USER,EQSTRU-USER .WORD GRSTRU-USER,NLSTRU-USER,NESTRU-USER,NGSTRU-USER .WORD FUNCVA-USER,JUMP -USER,FALSEJ-USER,CASEJU-USER .WORD INITVA-USER,CALL -USER,CALLSY-USER,ENTER -USER .WORD EXIT -USER,ENPROG-USER,EXPROG-USER,BEGINC-USER .WORD ENDCLA-USER,ENTERC-USER,EXITCL-USER,BEGINM-USER .WORD ENDMON-USER,ENTERM-USER,EXITMO-USER,BEGINP-USER .WORD ENDPRO-USER,ENPROC-USER,EXPROC-USER,POP -USER .WORD NEWLIN-USER,INCWOR-USER,DECWOR-USER,INITCL-USER .WORD INITMO-USER,INITPR-USER,PUSHLA-USER,CALLPR-USER .WORD TRUNCR-USER,ABSWOR-USER,ABSREA-USER,SUCCWO-USER .WORD PREDWO-USER,CONVWO-USER,EMPTY -USER,ATTRIB-USER .WORD REALTI-USER,DELAY -USER,CONTIN-USER,IO -USER .WORD START -USER,STOP -USER,SETHEA-USER,WAIT -USER HEAD99: .BLKB .HEADTYPE ; CONS99: .BLKB .INTEGER ; ; ; KLEN99 = . - ZERO ; ; ; .SBTTL .SBTTL ######################################################### .SBTTL .TITLE PASCAL INTERPRETER ; TOM ZEPKO ; JORGENSEN LAB 286-80 ; CALIFORNIA INSTITUTE OF TECHNOLOGY ; OCTOBER 1974 .SBTTL PROCESS HEAD ; ; HEAD = HEAD99 - USER99 ; "THESE ENTRIES IN THE PROCESS HEAD HEAPTO= HEAD99 + HEAPT1 ; ARE USED BY THE INTERPRETER." LINE = HEAD99 + LINE1 ; RESULT= HEAD99 + RESUL1 ; JOB = HEAD99 + JOB1 ; CONT = HEAD99 + CONTI1 ; OPCODE= HEAD99 + OPCOD1 ; ARG1 = HEAD99 + PARAM1 ; ARG2 = HEAD99 + PARAM1 + 2 ; ARG3 = HEAD99 + PARAM1 + 4 ; ARG4 = HEAD99 + PARAM1 + 6 ; OPLINE= HEAD99 + OPLIN1 ; CONST = CONS99 ; ; ; .SBTTL KERNEL OPERATIONS ; INITG1= INIT18 ;INITGATE1 ENTEG1= ENTE17 ;ENTERGATE1 LEAVG1= LEAV17 ;LEAVEGATE1 ENDPR1= ENDP14 ;ENDPROCESS1 INITP1= INIT13 ;INITPROCESS1 REALT1= REALT7 ;REALTIME1 DELAY1= DELA17 ;DELAYGATE1 CONTG1= CONT17 ;CONTGATE1 STOPJ1= STOP15 ;STOPJOB1 WAIT1 = WAIT7 ;WAIT1 SYSTE1= SYST11 ;SYSTEMERROR1 IO1 = IO31 ;INPUT_OUTPUT ; ; .SBTTL NEXT INSTRUCTION MACRO .MACRO NEXT .IF NE $.DBIT JSR PC,ITRACE .ENDC MOV @(Q)+,P .ENDM NEXT ; ; .SBTTL KERNEL CALL MACRO .MACRO KNCALL MOV (B),OPLINE IOT .ENDM KNCALL ; ; .SBTTL INTERPRETER TRACE MACRO .MACRO INTRCE .IF NE $.DBIT MOV HEAD99+INDEX1,R0 DEC R0 ASL R0 MOV S,ENDSTK-USER99(R0) BR ITRACX ENDSTK: .REPT PROCS .WORD 0 .ENDR ITRACE: MOV (Q),ARG1 MOV Q,ARG2 SUB #2.,ARG2 MOV S,ARG3 ADD #2.,ARG3 MOV HEAD99+INDEX1,R1 DEC R1 ASL R1 MOV ENDSTK-USER99(R1),ARG4 TRAP RTS PC ITRACX: .ENDC .ENDM INTRCE ; ; .SBTTL START ADDRESS ; STARTA: INTRCE ;STARTADDR: P:=ST(Q); Q:+2; NEXT ; ; ; .SBTTL REAL OVERFLOW ; REALOV: JMP OVERFL ;REALOVERFLOW: GOTO OVERFLOWERROR; ; ; .SBTTL CONSTADDR ;PROCEDURE CONSTADDR(DISPL); ; BEGIN CONSTA: TST JOB ; TEST ST(JOB); BNE 1$ ; IF ZERO MOV CONST,-(S) ; THEN S:-2; ST(S):=ST(CONSTADDR) "SYSTEM" BR 2$ ; 1$: MOV 10.(G),-(S) ; ELSE S:-2; ST(S):=ST(G+10); "JOB" 2$: ADD (Q)+,(S) ; ST(S):+ST(Q); Q:+2; NEXT ; END; ; ; .SBTTL LOCALADDR ;PROCEDURE LOCALADDR(DISPL); ; BEGIN LOCALA: MOV B,-(S) ; S:-2; ST(S):=B; ADD (Q)+,(S) ; ST(S):+ST(Q); Q:+2; NEXT ; END; ; ; .SBTTL GLOBALADDR ;PROCEDURE GLOBALADDR(DISPL); ; BEGIN GLOBAL: MOV G,-(S) ; S:-2; ST(S):=G; ADD (Q)+,(S) ; ST(S):+ST(Q); Q:+2; NEXT ; END; ; ; .SBTTL PUSHCONST ;PROCEDURE PUSHCONST(VALUE); ; BEGIN PUSHCO: MOV (Q)+,-(S) ; S:-2; ST(S):=ST(Q); Q:+2; NEXT ; END; ; ; .SBTTL PUSHLOCAL ;PROCEDURE PUSHLOCAL(DISPL); ; BEGIN PUSHLO: MOV B,W ; W:=B; ADD (Q)+,W ; W:+ST(Q); Q:+2; MOV (W),-(S) ; S:-2; ST(S):=ST(W); NEXT ; END; ; ; .SBTTL PUSHGLOBAL ;PROCEDURE PUSHGLOBAL(DISPL); ; BEGIN PUSHGL: MOV G,W ; W:=G; ADD (Q)+,W ; W:+ST(Q); Q:+2; MOV (W),-(S) ; S:-2; ST(S):=ST(W); NEXT ; END; ; ; .SBTTL PUSHIND ;PROCEDURE PUSHIND; ; BEGIN PUSHIN: MOV @(S),(S) ; ST(S):=ST(ST(S)); NEXT ; END; ; ; .SBTTL PUSHBYTE ;PROCEDURE PUSHBYTE; ; BEGIN PUSHBY: MOVB @(S),W ; W:=ST(ST(S)); MOV W,(S) ; ST(S):=W; NEXT ; END; ; ; .SBTTL PUSHREAL ;PROCEDURE PUSHREAL; ; BEGIN PUSHRE: MOV (S)+,W ; W:=ST(S); S:+2; ADD #8.,W ; W:+8; MOV -(W),-(S) ; W:-2; S:-2; ST(S):=ST(W); MOV -(W),-(S) ; W:-2; S:-2; ST(S):=ST(W); MOV -(W),-(S) ; W:-2; S:-2; ST(S):=ST(W); MOV -(W),-(S) ; W:-2; S:-2; ST(S):=ST(W); NEXT ; END; ; ; .SBTTL PUSHSET ;PROCEDURE PUSHSET; ; BEGIN PUSHSE: MOV (S)+,W ; W:=ST(S); S:+2; ADD #16.,W ; W:+16; MOV -(W),-(S) ; W:-2; S:-2; ST(S):=ST(W); MOV -(W),-(S) ; W:-2; S:-2; ST(S):=ST(W); MOV -(W),-(S) ; W:-2; S:-2; ST(S):=ST(W); MOV -(W),-(S) ; W:-2; S:-2; ST(S):=ST(W); MOV -(W),-(S) ; W:-2; S:-2; ST(S):=ST(W); MOV -(W),-(S) ; W:-2; S:-2; ST(S):=ST(W); MOV -(W),-(S) ; W:-2; S:-2; ST(S):=ST(W); MOV -(W),-(S) ; W:-2; S:-2; ST(S):=ST(W); NEXT ; END; ; ; .SBTTL FIELD ;PROCEDURE FIELD(DISPL); ; BEGIN FIELD: ADD (Q)+,(S) ; ST(S):+ST(Q); Q:+2; NEXT ; END; ; ; .SBTTL INDEX ;PROCEDURE INDEX(MIN,MAX-MIN,LENGTH); ; BEGIN INDEX: MOV (S)+,X ; X:=ST(S); S:+2; SUB (Q)+,X ; X:-ST(Q); Q:+2; BGE 1$ ; IF LESS THEN JMP RANGER ; GOTO RANGEERROR; 1$: CMP X,(Q)+ ; X COMPARE ST(Q); Q:+2; BLE 2$ ; IF GREATER THEN JMP RANGER ; GOTO RANGEERROR 2$: MUL (Q)+,X ; X:*ST(Q); Q:+2; ADD X,(S) ; ST(S):+X; NEXT ; END; ; ; .SBTTL POINTER ;PROCEDURE POINTER; ; BEGIN POINTE: TST (S) ; TEST ST(S); BNE 1$ ; IF ZERO THEN JMP POINER ; GOTO POINTERERROR; 1$: NEXT ; END; ; ; .SBTTL VARIANT ;PROCEDURE VARIANT(DISPL,TAGSET) ; BEGIN VARIAN: MOV #1,W ; W:=1; MOV (S),X ; X:=ST(S); "X=RECORD ADDR" ADD (Q)+,X ; X:+ST(Q); Q:+2; "X=TAG ADDR" ASH (X),W ; W: SHIFT ST(X); "W=1 SHIFT TAGVALUE" BIT W,(Q)+ ; ST(Q) TESTBIT W; Q:+2; BNE 1$ ; IF BITZERO THEN JMP VARIER ; GOTO VARIANTERROR; 1$: NEXT ; END; ; ; .SBTTL RANGE ;PROCEDURE RANGE(MIN,MAX); ; BEGIN RANGE: CMP (S),(Q)+ ; ST(S) COMPARE ST(Q); Q:+2; BGE 1$ ; IF LESS THEN JMP RANGER ; GOTO RANGEERROR; 1$: CMP (S),(Q)+ ; ST(S) COMPARE ST(Q); Q:+2; BLE 2$ ; IF GREATER THEN JMP RANGER ; GOTO RANGEERROR; 2$: NEXT ; END; ; ; .SBTTL COPYBYTE ;PROCEDURE COPYBYTE; ; BEGIN COPYBY: MOVB (S)+,@(S)+ ; ST(ST(S+2)):=ST(S); S:+4; NEXT ; END; ; ; .SBTTL COPYWORD ;PROCEDURE COPYWORD; ; BEGIN COPYWO: MOV (S)+,@(S)+ ; ST(ST(S+2)):=ST(S); S:+4; NEXT ; END; ; ; .SBTTL COPYREAL ;PROCEDURE COPYREAL; ; BEGIN COPYRE: MOV 8.(S),W ; W:=ST(S+8); MOV (S)+,(W)+ ; ST(W):=ST(S); W:+2; S:+2; MOV (S)+,(W)+ ; ST(W):=ST(S); W:+2; S:+2; MOV (S)+,(W)+ ; ST(W):=ST(S); W:+2; S:+2; MOV (S)+,(W)+ ; ST(W):=ST(S); W:+2; S:+2; TST (S)+ ; TEST ST(S); S:+2; NEXT ; END; ; ; .SBTTL COPYSET ;PROCEDURE COPYSET; ; BEGIN COPYSE: MOV 16.(S),W ; W:=ST(S+16); MOV (S)+,(W)+ ; ST(W):=ST(S); W:+2; S:+2; MOV (S)+,(W)+ ; ST(W):=ST(S); W:+2; S:+2; MOV (S)+,(W)+ ; ST(W):=ST(S); W:+2; S:+2; MOV (S)+,(W)+ ; ST(W):=ST(S); W:+2; S:+2; MOV (S)+,(W)+ ; ST(W):=ST(S); W:+2; S:+2; MOV (S)+,(W)+ ; ST(W):=ST(S); W:+2; S:+2; MOV (S)+,(W)+ ; ST(W):=ST(S); W:+2; S:+2; MOV (S)+,(W)+ ; ST(W):=ST(S); W:+2; S:+2; TST (S)+ ; TEST ST(S); S:+2; NEXT ; END; ; ; .SBTTL COPYTAG ;PROCEDURE COPYTAG(LENGTH DIV 2); ; BEGIN "LENGTH>0" COPYTA: MOV (S)+,@(S) ; ST(ST(S+2)):=ST(S); S:+2; MOV (Q)+,W ; W:=ST(Q); Q:+2; "W=LENGTH DIV 2" MOV (S)+,X ; X:=ST(S) S:+2; "X=TAG ADDR" TST (X)+ ; TEST ST(X); X:+2; 1$: CLR (X)+ ; ITERATE W TIMES SOB W,1$ ; CLEAR ST(X); X:+2; NEXT ; END; ; ; .SBTTL COPYSTRUC ;PROCEDURE COPYSTRUC(LENGTH DIV 2); ; BEGIN COPYST: MOV (Q)+,W ; W:=ST(Q); Q:+2; "W=LENGTH DIV 2" MOV (S)+,X ; X:=ST(S); S:+2; "X=SOURCE ADDR" MOV (S)+,Y ; Y:=ST(S); S:+2; "Y=DEST ADDR" 1$: MOV (X)+,(Y)+ ; ITERATE W TIMES SOB W,1$ ; ST(Y):=ST(X); Y:+2; X:+2; NEXT ; END; ; ; .SBTTL NEW ;PROCEDURE NEW(STACKLENGTH+LENGTH,LENGTH); ; BEGIN NEW: MOV B,X ; X:=B; SUB HEAPTO,X ; X:-ST(HEAPTOP); CMP X,(Q)+ ; X COMPARE ST(Q); Q:+2; BHIS 1$ ; IF LESS THEN JMP HEAPLI ; GOTO HEAPLIMIT; 1$: MOV HEAPTO,@(S)+ ; ST(ST(S)):=ST(HEAPTOP); S:+2; ADD (Q)+,HEAPTO ; ST(HEAPTOP):+ST(Q); Q:+2; NEXT ; END; ; ; .SBTTL NEWINIT ;PROCEDURE NEWINIT(STACKLENGTH+LENGTH,LENGTH); ; BEGIN "LENGTH>0" NEWINI: MOV B,X ; B:=X SUB HEAPTO,X ; X:-ST(HEAPTOP); CMP X,(Q)+ ; X COMPARE ST(Q); Q:+2; BHIS 1$ ; IF LESS THEN JMP HEAPLI ; GOTO HEAPLIMIT; 1$: MOV HEAPTO,@(S)+ ; ST(ST(S)):=ST(HEAPTOP); S:+2; MOV (Q)+,W ; W:=ST(Q); Q:+2; ADD W,HEAPTO ; ST(HEAPTOP):+W; ASR W ; HALVE W MOV HEAPTO,X ; X:=ST(HEAPTOP); 2$: CLR -(X) ; ITERATE W TIMES SOB W,2$ ; X:-2; CLEAR ST(X); NEXT ; END; ; ; .SBTTL NOT ;PROCEDURE NOT; ; BEGIN NOT: NEG (S) ; ST(S):=-ST(S); INC (S) ; INCREMENT ST(S); NEXT ; END; ; ; .SBTTL ANDWORD ;PROCEDURE ANDWORD; ; BEGIN ANDWOR: MOV (S)+,W ; W:=ST(S); S:+2; COM W ; W:=NOT W; BIC W,(S) ; ST(S):ANDNOT W; NEXT ; END; ; ; .SBTTL ANDSET ;PROCEDURE ANDSET; ; BEGIN ANDSET: MOV #8.,W ; W:=8; ; ITERATE W TIMES ; BEGIN 1$: COM (S) ; ST(S):=NOT ST(S); BIC (S)+,14.(S) ; ST(S+16):ANDNOT ST(S); S:+2; SOB W,1$ ; END; NEXT ; END; ; ; .SBTTL ORWORD ;PROCEDURE ORWORD; ; BEGIN ORWORD: BIS (S)+,(S) ; ST(S+2):OR ST(S); S:+2; NEXT ; END; ; ; .SBTTL ORSET ;PROCEDURE ORSET; ; BEGIN ORSET: MOV #8.,W ; W:=8; 1$: BIS (S)+,14.(S) ; ITERATE W TIMES SOB W,1$ ; ST(S+16):OR ST(S); S:+2; NEXT ; END; ; ; .SBTTL NEGWORD ;PROCEDURE NEGWORD; ; BEGIN NEGWOR: NEG (S) ; ST(S):=-ST(S) BVC 1$ ; IF OVERFLOW THEN JMP OVERFL ; GOTO OVERFLOWERROR; 1$: NEXT ; END; ; ; .SBTTL NEGREAL ;PROCEDURE NEGREAL; ; BEGIN NEGREA: ADD #100000,(SP) ; ST(S):=-ST(S); ;<01> NEXT ; END; ; ; .SBTTL ADDWORD ;PROCEDURE ADDWORD; ; BEGIN ADDWOR: ADD (S)+,(S) ; ST(S+2):+ST(S); S:+2; BVC 1$ ; IF OVERFLOW THEN JMP OVERFL ; GOTO OVERFLOWERROR; 1$: NEXT ; END; ; ; .SBTTL ADDREAL ;PROCEDURE ADDREAL; ; BEGIN ADDREA: .IF DF,F$PU ;<01> IF FPU, USE IT LDD (S)+,W ; W:=ST(S); S:+8; ADDD (S),W ; W:+ST(S); STD W,(S) ; ST(S):=W; .IFF ;<01> IF NOT, USE SOFTWARE ROUTINES JSR PC,$ADD ;<01> .ENDC ;<01> F$PU NEXT ; END; ; ; .SBTTL SUBWORD ;PROCEDURE SUBWORD; ; BEGIN SUBWOR: SUB (S)+,(S) ; ST(S+2):-ST(S): S:+2; BVC 1$ ; IF OVERFLOW THEN JMP OVERFL ; GOTO OVERFLOWERROR; 1$: NEXT ; END; ; ; .SBTTL SUBREAL ;PROCEDURE SUBREAL; ; BEGIN SUBREA: .IF DF,F$PU ;<01> GOT FPU? LDD (S)+,W ; W:=ST(S); S:+8; LDD (S),X ; X:=ST(S); SUBD W,X ; X:-W; STD X,(S) ; ST(S):=X; .IFF ;<01> IF NOT, USE SOFTWARE JSR PC,$SBD ;<01> .ENDC ;<01> F$PU NEXT ; END; ; ; .SBTTL SUBSET ;PROCEDURE SUBSET; ; BEGIN SUBSET: MOV #8.,W ; W:=8; 1$: BIC (S)+,14.(S) ; ITERATE W TIMES SOB W,1$ ; ST(S+16):ANDNOT ST(S); S:+2; NEXT ; END; ; ; .SBTTL MULWORD ;PROCEDURE MULWORD; ; BEGIN MULWOR: MOV (S)+,X ; X:=ST(S); S:+2; CLC ; CARRY:=FALSE; MUL (S),X ; X:*ST(S); BCC 1$ ; IF CARRY THEN JMP OVERFL ; GOTO OVERFLOWERROR; 1$: MOV X,(S) ; ST(S):=X; NEXT ; END; ; ; .SBTTL MULREAL ;PROCEDURE MULREAL; ; BEGIN MULREA: .IF DF,F$PU ;<01> FPU PRESENT? LDD (S)+,W ; W:=ST(S); S:+8; MULD (S),W ; W:*ST(S); STD W,(S) ; ST(S):=W; .IFF ;<01> IF NOT, USE SOFTWARE JSR PC,$MLD ;<01> .ENDC ;<01> F$PU NEXT ; END; ; ; .SBTTL DIVWORD ;PROCEDURE DIVWORD; ; BEGIN DIVWOR: MOV 2(S),X ; X:=ST(S+2); SXT W ; EXTENDSIGN W; DIV (S)+,W ; WX:/ST(S); S:+2; BVC 1$ ; IF OVERFLOW THEN JMP OVERFL ; GOTO OVERFLOWERROR; 1$: MOV W,(S) ; ST(S):=W; NEXT ; END; ; ; .SBTTL DIVREAL ;PROCEDURE DIVREAL; ; BEGIN DIVREA: .IF DF,F$PU ;<01> FPU PRESENT? LDD 8.(S),W ; W:=ST(S+8); DIVD (S)+,W ; W:/ST(S); S:+8; STD W,(S) ; ST(S):=W; .IFF ;<01> NO, USE SOFTWARE JSR PC,$DVD ;<01> CALL DP DIVIDE ROUTINE .ENDC ;<01> F$PU NEXT ; END; ; ; .SBTTL MODWORD ;PROCEDURE MODWORD; ; BEGIN MODWOR: MOV 2(S),X ; X:=ST(S+2); SXT W ; EXTENDSIGN W; DIV (S)+,W ; WX:/ST(S); S:+2; BVC 1$ ; IF OVERFLOW THEN JMP OVERFL ; GOTO OVERFLOWERROR; 1$: MOV X,(S) ; ST(S):=X; NEXT ; END; ; ; .SBTTL BUILDSET ;PROCEDURE BUILDSET; ; BEGIN BUILDS: MOV (S)+,W ; W:=ST(S); S:+2; BLT 1$ ; IF W<0 THEN GOTO RANGEERROR; CMP W,#127. ; W COMPARE 127; BLE 2$ ; IF GREATER THEN 1$: JMP RANGER ; GOTO RANGEERROR; 2$: MOV W,X ; X:=W; "X=MEMBER" BIC #177770,W ; W:MOD 8; "W=MEMBER MOD 8" ASH #-3.,X ; X:DIV 8; ADD S,X ; X:+S; "X=SET BYTE ADR" MOV #1,Y ; Y:=1; ASH W,Y ; Y:SHIFT W; "Y=SET BYTE BIT" BISB Y,(X) ; ST(X):OR Y; NEXT ; END; ; ; .SBTTL INSET ;PROCEDURE INSET; ; BEGIN INSET: MOV 16.(S),W ; W:=ST(S+16); BLT 1$ ; IF W<0 THEN GOTO RANGEERROR; CMP W,#127. ; W COMPARE 127; BLE 2$ ; IF GREATER THEN 1$: JMP RANGER ; GOTO RANGEERROR; 2$: MOV W,X ; X:=W; "X=MEMBER" BIC #177770,W ; W:MOD 8; "W=MEMBER MOD 8" ASH #-3.,X ; X:DIV 8; ADD S,X ; X:+S; "X=SET BYTE ADR" MOVB (X),Y ; Y:= ST(X); "Y=SET BYTE" NEG W ; W:=-W; ASH W,Y ; Y:SHIFT W; BIC #177776,Y ; Y:MOD 2; "Y=SET BIT" ADD #16.,S ; S:+16; MOV Y,(S) ; ST(S):=Y; NEXT ; END; ; ; .SBTTL LSWORD ;PROCEDURE LSWORD; ; BEGIN LSWORD: CLR W ; CLEAR W; CMP (S)+,(S) ; ST(S) COMPARE ST(S+2); S:+2; BLE 1$ ; IF GREATER THEN INC W ; INCREMENT W; 1$: MOV W,(S) ; ST(S):=W; NEXT ; END; ; ; .SBTTL EQWORD ;PROCEDURE EQWORD; ; BEGIN EQWORD: CLR W ; CLEAR W; CMP (S)+,(S) ; ST(S) COMPARE ST(S+2); S:+2; BNE 1$ ; IF EQUAL THEN INC W ; INCREMENT W; 1$: MOV W,(S) ; ST(S):=W; NEXT ; END; ; ; .SBTTL GRWORD ;PROCEDURE GRWORD; ; BEGIN GRWORD: CLR W ; CLEAR W; CMP (S)+,(S) ; ST(S) COMPARE ST(S+2); S:+2; BGE 1$ ; IF LESS THEN INC W ; INCREMENT W; 1$: MOV W,(S) ; ST(S):=W; NEXT ; END; ; ; .SBTTL NLWORD ;PROCEDURE NLWORD; ; BEGIN NLWORD: CLR W ; CLEAR W; CMP (S)+,(S) ; ST(S) COMPARE ST(S+2); S:+2; BGT 1$ ; IF NOTGREATER THEN INC W ; INCREMENT W; 1$: MOV W,(S) ; ST(S):=W; NEXT ; END; ; ; .SBTTL NEWORD ;PROCEDURE NEWORD; ; BEGIN NEWORD: CLR W ; CLEAR W; CMP (S)+,(S) ; ST(S) COMPARE ST(S+2); S:+2; BEQ 1$ ; IF NOTEQUAL THEN INC W ; INCREMENT W; 1$: MOV W,(S) ; ST(S):=W; NEXT ; END; ; ; .SBTTL NGWORD ;PROCEDURE NGWORD; ; BEGIN NGWORD: CLR W ; CLEAR W; CMP (S)+,(S) ; ST(S) COMPARE ST(S+2); S:+2; BLT 1$ ; IF NOTLESS THEN INC W ; INCREMENT W; 1$: MOV W,(S) ; ST(S):=W; NEXT ; END; ; ; .SBTTL LSREAL ;PROCEDURE LSREAL; ; BEGIN LSREAL: CLR W ; CLEAR W; .IF DF,F$PU ;<01> FPU PRESENT? LDD (S)+,X ; X:=ST(S); S:+8; CMPD (S)+,X ; ST(S) COMPARE X; S:+8; CFCC ; COPYCONDITIONS; .IFF ;<01> IF NOT, USE SOFTWARE JSR PC,$DCMP ;<01> CALL FLT COMPARE ROUTINE .ENDC ;<01> F$PU BGE 1$ ; IF LESS THEN INC W ; INCREMENT W; 1$: MOV W,-(S) ; S:-2; ST(S):=W; NEXT ; END; ; ; .SBTTL EQREAL ;PROCEDURE EQREAL; ; BEGIN EQREAL: CLR W ; CLEAR W; .IF DF,F$PU ;<01> LDD (S)+,X ; X:=ST(S); S:+8; CMPD (S)+,X ; ST(S) COMPARE X; S:+8; CFCC ; COPYCONDITIONS; .IFF ;<01> JSR PC,$DCMP ;<01> .ENDC ;<01> F$PU BNE 1$ ; IF EQUAL THEN INC W ; INCREMENT W; 1$: MOV W,-(S) ; S:-2; ST(S):=W; NEXT ; END; ; ; .SBTTL GRREAL ;PROCEDURE GRREAL ; BEGIN GRREAL: CLR W ; CLEAR W; .IF DF,F$PU ;<01> LDD (S)+,X ; X:=ST(S); S:+8; CMPD (S)+,X ; ST(S) COMPARE X; S:+8; CFCC ; COPYCONDITIONS; .IFF ;<01> JSR PC,$DCMP ;<01> .ENDC ;<01> F$PU BLE 1$ ; IF GREATER THEN INC W ; INCREMENT W; 1$: MOV W,-(S) ; S:-2; ST(S):=W; NEXT ; END; ; ; .SBTTL NLREAL ;PROCEDURE NLREAL ; BEGIN NLREAL: CLR W ; CLEAR W; .IF DF,F$PU ;<01> LDD (S)+,X ; X:=ST(S); S:+8; CMPD (S)+,X ; ST(S) COMPARE X; S:+8; CFCC ; COPYCONDITIONS; .IFF ;<01> JSR PC,$DCMP ;<01> .ENDC ;<01> F$PU BLT 1$ ; IF NOTLESS THEN INC W ; INCREMENT W; 1$: MOV W,-(S) ; S:-2; ST(S):=W; NEXT ; END; ; ; .SBTTL NEREAL ;PROCEDURE NEREAL; ; BEGIN NEREAL: CLR W ; CLEAR W; .IF DF,F$PU ;<01> LDD (S)+,X ; X:=ST(S); S:+8; CMPD (S)+,X ; ST(S) COMPARE X; S:+8; CFCC ; COPYCONDITIONS; .IFF ;<01> JSR PC,$DCMP ;<01> .ENDC ;<01> BEQ 1$ ; IF NOTEQUAL THEN INC W ; INCREMENT W; 1$: MOV W,-(S) ; S:-2; ST(S):=W; NEXT ; END; ; ; .SBTTL NGREAL ;PROCEDURE NGREAL ; BEGIN NGREAL: CLR W ; CLEAR W; .IF DF,F$PU ;<01> LDD (S)+,X ; X:=ST(S); S:+8; CMPD (S)+,X ; ST(S) COMPARE X; S:+8; CFCC ; COPYCONDITIONS; .IFF ;<01> JSR PC,$DCMP ;<01> .ENDC ;<01> F$PU BGT 1$ ; IF NOTGREATER THEN INC W ; INCREMENT W; 1$: MOV W,-(S) ; S:-2; ST(S):=W; NEXT ; END; ; ; .SBTTL EQSET ;PROCEDURE EQSET; ; BEGIN EQSET: CLR W ; CLEAR W; MOV S,X ; X:=S; MOV #8.,Y ; Y:=8; ; REPEAT 1$: CMP 16.(X),(X)+ ; ST(X+16) COMPARE ST(X); X:+2; BNE 2$ ; Y:-1; SOB Y,1$ ; UNTIL (Y=0) OR NOTEQUAL; INC W ; IF EQUAL THEN INCREMENT W; 2$: ADD #30.,S ; S:+30; MOV W,(S) ; ST(S):=W; NEXT ; END; ; ; .SBTTL NLSET ;PROCEDURE NLSET; ; BEGIN NLSET: CLR W ; CLEAR W; MOV S,X ; X:=S; MOV #8.,Y ; Y:=8; ; REPEAT 1$: BIC 16.(X),(X)+ ; ST(X):ANDNOT ST(X+16); X:+2; BNE 2$ ; Y:-1; SOB Y,1$ ; UNTIL (Y=0) OR NOTZERO; INC W ; IF ZERO THEN INCREMENT W; 2$: ADD #30.,S ; S:+30; MOV W,(S) ; ST(S):=W; NEXT ; END; ; ; .SBTTL NESET ;PROCEDURE NESET; ; BEGIN NESET: MOV #1,W ; W:=1; MOV S,X ; X:=S; MOV #8.,Y ; Y:=8; ; REPEAT 1$: CMP 16.(X),(X)+ ; ST(X+16) COMPARE ST(X); X:+2; BNE 2$ ; Y:-1; SOB Y,1$ ; UNTIL (Y=0) OR NOTEQUAL; CLR W ; IF EQUAL THEN CLEAR W; 2$: ADD #30.,S ; S:+30; MOV W,(S) ; ST(S):=W; NEXT ; END; ; ; .SBTTL NGSET ;PROCEDURE NGSET; ; BEGIN NGSET: CLR W ; CLEAR W; MOV S,X ; X:=S; MOV #8.,Y ; Y:=8; ; REPEAT 1$: BIC (X)+,14.(X) ; ST(X+16):ANDNOT ST(X); X:+2; BNE 2$ ; Y:-1; SOB Y,1$ ; UNTIL (Y=0) OR NOTZERO; INC W ; IF ZERO THEN INCREMENT W; 2$: ADD #30.,S ; S:+30; MOV W,(S) ; ST(S):=W; NEXT ; END; ; ; .SBTTL LSSTRUCT ;PROCEDURE LSSTRUCT(LENGTH DIV 2); ; BEGIN LSSTRU: MOV (Q)+,W ; W:=ST(Q); Q:+2; ASL W ; DOUBLE W; "W=LENGTH" MOV (S)+,X ; X:=ST(S); S:+2; "X=SOURCE ADDR" MOV (S),Y ; Y:=ST(S); "Y=DEST ADDR" CLR (S) ; CLEAR ST(S); ; REPEAT 1$: CMPB (Y)+,(X)+ ; ST(Y) COMPARE ST(X); Y:+1; X:+1; BNE 2$ ; W:-1; SOB W,1$ ; UNTIL (W=0) OR NOTEQUAL; 2$: BGE 3$ ; IF LESS THEN INC (S) ; INCREMENT ST(S); 3$: NEXT ; END; ; ; .SBTTL EQSTRUCT ;PROCEDURE EQSTRUCT(LENGTH DIV 2); ; BEGIN EQSTRU: MOV (Q)+,W ; W:=ST(Q); Q:+2; "W=LENGTH DIV 2" MOV (S)+,X ; X:=ST(S); S:+2; "X=SOURCE ADDR" MOV (S),Y ; Y:=ST(S); "Y=DEST ADDR" CLR (S) ; CLEAR ST(S); ; REPEAT 1$: CMP (Y)+,(X)+ ; ST(Y) COMPARE ST(X); Y:+2; X:+2; BNE 2$ ; W:-1; SOB W,1$ ; UNTIL (W=0) OR NOTEQUAL; INC (S) ; IF EQUAL THEN INCREMENT ST(S); 2$: NEXT ; END; ; ; .SBTTL GRSTRUCT ;PROCEDURE GRSTRUCT(LENGTH DIV 2); ; BEGIN GRSTRU: MOV (Q)+,W ; W:=ST(Q); Q:+2; ASL W ; DOUBLE W; "W=LENGTH" MOV (S)+,X ; X:=ST(S); S:+2; "X=SOURCE ADDR" MOV (S),Y ; Y:=ST(S); "Y=DEST ADDR" CLR (S) ; CLEAR ST(S); ; REPEAT 1$: CMPB (Y)+,(X)+ ; ST(Y) COMPARE ST(X); Y:+1; X:+1; BNE 2$ ; W:-1; SOB W,1$ ; UNTIL (W=0) OR NOTEQUAL; 2$: BLE 3$ ; IF GREATER THEN INC (S) ; INCREMENT ST(S); 3$: NEXT ; END; ; ; .SBTTL NLSTRUCT ;PROCEDURE NLSTRUCT(LENGTH DIV 2); ; BEGIN NLSTRU: MOV (Q)+,W ; W:=ST(Q); Q:+2; ASL W ; DOUBLE W; "W=LENGTH" MOV (S)+,X ; X:=ST(S); S:+2; "X=SOURCE ADDR" MOV (S),Y ; Y:=ST(S); "Y=DEST ADDR" CLR (S) ; CLEAR ST(S); ; REPEAT 1$: CMPB (Y)+,(X)+ ; ST(Y) COMPARE ST(X); Y:+1; X:+1; BNE 2$ ; W:-1; SOB W,1$ ; UNTIL (W=0) OR NOTEQUAL; 2$: BLT 3$ ; IF NOTLESS THEN INC (S) ; INCREMENT ST(S); 3$: NEXT ; END; ; ; .SBTTL NESTRUCT ;PROCEDURE NESTRUCT(LENGTH DIV 2); ; BEGIN NESTRU: MOV (Q)+,W ; W:=ST(Q); Q:+2; "W=LENGTH DIV 2" MOV (S)+,X ; X:=ST(S) S:+2; "X=SOURCE ADDR" MOV (S),Y ; Y:=ST(S); "Y=DEST ADDR" MOV #1,(S) ; ST(S):=1; ; REPEAT 1$: CMP (Y)+,(X)+ ; ST(Y) COMPARE ST(X); Y:+2; X:+2; BNE 2$ ; W:-1; SOB W,1$ ; UNTIL (W=0) OR NOTEQUAL; CLR (S) ; IF EQUAL THEN CLEAR ST(S); 2$: NEXT ; END; ; ; .SBTTL NGSTRUCT ;PROCEDURE NGSTRUCT(LENGTH DIV 2); ; BEGIN NGSTRU: MOV (Q)+,W ; W:=ST(Q); Q:+2; ASL W ; DOUBLE W; "W=LENGTH" MOV (S)+,X ; X:=ST(S); S:+2; "X=SOURCE ADDR" MOV (S),Y ; Y:=ST(S); "Y=DEST ADDR" CLR (S) ; CLEAR ST(S); ; REPEAT 1$: CMPB (Y)+,(X)+ ; ST(Y) COMPARE ST(X); Y:+1; X:+1; BNE 2$ ; W:-1; SOB W,1$ ; UNTIL (W=0) OR NOTEQUAL; 2$: BGT 3$ ; IF NOT GREATER THEN INC (S) ; INCREMENT ST(S); 3$: NEXT ; END; ; ; .SBTTL FUNCVALUE ;PROCEDURE FUNCVALUE(KIND); ; BEGIN FUNCVA: ADD (Q)+,P ; CASE KIND OF ; SIMPLEWORD: "0" ; BEGIN CLR -(S) ; S:-2; CLEAR ST(S); BR 1$ ; END; .WORD 0,0 ; "FILLER" ; SIMPLEREAL: "8" ; BEGIN SUB #8.,S ; S:-8; BR 1$ ; END; .WORD 0 ; "FILLER" ; CLASSWORD: "16" ; BEGIN MOV (S),W ; W:=ST(S); CLR (S) ; CLEAR ST(S); MOV W,-(S) ; S:-2; ST(S):=W; BR 1$ ; END; ; CLASSREAL: "24" ; BEGIN MOV (S),W ; W:=ST(S); SUB #8.,S ; S:-8; MOV W,(S) ; ST(S):=W; 1$: NEXT ; END; ; END; ; END; ; ; .SBTTL JUMP ;PROCEDURE JUMP(DISTANCE); ; BEGIN JUMP: ADD (Q),Q ; Q:+ST(Q); NEXT ; END; ; ; .SBTTL FALSEJUMP ;PROCEDURE FALSEJUMP(DISTANCE); ; BEGIN FALSEJ: ADD CONT,P ; IF (ST(CONTINUE) = 0) TST JOB ; & BEQ 1$ ; (ST(JOB) <> 0) JMP EXCEPT ; THEN GOTO EXCEPTION ; ELSE ; BEGIN 1$: TST (S)+ ; TEST ST(S); S:+2; "CONTINUE=10" BNE 2$ ; IF ZERO ADD (Q),Q ; THEN Q:+ST(Q) NEXT ; 2$: TST (Q)+ ; ELSE Q:+2; ; END NEXT ; END; ; ; .SBTTL CASEJUMP ;PROCEDURE CASEJUMP(MIN,MAX-MIN,DISTANCES); ; BEGIN CASEJU: MOV (S)+,W ; W:=ST(S); S:+2; SUB (Q)+,W ; W:-ST(Q); Q:+2; BLT 1$ ; IF LESS THEN GOTO RANGEERROR; CMP W,(Q)+ ; W COMPARE ST(Q); Q:+2; BLE 2$ ; IF GREATER THEN 1$: JMP RANGER ; GOTO RANGEERROR; 2$: ASL W ; DOUBLE W; ADD W,Q ; Q:+W; ADD (Q),Q ; Q:+ST(Q); NEXT ; END; ; ; .SBTTL INITVAR ;PROCEDURE INITVAR(LENGTH DIV 2); ; BEGIN INITVA: MOV (Q)+,W ; W:=ST(Q); Q:+2; MOV S,X ; X:=S; 1$: CLR (X)+ ; ITERATE W TIMES SOB W,1$ ; CLEAR ST(X); X:+2; NEXT ; END; ; ; .SBTTL CALL ;PROCEDURE CALL(DISTANCE); ; BEGIN CALL: MOV Q,W ; W:=Q; ADD (Q)+,W ; W:+ST(Q); Q:+2; MOV Q,-(S) ; S:-2; ST(S):=Q; MOV W,Q ; Q:=W; NEXT ; END; ; ; .SBTTL CALLSYS ;PROCEDURE CALLSYS((ENTRY-2)*2); ; BEGIN CALLSY: MOV 2(G),W ; W:=ST(G+2); "OLD S BEFORE PROGRAM CALL" ADD (Q)+,W ; W:+ST(Q); Q:+2; "W = ENTRY POINT ADDR" MOV Q,-(S) ; S:-2; ST(S):=Q; MOV (W),Q ; Q:=ST(W); NEXT ; END; .SBTTL ACTIVATION REC ;"ACTIVATION RECORD: ; ; HEAPTOP: ; S: ; ; B (OR G): ; + 2 ; + 4 ; + 6 ; + 8 ; + 10 ; () ; ; MONITOR VARIABLE: ; ; G: ; ; ; STACKLENGTH = VARLENGTH + TEMPLENGTH + 10 ; POPLENGTH = PARAMLENGTH + 8" ; ; .SBTTL ENTER ;PROCEDURE ENTER(STACKLENGTH,POPLENGTH,LINE, ; VARLENGTH); ; BEGIN ENTER: MOV S,X ; X:=S; SUB HEAPTO,X ; X:-ST(HEAPTOP); CMP X,(Q)+ ; X COMPARE ST(Q); Q:+2; "ERROR MESSAGE BHIS 1$ ; IF LESS THEN WILL REFER TO JMP STACKL ; GOTO STACKLIMIT; LINE OF CALL" 1$: MOV G,-(S) ; S:-2; ST(S):=G; MOV B,-(S) ; S:-2; ST(S):=B; TST -(S) ; S:-2; MOV S,(S) ; ST(S):=S; ADD (Q)+,(S) ; ST(S):+ST(Q); Q:+2; MOV (Q)+,-(S) ; S:-2; ST(S):=ST(Q); Q:+2; MOV S,B ; B:=S; SUB (Q)+,S ; S:-ST(Q); Q:+2; NEXT ; END; ; ; .SBTTL EXIT ;PROCEDURE EXIT; ; BEGIN EXIT: MOV B,S ; S:=B; TST (S)+ ; TEST ST(S); S:+2; MOV (S)+,W ; W:=ST(S); S:+2; MOV (S)+,B ; B:=ST(S); S:+2; MOV (S)+,G ; G:=ST(S); S:+2; MOV (S)+,Q ; Q:=ST(S); S:+2; MOV W,S ; S:=W; NEXT ; END; ; ; .SBTTL ENTERPROG ;PROCEDURE ENTERPROG(POPLENGTH,LINE,STACKLENGTH, ; VARLENGTH); ; BEGIN ENPROG: INC JOB ; INCREMENT ST(JOB); MOV G,-(S) ; S:-2; ST(S):=G; MOV B,-(S) ; S:-2; ST(S):=B; TST -(S) ; S:-2; MOV S,(S) ; ST(S):=S; ADD (Q)+,(S) ; ST(S):+ST(Q); Q:+2; MOV (Q)+,-(S) ; S:-2; ST(S):=ST(Q); Q:+2; MOV S,B ; B:=S; MOV B,G ; G:=B; MOV S,X ; X:=S; SUB HEAPTO,X ; X:-ST(HEAPTOP); CMP X,(Q)+ ; X COMPARE ST(Q); Q:+2; "ERROR MESSAGE BHIS 1$ ; IF LESS THEN WILL REFER TO JMP STACKL ; GOTO STACKLIMIT; LINE 1 OF USER 1$: SUB (Q)+,S ; S:-ST(Q); Q:+2; PROGRAM" NEXT ; END; ; ; .SBTTL EXITPROG ;PROCEDURE EXITPROG; ; BEGIN EXPROG: TST CONT ; TEST ST(CONTINUE); BNE 1$ ; IF ZERO JMP EXCEPT ; THEN GOTO EXCEPTION 1$: JMP TERMIN ; ELSE GOTO TERMINATED; ; END; ; ; .SBTTL BEGINCLASS ;PROCEDURE BEGINCLASS(STACKLENGTH,10,LINE,0); ; BEGIN BEGINC: MOV S,X ; X:=S; SUB HEAPTO,X ; X:-ST(HEAPTOP); CMP X,(Q)+ ; X COMPARE ST(Q); Q:+2; "ERROR MESSAGE BHIS 1$ ; IF LESS THEN WILL REFER TO JMP STACKL ; GOTO STACKLIMIT; LINE OF CALL" 1$: MOV G,-(S) ; S:-2; ST(S):=G; MOV B,-(S) ; S:-2; ST(S):=B; TST -(S) ; S:-2; MOV S,(S) ; ST(S):=S; ADD (Q)+,(S) ; ST(S):+ST(Q); Q:+2; MOV (Q)+,-(S) ; S:-2; ST(S):=ST(Q); Q:+2; MOV S,B ; B:=S; SUB (Q)+,S ; S:-ST(Q); Q:+2; MOV 2(B),W ; W:=ST(B+2); MOV -2(W),G ; G:=ST(W-2); NEXT ; END; ; ; .SBTTL ENDCLASS ;PROCEDURE ENDCLASS; ; BEGIN ENDCLA= EXIT ; "SAME AS EXIT" ; END; ; ; .SBTTL ENTERCLASS ;PROCEDURE ENTERCLASS(STACKLENGTH,POPLENGTH, ; LINE,VARLENGTH); ; BEGIN ENTERC= BEGINC ; "SAME AS BEGINCLASS" ; END; ; ; .SBTTL EXITCLASS ;PROCEDURE EXITCLASS; ; BEGIN EXITCL= EXIT ; "SAME AS EXIT" ; END; ; ; .SBTTL BEGINMON ;PROCEDURE BEGINMON(STACKLENGTH,10,LINE,0); ; BEGIN BEGINM: MOV S,X ; X:=S; SUB HEAPTO,X ; X:-ST(HEAPTOP); CMP X,(Q)+ ; X COMPARE ST(Q); Q:+2; "ERROR MESSAGE BHIS 1$ ; IF LESS THEN WILL REFER TO JMP STACKL ; GOTO STACKLIMIT; LINE OF CALL" 1$: MOV G,-(S) ; S:-2; ST(S):=G; MOV B,-(S) ; S:-2; ST(S):=B; TST -(S) ; S:-2; MOV S,(S) ; ST(S):=S; ADD (Q)+,(S) ; ST(S):+ST(Q); Q:+2; MOV (Q)+,-(S) ; S:-2; ST(S):=ST(Q); Q:+2; MOV S,B ; B:=S; SUB (Q)+,S ; S:-ST(Q); Q:+2; MOV 2(B),W ; W:=ST(B+2); MOV -2(W),G ; G:=ST(W-2); MOV #INITG1,OPCODE ; ST(KERNELOP):=INITGATE1; MOV G,ARG1 ; ST(KERNELARG1):=G; KNCALL ; KERNELCALL; NEXT ; END; ; ; .SBTTL ENDMON ;PROCEDURE ENDMON; ; BEGIN ENDMON: MOV #LEAVG1,OPCODE ; ST(KERNELOP):=LEAVEGATE1; MOV (G),ARG1 ; ST(KERNELARG1):=ST(G); KNCALL ; KERNELCALL; MOV B,S ; S:=B; TST (S)+ ; TEST ST(S); S:+2; MOV (S)+,W ; W:=ST(S); S:+2; MOV (S)+,B ; B:=ST(S); S:+2; MOV (S)+,G ; G:=ST(S); S:+2; MOV (S)+,Q ; Q:=ST(S); S:+2; MOV W,S ; S:=W; NEXT ; END; ; ; .SBTTL ENTERMON ;PROCEDURE ENTERMON(STACKLENGTH, POPLENGTH, ; LINE, VARLENGTH); ; BEGIN ENTERM: MOV S,X ; X:=S; SUB HEAPTO,X ; X:-ST(HEAPTOP); CMP X,(Q)+ ; X COMPARE ST(Q); Q:+2; "ERROR MESSAGE BHIS 1$ ; IF LESS THEN WILL REFER TO JMP STACKL ; GOTO STACKLIMIT; LINE OF CALL" 1$: MOV G,-(S) ; S:-2; ST(S):=G; MOV B,-(S) ; S:-2; ST(S):=B; TST -(S) ; S:-2; MOV S,(S) ; ST(S):=S; ADD (Q)+,(S) ; ST(S):+ST(Q); Q:+2; MOV (Q)+,-(S) ; S:-2; ST(S):=ST(Q); Q:+2; MOV S,B ; B:=S; SUB (Q)+,S ; S:-ST(Q); Q:+2; MOV 2(B),W ; W:=ST(B+2); MOV -2(W),G ; G:=ST(W-2); MOV #ENTEG1,OPCODE ; ST(KERNELOP):=ENTERGATE1; MOV (G),ARG1 ; ST(KERNELARG1):=ST(G); KNCALL ; KERNELCALL; NEXT ; END; ; ; .SBTTL EXITMON ;PROCEDURE EXITMON; ; BEGIN EXITMO= ENDMON ; "SAME AS ENDMON" ; END; ; ; .SBTTL BEGINPROC ;PROCEDURE BEGINPROC(LINE); ; BEGIN BEGINP: MOV (Q)+,(B) ; ST(B):=ST(Q); Q:+2; NEXT ; END; ; ; .SBTTL ENDPROC ;PROCEDURE ENDPROC; ; BEGIN ENDPRO: MOV #ENDPR1,OPCODE ; ST(KERNELOP):=ENDPROCESS1; KNCALL ; KERNELCALL; NEXT ; END; ; ; .SBTTL ENTERPROC ;PROCEDURE ENTERPROC(STACKLENGTH,POPLENGTH, ; LINE,VARLENGTH); ; BEGIN ENPROC: MOV S,X ; X:=S; SUB HEAPTO,X ; X:-ST(HEAPTOP); CMP X,(Q)+ ; X COMPARE ST(Q); Q:+2; "ERROR MESSAGE BHIS 1$ ; IF LESS THEN WILL REFER TO JMP STACKL ; GOTO STACKLIMIT; LINE OF CALL" 1$: MOV G,-(S) ; S:-2; ST(S):=G; MOV B,-(S) ; S:-2; ST(S):=B; TST -(S) ; S:-2; MOV S,(S) ; ST(S):=S; ADD (Q)+,(S) ; ST(S):+ST(Q); Q:+2; MOV (Q)+,-(S) ; S:-2; ST(S):=ST(Q); Q:+2; MOV S,B ; B:=S; SUB (Q)+,S ; S:-ST(Q); Q:+2; MOV 6(G),G ; G:=ST(G+6); CLR JOB ; CLEAR ST(JOB); NEXT ; END; ; ; .SBTTL EXITPROC ;PROCEDURE EXITPROC; ; BEGIN EXPROC: MOV B,S ; S:=B; TST (S)+ ; TEST ST(S); S:+2; MOV (S)+,W ; W:=ST(S); S:+2; MOV (S)+,B ; B:=ST(S); S:+2; MOV (S)+,G ; G:=ST(S); S:+2; MOV (S)+,Q ; Q:=ST(S); S:+2; MOV W,S ; S:=W; INC JOB ; INCREMENT ST(JOB); NEXT ; END; ; ; .SBTTL POP ;PROCEDURE POP(LENGTH); ; BEGIN POP: ADD (Q)+,S ; S:+ST(Q); Q:+2; NEXT ; END; ; ; .SBTTL NEWLINE ;PROCEDURE NEWLINE(NUMBER); ; BEGIN NEWLIN: MOV (Q)+,(B) ; ST(B):=ST(Q); Q:+2; NEXT ; END; ; ; .SBTTL INCRWORD ;PROCEDURE INCRWORD; ; BEGIN INCWOR: INC @(S)+ ; INCREMENT ST(ST(S)); S:+2; NEXT ; END; ; ; .SBTTL DECRWORD ;PROCEDURE DECRWORD; ; BEGIN DECWOR: DEC @(S)+ ; DECREMENT ST(ST(S)); S:+2; NEXT ; END; ; ; .SBTTL INITCLASS ;PROCEDURE INITCLASS(PARAMLENGTH,DISTANCE); ; BEGIN INITCL: MOV (Q)+,W ; W:=ST(Q); Q:+2; "W=PARAMLENGTH" BEQ 2$ ; IF NONZERO THEN ; BEGIN MOV S,X ; X:=S; ADD W,X ; X:+W; "X=S+PARAMLENGTH" MOV (X),X ; X:=ST(X); TST (X)+ ; TEST ST(X); X:+2; "X=CLASS ADDR+2" ASR W ; HALVE W 1$: MOV (S)+,(X)+ ; ITERATE W TIMES SOB W,1$ ; ST(X):=ST(S); X:+2; S:+2; ; END; 2$: MOV Q,W ; W:=Q; ADD (Q)+,W ; W:+ST(Q); Q:+2; MOV Q,-(S) ; S:-2; ST(S):=Q; MOV W,Q ; Q:=W; NEXT ; END; ; ; .SBTTL INITMON ;PROCEDURE INITMON(PARAMLENGTH,DISTANCE); ; BEGIN INITMO= INITCL ; "SAME AS INITCLASS" ; END; ; ; .SBTTL INITPROC ;PROCEDURE INITPROC(PARAMLENGTH,VARLENGTH, ; STACKLENGTH,DISTANCE); ; BEGIN INITPR: MOV #INITP1,OPCODE ; ST(KERNELOP):=INITPROCESS1; MOV (Q)+,ARG1 ; ST(KERNELARG1):=ST(Q); Q:+2; MOV (Q)+,ARG2 ; ST(KERNELARG2):=ST(Q); Q:+2; MOV (Q)+,ARG3 ; ST(KERNELARG3):=ST(Q); Q:+2; MOV Q,ARG4 ; ST(KERNELARG4):=Q; ADD (Q)+,ARG4 ; ST(KERNELARG4):+ST(Q); Q:+2; KNCALL ; KERNELCALL; TST (S)+ ; TEST ST(S); S:+2; NEXT ; END; ; ; .SBTTL PUSHLABEL ;PROCEDURE PUSHLABEL(DISTANCE); ; BEGIN PUSHLA: MOV Q,-(S) ; S:-2; ST(S):=Q; ADD (Q)+,(S) ; ST(S):+ST(Q); Q:+2; NEXT ; END; ; ; .SBTTL CALLPROG ;PROCEDURE CALLPROG; ; BEGIN CALLPR: MOV Q,W ; W:=Q; "W=OLD Q" MOV (S),Q ; Q:=ST(S); "Q=CODE ADDR" TST (Q)+ ; TEST ST(Q); Q:+2; MOV (Q)+,(S) ; ST(S):=ST(Q); Q:+2; "ST(S)=CODELENG" ADD #4.,Q ; Q:+4; "Q=CODEADDR+8" ADD Q,(S) ; ST(S):+Q; "ST(S)=CONSTADR" MOV W,-(S) ; S:-2; ST(S):=W; "PUSH(OLD Q)" NEXT ; END; ; ; .SBTTL TRUNCREAL ;PROCEDURE TRUNCREAL; ; BEGIN TRUNCR: .IF DF,F$PU ;<01> LDD (S)+,W ; W:= ST(S); S:+8; STCDI W,-(S) ; S:-2; ST(S):=TRUNC(W); BVC 1$ ; IF OVERFLOW THEN JMP OVERFL ; GOTO OVERFLOWERROR; .IFF ;<01> JSR PC,$DI ;<01> CONVERT DOUBLE -> INTEGER .ENDC ;<01> F$PU 1$: NEXT ; END; ; ; .SBTTL ABSWORD ;PROCEDURE ABSWORD; ; BEGIN ABSWOR: TST (S) ; TEST ST(S); BGE 1$ ; IF NEGATIVE THEN ; BEGIN NEG (S) ; ST(S):=-ST(S); BVC 1$ ; IF OVERFLOW THEN JMP OVERFL ; GOTO OVERFLOWERROR; ; END; 1$: NEXT ; END; ; ; .SBTTL ABSREAL ;PROCEDURE ABSREAL; ; BEGIN ABSREA: BIC #100000,(S) ;<01> SAVE A FEW MICRO-SECONDS NEXT ; END; ; ; .SBTTL SUCCWORD ;PROCEDURE SUCCWORD; ; BEGIN SUCCWO: INC (S) ; INCREMENT ST(S); NEXT ; END; ; ; .SBTTL PREDWORD ;PROCEDURE PREDWORD; ; BEGIN PREDWO: DEC (S) ; DECREMENT ST(S); NEXT ; END; ; ; .SBTTL CONVWORD ;PROCEDURE CONVWORD; ; BEGIN CONVWO: .IF DF,F$PU ;<01> LDCID (S)+,W ; W:=CONV(ST(S)); S:+2; STD W,-(S) ; S:-8; ST(S):=W; .IFF ;<01> JSR PC,$ID ;<01> .ENDC NEXT ; END; ; ; .SBTTL EMPTY ;PROCEDURE EMPTY; ; BEGIN EMPTY: CLR W ; CLEAR W; TST (S) ; TEST ST(S); BNE 1$ ; IF ZERO THEN INC W ; INCREMENT W; 1$: MOV W,(S) ; ST(S):=W; NEXT ; END; ; ; .SBTTL ATTRIBUTE ;PROCEDURE ATTRIBUTE; ; BEGIN ATTRIB: MOV (S),W ; W:=ST(S); ASL W ; DOUBLE W; MOV HEAD(W),(S) ; ST(S):=ST(W+HEAD); NEXT ; END; .SBTTL REALTIME ;PROCEDURE REALTIME; ; BEGIN REALTI: MOV #REALT1,OPCODE ; ST(KERNELOP):=REALTIME1; KNCALL ; KERNELCALL; MOV ARG1,-(S) ; S:-2; ST(S):=ST(KERNELARG1); NEXT ; END; ; ; .SBTTL DELAY ;PROCEDURE DELAY; ; BEGIN DELAY: MOV #DELAY1,OPCODE ; ST(KERNELOP):=DELAYGATE1; MOV (G),ARG1 ; ST(KERNELARG1):=ST(G); MOV (S)+,ARG2 ; ST(KERNELARG2):=ST(S); S:+2; KNCALL ; KERNELCALL; NEXT ; END; ; ; .SBTTL CONTINUE ;PROCEDURE CONTINUE; ; BEGIN CONTIN: MOV #CONTG1,OPCODE ; ST(KERNELOP):=CONTGATE1; MOV (G),ARG1 ; ST(KERNELARG1):=ST(G); MOV (S)+,ARG2 ; ST(KERNELARG2):=ST(S); S:+2; KNCALL ; KERNELCALL; MOV B,S ; S:=B; TST (S)+ ; TEST ST(S); S:+2; MOV (S)+,W ; W:=ST(S); S:+2; MOV (S)+,B ; B:=ST(S); S:+2; MOV (S)+,G ; G:=ST(S); S:+2; MOV (S)+,Q ; Q:=ST(S); S:+2; MOV W,S ; S:=W; NEXT ; END; ; ; .SBTTL IO ;PROCEDURE IO; ; BEGIN IO: MOV #IO1,OPCODE ; ST(KERNELOP):=IO1; MOV (S)+,ARG3 ; ST(KERNELARG3):=ST(S); S:+2; MOV (S)+,ARG2 ; ST(KERNELARG2):=ST(S); S:+2; MOV (S)+,ARG1 ; ST(KERNELARG1):=ST(S); S:+2; KNCALL ; KERNELCALL; NEXT ; END; ; ; .SBTTL START ;PROCEDURE START; ; BEGIN START: MOV #10.,CONT ; ST(CONTINUE):=10; NEXT ; END; ; ; .SBTTL STOP ;PROCEDURE STOP; ; BEGIN STOP: MOV #STOPJ1,OPCODE ; ST(KERNELOP):=STOPJOB1; MOV (S)+,ARG2 ; ST(KERNELARG2):=ST(S); S:+2; MOV (S)+,ARG1 ; ST(KERNELARG1):=ST(S); S:+2; KNCALL ; KERNELCALL; NEXT ; END; ; ; .SBTTL SETHEAP ;PROCEDURE SETHEAP; ; BEGIN SETHEA: MOV (S)+,HEAPTO ; ST(HEAPTOP):=ST(S); S:+2; NEXT ; END; ; ; .SBTTL WAIT ;PROCEDURE WAIT; ; BEGIN WAIT: MOV #WAIT1,OPCODE ; ST(KERNELOP):=WAIT1; KNCALL ; KERNELCALL; NEXT ; END; ; ; .SBTTL TERMINATED ;TERMINATED: TERMIN: MOV #0,RESULT ; ST(RESULT):=0; JMP EXCEPT ; GOTO EXCEPTION; ; ; .SBTTL OVERFLOWERROR ;OVERFLOWERROR: OVERFL: MOV #1,RESULT ; ST(RESULT):=1; JMP EXCEPT ; GOTO EXCEPTION; ; ; .SBTTL POINTERERROR ;POINTERERROR: POINER: MOV #2,RESULT ; ST(RESULT):=2; JMP EXCEPT ; GOTO EXCEPTION; ; ; .SBTTL RANGEERROR ;RANGEERROR: RANGER: MOV #3,RESULT ; ST(RESULT):=3; JMP EXCEPT ; GOTO EXCEPTION; ; ; .SBTTL VARIANTERROR ;VARIANTERROR: VARIER: MOV #4,RESULT ; ST(RESULT):=4; JMP EXCEPT ; GOTO EXCEPTION; ; ; .SBTTL HEAPLIMIT ;HEAPLIMIT: HEAPLI: MOV #5,RESULT ; ST(RESULT):=5; JMP EXCEPT ; GOTO EXCEPTION; ; ; .SBTTL STACKLIMIT ;STACKLIMIT: STACKL: MOV #6,RESULT ; ST(RESULT):=6; JMP EXCEPT ; GOTO EXCEPTION; ; ; .SBTTL EXCEPTION ;EXCEPTION: EXCEPT: MOV (B),LINE ; ST(LINE):=ST(B); TST JOB ; TEST ST(JOB); BNE 1$ ; IF ZERO THEN "INSYSTEM" ; BEGIN MOV #SYSTE1,OPCODE ; ST(KERNELOP):=SYSTEMERROR; KNCALL ; KERNELCALL; BR 2$ ; END ; ELSE "IN JOB" ; BEGIN 1$: MOV G,B ; B:=G; MOV B,S ; S:=B; TST (S)+ ; TEST ST(S); S:+2; MOV (S)+,W ; W:=ST(S); S:+2; MOV (S)+,B ; B:=ST(S); S:+2; MOV (S)+,G ; G:=ST(S); S:+2; MOV (S)+,Q ; Q:=ST(S); S:+2; MOV W,S ; S:=W; CLR JOB ; CLEAR ST(JOB); 2$: NEXT ; END; ; ; .TITLE DADD DOUBLE FLOATING ADD AND SUBTRACT .IF NDF,F$PU ;<01> .GLOBL $ADD,$SBD,OVERFL ; $ADD --- THE DOUBLE PRECISION ADD ROUT1INE ; ADD THE TOP STACK ITEM TO THE SECOND ITEM ; AND LEAVE THE SUM IN THEIR PLACE. ; $SBD --- THE DOUBLE PRECISION SUBTRACT ROUT1INE ; SUBTRACT THE TOP STACK ITEM FROM THE SECOND ITEM ; AND LEAVE THE DIFFERENCE IN PLACE OF THEM A1=6+10 B1=8.+10 C1=10.+10 D1=12.+10 A2=14.+10 B2=16.+10 C2=18.+10 D2=20.+10 SIGNS=0. ;ADD AND SUBTRACT TO STACK FROM STACK SUD$SS: $SBD: ADD #100000,2(SP) ;<01> NEGATE TOP STACK ITEM $ADD: ADD$SS: POP R0 ;<01> PUT RETURN ADDRESS IN R0 PUSH ;<01> SAVE THE REGISTERS CLR -(SP) ;CLEAR SIGNS CLR R4 ;CLEAR EXPONENTS CLR R5 ASL D1(SP) ;SHIFT OUT1 SIGN OF TOP ITEM ROL C1(SP) ROL B1(SP) ROL A1(SP) ;SHIFT A1 BISB A1+1(SP),R4 ;GET E1 BEQ A1Z ;JUMP IF $ZERO ROLB @SP ;GET S1 ASL D2(SP) ;SHIFT OUT1 SIGN OF SECOND ITEM ROL C2(SP) ROL B2(SP) ROL A2(SP) ;SHIFT A2 BISB A2+1(SP),R5 ;GET E2 BNE A2NZ ;JUMP IF NOT 0 RORB @SP ;RECONSTRUCT A1 ROR A1(SP) ROR B1(SP) ROR C1(SP) ROR D1(SP) MOV A1(SP),A2(SP) ;FIRST ARG TO TOP OF STACK MOV B1(SP),B2(SP) MOV C1(SP),C2(SP) MOV D1(SP),D2(SP) A1Z: TST (SP)+ ;FLUSH SIGNS JMP OUT1 ;DONE A2NZ: ROLB SIGNS+1(SP) ;GET S2 MOVB #1,A2+1(SP) ;INSERT NORMAL BIT MOVB #1,A1+1(SP) ;INSERT NORMAL BIT SUB R4,R5 ;R5=E2-E1, R4=E1 BGT EXPA ;JUMP IF E2>E1 MOV A2(SP),R0 ;R0=A2 MOV B2(SP),R1 ;R1=B2 MOV C2(SP),R2 MOV D2(SP),R3 BR SCHK ;GO CHECK SIGNS EXPA: ADD R5,R4 ;R5=E2-E1,R4=E2,E2>E1 MOV A1(SP),R0 ;R0=A1 MOV B1(SP),R1 ;R1=B1 MOV C1(SP),R2 MOV D1(SP),R3 MOV A2(SP),A1(SP) MOV B2(SP),B1(SP) MOV C2(SP),C1(SP) MOV D2(SP),D1(SP) SWAB @SP ;EXCHANGE SIGNS NEG R5 ;E1-E2 SCHK: CMPB SIGNS+1(SP),@SP ;COMPARE SIGNS BEQ ECHK ;THEY'RE THE SAME. CHECK EXPONENT NEG R3 ;NEGATE OPERAND ADC R2 ADC R1 ADC R0 NEG R2 ADC R1 ADC R0 NEG R1 ADC R0 NEG R0 ECHK: TST R5 ;CHECK EXPONENTS BEQ SHFT1D ;JUMP IF E1=E2 SHFT1: CMP #-57.,R5 ;IS THERE ANY POINT IN SHIFTING? BLE SHFTR ;YES MOV A1(SP),R0 ;NO, ANSWER IS OPERAND MOV B1(SP),R1 ;WITH THE LARGER EXPONENT MOV C1(SP),R2 MOV D1(SP),R3 BR NORMD1 SHFTR: CMP #-8.,R5 ;CHECK # OF BITS TO SHIFT BLE SR8 ;JUMP IF NOT MORE THAN 1/2 WORD TST R0 SXT -(SP) ;EXTEND SIGN SHFTR1: CMP #-16.,R5 BLT SR16 ;JUMP IF NOT MORE THAN A WORD TO SHIFT MOV R2,R3 ;SHIFT A WORD AT A TIME MOV R1,R2 MOV R0,R1 MOV @SP,R0 ;USE EXTENSION ADD #16.,R5 ;ADJUST EXPONENT BNE SHFTR1 ;TRY AGAIN TST (SP)+ ;POP EXTENSION BR SHFT1D ;SHIFT IS ALL DONE SR16: CMP #-3,R5 ;JUMP IF NOT MORE THAN 3 TO SHIFT BLE SR8A MOV R4,@SP ;SAVE EXP AND SHIFT COUNT MOV R5,-(SP) MOV R1,R4 ;SAVE R1 ASHC R5,R0 ;SHIFT HIGH ORDER MOV R2,R5 ;SAVE R2 ASHC @SP,R4 ;SHIFT IT MOV R2,R4 MOV R5,R2 ;R2 DONE MOV R3,R5 ;SET UP LOW ORDER ASHC (SP)+,R4 ;DO LOW ORDER MOV R5,R3 MOV (SP)+,R4 ;RESTORE EXPONENT TO R4 BR SHFT1D SR8A: TST (SP)+ ;POP EXTENSION SR8: ASR R0 ;SHIFT RIGHT ROR R1 ROR R2 ROR R3 INC R5 ;COUNT LOOP BLT SR8 SHFT1D: ADD D1(SP),R3 ;FORM THE SUM ADC R2 ADC R1 ADC R0 ADD C1(SP),R2 ADC R1 ADC R0 ADD B1(SP),R1 ADC R0 ADD A1(SP),R0 CMPB SIGNS+1(SP),@SP ;CHECK FOR UNEQUAL SIGNS BNE SUB ;GO CLEAN UP SUBTRACT BIT R0,#1000 BEQ NORMD1 ;JUMP IF NO NORMAL BIT OVERFLOW ASR R0 ROR R1 ROR R2 ROR R3 INC R4 ;INCREASE EXPONENT NORMD1: SWAB R4 ;MOVE EXPONENT LEFT BNE OVER1F ;JUMP IF OVERFLOW NFLOW: BISB R0,R4 ;INSERT HIGH ORDER FRACTION ROR (SP)+ ;INSERT SIGN ROR R4 ROR R1 ROR R2 ROR R3 ADC R3 ADC R2 ADC R1 ADC R4 BVS OVER1 ;JUMP IF OVERFLOW ON ROUND BCS OVER1 MOV R4,A2+0-2(SP) ;STORE EXPONENT AND SIGN MOV R1,B2+0-2(SP) ;INSERT LOW ORDER FRACTION MOV R2,C2+0-2(SP) MOV R3,D2+0-2(SP) OUT1: POP ADD #8.,SP ;POP SECOND ARGUMENT JMP @R0 ;<01> RETURN OVER1F: TST (SP)+ ;POP SIGN OVER1: POP ;<01> UNSAVE REGISTERS ADD #8.,SP ;<01> POP 1ST OPD JMP OVERFL UTEST: TST R4 ;CHECK FOR UNDERFLOW BGT NORMD1 UNDERF: ;<01> UNDERFLOW! UNDER: CLR R0 CLR R1 ;UNDERFLOW. TREAT AS 0 CLR R2 CLR R3 $ZERO: CLR @SP ;SET SIGN PLUS CLR R4 BR NFLOW ;FINISH OUT1 NORMALLY SUB: TST R0 ;CHECK HIGH ORDER RESULT FRACTION BGT BIT9 ;IF POSITIVE SIGN IS OK BEQ ZTEST ;CHECK FOR $ZERO RESULT NEG R3 ;GET ABSOLUTE VALUE ADC R2 ADC R1 ADC R0 NEG R2 ADC R1 ADC R0 NEG R1 ADC R0 SWAB @SP ;EXCHANGE SIGNS NEG R0 BEQ ZTEST ;CHECK FOR $ZERO RESULT BIT9: BIT9A: BIT R0,#400 ;CHECK NORMAL BIT BNE UTEST ;JUMP IF FOUND DEC R4 ;DECREASE EXPONENT ASL R3 ;DOUBLE FRACTION ROL R2 ROL R1 ROL R0 BR BIT9A ;TRY AGAIN ZTEST: SUB #8.,R4 ;REDUCE EXPONENT TST R1 BNE ZT1 ;JUMP IF ONLY R0=0 SUB #16.,R4 MOV R2,R1 BNE ZT2 ;JUMP IF R2 NOT 0 SUB #16.,R4 TST R3 BEQ $ZERO ;ANSWER IS 0 BISB R3,R1 ;MOVE BYTES TO R0,R1 SWAB R1 SWAB R3 BISB R3,R0 CLR R3 ;MAKE ALL OTHERS 0 BR BIT9 ;GO NORMALIZE ZT2: MOV R3,R2 CLR R3 ZT1: SWAB R1 ;MOVE ALL BYTES LEFT BISB R1,R0 CLRB R1 SWAB R2 BISB R2,R1 CLRB R2 SWAB R3 BISB R3,R2 CLRB R3 BR BIT9 ;GO NORMALIZE WHAT'S LEFT .ENDC .TITLE DMUL DOUBLE FLOATING MULTIPLIES .IF NDF,F$PU ;<01> .GLOBL $MLD,OVERFL ; $MLD THE DOUBLE MULTIPLY ROUTINE ; CALLED IN POLISH MODE. ; REPLACES THE TOP TWO DOUBLES ON THE STACK ; WITH THEIR PRODUCT. A=8.+10 B=16.+10 RESLT=12.+10 $SIGN=2 ;MULTIPLY STACK AND STACK $MLD: MUD$SS: POP R0 ;<01> POP RETURN TO R0 PUSH ;<01> SAVE THE REGISTERS ASL A+0-4(SP) ;SHIFT MULTIPLICAND ROL -(SP) ;KEEP $SIGN CLR -(SP) ;CLEAR EXPONENT MOVB A+1(SP),@SP ;KEEP MULTIPLICAND EXPONENT BEQ $ZERO1 ;JUMP IF ANSWER IS $ZERO1 MOVB A(SP),A+1(SP) ;SHIFT FRACTION LEFT SEC ;INSERT NORMAL BIT ROR A(SP) MOVB A+3(SP),A(SP) SWAB A+2(SP) MOVB A+5(SP),A+2(SP) SWAB A+4(SP) MOVB A+7(SP),A+4(SP) SWAB A+6(SP) CLRB A+6(SP) ;MAKE ROOM FOR EXTRA BITS ASL B(SP) ;SHIFT HIGH MULTIPLIER ADC $SIGN(SP) ;GET PRODUCT $SIGN TSTB B+1(SP) BNE NONZ ;JUMP IF NOT $ZERO1 $ZERO1: CMP (SP)+,(SP)+ ;FLUSH $SIGN AND EXPONENT ZERO11: JMP ZERO12 NONZ: CLR R0 ;CLEAR PRODUCT CLR R1 CLR R4 BISB B+1(SP),R4 ;GET EXPONENT ADD R4,@SP ;GET SUM OF EXPONENTS MOVB #1,B+1(SP) ;INSERT NORMAL BIT ROR B(SP) SWAB B(SP) ;LEFT JUSTIFY FRACTION MOVB B+3(SP),B(SP) SWAB B+2(SP) MOVB B+5(SP),B+2(SP) SWAB B+4(SP) MOVB B+7(SP),B+4(SP) SWAB B+6(SP) CLRB B+6(SP) MOV A(SP),-(SP) MOV B+6+2(SP),R4 ;GET A1*B4 JSR PC,EMULT MOV R4,R2 ;RESULT TO PRODUCT MOV R5,R3 MOV A+2(SP),-(SP) MOV B+4+2(SP),R4 ;GET A2*B3 JSR PC,EMULT ADD R4,R2 ;ADD TO PRODUCT ADC R1 ADD R5,R3 ADC R2 ADC R1 MOV A+4(SP),-(SP) MOV B+2+2(SP),R4 ;GET A3*B2 JSR PC,EMULT ADD R4,R2 ADC R1 ADD R5,R3 ADC R2 ADC R1 MOV A+6(SP),-(SP) MOV B+0+2(SP),R4 ;GET A4*B1 JSR PC,EMULT ADD R4,R2 ADC R1 ADD R5,R3 ADC R2 ADC R1 MOV R2,R3 ;DIVIDE BY 2**16 MOV R1,R2 CLR R1 MOV A(SP),-(SP) MOV B+4+2(SP),R4 ;GET A1*B3 JSR PC,EMULT ADD R4,R2 ADC R1 ADD R5,R3 ADC R2 ADC R1 MOV A+2(SP),-(SP) MOV B+2+2(SP),R4 ;GET A2*B2 JSR PC,EMULT ADD R4,R2 ADC R1 ADD R5,R3 ADC R2 ADC R1 MOV A+4(SP),-(SP) MOV B+0+2(SP),R4 ;GET A3*B1 JSR PC,EMULT ADD R4,R2 ADC R1 ADD R5,R3 ADC R2 ADC R1 MOV A(SP),-(SP) MOV B+2+2(SP),R4 ;GET A1*B2 JSR PC,EMULT ADD R4,R1 ADC R0 ADD R5,R2 ADC R1 ADC R0 MOV A+2(SP),-(SP) MOV B+0+2(SP),R4 ;GET A2*B1 JSR PC,EMULT ADD R4,R1 ADC R0 ADD R5,R2 ADC R1 ADC R0 MOV A(SP),-(SP) MOV B+0+2(SP),R4 ;GET A1*B1 JSR PC,EMULT ADD R4,R0 ADD R5,R1 ADC R0 MOV (SP)+,R4 ;GET SUM OF EXPONENTS ASL R3 ;SHIFT OUT NORMAL BIT ROL R2 ROL R1 ROL R0 BCS NORM2 ;JUMP IF IT WAS FOUND ASL R3 ROL R2 ROL R1 ROL R0 ;MUST HAVE GOT IT NOW DEC R4 ;ADJUST EXPONENT NORM2: SUB #200,R4 ;TAKE OUT ONE OF THE EXCESS 128'S BLE UNDER2 ;JUMP IF UNDERFLOW CMP #377,R4 BLT OVER2 ;JUMP IF OVERFLOW CLRB R3 BISB R2,R3 ;SHIFT FRACTION RIGHT SWAB R3 CLRB R2 BISB R1,R2 SWAB R2 CLRB R1 BISB R0,R1 SWAB R1 CLRB R0 BISB R4,R0 SWAB R0 ROR (SP)+ ;GET PRODUCT $SIGN ROR R0 ;INSERT IT IN RESULT ROR R1 ROR R2 ROR R3 ADC R3 ;ROUND RESULT ADC R2 ADC R1 ADC R0 BCS OVER21 ;JUMP IF OVERFLOW ON ROUND BVS OVER21 OUT: MOV R0,RESLT(SP) ;PUT OUT ANSWER MOV R1,RESLT+2(SP) MOV R2,RESLT+4(SP) MOV R3,RESLT+6(SP) POP ;<01> UNSAVE REGISTERS ADD #8.,SP ;FLUSH TOP ARGUMENT JMP @R0 ;<01> AND RETURN OVER21: TST -(SP) ;FAKE $SIGN OVER2: TST (SP)+ ;GET RID OF SIGN POP ;<01> UNSAVE REGISTERS ADD #8.,SP ;<01> POP OPD 1 JMP OVERFL ;<01> CEASE EXECUTION UNDER2: ECALL2: TST (SP)+ ;FLUSH $SIGN ZERO12: CLR R0 ;CLEAR HIGH ORDER RESULT CLR R1 ;CLEAR LOW ORDER CLR R2 CLR R3 BR OUT EMULT: CLR -(SP) ;CLEAR HIGH PRODUCT TST R4 ;TEST MULTIPLICAND BEQ MZ ;JUMP IF 0 BGT MPLUS ;+ TST 4(SP) ;TEST MULTIPLIER BEQ MZ ;JUMP IF 0 BGT MNEG1 ;+ BR MNEG MPLUS: TST 4(SP) ;TEST MULTIPLIER BEQ MZ ;JUMP IF 0 BGT MLTQ ;+ ADD R4,@SP BR MLTQ MNEG: ADD R4,@SP MNEG1: ADD 4(SP),@SP MLTQ: MUL 4(SP),R4 ;GET PRODUCT MDONE: ADD (SP)+,R4 ;ADD IN HIGH ORDER PARTS MOV (SP)+,@SP ;FLUSH MULTIPLIER RTS PC ;RETURN MZ: CLR R4 ;RESULT IS 0 CLR R5 BR MDONE .ENDC .TITLE DDIV DOUBLE FLOATING DIVIDE .IF NDF,F$PU ;<01> .GLOBL $DVD,OVERFL ; $DVD --- THE DOUBLE DIVIDE ROUT3INE ; CALLED IN THE POLISH MODE ; THE NUMERATOR IS THE SECOND ITEM ON THE STACK ; AND THE DENOMINATOR IS ON TOP. ; TAKES THE QUOTIENT AND PUTS IT ON TOP ; OF THE STACK IN THEIR PLACE D=8.+10 N=16.+10 Q=16.+10 $DVD: POP R0 ;<01> POP RETURN @ TO R0 PUSH ;<01> SAVE THE REGISTERS CLR R0 CLR R1 CLR R2 CLR R3 CLR -(SP) ASL N+0-2(SP) ;SHIFT NUMERATOR ROL @SP ;GET NUMERATOR SIGN CLR -(SP) TST D(SP) ;CHECK FOR 0.0 DENOMINATOR BEQ DCHK ;JUMP TO ERROR EXIT BISB N+1(SP),@SP ;GET NUMERATOR EXPONENT BEQ $$ZERO ;JUMP IF NUMERATOR IS $$ZERO BISB N(SP),R0 SWAB R0 ;LEFT JUSTIFY NUMERATOR FRACTION SEC ;INSERT NORMAL BIT ROR R0 BISB N+3(SP),R0 BISB N+2(SP),R1 SWAB R1 BISB N+5(SP),R1 BISB N+4(SP),R2 SWAB R2 BISB N+7(SP),R2 BISB N+6(SP),R3 SWAB R3 ASL D(SP) ;SHIFT DENOMINATOR ADC 2(SP) ;GET RESULT SIGN CLR R4 BISB D+1(SP),R4 ;GET DIVISOR EXPONENT SUB R4,@SP ;SUBTRACT EXPONENTS SWAB D(SP) ;LEFT JUSTIFY DENOMINATOR SEC ;INSERT NORMAL BIT ROR D(SP) MOVB D+3(SP),D(SP) MOVB D+2(SP),D+3(SP) MOVB D+5(SP),D+2(SP) MOVB D+4(SP),D+5(SP) MOVB D+7(SP),D+4(SP) MOVB D+6(SP),D+7(SP) CLRB D+6(SP) CLR Q(SP) ;CLEAR QUOTIENT CLR Q+2(SP) CLR Q+4(SP) CMP R0,D(SP) ;COMPARE HIGH NUM. AND DEN. BHI DLOW ;JUMP IF DENOMINATOR LOW BLO DHI ;JUMP IF DENOMINATOR HIGH CMP R1,D+2(SP) ;COMPARE LOW ORDER PARTS BHI DLOW BLO DHI CMP R2,D+4(SP) BHI DLOW BLO DHI CMP R3,D+6(SP) BHI DLOW BNE DHI INC @SP ;BUMP EXPONENT CLR R4 BR FLOAT DCHK: JMP OVERFL ;$$ZERO DIVIDE => OVERFLOW! BR $ECLL UNDER3: ECALL3: TST -(SP) ;FAKE SIGN $ECLL: $$ZERO: CMP (SP)+,(SP)+ ;FLUSH EXP AND SIGN CLR Q+0-4(SP) CLR Q+2-4(SP) CLR Q+4-4(SP) CLR Q+6-4(SP) BR $RTN DLOW: ROR R0 ;HALVE DENOMINATOR (C=0) ROR R1 ;TO ENSURE THAT N ;<01> ADD #8.,SP ;FLUSH FIRST ARGUMENT JMP @R0 ;<01> RETURN OVER31: TST -(SP) ;FAKE EXP OVER3: TST (SP)+ ;<01> POP GARBAGE WORD POP ;<01> POP REGISTERS JMP OVERFL ;<01> JUMP TO ERROR HANDLER DIV1: ASL R4 ;SHIFT QUOTIENT ASL R3 ;SHIFT NUMERATOR ROL R2 ROL R1 ROL R0 BCS GO ;GUARANTEED TO GO CMP D+0+2(SP),R0 ;COMPARE HIGH DIVISOR AND DIVIDEND BHI NOGO ;JUMP IF DIVISOR BIGGER BLO GO ;JUMP IF DIVISOR SMALLER CMP D+2+2(SP),R1 ;CHECK THE LOW ORDERS BHI NOGO BLO GO CMP D+4+2(SP),R2 BHI NOGO BLO GO CMP D+6+2(SP),R3 BHI NOGO BEQ NEQD ;JUMP IF NUMERATOR =DENOMINATOR GO: SUB D+6+2(SP),R3 ;N=N-D SBC R2 SBC R1 SBC R0 SUB D+4+2(SP),R2 SBC R1 SBC R0 SUB D+2+2(SP),R1 SBC R0 SUB D+0+2(SP),R0 INC R4 ;INSERT QUOTIENT BIT NOGO: DEC R5 ;COUNT LOOP BGT DIV1 RTS PC NEQD: INC R4 ;INSERT LAST 1 BIT IN QUOTIENT BR EQ1 EQ2: ASL R4 ;FINISH OUT3 QUOTIENT WITH 0'S EQ1: DEC R5 BGT EQ2 INC R5 ;FLAG NO MORE NUMERATOR RTS: RTS PC ;RETURN TO CALLER .ENDC .TITLE CMPD THE DOUBLE COMPARE ROUTINES .IF NDF,F$PU ;<01> ; H.J. .GLOBL $DCMP ;DOUBLE COMPARE ROUTINE. UPON EXIT THE ;CONDITION CODES WILL BE SET FOR THE SIGNED BRANCHES $DCMP: CMD$SS: MOV (SP),-(SP) ;<01> MAKE ROOM FOR PSW PUSH ;<01> SAVE REGS USED MOV SP,R1 ;ADDR OF ARG 2 MOV SP,R0 ADD #18.,R0 ;<01> ADDR OF ARG 1 CMDIS: ADD #10.,R1 ;<01> ADJUST ADDR OF ARG2 COMP: MOV @R0,R3 BIS @R1,R3 ;SET UP N BIT SAYING EITHER WAS NEGATIVE CMP (R0)+,(R1)+ ;ARE HIGH PARTS EQUAL BNE 1$ CMP (R0)+,(R1)+ ;CHECK REST TO SET C BIT BNE 1$ CMP (R0)+,(R1)+ BNE 1$ CMP @R0,@R1 ;LOW PARTS BNE 1$ ;GO HANDLE NOT EQUAL CASE, C BIT CLR R3 ;SET CONDITION CODES BR $XIT ;<01> DONE, EXIT ;AT THIS POINT THE C BIT SAYS WHETHER OPERAND 1 WAS BIGGER ;OR NOT THAN OPERAND 2 IN UNSIGNED MODE. C SET IF 1ST SMALLER 1$: ROR R3 ;GETS C AND N BITS TOGETHER ROL R3 ;SET V BIT ON FINAL RESULT .WORD CLN!CLZ ;DONT WANT N OR Z TO INTERFERE $XIT: GETPSW 10(SP) ;<01> PUT PSW IN STACK POP ;<01> POP REGS MOV 2(SP),22(SP) ;<01> PUT PSW IN PLACE MOV 0(SP),20(SP) ;<01> PUT PC IN PLACE ADD #20,SP ;<01> SP -> NEW PC RTI ;<01> AND RETURN .ENDC ;<01> .SBTTL CONVERT TO INTEGER .IF NDF,F$PU ;<01> .GLOBL $DI .GLOBL OVERFL ;<01> OVERFLOW LABEL ; REAL TO INTEGER CONVERSION. ; ARGUMENT IS A DOUBLE WORD REAL NUMBER ON THE TOP ; OF THE STACK. ; TRUNCATE IT AND CONVERT IT TO AN INTEGER ON THE ; TOP OF THE STACK. CLC$: CLD$: CIC$: CID$: $DI: POP R0 ;<01> POP RETURN TO R0 MOV (SP)+,2(SP) ;TRUNCATE TO REAL FORMAT MOV (SP)+,2(SP) CLF$: CIF$: $RI: CLR R2 ;CLEAR WORK SPACE INC R2 ;SET UP NORMAL BIT MOV (SP)+,R1 ;GET REAL ARGUMENT ROL @SP ;GET SIGN ROL R1 ;AND PUSH ;<01> SAVE REGISTERS (NOTE: C-BIT UNAFFECTED!) ROL -(SP) ;SAVE IT MOVB R1,R3 ;GET HIGH ORDER FRACTION CLRB R1 SWAB R1 ;GET EXPONENT SUB #201,R1 BLT .ZERO ;JUMP IF IT IS TOO SMALL BEQ DONE CMP #15.,R1 BLT OVER4 ;JUMP IF IT IS TOO BIG SWAB R3 ;FORM 16 BITS OF HIGH ORDER FRACTION CLRB R3 BISB 7(SP),R3 SHFT4: ASHC R1,R2 ;SHIFT DONE: NEG R2 ;MAKE - BVS NEGM ;JUMP IF POSSIBLE NEGMAX BGT OVER4 ;JUMP IF MORE THAN 15 BITS SIGN4: ROR (SP)+ ;GET SIGN BCS OUT4 ;JUMP IF - NEG R2 ;- RESULT OUT4: MOV R2,4(SP) ;<01> STORE INTEGER RESULT POP ;<01> RESTORE SACRED REGISTERS JMP @R0 ;RETURN TO CALLER NEGM: ROR (SP)+ BCS OUT4 ;OK IF RESULT TO BE - TST -(SP) ;<01> FAKE OUT STACK OVER4: TST (SP)+ ;<01> POP SIGN POP ;<01> RESTORE REGISTERS JMP OVERFL ;<01> ERROR, INT OVERFLOW .ZERO: CLR R2 ;ANSWER IS 0 BR SIGN4 .ENDC ;<01> .SBTTL CONVERT FROM INTEGER TO DOUBLE .IF NDF,F$PU ;<01> .GLOBL $ID ; INTEGER TO REAL CONVERSION. ; ARGUMENT IS A FULL WORD ON THE TOP OF THE STACK ; CONVERT IT TO REAL FORMAT AND RETURN IT AS THE TOP ; TWO WORDS ON THE STACK. CCI$: CDI$: $IC: $ID: POP R0 ;<01> PUT RETURN ADDRESS IN R0 MOV @SP,-(SP) ;PUSH ARGUMENT DOWN MOV @SP,-(SP) CLR 2(SP) ;CLEAR LOWEST ORDER DOUBLE CLR 4(SP) CFI$: $IR: CLR -(SP) ;MAKE ROOM FOR RESULT MOV 2(SP),R1 ;GET INTEGER ARGUMENT BGT POS BEQ ..ZERO NEG R1 ;GET ABSOLUTE VALUE POS: ROL -(SP) ;SAVE SIGN MOV #220,R2 ;GET MAX. POSSIBLE EXPONENT +1 CLRB 4(SP) ;CLEAR LOWEST ORDER FRACTION NORM5: ROL R1 ;LOOK FOR NORM5AL BIT BCS NORM5D ;JUMP IF FOUND DEC R2 ;DECREASE EXPONENT BR NORM5 ;TRY AGAIN NORM5D: MOVB R1,5(SP) ;SAVE LOW ORDER FRACTION CLRB R1 BISB R2,R1 ;COMBINE EXPONENT AND HIGH ORDER FRACTION SWAB R1 ROR (SP)+ ;GET SIGN ROR R1 ;INSERT SIGN IN RESULT RORB 3(SP) MOV R1,@SP ;OUTPUT RESULT ..ZERO: JMP @R0 .ENDC ;<01> .SBTTL END INTEND: ... = INTEND - ZERO ;LENGTH OF KERNEL ... = ...+511/512 ;# BLOCKS .END