        .SBTTL KERNEL/INTERPRETER INTERFACE
	.DSABL	AMA		   ;<01> THE FOLLOWING CODE MUST BE 
				   ;<01> RELOCATABLE
                                   ;
                                   ;
INTL99: .WORD  <INTEND - USER99>   ; 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:=<BYTE>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)):=<BYTE>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<UNSIGNED> 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<UNSIGNED> 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):=<REAL>-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:=<REAL>ST(S); S:+8;
        ADDD    (S),W           ;    W:+<REAL>ST(S);
        STD     W,(S)           ;    ST(S):=<REAL>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:=<REAL>ST(S); S:+8;
        LDD     (S),X           ;    X:=<REAL>ST(S);
        SUBD    W,X             ;    X:-<REAL>W;
        STD     X,(S)           ;    ST(S):=<REAL>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:=<REAL>ST(S); S:+8;
        MULD    (S),W           ;    W:*<REAL>ST(S);
        STD     W,(S)           ;    ST(S):=<REAL>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:=<REAL>ST(S+8);
        DIVD    (S)+,W          ;    W:/<REAL>ST(S); S:+8;
        STD     W,(S)           ;    ST(S):=<REAL>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<BYTE> 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:=<BYTE> 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:=<REAL>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:=<REAL>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:=<REAL>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:=<REAL>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:=<REAL>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:=<REAL>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<BYTE> 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<BYTE> 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<BYTE> 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<BYTE> 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:
                                ;            <HEAP>
                                ;  HEAPTOP:  <FREE SPACE>
                                ;  S:        <TEMPORARIES>
                                ;            <VARIABLES>
                                ;  B (OR G): <LINE>
                                ;    + 2     <OLD S>
                                ;    + 4     <OLD B>
                                ;    + 6     <OLD G>
                                ;    + 8     <OLD Q>
                                ;    + 10    <PARAMETERS>
                                ;           (<FUNCTION RESULT>)
                                ;
                                ; MONITOR VARIABLE:
                                ;            <VARIABLES>
                                ;  G:        <GATE ADDRESS>
                                ;            <PARAMETERS>
                                ;
                                ; 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<UNSIGNED> 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<UNSIGNED> 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<UNSIGNED> 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<UNSIGNED> 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<UNSIGNED> 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<UNSIGNED> 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:=<REAL> 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):=<REAL>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	<R0,R1,R2,R3,R4,R5> ;<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	<R5,R4,R3,R2,R1,R0>
	ADD	#8.,SP		;POP SECOND ARGUMENT
	JMP	@R0		;<01>	RETURN

OVER1F:	TST	(SP)+		;POP SIGN

OVER1:	POP	<R5,R4,R3,R2,R1,R0> ;<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	<R0,R1,R2,R3,R4,R5> ;<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	<R5,R4,R3,R2,R1,R0> ;<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	<R5,R4,R3,R2,R1,R0> ;<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	<R0,R1,R2,R3,R4,R5> ;<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<D
	ROR	R2
	ROR	R3
	INC	@SP		;COMPENSATE EXPONENT
DHI:	MOV	#9.,R5		;GO DO FIRST 9 QUOTIENT BITS
	JSR	PC,DIV1
	MOVB	R4,Q(SP)	;SAVE ALL HIGH ORDER Q FRACTION
				;EXCEPT NORMAL BIT
	TST	R5		;SEE IF DONE
	BNE	FLOAT1		;YES, REST OF NUMERATOR IS 0
	MOV	#16.,R5		;GO DO 16 MORE BITS
	JSR	PC,DIV1
	MOV	R4,Q+2(SP)
	TST	R5
	BNE	FLOAT1
	MOV	#16.,R5
	JSR	PC,DIV1
	MOV	R4,Q+4(SP)
	TST	R5
	BNE	FLOAT1
	MOV	#16.,R5
	JSR	PC,DIV1
	BR	FLOAT
FLOAT1:	CLR	R4		;CLEAR LOWEST ORDER QUOTIENT
FLOAT:	MOV	(SP)+,R5	;PUSH UP EXPONENT
	ADD	#200,R5		;ADD IN EXCESS 200
	BLE	UNDER3		;UNDER3FLOW
	CMP	#377,R5
	BLT	OVER3		;OVERFLOW
	MOVB	R5,Q+1-2(SP)	;INSERT EXPONENT IN RESLT
SIGN:	ROR	(SP)+		;INSERT QUOTIENT SIGN
	ROR	Q+0-4(SP)
	ROR	Q+2-4(SP)
	ROR	Q+4-4(SP)
	ROR	R4
	ADC	R4		;ROUND
	ADC	Q+4-4(SP)
	ADC	Q+2-4(SP)
	ADC	Q+0-4(SP)
	MOV	R4,Q+6-4(SP)	;INSERT LOW ORDER FRACTION
	BCS	OVER31
	BVS	OVER31

$RTN:	POP	<R5,R4,R3,R2,R1,R0> ;<01>
	ADD	#8.,SP		;FLUSH FIRST ARGUMENT
	JMP	@R0		;<01> RETURN

OVER31:	TST	-(SP)		;FAKE EXP
OVER3:
	TST	(SP)+		;<01> POP GARBAGE WORD
	POP	<R5,R4,R3,R2,R1,R0> ;<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	<R0,R1,R3>	;<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	<R3,R1,R0>	;<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	<R3,R2>		;<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	<R2,R3>		;<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	<R2,R3>		;<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
                                                                                                                                                                                                                                            