github.com/PDP-10.its
1
0
Fork 0
mirror of https://github.com/PDP-10/its.git synced 2026-03-07 19:40:48 +00:00
Code Issues Releases Wiki Activity
Files
5579a461eb12f3eb549162122304d4794d5fe2f5
PDP-10.its/src/nlogo/eval.119
Lars Brinkhoff b267d9ff34 SLOGO - PDP-11 Logo for SITS. 
This is the very latest version of 11LOGO.  Included in this commit is
a subset of files necessary to assemble 11LOGO for running under SITS.
2022-11-13 15:21:43 -05:00

7648 lines
170 KiB
Plaintext
Executable File
Raw Blame History

This file contains invisible Unicode characters
This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.
.SBTTL SYSTEM PRIMITIVES
VERSIO
.GLOBL .CRLF,ARGMSK,HOUR,NUMOBS,OPTS,PCHR,SECOND,SOBLST,SSTATS,STIME,VARIAB,YEAR ;001
.OPTIO: MOV #OPTS,A
JSR PC,PRAS
.OPTI1: SEZ
RTS PC
.PRIMI: MOV #SOBLST+2,F
9$: MOV (F)+,B
ADD #SOBLST,B
BIT #VARIAB*400,(B)
BEQ 1$
PRTXT <(>
1$: MOV B,A
CMP (A)+,(A)+
JSR PC,PRAS
MOV #'A,D
MOVB 1(B),C
BIC #ARGMSK,C
BEQ 3$
2$: PRTXT < :>
JSR PC,@PCHR
INC D
SOB C,2$
3$: BIT #VARIAB*400,(B)
BEQ 4$
PRTXT <)>
4$: JSR PC,.CRLF
CMP F,#SOBLST+<NUMOBS*2>
BLO 9$
SEZ
RTS PC
.IFNZ ENG&FR
ENGLIS:
ANGLAI: MOV #ENGFLG,LANG
ENG1: SEZ
RTS PC
FRENCH:
FRANCAIS: MOV #PFRFLG!FRFLG,LANG
BR ENG1
FRANGLAIS: BIS #ENGFLG!FRFLG,LANG
BR ENG1
.ENDC
.GLOBL WTA,S,TOPS,UDA,WTAB ;003
;THIS IS THE STUFF FOR ARRAY HACKING
AMAKE: ASL D
ADD S,D
MOV -(D),A ;ADDR OF ARRAY NAME
AMAKE5: MOV A,B
BIC #7777,A
CMP #ATOM,A ;IS A TYPE ATOM?
BNE AMAKE3 ;NO
AMAKE4: MOV #ABIND,A
JSR PC,.BINDL
BEQ AMAKE6
JMP CLRTOP
AMAKE3: CMP #LSTR,A ;IS A TYPE LSTR?
BNE AMAKE2 ;YES
BIT #7777,B ;NULL POIMTER?
BEQ AMAKE2 ;YES
MOV B,TOPS
JSR PC,UOBSCH ;GET ATOM
BNE AMAKE4
AMAKE6: ERROR+UDA
AMAKE2: ERROR+WTAB
.GLOBL HEADER ;004
.GLOBL ROB,WNA ;004
ARRAD: MOV B,E
SPUSH E ;TOP OF ARRAY HEADER
CMPB 4(E),F ;IS DIM=NO. OF INDICES?
BEQ ARRAD1 ;YES
ERROR+WNA ;WRONG NO OF ARGS
ARRAD1: CLR A ;TEMP ACCUMULATOR
ADD #12,E ;LENGTH OF DIMENSION IN E
ARRAD2: JSR PC,G1NARG ;GET INDEX OFF S-PDL
CMP B,(E) ;INDEX IN BOUNDS?
BGE ARRAD4 ;NO
TST B ;NEGATIVE INDEX?
BGE .+4 ;INDEX OK
ARRAD4: ERROR+ROB
ADD B,A
DEC F
BEQ ARRAD3 ;MORE INPUT
MUL -(E),A
MOV B,A
BR ARRAD2
ARRAD3: SPOP E ;ADDR OF ARRAY HEADER
TSTB 5(E) ;IS TYPE PTR?
BEQ 1$
ASL A
1$: ASL A ;TOTAL OFFSET (A*4)
ADD #HEADER,A ;ADDR OF FIRST VALUE
ADD E,A ;ADDR OF VALUE TO BE STORED
RTS PC
STORE: SAVE D
JSR PC,AMAKE
SPOP F ;NO. OF ARGUMENTS
SUB #2,F
POPS D ;VALUE TO BE STORED
JSR PC,ARRAD ;FIND STORAGE LOCATION
MOV A,F
MOV 4(E),A
MOV D,B
BIC #7777,A
BEQ STORE1
JSR PC,CONVERT
BNE 1$
ERROR+WTAB
1$: JSR PC,.LOADB
MOV A,(F)+
STORE1: MOV B,(F) ;VALUE IS NOW STORED
ADD #2,S
SRTSPC: SEZ
RTS PC
GET: SAVE D
JSR PC,AMAKE
SPOP F ;NO. OF ARGUMENTS
DEC F ;NO. OF INDICES
JSR PC,ARRAD ;COMPUTE STORAGE LOCATION
MOV A,F ;STORAGE LOCATION ADDR IN F
MOV (F),C
TSTB 5(E) ;TEST TYPE
BEQ GET1 ;TYPE 0 (PTR)
MOV (F)+,A
MOV (F),B
JSR PC,GRBAD ;STORES VALUE IN NODE SPACE
MOV 4(E),D
BIC #7777,D
BIS D,C ;SET TYPE ON PTR TO VALUE
GET1: MOV C,@S ;PTR ON TOP OF S-PDL
CLZ
RTS PC
;DEFINE AN ARRAY
.GLOBL ERW,LIMIT,WDIM,BAT,ASPACE,ARTOP,NAS,.RELES,..ALLO,TMPBLK
DEFAR: MOV D,F
CMP F,#LIMIT+2 ;WHICH SHOULD BE < ALLOWABLE LIMIT
BLE OKARAY ;OKAY,THIS IS.
AERROR: ERROR+WDIM
OKARAY: SUB #2,F ;DIMENSION OF ARRAY IN F
MOV F,A
MOV #1,D ;SET UP FOR MULTIPLICATION
JSR PC,G1NARG ;GET TYPE
MOV B,E ;SAVE IT
BEQ ALNUM ;0 FOR LNUM
.IFNZ FPPF
CMP #1,B
BEQ AFNUM ;1 FOR FNUM
.ENDC
CMP #2,B
BEQ NXTIDX ;2 FOR PTR
ERROR+BAT
ALNUM: BIS #LNUM,F
BR NXTIDX
.IFNZ FPPF
AFNUM: BIS #FNUM,F
.ENDC
NXTIDX: JSR PC,G1NARG ;GET MAGNITUDE OF LAST DIMENSION
PUSH B ;SAVE THIS DIMENSION
MUL B,D ;D IS ODD
BLE AERROR ;DIMENSION < 0
BCS AERROR ;DIMENSION TOO BIG
SOB A,NXTIDX
SPUSH F ;SAVE DIMENSION OF ARRAY
BIT #160000,D ;SIZE SHOULD NOT BE TOO BIG
BNE AERROR
CMP #2,E ;IS THIS PTR ARRAY
BEQ WALLOC
ASL D ;THIS IS DOUBLE PRECISION ARRAY
WALLOC: ASL D ;TO CONVERT TO BYTES
ADD #HEADER,D
SPUSH D ;SAVE SIZE OF ARRAY BLOCK
MOV @S,B ;GET NAME OF ARRAY
MOV B,A
BIC #7777,A ;SEE WHETHER IT HAS BEEN INTERNED?
CMP #ATOM,A ;BY TESTING ITS TYPE
BEQ FABIND ;YES
CMP #LSTR,A ;NO,IS NAME ALL RIGHT
BEQ 1$ ;YES
ERROR+WTAB
1$: MOV B,TOPS
JSR PC,UINTRN ;INTERN NAME OF ARRAY
MOV B,@S ;SAVE UOE PTR
FABIND: CLR TOPS ;NOT TO CHANGE BINDING
MOV #ABIND,A ;SEE IF AN ARRAY IS
JSR PC,.BIND ;BINDED TO THIS NAME
BEQ GETSPA ;NO
MOV C,@S ;SAVE PTR TO BINDING NODE
MOV B,C
MOV 2(C),B
ADD ASPACE,B ;ADDED TO AVAILABLE FREE SPACE
.IF NZ SITS
ADD #<ARYHPG-ARYPG+1>_13.+ARYAD,B ;TOTAL POSSIBLE ARRAY SPACE
SUB ARTOP,B ;AMOUNT OF CORE GOTTEN SO FAR
.ENDC
CMP B,(P) ;IS SUM ENOUGH FOR NEW BINDING?
BGE ERAOLD ;YES
FULL: ERROR+NAS ;NOT ENOUGH SPACE
ERAOLD: MOV C,B
JSR PC,.RELES ;RELEASE OLD BINDING
;FALLS THROUGH
;FALLS IN
GETSPA: SPOP B ;GET SIZE OF ARRAY
MOV B,D ;SAVE IT
JSR PC,..ALLOC ;ASSIGN SPACE
BEQ FULL ;NOT ENOUGH
SPOPS B ;UOE PTR
SPUSH A ;PUSH IT ON THE P PDL
MOV P,(A) ;MAKE THE ARRAY POINT BACK TO THE PDL SLOT
MOV #ABIND,A
MOV #LSTR,TOPS ;HAVE TO BIND IT TO SOMETHING
JSR PC,.BIND ;BIND NEW ARRAY
BIC #170000,C ;PTR TO BINDING NODE
ASL C
ASL C
ADD #NODESP+2,C ;THIS IS PHYSICAL ADDR OF BINDING NODE
SPOP A ;GET BACK POINTER TO THE ARRAY
MOV A,TMPBLK ;FOR MAKEWINDOW
MOV A,(C) ;MAKE THE BINDING NODE POINT TO THE ARRAY
MOV C,(A)+ ;BACK PTR FIRST ENTRY IN HEADER
MOV (A)+,D ;SIZE OF ARAY SECOND
SPOP F
MOV F,(A)+ ;DIMENSION OF ARRAY THIRD
ADD #LIMIT*2,A ;TO ADVANCE (A)
BIC #177400,F ;GET DIMENSION PART
MOV F,E
ASL E ;TO GET IT INTO BYTES
SUB E,A ;FOR OFFSET INTO HEADER
1$: SPOP (A)+
SOB F,1$
MOV (C),A
CLR C ;FOR CLEARING THE ARRAY
BIT #170000,4(A) ;IS IT A POINTER ARRAY?
BNE 2$ ;NO
MOV #LIST,C ;FILL IT WITH EMPTY LISTS
2$: ADD #HEADER,A
SUB #HEADER,D
ASR D
3$: MOV C,(A)+ ;ZERO ARRAY VALUES
SOB D,3$
JMP CLRTOP
.GLOBL RTB ;014
ERARAY: JSR PC,GTUOEB ;GET NEXT TOKEN
BNE ERARA1
ERARA2: CLR TOPS
MOV #ABIND,A
MOV B,F
JSR PC,.BIND
BEQ ERARAR
JSR PC,.RELES ;RELEASE ARRAY BLOCK
MOV F,B
JSR PC,.UNBND
ERARAR: SEZ
RTS PC
ERARA1: CMP #UFUN,A
BGT 1$
ERROR+ERW
1$: JSR PC,CVSFLS
MOV #ATOM,A
JSR PC,.OBSCH
BNE ERARA2
RTS PC
ERARAS: JSR PC,GNOLEI
ERARS1: JSR PC,GNOLE
BEQ ERARAR
MOV B,F
CLR TOPS
MOV #ABIND,A
JSR PC,.BIND
BEQ ERARS1 ;THIS NAME HAS NO ARRAY BINDING
JSR PC,.RELES ;RELEASE THIS ARRAYY
MOV F,B
JSR PC,.UNBND
BR ERARS1
;RETURNS SIZE OF ARRAY DIMENSIONS
ASIZEX: POPS A ;GET THE ARRAY NAME
JSR PC,AMAKE5 ;FINDS THE START OF THE ARRAY
ASIZE2: PUSH E
MOV B,E
MOVB 4(E),D ;TYPE/DIM WORD
MOV D,F
SPUSH D ;SAVE IT
ASL D ;SETS UP OFFSET FOR DIMENSION WORD
SUB D,E
ADD #14,E ;ADDR. OF FIRST DIM.
ASIZE1: MOV (E)+,B
JSR PC,.CSNIN ;CONVERT TO INUM AND PUT IN NODE
SPUSHS C ;SAVE PTR ON S-PDL
SOB F,ASIZE1 ;CHECK FO MORE DIMS.
SPOP D ;NO OF DIMS. IN D
JSR PC,SENT. ;LINK DIMS. IN LIST
POP E
CLZ
RTS PC
.SBTTL ARITHMETIC ROUTINES
.IFNZ FPPF
;FLOATING POINT MACROS
.MACRO FPUSH FF
STF FF,-(P)
JSR PC,PPUSHT
.ENDM
.MACRO FPOP FF
LDD (P)+,FF
JSR PC,PPOPT
.ENDM
.ENDC
.IFZ FPPF
;SINGLE PRECISION ARITHMETIC ROUTINES
UPLUS: CLZ ;UNARY PLUS - NOTHING TO DO
RTS PC
UMINS: JSR PC,G1IARG ;UNARY MINUS
DPNEG B,C
DONBC: JMP R1I.BC
SUM:
CLR E
CLR F
TST D
BLE DIFF.2 ;DONE
SUM.1: JSR PC,G1IARG ;GET 1 INTEGER
DPADD B,C,E,F
DEC D ;COUNTER
BGT SUM.1
BR DIFF.2 ;DONE
DIFF:
JSR PC,G2IARG ;GET 2 INTEGERS
DPSUB B,C,E,F
DIFF.2: CMP E,#100000 ;IS ANSWER = 100...00 ?
BNE DONEMP
TST F ;IF SO , THEN ERROR
BNE DONEMP
ERROR+RTB ;SINCE THAT IS SMALLEST NEG NUMBER
DONEMP: JMP R1I.EF
PROD:
CLR E
MOV #1,F
PROD.1: DEC D
BLT DONEMP ;DONE
JSR PC,G1IARG ;GET ONE ARG IN B
JSR PC,.DPMUL
BNE PROD.1
ERROR+RTB ;RESULT TOO BIG
MOD:
JSR PC,G2IARG
JSR PC,.DPDIV
BNE DONBC
ERROR+RTB
DIVDE:
DIV.1: JSR PC,G2IARG
JSR PC,.DPDIV
BNE DONEMP
ERROR+RTB
.ENDC
.IFNZ FPPF
;FLOATING POINT ARITHMETIC ROUTINES
ERRET: ERROR+RTB
UPLUS: CLZ
RTS PC
UMINS: MOV #INUM,F
JSR PC,G1ARG
LDD FA,FB
NEGF FB
BR .FSTOR ;STORE FB
DIFF: JSR PC,G2ARG ;LOAD FA AND FB
SUBF FA,FB
CFCC
BVS ERRET ;OVERFLOW?
BR .FSTOR ;STORE IT
SUM: MOV #INUM,F
CLRF FB
TST D
BLE .FSTOR
SUM.1: JSR PC,G1ARG ;GET A NUMBER
ADDF FA,FB
CFCC
BVS ERRET ;OVERFLOW?
DEC D
BGT SUM.1 ;ADD MORE NUMBERS
BR .FSTOR ;DONE AT LAST
PROD: MOV #INUM,F
LDCFD #40200,FB ;LOAD CONSTANT "1"
TST D
BLE .FSTOR ;DONE ALREADY
PROD.1: JSR PC,G1ARG
MULF FA,FB
CFCC
BVS ERRET ;OVERFLOW?
DEC D
BGT PROD.1 ;LOOK AT COUNTER
;FALLS THROUGH
;FALLS IN
;THIS TAKES A NUMBER OUT OF FB AND
;CONVERTS IT ACCORDING TO TYPE IN REG F (INUM,FNUM)
;AND RETURNS
.FSTOR: CMP #FNUM,F ;FNUM OR INUM?
BEQ .FST.2
STCFI FB,-(P) ;PUT INUM ON STACK
BCS ERRET ;OVERFLOW?
.FST.1: SPOP A
SPOP B
JSR PC,GRBAD ;STORE ANSWER
BIS F,C ;SET TYPE
JMP ORTC
.FST.2: STCDF FB,-(P) ;PUT FNUM ON STACK
JMP .FST.1
DIVDE: JSR PC,G2ARG ;GET ARGS
TSTF FA ;TEST ZERO DIVIDE
CFCC
BEQ ERRET ;IT WAS!!??
DIVF FA,FB
CFCC
BVS ERRET ;OVERFLOW?
BR .FSTOR ;STORE IT
MOD: JSR PC,G2ARG ;GET ARGUMENTS IN FA AND FB
SPUSH #.FSTOR
.MOD: TSTF FA ;IS FA 0?
CFCC
BEQ ERRET ;IT IS??
LDD FB,FC ;FC <- FB
DIVF FA,FC ;FC <- (FB/FA)
CFCC
BVS MOD2 ;THE ANSWER IS 0
MODD #40200,FC ;SEPERATE INTEGER AND FRACTION PARTS
MULF FA,FD ;FD <- FA * (INT (FB/FA))
SUBF FD,FB ;FB <- MOD (FB,FA)
MOD1: CFCC
BGE MOD3 ;IS IT POSITIVE?
ADDF FA,FB ;NO, ADD FA
BR MOD1
MOD2: CLRF FB
MOD3: RTS PC
.GLOBL GCPREV ;016
SQRT: MOV @S,GCPREV ;SAVE THIS WORD
JSR PC,G1NUM
BNE SQRT2
SQRT1: MOV GCPREV,B ;GET POINTER TO NUMBER OR ARGUMENT
ERROR+WTAB
SQRT2: TSTF FA
CFCC
BMI SQRT1
BEQ SQRTRT
CLR GCPREV ;NO NEED FOR THIS ANYMORE.
LDF FA,FB
STEXP FA,A
LDEXP #0,FA
ASR A
ADC A
ADDF #40000,FA
BCS 1$
ADDF #40000,FA
1$: CLRF FC
LDEXP A,FC
MULF FC,FA
MOV #4,A
SQRTLP: LDF FB,FC ;FC <= X
DIVF FA,FC ;FC <= X/Y
ADDF FC,FA ;FA <= Y + X/Y
MULF #40000,FA ;FA <= 1/2 * (Y + X/Y)
SOB A,SQRTLP
SQRTRT: MOV #FNUM,F
STCDF FA,-(P)
JMP .FST.1
; CALL WITH D POINTING TO CURX OR CURY.
; RETURN THE INTEGER OF CURX OR CURY IN B
GETINT: MOV (D)+,B ;THE FRACTION PART
ROL B
MOV (D)+,B ;THE INTEGER PART
ADC B ;ROUND
RTS PC
.GLOBL PI ;019
.GLOBL ACOPI,ATANTB,PITWO,TMNI ;020
SINEF: MOV #SINDEG,E
SINEF1: JSR PC,G1NUM ;FA <- ARGUMENT
BNE 1$
ERROR+WTAB ;WRONG TYPE OF ARG
1$: JSR PC,(E) ;FA <- SINE (FA)
COSF1: MOV #FNUM,F ;TELL .FST.1 IT'S AN FNUM
STCDF FA,-(P) ;PUT SINE ON STACK FOR .FST.1
JMP .FST.1 ;PUT IT INTO A NODE
COSF: MOV #COSDEG,E
BR SINEF1
SINDEG: MOV #-1,A
BR TRIG
COSDEG: MOV #1,A
TRIG: MOV #1,B
TSTF FA
CFCC
BGE TRIG1
NEGF FA
MUL A,B
TRIG1: DIVF #41464,FA ;DIVIDE BY 45
MODD #40200,FA ;SEPERATE FRACTION AND INTEGER
MODD #37400,FB
MULF #41000,FB ;MOD 8
SETI
STCFI FB,C
SETL
ASL C
ADD C,PC
BR .TRIG0
BR .TRIG1
BR .TRIG2
BR .TRIG3
BR .TRIG4
BR .TRIG5
BR .TRIG6
MUL A,B
BR .TRIG7
.TRIG6: MUL A,B
NEG A
BR .TRIG0
.TRIG4: NEG B
BR .TRIG0
.TRIG3: NEG B
MUL A,B
BR .TRIG7
.TRIG2: NEG A
MUL A,B
BR .TRIG0
.TRIG5: NEG B
.TRIG1: NEG A
.TRIG7: SUBF #40200,FA ;WE WANT 45 - ANGLE
NEGF FA
;FALLS THROUGH
;FALLS IN
.TRIG0: MULF PI,FA
MULF #37600,FA ;CONVERT FROM DEGREES TO RADIANS
LDD FA,FD
MULF FD,FD
NEGF FD ;-ANGLE SQUARED INTO FD
LDCFD #40200,FB ;COUNTING CONSTANT "1"
STF FB,FF
TST A
BLT .TRIG9 ;WE WANT SIN
LDD FB,FA
CLRF FB
.TRIG9: LDD FA,FC
TSTF FD
CFCC
BEQ TRIG11
TRIG10: ADDF FF,FB
DIVF FB,FC
ADDF FF,FB
DIVF FB,FC
MULF FD,FC
ADDF FC,FA
CMPF #41100,FB
CFCC
BGE TRIG10
TRIG11: TST B
BGE 1$
NEGF FA
1$: RTS PC
;ARCTAN ROUTINE
;ARG RECEIVED & RETURNED IN FA
;CALL ARG "X"; IT KEEPS CHANGING AS IT PASSES THRU THESE ROUTINES
ATAN: JSR PC,G1ARG ;ARG IN FA, DOES SEZ IF IT FINDS A NUMBER
BNE 2$ ;DID WE GET A NUMBER?
ERROR+WTA ;NO
2$: SETD ;DOUBLE PRECISION
;IF X >= 0, ATAN(X) = 180/PI * ATAN1(X)
;IF X < 0, ATAN(X) = -180/PI * ATAN1(-X)
LDD ACOPI,FD ;FD = 180/PI
STD FD,FE ;SAVE IT IN FE
TSTD FA ;X >= 0?
CFCC
BGE 1$ ;IF SO, BRANCH
NEGD FA ;FA = -X
NEGD FE ;FE = -180/PI
1$: JSR PC,ATAN1
MULD FE,FA ;RESULT IN FA
JMP COSF1 ;RETURN ARG
;IF X < 10**-9, ATAN1(X) = X
;IF X > 1, ATAN1(X) = PI/2 - ATAN2(1/X)
;ELSE ATAN1(X) = ATAN2(X)
ATAN1: CMPD TMNI,FA ;IS 10**-9 > X?
CFCC
BGT ATAN1B ;YES, X SMALL SO OUTPUT X
CMPD #40200,FA ;1 < X?
CFCC
BGE ATAN2 ;YES, SO OUTPUT ATAN2(X)
LDD #40200,FB ;LOAD A 1 INTO FB
DIVD FA,FB ;FB = 1/X
LDD FB,FA ;TRANSFER TO FA
JSR PC,ATAN2 ;ATAN2(1/X)
LDD PITWO,FB ;FB = PI/2
SUBD FA,FB ;FB = PI/2 - ATAN2(1/X)
LDD FB,FA ;TRANSFER TO FA
ATAN1B: RTS PC
;ATAN2(X) = (X*(B0+(A1/(Z+B1+(A2/(Z+B2+(A3/(Z+B3))))))))
;WHERE Z = X**2
;INTERMEDIATE RESULT CALLED "OP"
ATAN2: LDD FA,FB ;FA CONTAINS X
MULD FB,FB ;FB = X**2
MOV #ATANTB,D ;POINT TO TABLE OF CONSTANTS
LDD FB,FC ;FC = Z
ADDD (D)+,FC ;FC = B3 + Z
LDD (D)+,FD ;FD = A3
DIVD FC,FD ;FD = A3/OP; FD = NEW OP
LDD (D)+,FC ;FC = B2
ADDD FB,FC ;FC = Z + B2
ADDD FD,FC ;FC = FC + OP; FC = NEW OP
LDD (D)+,FD ;FD = A2
DIVD FC,FD ;FD = A2/OP; FD = NEW OP
ADDD (D)+,FB ;FB = Z +B1
ADDD FD,FB ;FB = FB + OP; FB = NEW OP
LDD (D)+,FD ;FD = A1
DIVD FB,FD ;FD = A1/OP; FD = NEW OP
ADDD (D)+,FD ;FD = OP + B0
MULD FD,FA ;FA = OP * X
RTS PC
.ENDC
.GLOBL NUM1,NUM1E,NUM2,NUM2E ;021
.IFNZ SARITH
;STRING PLUS JUST ADDS ITS TWO NUMBERS BY LINEARIZING THEM INTO NUM1 AND NUM2
;IT THEN ADDS THEM IN 9'S COMPLEMENT, RECONVERTING THE NUMBER IF NEEDED.
STNGPL: JSR PC,LIN2AR ;LINEARIZE THE TWO ARGS INTO NUM1 AND NUM2
;ALSO SET UP NUM1E AND NUM2E
;THIS ENTRY ALSO USED BY STRING MINUS
STNGAD: MOV NUM1E,B ;GET THE NUMBER OF DIGITS TO ADD TOGETHER
SUB #NUM1,B ;TURN IT INTO THE LENGTH
CLR C ;NO CARRY
ADDLOP: DEC B ;DEC POINTER
MOVB NUM1(B),D ;GET THE FIRST DIGIT
MOVB NUM2(B),E ;GET SECOND DIGIT
ADD D,E ;GET SUM
ADD C,E ;ADD IN THE CARRY
CLR C ;CLEAR THE CARRY FOR NEXT TIME
CMP E,#10. ;IS IT TOO BIG
BLO 1$ ;NO, JUST GO AHEAD
INC C ;SET CARRY
SUB #10.,E ;AND MAKE IT SMALL AGAIN
1$: MOVB E,NUM2(B) ;AND PUT IT BACK IN THE LIST
TST B ;ARE WE DONE YET?
BNE ADDLOP ;NOPE, CONTINUE
2$: CLR C ;THE SIGN IS POSITIVE
TSTB NUM2 ;IS THE RESULT NEGATIVE?
BEQ 3$ ;NO, IGNORE THIS
MOV NUM2E,B ;END IN B
MOV B,A ;COPY IT
SUB #NUM2,A ;GET POINTER TO THE NUMBER
JSR PC,COMPL ;COMPLEMENT IT
MOV #1,C ;SET NEGATIVE FLAG
3$: MOV #NUM2,A ;GET POINTER TO THE NUMBER
MOV NUM2E,B ;GET END OF NUMBER TO MAKE
;;; FALLS IN TO RETURN A STRING NUMBER
;;; A POINTS TO THE NUMBER, B THE END, AND C THE SIGN
RETSNG: JSR PC,BLSTI ;MAKE A LIST
TST C ;IS THE RESULT NEGATIVE?
BEQ 1$ ;NO, DO NOTHING
MOV #'-,D ;PUT A MINUS SIGN IN FRONT
JSR PC,BLST
1$: CMP A,B ;ARE WE AT THE END?
BEQ 2$ ;YES, JUST PRETEND WE HAVE FOUND NON ZERO BYTE
TSTB (A)+ ;IS IT 0?
BEQ 1$ ;YES, JUST CONTINUE
2$: TSTB -(A) ;BACK UP TO THE NON-ZERO WORD
3$: MOVB (A)+,D ;GET THE NUMBER
ADD #'0,D ;CONVERT IT TO ASCII
JSR PC,BLST ;AND BUILD IT ONTO THE LIST
CMP B,A ;IS IT AT THE START OF NUMBER?
BNE 3$ ;NO, GO BACK FOR NEXT DIGIT
JSR PC,BLSTF ;GET POINTER TO STRING IN TOPS
PUSHS TOPS ;PUSH IT ON THE OUTPUT PDL
CLR TOPS
CLZ
RTS PC ;WE ARE RETURNING A NUMBER STRING
STNGMI: JSR PC,LIN2AR ;LINEARIZE THE ARGS AND RETURN THE LENGTH IN A
MOV NUM1E,B ;POINTER TO THE END OF NUM1
JSR PC,COMPL ;COMPLEMENT IT
BR STNGAD ;NOW PRETEND IT IS AN ADD
;LINEARIZE TWO ARGS OFF THE S PDL
LIN2AR: MOV #NUM1,A ;POINTER TO THE FIRST AREA
JSR PC,LINEAR ;LINEARIZE THE NUMBER INTO NUM1
MOV A,NUM1E ;THE END OF THE FIRST NUMBER
SPUSH B ;SAVE THE SIGN
MOV #NUM2,A ;AND THE SECOND AREA
JSR PC,LINEAR ;DO THE SAME FOR THE SECOND NUMBER
MOV A,NUM2E
SPUSH B ;SAVE THE SIGN AGAIN
MOV A,B ;COPY POINTER TO NUM2E
SUB NUM1E,B ;GET THE DIFFERENCE IN LENGTHS
SUB #NUM2-NUM1,B ;SUBTRACT OFFSET
BEQ SINCAL ;NO DIFFERENCE, JUST DO SIGNS
BPL 1$ ;(NUM2 IS LONGER THAN NUM1)
NEG B ;MAKE IT POSITIVE (NUM1 IS LONGER THAN NUM2 HERE)
MOV #NUM2,D ;POINTER TO THE START OF THE NUMBER
ADD B,NUM2E
BR 2$ ;BLT UP NUM2 POINTER IN A
1$: MOV NUM1E,A ;POINTER TO NUM1 WHICH WE WILL BLT UP
MOV #NUM1,D ;POINTER TO THE START OF NUM1
ADD B,NUM1E ;MAKE BOTH THE MAXIMUM
2$: MOV A,C ;COPY POINTER TO THE END
ADD B,C ;THE NUMBER OF BYTES WE ARE MOVING IT UP BY
BLTLOP: MOVB -(A),-(C) ;BLT DOWN THE NUMBER
CMP A,D ;POINTER TO THE START OF THE NUMBER
BNE BLTLOP
CLRLOP: CLRB -(C) ;CLEAR OUT THE REST OF THE AREA
CMP C,D
BNE CLRLOP ;NOW WE HAVE THE NUMBERS THE SAME LENGTH IN NUM1 AND 2
SINCAL: MOV NUM1E,A ;THE NUMBER OF BYTES TO CONVERT
SUB #NUM1,A ;GET THE LENGTH IN A
TST (P)+ ;IS THE SECOND NUMBER NEGATIVE?
BEQ 1$ ;NO
MOV NUM2E,B ;POINTER TO THE NUMBER TO NEGATE
JSR PC,COMPL ;GET 9'S COMPLEMENT
1$: TST (P)+ ;IS THE FIRST NEGATIVE?
BEQ 2$ ;NO ALL DONE
MOV NUM1E,B ;POINTER TO THE NUMBER
JSR PC,COMPL
2$: RTS PC
STNGML: JSR PC,STNG2U ;GET TWO UNSIGNED ARGUMENTS FOR
MOV #NUM3,A ;GET POINTER TO THE RESULT AREA
MOV #NUM3EN-NUM3,B ;CLEAR OUT THE WHOLE AREA
1$: CLRB (A)+
SOB B,1$
MOV #TMPBLK,A ;GET POINTER TO THE DATA AREA
MOV #NUM1,(A)+ ;POINTER TO THE FIRST ARG
MOV NUM1E,(A)
SUB #NUM1,(A)+ ;GET THE LENGTH OF THE FIRST ARG
MOV #NUM2,(A)+ ;POINTER TO THE SECOND ARG
MOV NUM2E,(A)
SUB #NUM2,(A)+ ;GET THE LENGTH OF THE SECOND ARG
CMP TMPBLK+2,TMPBLK+4 ;COMPARE THE LENGTHS
BGE 2$ ;WE WANT THE FIRST ARGUMENT TO BE THE SHORTEST
SPUSH TMPBLK ;EXCH TMPBLK,TMPBLK+4
MOV TMPBLK+4,TMPBLK
SPOP TMPBLK+4
SPUSH TMPBLK+2 ;EXCH TMPBLK+2,TMPBLK+6
MOV TMPBLK+6,TMPBLK+2
SPOP TMPBLK+6
2$: SPUSH #NUM3EN ;POINTER FOR THIS PRODUCT TO BE ADDED IN AT
ADD TMPBLK+6,TMPBLK+4 ;MAKE IT POINT TO THE END OF THE SHORTER NUMBER
;;; HERE TMPBLK LOOKS LIKE THIS
;;; TMPBLK: POINTER TO THE LONGER NUMBER
;;; LENGTH OF THE LONGER NUMBER
;;; POINTER TO THE END OF THE SHORTER NUMBER
;;; LENGTH OF THE SHORTER NUMBER
;;; ON THE STACK IS A POINTER TO THE PLACE TO ADD IN THE CURRENT PARTIAL PRODUCT
NXTBYT: DEC TMPBLK+6 ; COUNT OF BYTES LEFT IN THE SHORTER NUMBER
BLT MULDON ;DONE IF IT COUNTS DOWN
DEC TMPBLK+4 ;MOV -(TMPBLK+4),C
MOVB @TMPBLK+4,C
MOV (P),F ;OUTPUT POINTER
DEC (P) ;FOR NEXT TIME
MOV TMPBLK+2,D ;COUNT OF DIGITS IN LONGER NUMBER
MOV TMPBLK,E ;POINTER TO THE LONGER NUMBER
ADD D,E ;SET UP POINTER TO THE END OF LONGER NUMBER
CLR A ;NO CARRY TO START
;;; HERE WE HAVE THE REGISTERS SET UP AS FOLLOWS:
;;; A: CARRY FROM PREVIOUS MUL
;;; B: SCRATCH
;;; C: MULTIPLIER DIGIT FROM SHORT NUMBER
;;; D: COUNT OF DIGITS IN LONGER NUMBER
;;; E: POINTER TO THE NEXT DIGIT IN LONGER NUMBER
;;; F: OUTPUT POINTER
MULLOP: CMP F,#NUM3 ;OVERFLOWED AREA?
BLOS MULBER ;TOO BIG A NUMBER
MOVB -(E),B ;PICK UP NEXT DIGIT IN LONG NUMBER
MUL C,B ;MULTIPLY AND ADD IN CARRIES
ADD A,B
MOVB -(F),A ;AND ADD IN PREVIOUS CONTENTS
ADD A,B
CLR A ;FOR DIVIDE
DIV #10.,A ;A: THE CARRY, B IS THE DIGIT
MOVB B,(F) ;PUT IT BACK
SOB D,MULLOP ;AND DO REST OF LONG NUMBER
TST A ;ANY CARRY OUT OF HIGH PART OF NUMBER?
BEQ NXTBYT ;NO, GO ON TO THE NEXT DIGIT IN THE SHORT NUMBER
CMP F,#NUM3 ;WILL WE OVERFLOW?
BLOS MULBER ;YES
MOVB A,-(F) ;STORE IT AWAY (MUST BE A 0 BYTE (F) NOW)
BR NXTBYT ;GO DO REST OF SHORT NUMBER
MULDON: TST (P)+ ;POP OFF THE START POINTER
MOV #NUM3EN,B ;POINTER TO THE END OF THE NUMBER
MOV #NUM3,A ;POINTER TO THE START OF THE NUMBER TO RETURN
MOV NUM1S,C ;GET SIGN OF FIRST
MOV NUM2S,D ;AND SIGN OF SECOND
XOR D,C ;GET SIGN OF RESULT
JMP RETSNG ;RETURN IT
MULBER: ERROR+RTB ;RESULT TOO BIG
;LINEARIZE TO NUMBERS INTO NUM1 AND NUM2 PUT THE SIGNS INTO NUM1S AND NUM2S
STNG2U: MOV #NUM1,A ;GET POINTER TO THE FIRST NUMBER
JSR PC,LINEAR
MOV B,NUM1S
MOV A,NUM1E ;GET THE END OF THE FIRST NUMBER
MOV #NUM2,A ;GET POINTER TO THE SECOND NUMBER
JSR PC,LINEAR
MOV B,NUM2S
MOV A,NUM2E
RTS PC
;;; DIVIDE TWO STRING NUMBERS
STNGDV: JSR PC,STNG2U ;GET DIVIDEND IN NUM1 DIVISOR IN NUM2
MOV #NUM1,A ;FIND FIRST NON ZERO DIGIT IN DIVISOR
1$: TSTB (A)+
BNE SDIV1
CMP A,NUM1E ;BE SURE WE DONT RUN OFF THE NUMBER
BLO 1$ ;STILL OKAY
SDIVER: ERROR+RTB ;RESULT TOO BIG
SDIV1: MOV #TMPBLK,B ;GET POINTER TO TEMPORARY AREA
TSTB -(A) ;BACK UP POINTER
MOV A,(B)+ ;POINTER TO DIVISOR
SUB NUM1E,A ;GET LENGTH OF IT
NEG A
MOV A,(B)+ ;AND STORE IT
MOV #NUM2,C ;GET POINTER TO THE DIVIDEND
1$: TSTB (C)+ ;STRIP OFF LEADING ZEROS
BNE 2$ ;FOUND A DIGIT
CMP C,NUM2E ;AT END YET?
BLO 1$ ;NO, TRY AGAIN
2$: TSTB -(C) ;BACK UP POINTER
MOV C,(B)+ ;POINTER TO THE DIVIDEND
ADD C,A ;START WITH THE TRIAL DIVIDEND EQUAL IN LENGTH TO DIVISOR
MOV A,(B)+ ;STORE IT
CLR (B)+ ;CLEAR FLAG SAYING THAT DIVIDEND IS BIGGER THAN DIVISOR
MOV #NUM3+1,NUM3E ;LEAVE A DIGIT ON TOP TO BE ZERO IN CASE NO DIVIDES WORK
MOV NUM3E,(B) ;START PUTTING DIGITS AT THE BOTTOM OF NUM3
;;; HERE TMPBLK IS SET UP AS FOLLOWS:
;;; TMPBLK: POINTER TO THE DIVISOR (NON-ZERO DIGIT)
;;; DIVISOR LENGTH
;;; POINTER TO THE START OF THE DIVIDEND WE ARE TRYING TO GET QUOTIENT FOR
;;; POINTER TO THE END OF THE DIVIDEND WE ARE TRYING TO GET QUOTIENT FOR
;;; FLAG SAYING THAT DIVIDEND LENGTH IS > DIVISOR LENGTH
;;; OUTPUT POINTER
DIVLOP: CMP TMPBLK+6,NUM2E ;DONE WITH THE DIVIDEND YET?
BHI DIVDON ;YES
JSR PC,DIVDGT ;GET A DIGIT OF THE QUOTIENT
MOVB A,@TMPBLK+12 ;AND IN OUTPUT DATA
BEQ 2$ ;IF ZERO, DONT MOVE THE START POINTER
TSTB @TMPBLK+4 ;IS THIS DIGIT 0?
BNE 2$ ;WELL, NO, SO LEAVE IT THERE FOR NEXT TIME
INC TMPBLK+4 ;WE ARE DONE WITH THAT DIGIT FOR SURE
1$: INC TMPBLK+6 ;ADD ANOTHER DIGIT ON THE RIGHT SIDE
INC TMPBLK+12 ;POINT TO NEXT SLOT
BR DIVLOP ;DO IT AGAIN
2$: INC TMPBLK+10 ;SET FLAG SAYING THAT DIVIDEND IS BIGGER
BR 1$ ;AND LOOP BACK
DIVDON: MOV NUM1S,C ;GET THE SIGN OF THE DIVIDEND
MOV NUM2S,D ;AND SIGN OF DIVISOR
XOR D,C ;GET SIGN OF RESULT
MOV TMPBLK+12,B ;GET POINTER TO THE END OF THE NUMBER
MOV #NUM3,A ;AND POINTER TO THE START OF THE NUMBER
JMP RETSNG ;RETURN THE NUMBER
;;; DIVIDE UTILITIES
;;; DIVDGT GETS A QUOTIENT DIGIT
DIVDGT: JSR PC,DIVEST ;ESTIMATE THE DIGIT
SPUSH A ;SAVE THE DIGIT
BEQ 1$ ;IT IS ZERO, SO SKIP THE MUL AND SUBTRACTION
MOV A,C ;COPY IT
JSR PC,DIVMUL ;MAKE DIVIDEND = DIVIDEND - DIVISOR*DIGIT
1$: JSR PC,DIVCMP ;SEE IF ANOTHER DIVISOR FITS IN CURRENT PIECE OF DIVIDEND
BEQ 2$ ;YEP, SUBTRACT IT OFF
TST TMPBLK+10 ;ARE WE CURRENTLY ONE DIGIT LONGER?
BEQ 4$ ;NO, JUST RETURN
MOV TMPBLK+4,C ;GET POINTER TO THE DIVIDEND
TSTB (C)+ ;SKIP IT, SHOULD BE ZERO
TSTB (C) ;IS THE NEXT DIGIT 0?
BNE 4$ ;NO, STILL WILL BE ONE LONGER NEXT TIME
CLR TMPBLK+10 ;OTHERWISE CLEAR FLAG, AND INCREMENT START
INC TMPBLK+4 ;SO THAT WE WIN NEXT LEVEL UP
4$: SPOP A ;GET BACK DIGIT
RTS PC ;AND RETURN
2$: INC (P) ;QUOTIENT DIGIT IS REALLY ONE BIGGER
MOV #1,C ;MULTIPLY BY 1
JSR PC,DIVMUL ;SUBTRACT OFF DIVISOR AGAIN
BR 1$ ;AND TRY AGAIN
;;; DIVEST CONSERVATIVELY ESTIMATES THE QUOTIENT DIGIT
DIVEST: MOV TMPBLK+4,C ;GET POINTER TO THE HIGH ORDER DIGITS OF THE DIVIDEND PIECE
TST TMPBLK+10 ;IS THE DIVIDEND LONGER?
BNE DIVES1 ;YES, SO TAKE THE NEXT TWO DIGITS FROM DIVIDEND
MOVB (C)+,B ;GET THE FIRST DIGIT
;;; HERE THE FIRST DIGIT OR TWO OF DIVIDEND IS IN B, WE DIVIDE BY A ROUNDED UP DIVISOR DIGIT
DIVES2: MOVB @TMPBLK,C ;GET FIRST DIGIT OF DIVISOR
INC C ;ROUND UP
CLR A ;FOR THE DIVIDE
DIV C,A ;GET QUOTIENT IN A FOR TRIAL
RTS PC ;AND RETURN
;;; HERE THE DIVIDEND PIECE IS ONE LONGER THAN THE DIVISOR, SO TAKE THE FIRST TWO DIGITS
DIVES1: MOVB (C)+,B ;GET THE FIRST
MUL #10.,B ;AND ADD IN THE SECOND
MOVB (C)+,A
ADD A,B
BR DIVES2 ;NOW CONTINUE AS NORMAL
;;; DIVCMP SEES IF ANOTHER DIVISOR WILL FIT IN THE DIVIDEND PIECE WE ARE WORKING ON
DIVCMP: MOV TMPBLK+4,A ;GET POINTER TO THE DIVIDEND PIECE
MOV TMPBLK,B ;GET POINTER TO THE DIVISOR
MOV TMPBLK+2,C ;GET COUNT OF THE DIVISOR
TST TMPBLK+10 ;IS THE DIVIDEND PIECE ONE LONGER THAN THE DIVISOR
BNE DVCMP1 ;YES, COMPARE SPECIALLY
DVCMPL: CMPB (A)+,(B)+ ;COMPARE THE DIVIDEND TO THE DIVISOR
BGT DVCMPF ;FAIL IF THE DIVIDEND IS BIGGER
BLT DVCMPS ;SUCCEED IF IT IS SMALLER
SOB C,DVCMPL ;IF EQUAL KEEP TRYING
;;; IF EXACTLY EQUAL, FAIL
DVCMPF: SEZ
DVCMPS: RTS PC
DVCMP1: TSTB (A)+ ;IF THE FIRST DIGIT ISNT ZERO, THEN WE FAIL
BNE DVCMPF
BR DVCMPL ;IF IT IS, COMPARE THE REST OF THE NUMBER
;;; DIVMUL MULTIPLIES THE DIVISOR BY A DIGIT, THEN SUBTRACTS IT FROM A PIECE OF THE
;;; DIVIDEND
DIVMUL: CLR A ;CARRY HERE
MOV TMPBLK+2,D ;LENGTH OF THE DIVISOR
MOV D,E ;COPY IT
ADD TMPBLK,E ;AND GET POINTER TO THE END OF THE DIVISOR
MOV TMPBLK+6,F ;WHERE TO START SUBTRACTING FROM (END OF THE DIVISOR PIECE)
DVMULL: MOVB -(E),B ;MUL -(E),C => B
MUL C,B
SUB B,A ;THIS IS THE CARRY (WILL ALWAYS BE NEGATIVE)
DVMUL1: MOVB -(F),B ;GET THE DIGIT TO SUBTRACT IT FROM
ADD A,B ;WELL A IS NEGATIVE SO THIS IS A SUBTRACT
SXT A ;FOR DIVIDE
DIV #10.,A ;GET THE DIGIT AND THE CARRY
TST B ;IS THE REMAINDER NEGATIVE?
BGE 1$ ;NO, SO IT IS OKAY, THERE CAN'T BE A CARRY
ADD #10.,B ;GET THE DIGIT BY 9'S COMPLEMENT
DEC A ;CARRY IS ONE MORE NEGATIVE
1$: MOVB B,(F) ;STORE BACK THE DIGIT
SOB D,DVMULL ;GO UNTIL WE ARE DONE WITH THE DIVISOR
TST A ;CARRY?
BNE 2$ ;YES, WE WILL HAVE TO CONTINUE
RTS PC
2$: CLR B ;THIS IS THE SUBTRAHEND
INC D ;TO FAKE OUT THE SOB
BR DVMUL1 ;GO BACK AN PROPOGATE CARRY
.GLOBL MXNUML
;LINEARIZE A NUMBER OFF THE S PDL, A POINTS TO AREA, A IS RETURNED POINTING
;PAST THE END OF NUMBER, B IS THE SIGN OF THE NUMBER 0=POS. 1=NEG
LINEAR: CLR (A)+ ;CLEAR THE FIRST TWO DIGITS
CLR -(P) ;THE SIGN FLAG
SPUSH A ;SAVE THE REGS
MOV @S,B ;GET THE ARGUMENT
MOV #LSTR,A ;CONVERT IT TO LSTR
JSR PC,CONVERT ;TRY AND CONVERT
BNE 1$
ERROR+WTAB ;WRONG TYPE OF ARG
1$: SPOP E ;GET BACK POINTER
MOV #MXNUML,F ;COUNTER FOR THE MAXIMUM LENGTH OF NUMBERS
JSR PC,INSTR ;START THE STRING
BEQ LNRDON ;NO STRING WE MUST BE DONE
CLR B ;LEADING ZERO FLAG
CMP D,#'+ ;WAS IT PLUS?
BEQ LNRLOP ;YES, JUST LOOP
CMP D,#'- ;WAS IT MINUS
BNE LNRLP1 ;NO, TREAT IT LIKE A NUMBER
COM 2(P) ;SET SIGN FLAG
LNRLOP: JSR PC,@(SP)+ ;CALL COROUTINE TO GET CHARACTER
BEQ LNRDON ;WE ARE DONE NOW
LNRLP1: SUB #'0,D ;CONVERT IT FROM ASCII
BEQ 3$ ;IT IS ZERO, CHECK LEADING 0 FLAG
BLT 1$ ;ERROR IF NOT A DIGIT
CMP #'9-'0,D ;IS IT TO BIG
BHIS 2$ ;IT IS A DIGIT
1$: ERROR+WTA ;WRONG ARGUMENT
3$: TST B ;IGNORE ZEROS?
BEQ LNRLOP ;YES, IGNORE THE ZEROS
2$: INC B ;WE ARE PLACING A DIGIT, NO LONGER IGNORE ZEROS
MOVB D,(E)+ ;PUT THE BYTE AWAY
SOB F,LNRLOP ;DO FOR ALL THE BYTES
JSR PC,@(SP)+ ;SEE IF THERE IS ANOTHER NUMBER
BEQ LNRDON ;NOPE, WIN
ERROR+RTB ;NUMBER TO BIG
LNRDON: SPOP B ;GET BACK THE SIGN FLAG
ADD #2,S ;POP OFF THE ARGUMENT
MOV E,A ;PUT BACK POINTER INTO A
RTS PC
; GET THE 9'S COMPLEMENT OF A NUMBER WHOSE END IS POINTED TO BY B, LENGTH IN A
COMPL: SPUSH A
MOV #1,C ;ADD THE CARRY IN
COMPLP: MOVB -(B),D ;GET THE NUMBER TO CONVERT
SUB #9.,D ;COMPLEMENT IT
NEG D
ADD C,D ;ADD THE CARRY
CLR C ;CLEAR THE CARRY
CMP D,#10. ;IS IT TOO BIG?
BLT 1$ ;NO, CLEAR TEH CARRY AND GO AWAY
SUB #10.,D ;MAKE IT SMALL AGAIN
INC C
1$: MOVB D,(B) ;PUT BACK COMPLEMENTED BYTE
SOB A,COMPLP ;GO BACK FOR ALL THE BYTES
SPOP A
RTS PC
.ENDC
.SBTTL LIST AND WORD OPERATIONS
SENTEN:
SENT.: CLR C
TST D
SENT.1: BLE SENT.R ;RETURN
MOV @S,B ;ARGUMENT. LEAVE ON S-PDL FOR GARBGE COLLECTOR
MOV B,A
BIC #7777,A ;LEAVE ONLY DATA TYPE
CMP #LIST,A
BEQ SENT.S ;ARG IS LIST
CMP #ATOM,A
BNE SENT.2 ;ARG IS LSTR OR INUM
;ARG IS AN ATOM
SENT.A: JSR PC,.LOAD ;CONVERT ATOM TO LSTR
MOV #LSTR,A
SENT.2: BIS C,A ;C POINTS TO PREVIOUS STUFF OF SENTENCE
JSR PC,GRBAD
SENT.3: MOV C,GCPREV ;POINTER TO PREVIOUS STUFF OF SENTENCE
BIS #LIST,GCPREV ;GARBAGE COLLECTOR NEEDS RIGHT DATA TYPE
SENT.4: JSR PC,SPOPT ;POP S
DEC D ;COUNTER
BR SENT.1
SENT.S: BIT #7777,B ;ARGUMENT IS A LIST
BEQ SENT.4 ;EMPTY
TST C ;0 IF FIRST TIME CALLED
BEQ SENS.1 ;NO NEED TO COPY
;SECOND OR LATER TIME THROUGH
SENS.2: JSR PC,COPYL ;COPY LIST. RETURN POINTER IN B
BIC #170000,GCPREV ;CLEAR DATA TYPE
BIS GCPREV,A ;POINTER TO PREVIOUS STUFF
JSR PC,.STP1 ;C STILL POINTS TO LAST NODE COPIED
SENS.1: BIC #170000,B ;LEAVE POINTER ONLY
MOV B,C
BR SENT.3
;RETURN. POINTER TO SENTENCE IN C
SENT.R: BIS #LIST,C
CLR GCPREV
PUSHS C
CLZ
RTS PC
.GLOBL GCP1,UEL ;025
LIST.P:
SAVE #ORTC
LIST1: CLR C
LIST.1: DEC D ;COUNT
BLT LIST.9 ;DONE
MOV @S,B
MOV B,A
BIC #7777,A ;LEAVE DATA TYPE ONLY
LIST.2: BIS C,A ;POINTER TO REST OF LIST
JSR PC,GRBAD
MOV C,GCPREV ;PROTECT FROM GARBAGE COLLECTOR
BIS #LIST,GCPREV ;GAR. COLL. NEEDS RIGHT DATA TYPE
JSR PC,SPOPT
BR LIST.1 ;GET NEXT ARG
LIST.9: CLR GCPREV
BIS #LIST,C
RTS PC
FPUT:
CLR F
BR LPUT69
LPUT:
MOV #<LPUT1-FPUT1>,F
LPUT69: SAVE #ORTC
DEC D
BGT 1$
ERROR+UEL ;NEED AT LEAST 2 ARGS
1$: JSR PC,GLWARG
BEQ 2$ ;LIST
ERROR+WTA ;FIRST ARG MUST BE LIST
2$: ADD F,PC ;CHOOSE BETWEEN LPUT AND FPUT
FPUT1: MOV B,A ;POINTS TO ARG
BIC #170000,A ;CLEAR DATA TYPE
JSR PC,SPOPT
MOV @S,B ;FIRST ELEMENT TO BE PUT
MOV B,C
BIC #7777,C ;THIS DATA TYPE WILL BE SET INTO A
DEC D
BR LIST.2
LPUT1: JSR PC,COPYL ;COPY LIST. RETURN PTR IN B
MOV B,GCP1
JSR PC,SPOPT ;POP 1ST ARG
JSR PC,LIST1 ;LIST REST OF ARGS
TST F
BEQ LPUT2
BIC #170000,C ;POINTER TO THAT LIST
MOV C,D ;SAVE IT
MOV F,C ;POINTER TO LAST NODE OF COPIED LIST
JSR PC,.LDP1
BIS D,A ;JOIN COPIED LIST TO LIST OF ARGS
JSR PC,.STP1
MOV GCP1,C
LPUT2: CLR GCP1
RTS PC
WORD: CLR GCPREV ;USED AS A FLAG LATER
CLR C
TST D
WORD.1: BLE WORDR
MOV @S,B ;GET ARG, BUT LEAVE ON STACK
.IFZ FPPF
CMP B,#LNUM ;IS ARG NUMBER?
BLO WORD.2
CMP B,#<LNUM+10000>
BLO WORD.N ;NUMBER
.IFF
MOV B,A ;DOES B POINT TO INUM OR FNUM
BIC #170000,A
CMP #INUM,A
BEQ WORD.N
CMP #FNUM,A
BEQ WORD.N
.ENDC
WORD.2: MOV #LSTR,A
JSR PC,CONVERT
BNE 1$
ERROR+WTAB
1$: BIT #7777,B ;IS ARG THE EMPTY WORD
BEQ WORD.4 ;YES
TST GCPREV ;IS 0 FIRST TIME THROUGH
BEQ WORD.3
;SECOND OR LATER ARG
JSR PC,CPYSTR ;COPY STRING
WORD.6: JSR PC,.LDP1 ;LAST NODE OF COPIED STRING
BIC #170000,GCPREV ;CLEAR DATA TYPE
BIS GCPREV,A ;BIS POINTER TO PREVIOUS STUFF
JSR PC,.STP1 ;STORE BACK
WORD.3: BIC #170000,B
BIS #LSTR,B ;GAR. COLL. NEEDS RIGHT DATA TYPE
MOV B,GCPREV ;POINTER TO PREVIOUS STUFF
WORD.4: JSR PC,SPOPT ;POP S
DEC D
BR WORD.1
;ARGUMENT IS NUMBER. CONVERT TO STRING
WORD.N:
.IFZ FPPF
JSR PC,.CINLS
.IFF
.CLNLS: MOV B,A
BIC #170000,A
CMP #INUM,A
BEQ .CLNL1
JMP .CINLS
.CLNL1: JMP .CFNLS
.ENDC
TST GCPREV ;IS 0 FIRST TIME THROUGH
BEQ WORD.3 ;IS FIRST ARG
BR WORD.6 ;SECOND OR LATER, BUT DON'T RECOPY!!
;RETURN
WORDR: MOV GCPREV,C
BIS #LSTR,C
CLR GCPREV
JMP ORTC
MEMBER: JSR PC,GLWARG ;GET A LIST OR WORD ARGUMENT
BNE MEM.WD ;ITS A WORD
MOV B,GCPREV ;PROTECT THIS FROM THE GC
SAVE B ;SAVE POINTER TO NEXT NODE
ADD #2,S ;AND POP IT OFF
JSR PC,GLWARG ;GET A LIST OR WORD ARGUMENT
MOV B,@S ;PROTECT THE ARGUMENT
MEMLP: SPOP A ;GET POINTER TO THE THING WE ARE LOOKING FOR
BIT #7777,A ;IS IT EMPTY
BEQ MEMFLS ;YES, RETURN IT
MOV A,GCPREV ;SAVE IT
JSR PC,.LOADA ;LOAD IT INTO A,,B
SPUSH A ;SAVE POINTER TO BUTFIRST
MOV @S,C ;GET THE OBJECT TO COMPARE AGAINS
JSR PC,EQUAL1 ;ARE THEY EQUAL?
BEQ MEMLP ;NOT EQUAL, TRY THE NEXT ELEMENT
TST (P)+
MOV GCPREV,A ;GET BACK THE LIST TO RETURN
MEMFLS: BIC #170000,A ;CLEAR IT'S TYPE
BIS #LIST,A ;IT'S A LIST
MOV A,@S ;AND RETURN
MEMRT: CLR GCPREV ;NO GC PROTECTION ANY MORE
CLZ ;RETURN A VALUE
RTS PC
MEMWDF: MOV #LSTR,@S ;RETURN EMPTYP WORD
BR MEMRT ;AND RETURN
;HERE FIND THE CHARACTER IN THE WORD THAT IS EQ TO THE FIRST CHAR OF THE SEARCHED
;FOR WORD
MEM.WD: MOV B,GCPREV ;SAVE THE WORD TO SEARCH THROUGH
ADD #2,S ;POP IT OFF
JSR PC,GLWARG ;GET THE OBJECT TO LOOK FOR
BEQ MEMWDF ;ITS A LIST, CANT SEARCH FOR THAT IN A WORD!!
JSR PC,INSTR ;IS THERE A CHARACTER?
BEQ MEMWDF ;NO, JUST RETURN EMPTYP WORD
TST (P)+ ;POP OFF CO-ROUTINE LINKAGE
MOV D,F ;SAVE THE CHARACTER TO LOOK FOR, AND DESTROY CO-ROUTINE
MOV GCPREV,B ;GET BACK POINTER TO THE WROD TO SEARCH FOR
MOV #INSTR,-(P) ;CALL THE SUBROUTINE TRICKILY
MWDLP: JSR PC,@(P)+ ;GET THE NEXT CHARACTER
BEQ MEMWDF ;NO MORE, RETURN EMPTY WORD
CMP D,F ;ARE THEY EQUAL?
BNE MWDLP ;NO, CHECK THE NEXT CHARACTER
TST (P)+ ;POP OFF CO-ROUTINE
MOV A,B ;THE REST OF THIS WORD (INCLUDING THE CHAR IN D)
MOV C,A ;THE POINTER TO THE REST OF THE WORD
JSR PC,GRBAD ;GET A NODE WITH THEM IN IT
BIC #170000,C ;CLEAR THE TYPE
BIS #LSTR,C ;MAKE IT AN LSTR
MOV C,@S ;AND RETURN IT
BR MEMRT
FIRST:
JSR PC,GLWANE
BEQ F.SENT ;ARG IS SENTENCE
;ARG IS WORD
JSR PC,INSTR ;RETURN ONE CHAR IN D
BNE F.WTA9 ;FOUND A CHAR
F.WTA: ERROR+WTA ;NO CHARS IN STRING
F.WTA9: TST (SP)+ ;POP OFF CO-ROUTINE LINK
MOV D,B
F.STOR: CLR F
JSR PC,ACTSTO ;STORE THE CHAR.
POPS C
BIC #170000,C
BIS #LSTR,C ;POINTER TO THE NODE OF THE CHAR
JMP ORTNC
F.SENT: MOV B,C
JSR PC,.LDP2
JMP ORTNA
BUTFIRST:
JSR PC,GLWANE
BEQ BF.SEN
;ARG IS WORD
JSR PC,INSTR ;RETURN ONE CHAR
BEQ F.WTA ;NO CHARS IN STRING
TST (SP)+
;A CONTAINS FIRST 2 CHARS OF THE STRING
;BUT IT MAY ONLY HAVE ONE.
BIT #377,A ;IS TOP CHAR OF A 0?
BEQ BF.W1
BIT #77400,A
BEQ BF.W1 ;YES. ONLY ONE CHAR IN A
CLRB A ;KILL THE FIRST CHAR
MOV A,B
MOV C,A ;POINTER TO REST
JSR PC,GRBAD
BF.W1: BIC #170000,C
BIS #LSTR,C
JMP ORTNC
;ARG IS SENTENCE
BF.SEN: MOV B,C
JSR PC,.LDP1 ;POINTER TO REST OF SENTENCE
BIC #170000,A ;LEAVE ONLY POINTER
BIS #SENT,A
JMP ORTNA
LAST:
JSR PC,GLWANE
BEQ L.SENT ;ARG IS SENTENCE
;ARG IS WORD
MOV B,C
SPUSH #INSTR1 ;ADDRESS OF CO-ROUTINE
CLR D
L.W1: MOV D,B ;SAVE LAST CHAR
JSR PC,@(SP)+ ;RETURNS CHAR IN D
BNE L.W1 ;FOUND ONE
TST B ;STRING DONE
BNE F.STOR ;STORE THE CHAR AND RETURN
ERROR+WTA ;NO CHARS FOUND
L.SEN1: MOV A,B
;ARG IS SENTENCE
L.SENT: JSR PC,.LOAD
BIT #7777,A ;LAST NODE OF SENTENCE YET?
BNE L.SEN1
L.SRET: JMP ORTNB
BUTLAS: JSR PC,GLWANE
BEQ BL.SEN ;ARG IS A SENTENCE
;ARG IS A WORD
JSR PC,CPYSTR ;COPY STRING.
JSR PC,.LDP2 ;LAST NODE OF NEW STRING
SWAB A
BNE 2$ ;THE LAST CHARACTER IS REALLY THERE
CMP B,C ;IS THERE ONLY ONE NODE
BNE 1$ ;MORE TAN ONE NODE
CLR B ;ANSWER IS EMPTY WORD
BR 3$
1$: MOV C,F ;SAVE THIS NODE POINTER
SPUSHS B
MOV B,C ;POINTER TO HEAD OF LIST
4$: JSR PC,.LOADC ;LAOD THE NODE
BIC #170000,A ;FLUSH TYPE
CMP A,F ;DOES IT POINT TO ME?
BEQ 5$
MOV A,C
BR 4$
5$: MOV #SSTR,A
JSR PC,.STORE
SPOPS B
BR 3$
2$: CLRB A ;CLEAR LAST CHAR
JSR PC,.STP2 ;STORE NODE BACK
3$: BIS #LSTR,B ;POINTER TO THE WORD
JMP ORTNB
;ARG IS A SENTENCE
BL.SEN: JSR PC,COPYL ;COPY LIST
MOV E,C ;POINTS TO NEXT TO LAST NODE
BEQ BL.SR ;ANSWER IS EMPTY
JSR PC,.LDP1
BIC #7777,A
JSR PC,.STP1
MOV B,C
BL.SR: BIS #LIST,C
JMP ORTNC
.GLOBL LSTRCV ;031
;INPUT IS NUMBER. OUTPUT IS THE CHARACTER CORRESPONDING TO THAT NUMBER
CHAR: JSR PC,G1IARG ;B,,C _ NUMBER
MOV C,B
BIC #177400,B
MOV #SSTR,A
JSR PC,GRBAD
BIS #LSTR,C
JMP ORTC
;INPUT IS WORD, OUTPUT IS # OF FIRST CHAR
ASCI: JSR PC,LSTRCV ;CONVERT TO LSTR
JSR PC,.LOAD ;GET THE FIRST NODE
BIC #177400,B ;GET A 8 BIT CHARACTER
JMP R1NARG
COUNT:
JSR PC,GLWARG
BEQ CT.SEN
;ARG IS WORD
MOV B,C
CLR B
MOV #INSTR1,-(SP) ;ADDRESS OF A CO-ROUTINE
CT.W1: INC B ;INCREMENT COUNTER
JSR PC,@(SP)+ ;RETURNS CHAR IN B
BNE CT.W1
DEC B ;WHEN RETURNS HERE, NO MORE CHARS
CT.ORT: POPS C
JMP R1NARG ;C IS A THROW-AWAY
;ARG WAS A SENTENCE
CT.SEN: MOV B,C
JSR PC,CLE ;RETURNS NUMBER OF LIST ELEMENTS IN B
BR CT.ORT
;COPY LIST.
; CALL WITH B POINTING TO LIST
; RETURNS B POIOTING TO NEW LIST, C POINTING TO LAST NODE
COPYL: CLR E ;WILL POINT TO 2ND NODE FROM LAST
CLR F
BIT #7777,B
BEQ COPYR1
COPYL1: BIT #7777,B
BEQ COPYLR ;DONE
JSR PC,.LOAD
MOV F,E ;LISTB PLACES LAST NODE PTR INTO F
JSR PC,LISTB
MOV A,B
BR COPYL1
COPYLR: MOV F,C ;LISTB KEEPS PTR TO LAST NODE OF LIST IN F
POPS B ;LISTB KEEPS POINTER TO NEW LIST ON S.
COPYR1: RTS PC
;COPY STRING
;CALL WITH B POINTING TO STRING TO BE COPIED,
;ASSUMES THAT INPUT STRING HAS BEEN GARBAGE COLLECT PROTECTED ALREAEDY
;B POINTS TO FIRST NODE OF NEW STRING, C POINTS TO LAST
CPYSTR: MOV #INSTR,A
MOV D,-(SP)
MOV E,-(SP)
MOV F,-(SP)
MOV A,-(SP) ;ADDRESS OF INPUT STRING ROUTINE
CLR F
OUTSTR: JSR PC,@(SP)+ ;CALL INPUT STRING CO-ROUTINE
BEQ OSTRE1 ;INPUT STRING DONE
OSTR1: MOV D,B ;SAVE CHARACTER
JSR PC,@(SP)+ ;CALL INPUT STRING CO-ROUTINE
BEQ OSTRE2 ;INPUT STRING DONE
OSTR2: SPUSH A ;SAVE REGISTERS USED BY INPUT STRING
SWAB D
BIS D,B ;BIS SECOND CHARACTER
JSR PC,ACTSTO ;ACTUAL STORE
SPOP A
BR OUTSTR
;INPUT STRING HAS ENDED
OSTRE2: JSR PC,ACTSTO ;STORE CHAR IN B
OSTRE1: POPS B ;POINTER TO FIRST NODE OF STRING
MOV F,C ;POINTER TO LAST NODE
BIC #170000,B
BIC #170000,C
.RDEF: CLR GCP1
MOV (SP)+,F
MOV (SP)+,E
MOV (SP)+,D
SEZ
OSTRR: RTS PC
;ACTUALLY STORE OUTPUT NODE
ACTSTO: MOV #SSTR,A
JMP LISTB
;INPUT STRING
;A CO-ROUTINE THAT HANDS BACK A CHARACTER IN BOTTOM BYTE OF D
;DOES RTS PC WHEN INPUT STRING FINISHED
INSTR: MOV B,C
INSTR1: BIT #7777,C
BEQ OSTRR ;RTS PC
JSR PC,.LDP2I
MOVB A,D
BIC #177400,D ;CLEAR TOP BYTE
BEQ INSTR2 ;NULL CHAR
JSR PC,@(SP)+ ;RETURN TO CO-ROUTINE
INSTR2: CLRB A
SWAB A
MOV A,D
BIC #177400,D
BEQ INSTR1 ;NULL CHAR
JSR PC,@(SP)+ ;RETURN TO CO-ROUTINE
BR INSTR1
;LIKE INSTR, EXCEPT GETS CHAR FROM TEXT STRING (NOT NODE SPACE)
;NOTE -- ENTER AT INTXT
INTXT0: JSR PC,@(P)+
INTXT: MOVB (C)+,D
BNE INTXT0 ;BR IF NOT END OF TEXT
RTS PC
.GLOBL HNV,TOPS1 ;034
.GLOBL FLAGS2,NBKTS ;035
MAKE:
MMAKE9: POPS TOPS ;PUT VALUE INTO TOPS
MOV @S,B
MOV B,A
BIC #7777,A
CMP #ATOM,A ;IS TYPE ATOM?
BNE MAKE2
MAKE4: MOV #VBIND,A ;YES< SET VARIABLE BINDING?
JSR PC,.BIND
MAKE1: POPS A
JMP CLRTP1
MAKE2: CMP #LSTR,A
BEQ MAKE3
MAKE5: ERROR+WTAB ;WRONG TYPE OF ARG
MAKE3: BIT #7777,B
BEQ MAKE5
MOV TOPS,@S
MOV B,TOPS ;FOR .INTRN
JSR PC,UINTRN ;.INTRN FOR STRINGS THAT MAY INCLUDE NULL CHARS
MOV @S,TOPS
BIS #ATOM,B
MOV B,TOPS1
BR MAKE4
DOTS: JSR PC,GETVAL ;GET VALUE IF IT HAS ONE
BNE 1$
ERROR+HNV ;HAS NO VALUE
1$: PUSHS B
CLR TOPS
CLZ
RTS PC
THINGP: JSR PC,GETVAL ;DOES IT HAVE A VALUE?
BEQ THNGPF ;NO
JMP RTTRUE
THNGPF: JMP RTFALS
GETVAL: JSR PC,GUOEB ;GET UOE PTR FROM S INTO B
BEQ GETVA1
MOV #VBIND,A
JSR PC,.BINDL
BEQ GETVA1
TST B
GETVA1: RTS PC ;HAS NO VALUE (UNBOUND LOCAL)
GUOEB: POPS B ;GET UOE OR LSTR IN B FROM S
MOV B,A ;SKIP IF UOE
BIT #7777,A ;EMPTY?
BEQ GUOE5
BIC #7777,A
CMP #ATOM,A
BEQ GUOE1
CMP #LSTR,A
BEQ GUOE2
GUOE5: ERROR+WTAB ;.(B). ISWRONG TYPE OF ARG
GUOE2: MOV B,TOPS
JMP UOBSCH ;.OBSCH FOR STRINGS THAT HAVE NULL CHARS
GUOE1: CLZ
RTS PC
;PRINT TOP (C) THINGS ON S
FPRINT: INC NBKTS ;PRINTS OUTER [,]'S
PRINT: SAVE D
JSR PC,REVS ;DOESNT "
POP C
JSR PC,TYPE1
JSR PC,.CRLF
SEZ
RTS PC
TYPE: SAVE D
JSR PC,REVS
POP C
JSR PC,TYPE1 ;PRINT WITHOUT CRLF AT END
SEZ
RTS PC
TYPE1: DEC C
BLT 1$
BIS #DPQF+CPTBF,FLAGS2 ;DONT PRINT QUOTE BEFORE STRINGS
;BUT DO PRINT % AS BLANK
JSR PC,PRS1
POPS A
BR TYPE1
1$: BIC #DPQF+CPTBF,FLAGS2
RTS PC
.IFNZ LSIHAK
LOAD:
.IFZ DMPCAS
MOV #1,D ;TO LOGO. THE SITS RTN WILL THEN INPUT THE CONTENTS
JSR PC,SETTIM
JSR PC,TYO ;OF THE FILE TO LOGO
JSR PC,RESTTY
MOV #1,D ;ONE THING TO PRINT
JSR PC,TYPE1
JSR PC,.CRLF
.IFF
STLANC
ENGINS <PRTXT <START TAPE>>
ENDENG
FRINS <PRTXT <PARTIR LA CASSETTE>>
ENDLAN
.ENDC
JSR PC,LSTIG ;SET TTY INPUT TO IMAGE WITH BIG BUFFER
CLR LSILSC ;CLEAR LOST CAHRS COUNT
MOV PC,REDFLG
SEZ
RTS PC
ENDFIL: JSR PC,LSTRES ;RESTORE REAL BUFFERS
CLR REDFLG
TST LSILSC
BEQ 1$
PRTXT <LOST SOME CHARS!>
CLR LSILSC
1$: SEZ
RTS PC
DUMP:
STLANC
ENGINS <PRTXT <START TAPE RECORDING THEN TYPE SPACE>>
ENDENG
FRINS <PRTXT <COMMENCER L'ENREGISTREMENT ET TAPER UN ESPACE>>
ENDLAN
JSR PC,ONETYI
MOV PC,WRTFLG
JSR PC,SETTIM ;SET TTY TO IMAGE MODE
JSR PC,SHOWAL
STLANC
ENGINS <CPRTXT <!STOP TAPE THEN TYPE SPACE!>>
ENGINS <CPRTXT <ENDFILE>>
ENDENG
FRINS <CPRTXT <!ARRETER L'ENREGISTREMENT ET TAPER UN ESPACE!>>
FRINS <CPRTXT <FINFICHIER>>
ENDLAN
PRCR
JSR PC,ONETYI
JSR PC,RESTTY
CLR WRTFLG
SEZ
RTS PC
.ENDC
.SBTTL PREDICATES, IF, UNTIL AND TEST
EQUAL: MOV S,F
MOV (F)+,B ;ARG1. LEAVE ON STACK FOR GC PROTECTION
MOV (F),C ;ARG2
JSR PC,EQUAL1
BEQ EQ.F ;RETURNS HERE IF FALSE
ADD #4,S
JMP RTTRUE
EQ.F: ADD #4,S
JMP RTFALS
;COMPARE THE DATA ITEM POINTED TO BY B WITH
;THE DATA ITEM POINTED TO BY C.
;SKIP IF THEY ARE EQUAL
EQUAL1: CMP B,C ;ARE THEY EQ?
BEQ EQTRUE ;WONDERFULLY SIMPLE CASE
MOV #7777,E ;AN OFT-USED CONSTANT
MOV B,A
MOV C,D
BIC E,A
BIC E,D
CMP A,D
BNE WEQUAL
CMP #LIST,A
BNE WEQUAL
EQ.LST: BIC #170000,B
BIC #170000,C
CMP B,C
BEQ EQTRUE
TST B
BEQ EQFALS
TST C
BEQ EQFALS
JSR PC,.LOAD
PUSH A
JSR PC,.LDP2I
SPUSH C
MOV A,C
JSR PC,EQUAL1
BEQ EQ.FF
POP B
SPOP C
BR EQ.LST
EQ.FF: CMP (SP)+,(SP)+ ;POP OFF THE POINTERS TO THE BF'S
JSR PC,PPOPT
SEZ
RTS PC
;COMPARE TWO WORDS
.GLOBL EXCH1,GCP2 ;039
.GLOBL FALSE,TRUE ;040
.IFZ FPPF
WEQUAL: MOV #INUM,A
JSR PC,CONVERT ;TRY CONVERTING ARG TO INUM
BEQ EQ.STR ;NOT NUMERIC
EXCH B,C
JSR PC,CONVERT ;TRY CONVERTING 2ND ARG
BEQ EQFALS ;NOT NUMERIC
JSR PC,.LOAD ;A,,B HAVE NUMBER
MOV A,D
MOV B,F
JSR PC,.LOADC
CMP A,D ;COMPARE 2 INTEGERS
BNE EQFALS
CMP B,F
BNE EQFALS
BR EQTRUE
.IFF
WEQUAL: JSR PC,G1NUMS ;IS IT A NUMBER?
BEQ EQ.STR
LDD FA,FB ;IT WAS SO SAVE IT
MOV C,B ;IS THE SECOND A NUM?
JSR PC,G1NUMS
BEQ EQFALS
CMPF FA,FB ;COMPARE THEM
CFCC
BNE EQFALS
BR EQTRUE
.ENDC
;ARG NOT NUMERIC. TRY STRING COMPARE
EQ.STR: MOV #LSTR,A
JSR PC,CONVERT
BEQ EQFALS ;EQUAL NOT DEFINED FOR SNAPS, ETC
EXCH B,C
JSR PC,CONVERT ;TRY CONVERTING 2ND ARG, TOO
BEQ EQFALS ;NOT SAME TYPE AS FIRST ARG
CMP B,C
BEQ EQTRUE
;COMPARE TWO STRINGS. POINTERS IN B AND C.
SPUSH #INSTR1
MOV C,GCP2
CMPSTR: MOV B,GCP1
MOV B,F
CMPST1: BIT E,F ;IS ARG 1 ENDED
BEQ CMPSTE ;YES
SPUSH A ;SAVE A
MOV F,B ;POINTER TO REST OF ARG1
JSR PC,.LOAD
MOV A,F ;POINTER TO REST OF ARG1
SPOP A ;RESTORE A
TSTB B ;IS CHAR REAL OR NULL?
BEQ CMPST2 ;NULL
JSR PC,@(SP)+ ;PUTS 1 CHAR OF ARG 2 INTO B
BEQ CSFAL1 ;ARG 2 ENDED
CMPB D,B ;COMPARE CHARS!!
BNE CSFALS
CMPST2: SWAB B
BIC #177400,B
BEQ CMPST1 ;NULL CHAR
JSR PC,@(SP)+ ;1 CHAR OF ARG 2 IN B
BEQ CSFAL1
CMPB D,B ;COMPARE CHARS!!
BEQ CMPST1
CSFALS: TST (SP)+ ;POP CO-ROUTINE LINKAGE
CSFAL1: CLR GCP1
CLR GCP2
EQFALS: SEZ
RTS PC
;ARG 1 HAS ENDED
CMPSTE: JSR PC,@(SP)+
BNE CSFALS ;BUT ARG 2 HASN'T ENDED
CLR GCP1
CLR GCP2
EQTRUE: CLZ
RTS PC ;BOTH ENDED AT THE SAME TIME!!!!
;CALL WITH B = POINTER TO STRING IN NODE SPACE
; C = POINTER TO STRING IN DATA SPACE
EQ.TXT: SPUSH #INTXT ;ADDRESS OF CO-ROUTINE
MOV #7777,E ;AN OFT USED CONSTANT
BR CMPSTR
;MORE PREDICATES
GREATR: JSR PC,CMP2IA
BGT RTTRUE
RTFALS:
STLANC
ENGINS <PUSHS #FALSE>
ENDENG
FRINS <PUSHS #FAUX>
ENDLAN
RTNCMP: CLZ
RTS PC
LESSP:
LESS: JSR PC,CMP2IA
BGE RTFALS
RTTRUE:
STLANC
ENGINS <PUSHS #TRUE>
ENDENG
FRINS <PUSHS #VRAI>
ENDLAN
BR RTNCMP
GREQ: JSR PC,CMP2IA
BGE RTTRUE
BR RTFALS
LSEQ: JSR PC,CMP2IA
BLE RTTRUE
BR RTFALS
NUMBP: POPS B
MOV #INUM,A
JSR PC,CONVERT
.IFZ FPPF
BEQ RTFALS ;COULDN'T CONVERT IT
BR RTTRUE
.IFF
BNE RTTRUE
MOV #FNUM,A
JSR PC,CONVERT
BEQ RTFALS
BR RTTRUE
.ENDC
EMPTYP: POPS B
BIT #7777,B
BEQ RTTRUE
BR RTFALS
LISTP: POPS B
BIC #7777,B
CMP #SENT,B
BEQ RTTRUE
BR RTFALS
WORDP: POPS B
BIC #7777,B
CMP #SENT,B
BEQ RTFALS
BR RTTRUE
.IFZ FPPF
;COMPARE TWO INTEGER ARGUMENTS
CMP2IA: JSR PC,G2IARG
;COMPARE 2 INTEGERS IN B,,C & E,,F
.ENDC
CMP2I: CMP E,B
BNE CMP2IR ;CONDITION CODES SET CORRECTLY
CMP F,C
BEQ CMP2IR
BHI CMP2IH
;E,,F < B,,C
CMP #0,(PC)
RTS PC
CMP2IH: TST (PC)
CMP2IR: RTS PC
.IFNZ FPPF
;GET AND COMPARE TWO (FNUM OR INUM) ARGS
CMP2IA: SPUSH A
JSR PC,G2ARG
SPOP A
CMPF FB,FA
CFCC
RTS PC
INTEGE: JSR PC,G1ARG ;GET A FNUM ARG
LDD FA,FB
MOV #INUM,F
JMP .FSTOR
.ENDC
NOT: JSR PC,TSTST ;TEST S SKIP IF TRUE
BEQ RTTRUE
BR RTFALS
BOTH: JSR PC,TSTST
BNE EITH1
JSR PC,SPOPT
BOTH1: BR RTFALS
EITH1: JSR PC,TSTST
BEQ BOTH1
BR RTTRUE ;BOTH ARE "TRUE !!
EITHER: JSR PC,TSTST
BEQ EITH1 ;IS 2ND ONE "TRUE?
JSR PC,SPOPT ;POP 2ND ARG
BR RTTRUE
.GLOBL BRAKE,BRK,CPLN,CTP,FLAGS,FUNLEV,IFLEV,NOPAR,OOP ;042
.GLOBL $ELSE,$IF,$LPAR,$RPAR,CT ;043
.GLOBL .BUG.,IS,NTF ;044
TEST: JSR PC,TSTST ;IS TOP OF S "TRUE"?
BEQ TES1 ;NO, CLEAR FLAG
BIS #TSTFLG,FLAGS ;YES, SET FLAG
BR IFR
TES1: BIC #TSTFLG,FLAGS
BR IFR
IFTRUE: JSR PC,IFTFST ;FLAG SET?
BNE IFR ;YES, CONTINUE
BR IFT1 ;GO ACT LIKE A FAILED IF
IFFALS: JSR PC,IFTFST
BEQ IFR ;YES, CONTINUE
BR IFT1 ;NO STOP
IFTFST: INC IFLEV
BIT #TSTFLG,FLAGS
RTS PC
UNTIL: JSR PC,TSTST
BNE IFR
MOV CPLN,TMPBLK ;STORE THE CURRENT LINE NUMBER
BIT #DORF,FLAGS ;IN A DO OR RUN FRAME?
BNE UNTIL1 ;YES, DO THE UNTIL IN THIS FRAME
TST FUNLEV ;AT TOP LEVEL?
BEQ UNTIL1 ;YES, DO IT IN THIS FRAME
JMP GOUNTL
UNTIL1: BRAKET ;CHECK FOR INFINITE LOOP IN EVLINE
MOV #HEADER,CTP ;POINT AT LINE IN CURLIN
JSR PC,IGNT ;RESET POINTERS TO THE START OF THE LINE
SEZ ;NO OUTPUT
RTS PC
IF: INC IFLEV
JSR PC,TSTST ;TEST S, SKIP IF "TRUE"
BNE IFR
IFT1: CLR NOPAR
JSR PC,STNE
BEQ IFR
BIC #RTF,FLAGS
DEC IFLEV
IFR: SEZ
RTS PC
THEN: TST IFLEV
BGT IFR
ERROR+OOP ;THEN OUT OF PLACE
ELSE: DEC IFLEV
BGE ELSE9
ELSE1: ERROR+OOP ;ELSE OUT OF PLACE
ELSE9: CLR NOPAR
JSR PC,STNE
BEQ IFR
TST IFLEV
BLE ELSE1
BR IFR
STNE: ;SCAN TOO NEXT ELSE, CR OR UNMATCHED );
; SET RTF. SKIP IIF "ELSE"
JSR PC,GNT
CMP #$RPAR,B
BNE STNE4
DEC NOPAR
BGE STNE
BIS #RTF,FLAGS
SEZ
RTS PC
STNE4: CMP #$LPAR,B
BNE STNE5
INC NOPAR
BR STNE
STNE5: TST NOPAR
BGT STNE
.IFNZ ENG
CMP #$ELSE,B
BEQ STNE6
.ENDC
.IFNZ FR
CMP #$SINON,B
BEQ STNE6
.ENDC
STNE1: BIT #CRF,FLAGS
BEQ STNE2
STNE3: BIS #RTF,FLAGS ;IF "CR" SET RTF AND RETURN
BIC #CRF,FLAGS
SEZ
RTS PC
STNE6: BIS #RTF,FLAGS ;IF "ELSE", SET RTF AND SKIP RETURN
RTS PC
STNE2:
.IFNZ ENG
CMP #$IF,CT ;IS "IF", LOOK FOR THE NEXT ELSE!
BEQ STNE7
.ENDC
.IFNZ FR
CMP #$SI,CT
BEQ STNE7
.ENDC
BR STNE
STNE7: JSR PC,STNE
BEQ STNE3
BIC #RTF,FLAGS
BR STNE
.GLOBL SPSWPI
TSTST:
MOV @S,B ;TEST S, SKIP IF TRUE
.IFNZ ENG
CMP B,#FALSE
BEQ TSTF9 ;IT'S "FALSE
.ENDC
.IFNZ FR
CMP B,#FAUX
BEQ TSTF9
.ENDC
.IFNZ ENG
MOV #TRUE,C ;ERROR IF NEITHER "TRUE" OR "FALSE"
JSR PC,EQUAL1
BNE TESTIT
.ENDC
.IFNZ FR
MOV @S,B
MOV #VRAI,C
JSR PC,EQUAL1
BNE TESTIT
.ENDC
.IFNZ ENG
MOV @S,B
MOV #FALSE,C
JSR PC,EQUAL1
BNE TSTF9
.ENDC
.IFNZ FR
MOV @S,B
MOV #FAUX,C
JSR PC,EQUAL1
BNE TSTF9
.ENDC
ERROR+NTF ;NOT "FALSE, EITHER
TSTF9: JSR PC,SPOPT
SEZ
RTS PC ;"FALSE!!
TESTIT: JSR PC,SPOPT
CLZ
RTS PC ;"TRUE!!
REVS: CMP #1,2(P) ;REVERSES THE TOP ((P)+2) THINGS ON S
BLT 1$ ;IF <2 QUIT
RTS PC
1$: CMP #MAXARG,2(P)
BGE 2$
.BUG. ;BARF, WHO ASKED REVS TO SWITCH > 32 THINGS?
2$: PUSH A
SPUSH B
SPUSH C
SPUSH D
MOV 10.(P),C ;GET # TO BE SWITCHED
5$: MOV S,A ;COMPUTE ADDR OF WORD JUST BEYOND BLOCK
MOV C,B
ASL B
ADD A,B
CMP IS,B ;SHOULD WE FORCE A SWAPIN?
BLO 4$ ;YES
ASR C
BEQ 9$
8$: MOV (A),D
MOV -(B),(A)+
MOV D,(B)
DEC C
BGT 8$
9$: JMP RETD
4$: JSR PC,SPSWPI ;SWAP S PDL BACK IN
BR 5$
.SBTTL DOUBLE PRECISION INTEGER ARITHMETIC
.IFZ FPPF
;INTEGER MULTIPLICATION
;CALL WITH ONE DOUBLE PRECISION ARGUMENT IN B,,C
;AND THE OTHER IN E,,F
;RETURNS PRODUCT IN E,,F.
;ALL OTHER ACCUMULATORS (INCLUDING B,C ARE UNCHANGED)
.DPMUL: SPUSH A ;SAVE A
CLR A
DVML: PUSH B
SPUSH C
SPUSH D
SPUSH E
SPUSH F
PUSH B ;STUFF ABS(B,,C)
SPUSH C
SPUSH E ;AND ABS(E,,F)
SPUSH F
CLR -(SP) ;A FLAG FOR NEG. ARGS
TST B ;MAKE SURE ARGS ARE POSITIVE
BGE DVML1
DPNEG B,C
DPNEG 10(P),6(P) ;ALSO ON STACK (FOR DIV)
COM (SP)
DVML1: TST E
BGE DVML2
DPNEG E,F
DPNEG 4(P),2(P)
COM (SP)
DVML2: ADD A,PC ;CHOOSE BETWEEN MUL AND DIV
;DOUBLE PRECISION MULTIPLY (CONT.)
MUL1: TST B ;OVERFLOW UNLESS A1*A2=0
BEQ MUL2
TST E
BNE MDV2 ;OVERFLOW!
EXCH B,E ;WANT ARG1 TO HAVE ZERO HIGH ORDER PART
EXCH C,F
MUL2: CLR -(SP) ;SET B1 AND B2
ASL C
BCC 1$
MOV #100000,(SP) ;B2
1$: ASL F
BCC 2$
ADD #200,(SP) ;B1 (ALSO CLEARS CARRY)
2$: ROR C ;C2
ROR F ;C1
;IF B2*A1>0, THEN OVERFLOW
TST (SP)
BGE MUL3 ;B2=0
TST E ;A1
BNE MDV1 ;OVERFLOW
;DOUBLE PRECISION MULTIPLY (CONT.)
;GET A1*C2*(2**16.)
MUL3:
MOV C,A ;C2*A1
MUL E,A
BCS MDV1 ;CARRY INTO A IS OVERFLOW
MOV B,ANSWER+2 ;SINCE A1*C2 IS HIGH ORDER OF ANSWER
;GET C1*C2 AND ADD INTO ANSWER
MOV C,A ;C1*C2
MUL F,A
MOV B,ANSWER ;LOW ORDER PARTIAL PRODUCT
ADD A,ANSWER+2 ;ADDED TO A1*C2
BVS MDV1 ;OVERFLOW
;GET C2*B1*(2**15.) AND ADD INTO ANSWER
TSTB (SP)
BEQ MUL35 ;B1=0
CLR A
MOV C,B ;GET C2
ASHC #15.,A ;SHIFT C2 LEFT 15 PLACES
ADD B,ANSWER ;DOUBLE PRECISION ADD
ADC ANSWER+2
BVS MDV1
ADD A,ANSWER+2
BVS MDV1
;NOW GET B2*C1*(2**15.) AND ADD INTO ANSWER
MUL35: TST (SP)
BGE MUL4
CLR A
MOV F,B ;GET C1
ASHC #15.,A ;SHIFT C1 LEFT 15 PLACES
ADD B,ANSWER ;DOUBLE PRECISION ADD
ADC ANSWER+2
BVS MDV1
ADD A,ANSWER+2
BVS MDV1
;NOW GET B1*B2*(2**30.)
MUL4: CMP (SP)+,#100200 ;ARE BOTH B1 AND B2 SET
BNE MUL5 ;NO (PRODUCT IS ZERO, OBVIOUSLY)
ADD #40000,ANSWER+2 ;1*2**30. + ANSWER
BVS MDV2 ;OVERFLOW
;PUT ANSWER IN THE RIGHT PLACE
MUL5: MOV ANSWER+2,E ;HIGH ORDER PARTS
MOV ANSWER,F ;LOW ORDER PARTS
TST (SP)+ ;NEGATIVE?
BEQ MUL6
DPNEG E,F
MUL6: ADD #14,SP ;THROW AWAY E,,F, ABS(B,,C) AND ABS(E,,F)
JMP SRETD ;BUT RESTORE THE REST
;OVERFLOW EXITS
MDV1: TST (SP)+ ;POP 2 WORDS + ABS'S
MDV2: ADD #12,SP ;POP 1 WORD + ABS'S
JMP RETF ;RESTORE ALL AC'S AND RTS
;DOUBLE PRECISION DIVIDE
; DIVIDE E,F BY B,C
;RETURN QUOTIENT IN E,F AND REMAINDER IN B,C
.DPDIV: SPUSH A
MOV #<DIV1-MUL1>,A ;ADD TO THE PC IN A WHILE
JMP DVML ;INITIALIZATION.
DIV1: TST B ;IS DEN = 0, 1, OR DOUBLE PRECISION ?
BNE DIV2 ;DOUBLE PRECISION
TST C
BLT DIV2 ;DOUBLE PRECISION (SINCE TOP BIT WAS SET)
;DEN IS SINGLE PRECISION
BEQ MDV2 ;DEN=0. OVERFLOW!
CMP C,#1 ;IS IT 1?
BNE SPDEN1 ;NO
CLR B
CLR C
BR DIV10
SPDEN1: JSR PC,.SPDEN ;DO THE DIVISION
BR DIV10
;DEN IS DOUBLE PRECISION
DIV2: JSR PC,CMP2I ;IS NUM < DEN
BGE DIV5 ;NO
;NUM<DEN. QUOTIENT=0. REM=NUM
DIV4: MOV E,B
MOV F,C
CLR E
CLR F
BR DIV10
;NUM>=DEN.
DIV5: PUSH B ;SAVE DENOMINATOR
SPUSH C
MOV B,A ;MOVE B,,C TO A,,B AND NORMALIZE
MOV C,B
CLR SHFCNT
DIV5A: INC SHFCNT ;COUNT A LEFT SHIFT
ASHC #1,A
BVC DIV5A ;UNTIL SIGN BIT CHANGES (OVERFLOW)
ASHC #-1,A ;UNDO LAST SHIFT
BIC #100000,A ;AND CLEAR SIGN BIT WHICH WAS SET
DEC SHFCNT ;UNCOUNT THE LAST SHIFT
MOV A,C ;DIVIDE BY HIGH-ORDER OF NORMED DIVISOR
JSR PC,.SPDEN ;E,,F _ (E,,F)/(DIVISOR*2^[N-16.])
MOV E,A ;MOV (QUOTIENT*2^[16.-N]) TO A,,B
MOV F,B
ADD #-16.,SHFCNT ;TIMES 2^[N-16.] IS TRIAL QUOTIENT
ASHC SHFCNT,A
;GET TRIAL NUM_(TRIAL QUOTIENT-1)*DEN. COMPARE WITH TRUE NUM
POP F ;E,,F _ SAVED DENOMINATOR
SPOP E
MOV B,C ;B,,C _ A,,B (TRIAL QUOTIENT)
MOV A,B
SUB #1,C ;TRY FIRST WITH Q_Q-1
SBC B
BVS MDV2 ;OVERFLOW
JSR PC,.DPMUL
BEQ MDV2 ;MULTIPLY GOT AN ERROR (HMM!)
;COMPARE NUM TO TEM
MOV B,ANSWER+2 ;SAVE TRIAL QUO
MOV C,ANSWER
;FALLS THROUGH
;FALLS IN
;GET TEM-NUM
MOV SP,D
TST (D)+
SUB (D)+,F
SBC E
BVS MDV2
SUB (D)+,E
BVS MDV2
;TURN INTO NUM-TEM
DPNEG E,F
MOV E,B
MOV F,C
MOV (D)+,F ;E,,F_DEN
MOV (D)+,E
DIV6: TST B ;NUM-TEM
BEQ DIV7
BGT DIV75
;ANSWER TOO BIG. TRY ANSWER _ ANSWER - 2
SUB #2,ANSWER
SBC ANSWER+2
BVS MDV2
;THIS MAKE TEM _ TEM + 2*DEN
ADD F,C
ADC B
BVS MDV2
ADD E,B
BVS MDV2
ADD F,C
ADC B
BVS MDV2
ADD E,B
BVS MDV2
BR DIV6
DIV7: TST C
BEQ DIV9 ;TRIAL QUOTIENT = QUOTIENT !!
;TEM < NUM. EITHER QUOT=QUOT OR QUOT+1
DIV75: JSR PC,CMP2I ;IS REM < DEN
BGT DIV9 ;YES
DIV8: ADD #1,ANSWER ;QUOT _ QUOT + 1
ADC ANSWER+2
BVS MDV2
SUB F,C ;REM _ REM - DEN
SBC B
BVS MDV2
SUB E,B
BVS MDV2
DIV9: MOV ANSWER+2,E
MOV ANSWER,F
DIV10: TST (SP)+ ;NEG. IF ANSWER SHOULD BE NEG.
BGE DIV11
DPNEG B,C
DPNEG E,F
DIV11: ADD #14,SP ;POP ABS(E,,F), ABS(B,,C) AND E,,F
POP D ;RESTORE D
CMP (SP)+,(SP)+ ;THROW AWAY B & C
SPOP A ;RESTORE A
CLZ
RTS PC
;SINGLE PRECISION DENOMINATOR. DOUBLE PRECISION NUMERATOR.
;C=DEN. E,F=NUM. RETURNS C_REM, E,F_QUOTIENT
.SPDEN: SPUSH A
SPUSH B
ASL E ;DOUBLE E,,F
ASL F
ADC E
MOV E,B ;2E/C
CLR A
DIV C,A
MOV A,E ;2*HIGH-QUOTIENT -> E
MOV B,A ;(2REM + 2F)/2 /C
MOV F,B
ASHC #-1,A
DIV C,A
MOV A,F ;LOW-QUOTIENT -> F
MOV B,C ; REMAINDER -> C
ASR E ;HALVE E TO GET PROPER HIGH-QUOTIENT
BCC 1$
BIS #100000,F ;& LOW BIT FROM DOUBLE-E CLOBBERS F'S SIGN BIT
1$: SPOP B
SPOP A
RTS PC
.ENDC
.IFNZ FPPF
;FLOATING DIVIDE AND MULTIPLY FROM REGS B,,C AND E,,F
.DPMUL: PUSH A
CLR A ;SET SWITCH
.DPMU1: FPUSH FA
FPUSH FB
SPUSH C
SPUSH B
LDCIF (P)+,FA
SPUSH F
SPUSH E
LDCIF (P)+,FB ;LOAD FLOATING REGS
ADD A,PC ;WHICH ENTRY?
.DPMU5: MULF FA,FB
BR .DPMU2
.DPMU6: LDD FB,FC ;SAVE FB
DIVF FA,FB
.DPMU2: STCFI FB,-(P) ;STACK QUOTIENT OR PRODUCT
BCS .DPERR ;TOO BIG!?
SPOP E
SPOP F ;LOAD E,,F
TST A
BNE .DPMU4 ;BRANCH ON DIVIDE
.DPMU3: FPOP FB
FPOP FA
SPOP A
CLZ
RTS PC
.DPMU4: STCFI FB,-(P)
LDCIF (P)+,FB ;TRUNCATE QUOTIENT
MULF FA,FB
SUBF FB,FC ;GET REMAINDER
STCFI FC,-(P)
SPOP B
SPOP C ;LOAD B,,C WITH REMAINDER
BR .DPMU3
.DPDIV: TST C ;DIVIDE ENTRY
BNE .DPDI1
TST B ;DON'T DIVIDE BY ZERO
BEQ .DPERQ
.DPDI1: PUSH A
MOV #<.DPMU6-.DPMU5>,A ;SET DIVIDE SWITCH
BR .DPMU1 ;GO DO IT
.DPERR: CMP (P)+,(P)+ ;CLEAR STACK
FPOP FB
FPOP FA
SPOP A
SEZ
.DPERQ: RTS PC
.ENDC
.GLOBL CNVTBL ;051
.SBTTL CONVERSION ROUTINES
;CONVERT
;CALL WITH DESIRED DATA TYPE IN A
;CALL WITH POINTER TO DATA IN B
;IF CONVERSION SUCCEEDS, RETURN POINTER TO CONVERTED DATA IN B AND
;LEAVE A UNCHANGED.
;
;IF CONVERSION FAILS, LEAVE B UNCHANGED,BUT RETURN ITS DATA TYPE IN A
CONVERT:
MOV A,-(SP) ;SAVE A,B,C HERE
MOV B,-(SP)
MOV C,-(SP)
BIC #107777,A ;LEAVE DATA TYPE ONLY
MOV B,C
BIC #107777,C
ASR A ;SHIFT DESTINATION DATA TYPE 3 PLACES
ASR A
ASR A
BIS C,A ;SET SOURCE DATA TYPE IN THE 3 VACATED BITS
ASR A ;AND PLACE THE ENTIRE MESS IN BOTTOM 6 BITS
SWAB A
;(A IS NOW A 6 BIT DISPATCH ADDRESS)
MOVB CNVTBL(A),A ;PICK UP ENTRY FROM TABLE
BIC #177400,A ;CLEAR TOP BYTE
ASL A ;IT IS A BYTE ADDRESS
JSR PC,CNVTOP(A) ;RELATIVE TO CONVERT TOP
BEQ CONV.F ;THE CONVERSION FAILED
MOV (SP)+,C
TST (SP)+ ;DON'T RESTORE B
MOV (SP)+,A
RTS PC
CONV.F: MOV (SP)+,C
MOV (SP)+,B
MOV B,A
BIC #7777,A ;DATA TYPE OF ARG LEFT IN A
TST (SP)+ ;DON'T RESTORE A
;FALLS THROUGH
;CONVERT ROUTINE JUMPS TO THE PROGRAMS HERE
DC CNVTOP,. ;TOP OF CONVERT ROUTINES
;THE ARGUMENT CAN'T BE CONVERTED TO DESIRED DATA TYPE
.CERR: SEZ
RTS PC
DC CA2LS,<<.-CNVTOP>/2>
;CONVERT ATOM TO LSTR
.CATLS: JSR PC,.LOAD
DC CNVNOP,<<.-CNVTOP>/2>
;THE ARGUMENT ALREADY HAS THE DESIRED TYPE
.CNOP: CLZ
RTS PC
DC CSN2IN,<<.-CNVTOP>/2>
;CONVERT SNUM TO INUM. ASSUME NUMBER IN B, RATHER THAN POINTER
.CSNIN: CLR A
TST B ;IS NUM NEGATIVE?
BGE 1$
COM A ;SET TOP PART TO ALL 1'S
1$: JSR PC,GRBAD
BIS #INUM,C ;C POINTS TO NEW NODE
MOV C,B
RTS PC
.GLOBL ABASE ;053
;MORE CONVERSION ROUTINES
DC CIN2SN,<<.-CNVTOP>/2>
;CONVERT INUM TO SNUM. RETURN NUMBER IN B
.CINSN: JSR PC,.LOAD
TST B
SXT C ;SEE IF B'S SIGN EXTENDED FILLS A.
CMP A,C
BNE .CERR
CLZ
RTS PC
DC CSN2LS,<<.-CNVTOP>/2>
;CONVERT SNUM TO LSTR
.CSNLS: JSR PC,.CSNIN ;CONVERT TO INUM FIRST
DC CIN2LS,<<.-CNVTOP>/2>
;CONVERT INUM TO LSTR
.CINLS: SPUSH D
SPUSH E
SPUSH F
JSR PC,.LOAD ;A,B HAS NUMBER
JSR PC,.CINST ;CONVERT TO STRING ON P-PDL
.CINL0: CLR F
MOV #SSTR,A
.CINL1: SPOP B
BEQ .CINL2 ;0 MARKS END OF DIGITS
JSR PC,LISTB ;PUT NEXT 2 CHARS ONTO LIST
BR .CINL1
.CINL2: POPS B ;POINTER TO FIRST NODE OF ANSWER
BIC #170000,B ;CLEAR DATA TYPE
BIS #LSTR,B ;REPLACE BY LSTR
MOV F,C ;GET PTR TO LAST NODE IN STRING
.SRDEF: CLR GCP1
MOV (SP)+,F
MOV (SP)+,E
MOV (SP)+,D
CLZ
RTS PC
;GET NEXT CHARACTER IN B
;SKIP UNLESS NO MORE CHARS
.CNXTD: TST E ;IS THERE MORE NUMBER LEFT
BNE .CNXD1 ;YES
TST F
BEQ .CNXD2
.CNXD1: MOV #10.,C
ADD ABASE,C ;ADD DELTA ARITHMETIC BASE TO C
CLR B
JSR PC,.DPDIV ;C_REM, E,,F_QUO
BEQ .CNXD2
ADD #60,C ;TURN TO ASCII
.CNXD2: RTS PC
.GLOBL TEM1 ;054
;CONVERT INUM TO STRING ON P-PDL
.CINST: MOV (SP),TEM1 ;RETURN ADDRESS
CLR (SP)
MOV #10,D
MOV A,E
BGE .CINI1 ;NUMBER IS POSITIVE
DPNEG E,B ;NUMBER IS NEG
CLR D ;FLAG
.CINI1: MOV B,F
.CINI2: JSR PC,.CNXTD ;GET NEXT DIGIT IN C
BEQ .CINI5 ;NO MORE CHARS
SWAB C
PUSH C
JSR PC,.CNXTD
BEQ .CINI6
BISB C,(SP) ;SET NEW CHAR INTO PREVIOUS ONE
BR .CINI2
.CINI5: ADD D,PC ;NEGATIVE?
SPUSH #<55*256.> ;PUSH A MINUS SIGN IN HIGH BYTE
.CINIR: JMP @TEM1 ;RETURN
BR .CINI7
.CINI6: ADD D,PC ;NEGATIVE?
BIS #55,(SP) ;PUT A MINUS SIGN IN LOW BYTE
JMP @TEM1
.CINI7: TST (SP) ;WERE ANY CHARACTERS GENERATED?
BNE .CINIR ;YES, SO RETURN
SPUSH #<60*256.> ;NO, SO PUSH A "0 IN HIGH BYTE
BR .CINIR
;MORE CONVERSION ROUTINES
DC CLS2SN,<<.-CNVTOP>/2>
;CONVERT LSTR TO SNUM
.CLSSN: JSR PC,.CLSIN ;CONVERT TO INUM FIRST
BEQ .CLNR
JSR PC,.CINSN ;THEN CONVERT TO SNUM
.CLNR: RTS PC ;FAILED
DC CLS2IN,<<.-CNVTOP>/2>
;CONVERT LSTR TO INUM
.CLSIN: BIT #7777,B ;IS B EMPTY
BEQ .CLNR ;CAN'T CONVERT EMPTY
PUSH D
SPUSH E
SPUSH F
MOV B,GCP1 ;POINT TO INPUT. (GETS CLEARED AT .RDEF & .SRDEF)
MOV B,C
CLR E
CLR F
.CLSS0: CLR -(SP) ;A FLAG
JSR PC,INSTR1 ;GET FIRST CHAR IN D
BEQ .CLSS8 ;NO CHARS (HMM)
CMPB D,#53 ;PLUS
BEQ .CLSSA
CMPB D,#55 ;MINUS
BNE .CLSS3 ;NOT + OR -
COM 2(SP) ;-1
.CLSSA: JSR PC,@(SP)+
BEQ .CLSS8
BR .CLSS4
.CLSS1: JSR PC,@(SP)+ ;GET NEXT CHAR INTO D
.CLSS4: BEQ .CLSS9 ;ALL CHARS GOTTEN
.CLSS3: SPUSH C ;SAVE C
SUB #60,D ;CONVERT FROM ASCII
BLT .CLSS7 ;NOT DIGIT
CMPB D,#10.
BGE .CLSS7 ;NOT DIGIT
MOV #10.,C
ADD ABASE,C ;ADD DELTA ARITHMETIC BASE TO C
CLR B
JSR PC,.DPMUL
BEQ .CLSS7 ;TOO BIG
ADD D,F ;ADD NEXT DIGIT IN
ADC E
BVS .CLSS7 ;OVERFLOW
SPOP C
BR .CLSS1
;EITHER A NON-DIGIT CHARACTER WAS FOUND, OR ELSE
;THERE WAS OVERFLOW
.CLSS7: CMP (SP)+,(SP)+ ;POP OFF C & CO-ROUTINE LINKAGE
.CLSS8: TST (SP)+ ;POP OFF FLAG
JMP .RDEF
;ALL CHARS GOTTEN. NUMBER IS IN E,,F
.CLSS9: TST (SP)+ ;BUT SHOULD IT BE NEG?
BGE .CLSSR ;NO
DPNEG E,F
.CLSSR: MOV E,A
MOV F,B
JSR PC,GRBAD
BIS #INUM,C
MOV C,B
JMP .SRDEF
.IFNZ FPPF
;FLOATING POINT CONVERSION ROUTINES
DC CSN2FN,<<.-CNVTOP>/2>
.CSNFN: SPUSH #.CINFN
JMP .CSNIN
DC CIN2FN,<<.-CNVTOP>/2>
.CINFN: MOV #INUM,A
JSR PC,.FLOAD
STCFD FA,-(P)
RFSTR: SPOP A
SPOP B
JSR PC,GRBAD
BIS #FNUM,C
MOV C,B
CLZ
RTS PC
DC CFN2IN,<<.-CNVTOP>/2>
.CFNIN: MOV #FNUM,A
JSR PC,.FLOAD
ADDF #40000,FA
CFCC
BVS .LERR1
BGE 1$
SUBF #40200,FA
1$: STCFI FA,-(P)
BCS .LERR
SPOP A
SPOP B
JSR PC,GRBAD
MOV C,B
BIS #INUM,B
CLZ
RTS PC
.LERR: CMP (P)+,(P)+
.LERR1: SEZ
RTS PC
DC CFN2SN,<<.-CNVTOP>/2>
.CFNSN: JSR PC,.CFNIN
BEQ .LERR1
JMP .CINSN
DC CFN2LS,<<.-CNVTOP>/2>
.CFNLS: SPUSH D
SPUSH E
SPUSH F
MOV #FNUM,A
JSR PC,.FLOAD
JSR PC,.CFNST
JMP .CINL0
.GLOBL FNPDL,SEXP ;057
DC CLS2FN,<<.-CNVTOP>/2>
.CLSFN: CLR FNPDL+2
CLR SEXP
CLR FNPDL
STF FA,FE ;STORE FLOATING REGISTERS
STF FB,FF
CLRF FB
BIT #7777,B ;CAN'T CONVERT EMPTY LSTR
BEQ .FNLR
PUSH D
SPUSH E
SPUSH F
MOV B,GCP1
MOV B,C
CLR E
CLR F
CLR -(P) ;A FLAG FOR THE SIGN OF NUMBER
JSR PC,INSTR1 ;GET FIRST CHAR
BEQ .FERR ;NO CHARS
SETI ;TO PREPARE FOR MOVES FROM REGS TO FLOAT REGS
CMPB D,#53 ;IS CHAR A "+?
BEQ CLSSA
CMPB D,#55 ;IS CHAR A "-?
BNE CLSS3
COM 2(P) ;SET NEGATIVE NUMBER FLAG
CLSSA: JSR PC,@(P)+ ;GET NEXT CHAR
BEQ .FERR ;NO MORE CHAR????
BR CLSS69
CLSS1: JSR PC,@(P)+ ;GET NEXT CHAR
CLSS69: BEQ CLSS9
CLSS3: SUB #60,D ;CONVERT FROM ASCII
BLT CLSS7 ;IT WASN'T A DIGIT
CMPB D,#12
BGE CLSS7 ;IT WASN'T A DIGIT
CLR B
LDCFD #41040,FA ;CONSTANT 10
MULF FA,FB
CFCC
BVS CLSS8
LDCIF D,FD
INC FNPDL+2 ;SET SWITCH
ADDF FD,FB
CFCC
BVS CLSS8 ;OVERFLOWED A FLOATING REGISTER??????!!!
ADD E,F
BR CLSS1 ;GET ANOTHER CHAR
CLSS8: TST (P)+ ;DESTROY CO-ROUTINE LINKAGE
JMP .FERR
CLSS9: CLR B ;NO EXPONENT
JMP OKY
CLSS7: INC FNPDL
CMPB D,#25 ;IS IT "E?
BEQ GTEXP
CMPB D,#36 ;IS IT "N?
BEQ GTNEXP
CMPB D,#177776 ;ITS NOT ".!!??
BNE CLSS8
TST E
BNE CLSS8 ;THERE WERE TWO ".
DEC E
BR CLSS1
.FNLR: LDF FE,FA ;RESTORE REGS
LDF FF,FB
SEZ
RTS PC
FERR2: POPS GCP1
FPOP FB
FPOP FA
.FERR: TST (P)+
LDF FF,FB
LDF FE,FA
SETL
JMP .RDEF
GTNEXP: DEC SEXP ;SET NEG EXPONENT FLAG
GTEXP: SETL
SPOP D ;SAVE CO-ROUTINE LINKAGE
FPUSH FA
FPUSH FB
JSR PC,KL ;GET EXPONENT
BEQ FERR2
POPS GCP1
FPOP FB
FPOP FA
SPUSH A
CLR A
JSR PC,.LOAD ;GET EXPONENT IN A,,B
TST A
BEQ OKAY
SPOP A ;THE EXPONENT WAS TOO TOO LARGE!!!
BR .FERR
OKAY: SPOP A
OKY: TST FNPDL+2
BEQ .FERR
SETL
TST (P)+ ;THE NUMBER IS NEGATIVE?
BGE OKY1
NEGF FB
OKY1: LDCDF #40200,D ;CONSTANT 1
TST SEXP ;GET FINAL EXPONENT
BGE 1$ ;IS EXP NEGATIVE
NEG B
1$: CLR SEXP
ADD B,F
TST F ;GET ABSOLUTE VALUE IN F
BGE LOOP
DEC SEXP
NEG F
LOOP: DEC F ;GET 10 TO THE EXPONENT IN FD
BLT DONEX
MULF FA,FD
CFCC
BVS .FERR+2 ;TO BIG
BR LOOP
DONEX: TST SEXP ;IF EXP IS POSITIVE MULTIPLY BY IT
BLT DIVE ;IF NEG DIVIDE BY IT
MULF FD,FB ;AND PUT RESULT IN FB
CFCC
BVS .FERR+2
BR FIN
DIVE: DIVF FD,FB
FIN: STCFD FB,-(P)
SPOP A ;GET RESULT IN A,,B
SPOP B
JSR PC,GRBAD ;STORE RESULT IN NODE SPACE
BIS #FNUM,C ;PUT POINTER TO DATA IN B
MOV C,B
; TST FNPDL
; BEQ .FERR+2
LDF FF,FB ;RESTORE FLOATING REGS
LDF FE,FA
JMP .SRDEF
KL: SPUSH D ;SHORT FOR KLUDGE.
SPUSH E ;PREPARE TO FAKE OUT .CLSSA
SPUSH F ;IT WILL GET US AN EXPONENT
CLR -(P) ;FAKE A FLAG
SPUSH D ;RESTORE CO-ROUTINE LINKAGE
CLR E
CLR F
PUSHS GCP1
JMP .CLSSA ;GET POINTER TO EXPONENT
;CONVERT FROM FNUM TO SSTR ON P-PDL
.CFNST: SPOP SEXP ;SAVE PC
CLR -(P)
MOV #FNPDL+16,D ;INITIALIZE STACK POINTER
TSTF FA
CFCC
BEQ .CFNZE ;ITS ZERO
BGE .CFNS0
MOVB #'-,-(D) ;PUT IN A MINUS SIGN
NEGF FA ;PROCESS SIGN OF FNUM
.CFNS0: CLR A
LDCFD #40200,FB ;CONSTANT 1
LDCFD #41040,FD ;CONSTANT 10
CMPF FA,FB
CFCC
BLT .CFNS2
.CFNS1: DIVF FD,FA ;NORMALIZE FA
INC A ;DIVIDE UNTIL 0<FA<1
CMPF FA,FB
CFCC
BGE .CFNS1
.CFNS2: MULF FD,FA ;MULTIPLY UNTIL 1<F=FA<10
DEC A
CMPF FA,FB
CFCC
BLT .CFNS2
SPUSH #66152
SPUSH #2657
SPUSH #33675
SPUSH #33006
ADDF (P)+,FA ;ADD .0000005 FOR ROUNDING
CMPF FA,FD ;9.99999999999999 WILL OVERFLOW
CFCC
BLT 1$
DIVF FD,FA
INC A ;MAKE IT 1.000 WHEN IT WAS 10.000
1$: MOV A,FNPDL ;SAVE EXPONENT
MOV #7,B ;COUNTER FOR SEVEN DIGITS
SETI
INC A
BLT 2$ ;ITS LESS THAN .1
CMP #7,A
BLT 2$ ;ITS GREATER THAN 10000000.
INC A
CLR FNPDL
BR .CFNS3
2$: MOV #2,A
.CFNS3: DEC A ;A COUNTS PLACES TO DECIMAL POINT
BNE 1$
MOVB #'.,-(D) ;PUT IN ".
1$: STCFI FA,C ;GET DIGIT
LDCIF C,FB
ADD #'0,C
MOVB C,-(D) ;STACK CHARACTER
SUBF FB,FA ;GET FRACTIONAL PART OF NUMBER
MULF FD,FA
SOB B,.CFNS3
DEC A
BNE 2$
MOVB #'.,-(D)
2$: SETL
CLR A
;FALLS THROUGH
;FALLS IN
.CFNS4: INC A ;COUNT ZEROS POPPED
CMPB #'0,(D)+
BEQ .CFNS4 ;POP INSIGNIFICANT ZEROS
DEC D ;RESET POINTER
MOV FNPDL,B ;RETRIEVE EXPONENT
BEQ .CFNS6 ;NO EXPONENT
BGT .CFNS5
ADD B,A
BGE .CFNS8 ;IT NOW FITS DUE TO POPPED ZEROS
NEG B
MOVB #'N,-(D) ;STACK "N
BR .CFNS5+4
.CFNS5: MOVB #'E,-(D) ;STACK "E
CLR A
MOV D,FNPDL ;SAVE POINTER
JSR PC,.CINST ;REDUCE EXPONENT TO SSTR
SPOP A
SPOP B
MOV FNPDL,D ;RESTORE POINTER
MOVB A,-(D) ;STACK EXPONENT DIGIT
BNE 1$
INC D ;IT WASN'T A DIGIT SO KILL IT
1$: SWAB A
MOVB A,-(D) ;GET OTHER DIGIT
.CFNS6: MOVB (D)+,-(P) ;GET HIGH BYTE
BEQ .CFNS7 ;A ZERO BYTE MEANS ITS DONE
SWAB (P)
MOVB (D)+,(P) ;GET ANOTHER BYTE
BNE .CFNS6 ;ZERO BYTE SIGNALS END
SUB #2,P
.CFNS7: ADD #2,P ;FIX UP STACK POINTER
JMP @SEXP
.CFNZE: SPUSH #"0. ;PUT "0. ON STACK
JMP @SEXP
.CFNS8: ADD D,B ;CREATE POINTER
INC B
MOV B,C ;SAVE IT
.CFNS9: MOVB (D)+,(B)+ ;SHIFT STACK
CMPB #'.,-1(B)
BNE .CFNS9
MOVB (D),-1(B) ;GET LAST DIGIT
MOV FNPDL,A
COM A ;COMPUTE HOW MANY ZEROS ARE TO BE ADDED
.CFN10: MOVB #'0,(B)+
SOB A,.CFN10
MOVB #'.,(B)
MOV C,D ;RESTORE POINTER
BR .CFNS6 ;I HOPE YOUR HAPPY THAT THE EXPONENT IS GONE
.ENDC
.SBTTL GET ARGUMENT ROUTINES
;GET 2 SNUM'S OFF OF S PDL
;RETURN TOP ONE IN A, BOTTOM ONE IN B
G2NARG: JSR PC,G1NARG ;NUMBER IN B
MOV B,A
;GET 1 SNUM OFF OF S PDL
;RETURN IT IN B
G1NARG: POPS B
G1NAR1: MOV A,-(SP) ;ENTER HERE WITH ARG IN B
MOV #SNUM,A
JSR PC,CONVERT
BEQ G1ARG1
MOV (SP)+,A
RTS PC
;GET ONE LIST OR WORD ARG
;SKIP IF WORD
GLWARG: MOV @S,B ;DON'T POP ARG. LEAVE IT GC PROTECTED
GLWAR1: MOV #LSTR,A
JSR PC,CONVERT
BNE GSW2
GSW1: CMP A,#SENT
BNE G1ARG1 ;NOT SENTENCE EITHER
SEZ
GSW2: RTS PC
;GET ONE LIST OR WORD. ERRROR IF EMPTY
GLWANE: MOV @S,B
BIT #7777,B
BEQ G1ARG1
BR GLWAR1
;RETURN ONE NUMERIC ARGUMENT
;CALL WITH SNUM IN B
R1INT: JSR PC,GETINT
R1NARG: JSR PC,.CSNIN ;CONVERT SNUM TO INUM
JMP ORTB
PSHINT: JSR PC,GETINT
;PUSH A NUMBER ONTO THE S-PDL
PSHNUM: JSR PC,.CSNIN
SPUSHS B
RTS PC
.IFZ FPPF
;GET 2 INTEGERS FROM THE S-PDL
G2IARG: JSR PC,G1IARG
MOV B,E
MOV C,F
JSR PC,G1IARG
EXCH B,E
EXCH C,F
ILOAD1: RTS PC
G1ARG1: ERROR+WTAB
.ENDC
;GET 1 INTEGER FROM THE S-PDL
G1IARG: POPS B
SPUSH A ;SAVE A
MOV #INUM,A
JSR PC,CONVERT
BEQ G1ARG1
JSR PC,.LOAD ;INTEGER IN A,,B
MOV B,C
MOV A,B
SPOP A
RTS PC
.IFZ FPPF
;RETURN 1 INTEGER FROM B,,C
R1I.BC: MOV B,A
MOV C,B
BR R1I.N
;;RETURN 1 INTEGER FROM E,,F
R1I.EF: MOV E,A
MOV F,B
R1I.N: JSR PC,GRBAD
BIS #INUM,C
JMP ORTC
.ENDC
.IFNZ FPPF
;ROUTINES TO LOAD FLOATING REGS FROM NODESPACE
G2ARG: MOV #INUM,F
JSR PC,G1NUM ;GET 1 INTO FA
BEQ G1ARG1
LDD FA,FC
JSR PC,G1NUM ;GET ANOTHER
BEQ G1ARG1
LDD FA,FB
LDD FC,FA ;SWITCH THEM
RTS PC ;F WILL CONTAIN TYPE EXPECTED OF
;ARITHMETIC RESULT
;LOAD ONE ARG INTO FA AND ERROR+WTA
G1ARG: JSR PC,G1NUM
BNE ILOAD1
G1ARG1: ERROR+WTAB
;LOAD ONE ARG INTO FA AND CLZ
G1NUM: POPS B
G1NUMS: MOV B,A ;IS IT ALREADY AN FNUM?
BIC #7777,A
CMP #FNUM,A
BEQ G1FAG
MOV #INUM,A
JSR PC,CONVERT ;TRY TO GET AN INUM
BNE .FLOAD
MOV #FNUM,A
JSR PC,CONVERT ;TRY TO GET A FNUM
BEQ ILOAD1
G1FAG: MOV A,F ;SET F TO SHOW FNUM
.FLOAD: BIC #170000,B
ASL B
ASL B
ADD #NODESP,B
CMP #INUM,A
BEQ .ILOAD ;LOAD AN INUM?
LDCFD (B),FA ;LOAD FNUM
CLZ
RTS PC
.ILOAD: LDCIF (B),FA ;LOAD INUM
CLZ
ILOAD1: RTS PC
.ENDC
;GET 1 SNAP
; RETURN POINTER TO SNAP IN D, DELTA X IN E, DELTA Y IN F
G1SNAP: MOV @S,C ;POINTER TO ARG
BIT #7777,C ;IS IT EMPTY?
BEQ ILOAD1 ;YES. RETURN WITHOUT SKIPPING
;LOAD 3 NUMBERS
; GROVEL DOWN A LIST OF NUMBERS RETURNING 3 NUMBERS IN D,E,F
; CALL WITH C POINTING TO LIST
; IF LIST CONTAINS 1)NON-NUMBERS OR 2)MORE THAN 3 ELEMENTS,
; THEN ERROR+WTA
LD3NUM: PUSH A
SPUSH B
SPUSH C
MOV #7777,D ;AN OFT USED CONSTANT
MOV #3,F ;COUNTER
LDN.L: BIT D,C ;IS THERE MORE LIST?
BEQ LDN.ER ;ERROR
JSR PC,.LOADC ;LOAD A WITH NEXT ELEMENT
MOV A,C
.IFNZ FPPF
CMP #3,F
BGT LDN.E
.ENDC
MOV #SNUM,A
JSR PC,CONVERT
BEQ LDN.ER
LDN.E: SPUSH B ;PUSH THIS ELEMENT
SOB F,LDN.L
BIT D,C ;IS THE LIST FINISHED?
BNE LDN.ER ;NO. ERROR
JMP SRETF ;SKIP RETURN AND RESTORE ALL AC'S!
LDN.ER: ERROR+WTA
.SBTTL EVAL
EVAL: JSR PC,GNT ;GET NEXT TOKEN, RETURNED IN A
.IIF NZ DEBUGR, JSR PC,STRACE ;CHECK FOR SYSTEM TRACE
BIC #DPQF+CPTBF,FLAGS2 ;DON'T PRINT QUOTE, CHANGE % TO BLANK
BIC #7777,A
CMP A,#UFUN ;USER FUNCTION?
BLOS EVFUN
CMP A,#UVAR ;USER VARIABLE?
BEQ EVVAR
CMP A,#SSTR
BHI EVWHA1
EVWHAT: .BUG.
EVWHA1: CMP A,#ATOM
BEQ EVATM
CMP A,#SNUM ;INTEGER?
BEQ EVWHAT
.IIF Z FPPF, CMP A,#LSTR
.IIF NZ FPPF, CMP A,#FNUM
BLOS EVCON
CMP A,#LIST
BNE EVWHAT
EVCON:
EVATM:
PUSHS CT ;SAVE ON S-PDL FOR OUTPUT
BR EVI
EVVAR: BIC #170000,B
BIS #ATOM,B
MOV B,D ;SAVE UOE PTR FOR ERROR
JSR PC,.BINDL
BEQ EVVAR2 ;NO BINDING FOUND
TST B ;NIL?
BNE EVVAR1 ;NO, GOOD
MOV D,B
EVVAR2: ERROR+HNV ;... HAS NO VALUE
EVVAR1: PUSHS B ;SAVE IT FOR OUTPUT
EVI: JSR PC,GNT ;ABOUT TO OUTPUT A VALUE.
;BEFORE WE DO, CHECK TO SEE IF
;NEXT TOKEN IS INFIX WHICH SHOULD GOBBLE IT.
BIC #7777,A ;IS NEXT TOKEN INFIX?
CMP #INFIX,A
BEQ CKPRCD ;YES
EVI1: BIS #RTF,FLAGS ;SET REPEAT TOKEN FLAG
BIC #CRF,FLAGS ;CLEAR CARRIAGE RETURN TOKEN FLAG
CLZ
RTS PC
.GLOBL $BKAR,CO,COF,NOR ;066
CKPRCD: TST CO ;COMPARE PRECEDENCE
BEQ EVI2
MOV CT,A
BIC #170000,A ;CLEAR OUT THE TYPE (FOR INFIX TYPES)
ASL A
MOV SOBLST(A),A ;SYSTEM OBLIST ELEMENT (NEXT OPER.)
BIC #7777,A
MOV COF,B ;CURRENT OPERATOR FLAG
BIC #7777,B
CMP A,B ;IS PRECD OF CO >= PRECD NEXT OPER
BLO EVI1 ;YES, > - GIVE OUTPUT TO CO
BEQ EVI4 ;YES, = - CHECK FOR _
;NO - NEXT TOKEN SHOULD GOBBLE THIS OUTPUT
EVI2:
.IIF NZ DEBUGR, JSR PC,STRACE
EVI3: PUSH CO
SPUSH NOR ;NO. OF OPERANDS STILL NEEDED
MOV CT,CO
MOV CO,A ;GET FLAGS
BIC #170000,A ;CLEAR OUT THE INFIX TYPE
ASL A
MOV SOBLST(A),COF ;SET CURRENT OPERATOR FLAG
MOV #1,NOR
JMP EVW ;CALLS EVAL
EVI4: CMP #INFIX+$BKAR,CT ;PRECD ARE = - IF _ DO RIGHT ONE FIRST
BEQ EVI2 ;IT IS _
BR EVI1
.GLOBL $DO,$LLPAR,EDTIF2,HNM,PREPRI,UELX ;067
EVFUN: BIT #CRF,FLAGS ;CT IS A FUNCTION
BEQ 1$
ERROR+UELX ;UNEXPECTED END OF LINE
1$: CMP #$LPAR,CT ;IS NEXT TOKEN A LEFT PAREN?
BNE EVF1
TST CO ;NEXT OPERATOR?
BEQ EVF11 ;NOTHING THERE
.IFNZ ENG
CMP #$DO,CO ;IS NEXT OPERATOR A RUN COMMAND?
BEQ EVF11
.ENDC
.IFNZ FR
CMP #$EXECUT,CO
BEQ EVF11
.ENDC
CMP #$LLPAR,CO
BNE EVF1
EVF11: MOV #$LLPAR,CT ;INSERT PARENS.FOR PARSE
EVF1: PUSH CO
SPUSH NOR ;NO. OF ARGS NEEDED FOR CO'S EXECUTION
CMP #$LLPAR,CO ;IF CO IS !(, PUSH IFLEV INSTEAD OF NOR
BNE EVF13
MOV IFLEV,(P)
CLR IFLEV
EVF13: MOV CT,CO
CLR EDTIF2
EVF2: CMP A,#UFUN ;IS POPPED OPER. A USER FUNCTION?
BLO MFUN ;NO, MACHINE
MOV #<PREPRI_13.>,COF ;SET PRECD TO PREPRI
JSR PC,GNASN ;GET NO. OF ARGS IN B
BNE 1$ ;FOUND A FUNCTION BINDING
ERROR+HNM ;... HAS NO MEANING
1$: MOVB B,B ;CLEAR ANY LEFT HALF FLAGS
MOV B,NOR
BEQ EVXP ;NO ARGUMENTS, THEN JUST EVALUATE IT
JMP EVL1
EVXP:
.IIF NZ DEBUGR, JSR PC,STRACS ;NO MORE, SPACE AND CHECK FOR SYSTEM TRACE
JSR PC,PEVAL ;SET TO EVALUATE THIS USER PROCEDURE
BEQ XNORT ;PEVAL DOES SEZ IF THERE IS NO OUTPUT
JMP XORT ;DOES CLZ IF THERE IS
.GLOBL INF1,LO,VNAF ;068
MFUN: MOV CO,A ;GET FLAGS FOR THIS MACHINE PROCEDURE
BIC #170000,A ;CLEAR THE INFIX TYPE
ASL A
MOV SOBLST(A),A
MOV A,COF
SWAB A
BIC #ARGMSK,A ;FIND NO. OF ARGS. NECESSARY
MOV A,NOR
BNE EVS ;IS NO. ARGS = 0? (BRANCH IF NO)
BIT #PTLPF,FLAGS ;PREVIOUS TOKEN LP?
BEQ EVXM ;NO, AND NO ARGS NEEDED, EXECUTE
BIT #VNAF,COF ;VARIABLE?
BNE EVL ;YES, GO MAYBE GOBBLE ARG(S)
EVXM: JMP MEVAL ;YES. EXECUTE THIS MACHINE PROCEDURE
XNORT: BIC #EDTIF,FLAGS
TST EDTIF2
BEQ NORT0
BIS #EDTIF,FLAGS
NORT0: MOV #EVDNO,A ;SET RETURN TO INDICATE NO OUTPUT
NORT1:
MOV CO,LO
POP NOR
SPOP B
MOV B,CO
CMP #$LLPAR,B ;IF POPPED OPER IS !(, IFLEV_NOR, NOR_1
BNE NORT3
MOV NOR,IFLEV
MOV #1,NOR
NORT3: CLR COF
TST B
BEQ NORT2 ;NO MORE OPERATORS
BIT #160000,CO ;IS IT A UFUN
BNE NORT2 ;YES
BIC #170000,B ;CLEAR THE INFIX TYPE
ASL B ;NO, MUST BE A PRIMITIVE. GET OFFSET IN BYTES
MOV SOBLST(B),COF
NORT2: JMP (A) ;RETURN DEPENDS ON WHETHER OUTPUT EXISTS
EVDNO: SEZ
RTS PC
EVS: BIT COF,#INFIX ;IS CO INFIX OP
BEQ EVL ;NO
JSR PC,CKUI ;CHECK FOR VALID UNARY INFIX +,-
BNE EVW
ERROR+INF1 ;INFIX IN WRONG PLACE
PROC: MOV @S,B ;THE WORD
BIT #7777,B ;IS IT THE EMPTY WORD
BNE 1$
ERROR+WTA
1$: JSR PC,GUOEB ;PEVAL INVOKED VIA "#"
BEQ PROC1
MOV B,(P) ;OLD RETURN - POPPED LATER
JSR PC,.BINDF ;IS A PROC DEFINED
BEQ PROC3 ;NO
MOV #UFUN,CO ;YES
MOV (P),B
PROC2: CLR TOPS
MOV B,CO
SPOP B ;GET P BACK IN PHASE
JMP EVF2
PROC3: JSR PC,.LOAD ;GET PNAME FOR UOBSCH
PROC1: MOV B,TOPS
MOV #SFUN,A
JSR PC,UOBSCH ;MAKE SURE CO EXISTS
BNE 1$
ERROR+HNM ;HAS NO MEANING
1$: MOV A,CO
BR PROC2
.GLOBL ERP,NIP,NOU,TIP,TMAP ;069
EVL: BIT #PTLPF,FLAGS ;WAS PREVIOUS TOKEN A LEFT PAREN
BEQ EVL1 ;NO
BIT #VNAF,COF ;DOES CO USE VARIABLE NO. OF ARGS.?
BEQ EVL1 ;NO
CLR NOR
BR EVW9
EVL1: JSR PC,GNT
EVW1: BIS #RTF,FLAGS ;SET REPEAT TOKEN FLAG
BIC #CRF,FLAGS
EVW: JSR PC,EVAL ;EVALUATE THIS ARGUMENT
BEQ EVW2 ;NO OUTPUT FROM EVAL
DEC NOR
BEQ EVX ;WHEN NOR = 0, WE'VE ENUF INPUTS
EVW9: JSR PC,GNT
TST NOR ;IF NOR < 0 AND NEXT TOKEN IS ")" THEN THE ")"
BGT EVW1 ;TERMINATES THE ARG SCAN FOR THE CO
CMP #$RPAR,CT
BNE EVW1 ;NO
BIS #RTF,FLAGS
BIC #CRF,FLAGS
NEG NOR
CMP #MAXARG,NOR
BGE MEVAL ;EXECUTE MACHINE PROC.
ERROR+TMAP ;TOO MANY ARGS COMMAND/OPERATION
EVX: BIT #160000,CO ;IS IT A MACHINE PROCEDURE
BEQ 1$
JMP EVXP ;NO
1$: BIT #VNAF,COF ;MACHINE PROC NOW HAS ITS "STD" NO. OF ARGS.
;IF IT CAN TAKE A VARIABLE NO., THEN THE "STD" NO. HAS
;BE PUSHED ON P
BEQ MEVAL ;IT DOESN'T- GO EVALUATE IT
MOV COF,A
SWAB A
BIC #ARGMSK,A
MOV A,NOR
BR MEVAL
EVW2:
CMP #$LLPAR,CO ;EVAL SHOULD OUTPUT WHEN NOT AT TOP LEVEL
BEQ EVW ;EXCEPT WHEN CO IS LLPAR
ERROR+NOU ;WHAT, NO OUTPUT??!!
LLPAR:
LPAR: JSR PC,GNT
CMP #$RPAR,CT
BEQ LPAR1
ERROR+TIP ;TOO MUCH INSIDE PARENS
LPAR1: CLZ
RTS PC
RPAR: BIT #PTLPF,FLAGS
BEQ 1$
ERROR+NIP ;NOTHING INSIDE PARENS
1$: CMP 4(P),#$LLPAR ;IS PENDING COMMAND !(
BNE RPAR1
RPAR2: POP A
MOV (P),IFLEV
CMP (P)+,(P)+ ;POP !( OFF THE STACK
MOV A,(P) ;CRETINOUS NON-LOCAL RETURN
SEZ
RTS PC
RPAR1: ERROR+ERP ;EXTRA RIGHT PAREN
.GLOBL $MINUS,$PLUS,$UMINS,$UPLUS ;070
CKUI: PUSH A
MOV CO,A
BIC #170000,A ;CLEAR THE INFIX TYPE
CMP A,#$PLUS ;+
BNE CKUI1
MOV #$UPLUS,A
CKUI0:
MOV A,CO
ASL A
MOV SOBLST(A),COF
MOV #1,NOR
JMP SRETA
CKUI1: CMP A,#$MINUS ;-
BNE CKUI2
MOV #$UMINS,A
BR CKUI0
CKUI2: POP A
RTS PC
MEVAL:
.IIF NZ DEBUGR, JSR PC,STRACS
MOV CO,A
BIC #170000,A ;CLEAR OUT THE INFIX TYPE
CLR NBKTS
MOV NOR,D ;ONLY NEEDED FOR MULTIPLE ARG THINGS, BUT IT WON'T HURT...
ASL A
.IIF NZ METERS, MOV #MTPRIM,METERP ;IN A PRIMITIVE
JSR PC,@2+SOBLST(A) ;JMP ADDR IS IN 2ND WORD
BNE XORT ;PROCEDUE OUTPUTS
LDFPS #40300
.IIF NZ METERS, MOV #MTEVAL,METERP ;IN THE EVALUATOR
JMP XNORT ;NO OUTPUT
XORT: LDFPS #40300
MOV #EVI,A
.IIF NZ METERS, MOV #MTEVAL,METERP ;IN THE EVALUATOR
JMP NORT1
ORTNA: MOV A,@S
BR SRET
ORTNB: MOV B,@S
BR SRET
ORTNC: MOV C,@S
BR SRET
ORTND: MOV D,@S
BR SRET
ORTNE: MOV E,@S
BR SRET
ORTNF: MOV F,@S
BR SRET
ORTNP: MOV (SP)+,@S
BR SRET
ORTA: PUSHS A
BR SRET
ORTB: PUSHS B
BR SRET
ORTC: PUSHS C
BR SRET
ORTD: PUSHS D
BR SRET
ORTE: PUSHS E
BR SRET
ORTF: PUSHS F
BR SRET
DC ORTP,.
ORTSP: PUSHS (SP)+
RETF: POP F
BR RETE1
RETE: POP E
BR RETD1
RETD: POP D
BR RETC1
RETC: POP C
BR RETB1
RETB: POP B
BR RETA1
RETA: POP A
SEZ
RTS PC
RETF1: SPOP F
RETE1: SPOP E
RETD1: SPOP D
RETC1: SPOP C
RETB1: SPOP B
RETA1: SPOP A
RET: SEZ
RTS PC
SRETF: POP F
BR SRETE1
SRETE: POP E
BR SRETD1
SRETD: POP D
BR SRETC1
SRETC: POP C
BR SRETB1
SRETA: POP A ;POP A THEN DO CLZ RETURN
BR SRET
SRETE1: SPOP E
SRETD1: SPOP D
SRETC1: SPOP C
SRETB1: SPOP B
SRETA1: SPOP A ;POP A THEN DO CLZ RETURN
SRET: CLZ
RTS PC
.SBTTL PROCEDURE EVALUATOR
.GLOBL CPP,SPUSHL,TF7 ;072
.GLOBL $COMT,$LOCAL,$USING,$AVEC ;073
.GLOBL CPBND,CPDLP,PROEND,PROSTK,WDW ;074
.GLOBL PBASE,SPSWPO ;075
PEVAL: JSR PC,CKSTG ;CHECK STORAGE
MOV CO,B ;FIRST CHECK IF THE PROC IS THERE
JSR PC,.BINDF ;GET BINDING
BNE 1$
ERROR+HNM ;PROCEDURE HAS NO MEANING
1$: JSR PC,SAVEVL ;SAVE ALL PROCEDURE INFORMATION
MOV B,C ;SAVE POINTER TO THE ARRAY WE WILL EVAL
MOV CO,B ;GET BACK POINTER TO THE ATOM
MOV B,CPP ;SET UP POINTER TO PROCEDURE NAME
JSR PC,GNASN ;GET THE NUMBER OF ARGMENTS AND FLAGS IN B
MOV B,FLAGS
MOVB B,B
SPUSH B ;PUSH # ARGS
MOV #TRRTS,TF7 ;SET TRACE DISP
BIC #-<TPTF+TPSF>-1,FLAGS ;CLEAR ALL BUT TRACE AND STEP FLAGS
.IF NZ DEBUGR
BNE PEV3
BIT #TRACEF,FLAGS2 ;IS TRACE SET?
.ENDC
BEQ PEV6 ;NO
PEV3:
.IIF NZ DEBUGR, BIS #TPTF,FLAGS ;IT REALLY IS TRACED
MOV #TINPUT,TF7
MOV CO,B ;SET UP B TO POINT TO THE PROCEDURE
INC FUNLEV
JSR PC,TINDNT ;SET SPACING ACCORDING TO FUNCTION LEVEL
DEC FUNLEV
STLANC
ENGINS <JSR PC,PPNAME> ;PRINT PROCEDURE NAME
ENGINS <PRTXT ^\ STARTS. \>
ENDENG
FRINS <JSR PC,PPNAME>
FRINS <PRTXT ^\ COMMENCE. \>
ENDLAN
MOV (P),B ;# OF ARGS
PEV6: SPUSH C ;SAVE FOR BELOW (POINTS TO LASTLINEPTR)
;SAVE FOR BELOW POINTS TO START OF THE ARRAY
MOV B,D ;NO. OF ARGS
ADD #HEADER,C ;POINT TO THE START OF THE ARRAY DATA
SPUSH C ;PUSH POINTER TO THE ARGUMENTS LINE
ASH #2,B ;GET THE NUMBER OF BYTES WE WILL NEED ON THE STACK
NEG B
ADD S,B ;GET THE ULTIMATE VALUE OF S
CMP SPUSHL,B ;ENOUGH ROOM ON S-PDL?
BLOS 2$ ;OK
JSR PC,SPSWPO ;SWAP OUT S-PDL
2$: MOV D,B ;# OF ARGS
ASL B ;MULTIPLY BY TWO FOR OFFSET
MOV S,D
MOV D,E
SUB B,E
MOV E,S
;DROPS INTO NEXT PAGE
;DROPPED IN FROM ABOVE
ASR B
BEQ 3$
1$: MOV (D)+,(E)+ ;GET ARGS ON TOP OF STACK
SOB B,1$
3$: MOV (P),A ;GET SAVED LLP PTR
MOV A,F ;POINTER TO THE END OF THIS LINE
ADD (A),F ;POINT TO THE START OF THE NEXT LINE
ADD #2,F ;BECAUSE THE NUMBER OF VARIABLES IS ON THIS LINE
ADD #4,A ;MAKE A POINT TO THE FIRST VARIABLE
MOV A,(P) ;AND PUT IT BACK
PEV1: CMP A,F ;ARE WE AT END?
BEQ PEV11 ;YUP, GIVE UP
MOV (A)+,B ;GET THE NEXT ARGUMENT
MOV A,(P) ;PTR. TO NEXT NODE
CMP #$COMT,B ;IS CURRENT NODE A COMMENT?
BNE 1$
JSR PC,PEVCOM ;GO PAST COMMENT
BR PEV1 ;GET A REAL THING
1$: CMP #$LOCAL,B ;IS CURRENT NODE LOCAL?
BEQ PEVLOC ;GO GOBBLE LOCALS
STLANC
ENGINS < CMP #$USING,B ;USING?>
ENGINS < BEQ PEVLOC ;SAME>
ENDENG
FRINS < CMP #$AVEC,B ;AVEC?>
FRINS < BEQ PEVLOC ;TREAT AS WITH LOCAL>
ENDLAN
BR PEV10
PEVCOM: CMP A,F ;ARE WE POINTING TO THE NEXT LINE?
BEQ PEVCO1
MOV (A)+,B ;GET THE NEXT TOKEN ON THIS LINE
CMP #$COMT,B
BNE PEVCOM
PEVCO1: RTS PC
PEV10: JSR PC,@TF7
JSR PC,SAVVAR ;SAVE THIS VARIABLE BINDING
MOV (P),A
CMP A,F ;ARE WE AT THE END OF THE TITLE LINE?
BEQ PEV11
BR PEV1 ;GO DO NEXT ARG
TINPUT:
STLANC
ENGINS <PRTXT ^\ITS INPUTS ARE: \>
ENDENG
FRINS <PRTXT ^/LES INPUTS SONT: />
ENDLAN
MOV #CINPUT,TF7
BR PINPUT
CINPUT: PRTXT ^\, \
PINPUT: SAVE <A,B,D>
MOV -2(E),B ;TOP ARGUMENT
MOV B,A
INC NBKTS
JSR PC,PRTAB ;PRINT TOKEN IN A,,B
DEC NBKTS
REST <D,B,A>
TRRTS: RTS PC
PEVLOC: CMP A,F
BEQ PEV11
MOV (A)+,B
MOV A,(P)
CMP #$COMT,B ;COMMENT?
BNE 1$
JSR PC,PEVCOM ;GO PAST IT
BR PEVLOC
1$: JSR PC,LOCVAR
INC 4(P) ;CHANGE NUMBER OF ARGS
MOV (P),A
BR PEVLOC
PEV11: SPOP C ;USED TITLE LINE POINTER
PEV2:
SPOP C ;PTR TO LLP THAT WAS PUSHED WAY ABOVE
;POINTER TO THE START OF THE ARRAY
MOV (C),CPBND ;SET UP POINTER TO THE BINDING NODE
INC PROSTK(C) ;INCREMENT THE REFERENCE COUNT FOR THIS PROCEDURE
MOV C,F ;COPY IT
ADD #HEADER,F ;POINT TO THE PROCEDURE START
ADD (F)+,F ;POINT TO THE FIRST LINE
SUB C,F ;MAKE IT RELATIVE TO THE START OF THE PROCEDURE ARRAY
MOV F,CTP ;F POINTS TO THE FIRST EXECUTABLE LINE OF THE PROCEDURE
CMP F,PROEND(C) ;IS IT = TO THE END OF THE PROC?
BNE 1$ ;NO
CLR CTP ;OH WELL, MAKE IT STOP AT EVAL LEVEL
1$:
CMP #TRRTS,TF7
BEQ PEV2B
PEV2A: PRCR
PEV2B: JSR PC,SAVPPS ;SAVE PDL PTRS
BIS #1,CPDLP ;INDICATES PROC PUSH AS OPPOSED TO A LOCAL PUSH
CLR CPLN
CLR CO
CLR IFLEV
INC FUNLEV
PMLOOP: JSR PC,GETLIN
JSR PC,EVLINE
BEQ PMWDW
BR PMLOOP ;LOOP BACK
PMWDW: ERROR+WDW ;WHAT SHOULD I DOO WITH (S)
GETLIN: MOV CTP,A ;POINTER TO END OF PREVIOUS LINE
BEQ ENDPRO ;THE END OF THIS PROCEDURE
MOV A,C
MOV @CPBND,F ;GET POINTER TO START OF ARRAY
ADD F,C ;MAKE IT AN ABSOLUTE POINTER
MOV 2(C),CPLN ;GET THE LINE NUMBER
CMP A,PROEND(F) ;ARE WE AT THE END?
BEQ ENDPRO
BHI GSTBUG
MOV CPBND,PBASE ;MAKE PBASE POINT TO THE PROCEDURE IN QUESTION
BIT #TPSF,FLAGS ;PROCEDURES STEPPED?
BEQ 2$ ;NOPE
JSR PC,LINSTP ;PRINT THE LINE, AND WAIT FOR CR.
2$:
.IF NZ DEBUGR
BIT #TRACEF,FLAGS2 ;ARE WE TRACED
BEQ GSTDON ;NO, WE ARE DONE
SPUSH A ;SAVE THE POINTER TO THE LINE
CPRTXT ^\ #\
MOV CPP,B
JSR PC,PPNAME ;PRINT PNAME
PRTXT ^\ LINE \
MOV CPLN,A
JSR PC,PRDN
PRCR
SPOP F ;GET BACK POINTER
JSR PC,PRLN
PRCR
.ENDC
GSTDON: RTS PC
GSTBUG: .BUG. ;PROCEDURE SCREWED
ENDPRO: TST (P)+ ;POP OFF THE RETURN ADDRESS
JMP PSTOP ;STOP THIS PROCEDURE
.GLOBL .SPACE,CSPDLP,IP,PRBAO,SPRBAO ;076
SAVVAR: ;SAVE IN (D) VARIABLE BINDING OF UOE PT'ED TO BY B
;GIVE IT NEW VALUE WHICH IS AT (E)
;USES A,C. TOPS MUST BE 0
;BOTH D AND E ARE -()ED
MOV B,-(D) ;SAVE UOE PTR
MOV #VBIND,A ;THIS WILL CHECK SPDL THINGS--
;NOP IT IF IT SEEMS TO CAUSE TROUBLE. RWW
JSR PC,.BINDL ;NOW GET VARIB. BINDING
BEQ SAVV2 ;NOT THERE
SAVV1: MOV -(E),A ;GET NEW VALUE PTR
MOV B,-(D) ;SAVE OLD VALUE PO[NTER
MOV A,B
JSR PC,.LDP1
BIC #100000,A ;MAKE SURE BINDING NODE SAYS "VBIND"
JSR PC,.STORE ;STORE NEW BINDING AWAY
RTS PC
SAVV3: TST -(E)
CLR -(D) ;THERE IS NO OLD VALUE POINTER
RTS PC
SAVV2: TST -2(E)
BEQ SAVV3 ;IF NEW VALUE = 0, DON'T BOTHER TO CREATE CELL
MOV #VBIND,A
CLR B
JSR PC,GRBAD1
BR SAVV1
SAVPPS: POP F ;SAVE P AND S PDL PTRS
SPUSH CSPDLP
MOV IS,A ;COMPUTE RELATIVE S PDL PTR
SUB S,A ;CURRENT TOP OF S-PDL
ADD SPRBAO,A ;# OF PDL BLOCKS SWAPPED OUT
MOV A,CSPDLP
SPUSH CPDLP
MOV IP,A ;COMPUTE RELATIVE P PDL PTR
SUB P,A
ADD PRBAO,A
MOV A,CPDLP
JMP (F)
TINDNT: PUSH A ;TRACE INDENT
MOV FUNLEV,A
TIND2: DEC A
BGT TIND1
JMP RETA
TIND1: SPACE
BR TIND2
LOCAL: JSR PC,GUOEB ;GET UOE PTR FROM S
LOC9: MOV IS,F ;MOVE STUFF FROM S TO P PDLS
SUB S,F
ADD SPRBAO,F
MOV CSPDLP,D
BIC #1,D
SUB D,F
ASR F
MOV F,A
BLE LOC2
LOC1: POPS D
PUSH D
DEC A
BGT LOC1
LOC2: JSR PC,LOCVAR ;STORE AWAY POINTER AND OLD VALUE
MOV F,A ;NOW RETURN STUFF FROM P TO S
BLE LOC4
LOC3: POP D
PUSHS D
DEC A
BGT LOC3
LOC4: MOV IP,A ;NOW MOVE STUFF FROM P TO S
SUB P,A
ADD PRBAO,A
MOV CPDLP,D
BIC #1,D
SUB D,A
ASR A
MOV A,F
BLE LOC6
LOC5: POP D
PUSHS D
DEC A
BGT LOC5
LOC6: PUSH #1 ;PUSH GOODIES ON P
SPUSH CSPDLP
SPUSH CPDLP
BIC #1,CPDLP ;INDICATE LOCAL PUSH
BIC #1,CSPDLP
ADD #4,CSPDLP
ADD #6,CPDLP
MOV F,A
BLE LOC8
LOC7: POPS D ;NOW RETURN STUFF TO P
PUSH D
DEC A
BGT LOC7
LOC8: SEZ
RTS PC
LOCVAR: MOV S,D ;GET THE ULTIMATE VALUE OF S
SUB #14,D ;ROOM FOR THE STUFF TO PUSH & PARANOIA
CMP SPUSHL,D ;ENOUGH ROOM ON S-PDL?
BLOS 2$ ;OK
JSR PC,SPSWPO ;SWAP OUT S-PDL
2$: MOV S,D ;NOW STORE AWAY PTR & OLD VALUE
SPUSHS #0
MOV S,E
SPUSHS #0
JMP SAVVAR
.SBTTL PROC EVAL - "OUTPUT" "STOP"
.GLOBL DOFRET,OIP,PSTOPR ;078
.GLOBL ILINEL,PROTYP,TF3 ;079
OIPTST: TST FUNLEV ;IN A PROCEDURE
BGT 1$ ;YES
2$: ERROR+OIP ;ONLY IN A PROCDURE
1$: BIT #BRKF,FLAGS ;ARE WE IN A BREAK LOOP
BNE 2$
RTS PC
OUTPUT: JSR PC,OIPTST
OUTPU2: MOV #SRET,PSTOPR ;SEZ WHEN WE RETURN
BR PSTOP1 ;AND STOP THIS PROCEDURE
STOP:
PSTOP: JSR PC,OIPTST
MOV #RET,PSTOPR ;CLZ WHEN WE RETURN
CLR TOPS1 ;JUST RANDOM
PSTOP1: MOV #POPFRM,DOFRET ;JUST POP THE DO FRAME
BIT #DORF,FLAGS ;IS IT A DO FRAME?
BNE POPFRM ;IGNORE THE TRACE
BIT #TPTF!TPSF,FLAGS ;PROCEDURE TRACED?
BEQ POPFRM ;NO, JUST IGNORE
PSTOP3: JSR PC,TINDNT ;INDENT THE RIGHT AMOUNT
;HERE PRINT MESSAGE
MOV CPP,B ;GET POINTER TO PROCEDURE NAME
JSR PC,PPNAME ;AND PRINT IT
CMP #SRET,PSTOPR ;OUTPUTTING?
BNE PSTOP5 ;NO, PRINT JUST "STOPS"
MOV @S,B ;GET THE OUTPUT
PRTXT ^\ OUTPUTS \ ;PRINT "OUTPUTS"
INC NBKTS ;PRINT BRACKETS AROUND THE OUTPUT
JSR PC,PNODAB ;AND PRINT THE OUTPUT
DEC NBKTS ;AND RESET FLAG
BR PSTOP8 ;PRINT CR AND CONTINUE
PSTOP5:
STLANC
ENGINS <PRTXT ^\ STOPS. \>
ENDENG
FRINS <PRTXT ^\ STOPPE. \>
ENDLAN
PSTOP8: PRCR ;PRINT CR.
;FALLS THROUGH, OR BRANCES INTO NEXT PAGE
;IS BRANCHED INTO, AND FALLEN INTO FROM PREVIOUS PAGE
;HERE IS AN ENTRY POINT FOR RESTORING THE VARIABLES FOR A FRAME
;IF OUTPUTTING, EXPECTS PSTOPR TO BE SRET, AND OUTPUT ON STACK
;POPVAR IGNORES OUPUT, AND JUST POPS THE FRAME
POPFRM: CMP #SRET,PSTOPR ;OUTPUTTING?
BNE POPVAR ;NO
POPS TOPS1 ;PUT OUTPUT INTO TOPS1
POPVAR: JSR PC,RESPPS ;RESTORE THE PDLS
SPOP D ;GET THE NUMBER OF ARGUMENTS
BEQ PSTOP6 ;NONE, DONT BOTHER REBINDING
PSTOP4: POPS TOPS ;GET THE OLD VARIABLE BINDING
SPOPS B ;GETH THE UOE POINTER
MOV #VBIND,A ;MAKE A VARIABLE BINDING
TST TOPS ;IS IT GOING TO BE BOUND?
BEQ PVUNBN ;THEN UNBIND IT
JSR PC,.BIND ;GET A POINTER TO THE BINDING
PSTOP7: SOB D,PSTOP4 ;DO IT FOR ALL THE VARIABLES
BR PSTOP6 ;DONE WITH THIS FRAME
PVUNBN: JSR PC,.UNBND ;UNBIND IT
SOB D,PSTOP4 ;AND RETURN TO NEXT VARIABLE
PSTOP6: TST TF3 ;WAS IT A LOCAL PUSH
BEQ POPVAR ;YES, CONTINUE POPPING UNTIL WE GET TO SOMETHING
;WITH SOME MEAT ON IT
BIT #DORF,FLAGS ;IS IT A DO FRAME?
BNE STOPDO ;STOP A DO FRAME
BIT #ERRF,FLAGS ;ERROR FRAME?
BNE 1$ ;YES, JUST RETURN
DEC FUNLEV ;ONE LESS FUNCTION LEVEL
MOV @CPBND,E ;GET POINTER TO THE ARRAY WE ARE LEAVING IN E
DEC PROSTK(E) ;DECREMENT THE REFERENCE COUNT
BLT PRCNTB ;ERROR IF LESS THAN 0
BGT 1$ ;STILL REFENCED ON THE STACK
TST PROTYP(E) ;HAS IT BEEN DELETED?
BPL 1$ ;NO
MOV E,B ;COPY POINTER TO THE ARRAY
JSR PC,DELPRO ;AND DELETE IT
1$: JSR PC,RESEVL ;GET BACK EVAL
MOV B,FLAGS ;AND RESTORE THE FLAGS
JSR PC,POUTPU ;AND RESTACK OUTPUT IF NEEDED
JMP @PSTOPR ;SAY WE HAVE STOPPED
STOPDO: SPOPS A ;GET BACK POINTER TO THE ILINE
MOV A,ILINEL ;GC PROTECT IT
JSR PC,WRTLIN ;AND WRITE IT AWAY
JSR PC,RESEVL ;RETORE EVAL
MOV B,FLAGS ;RESTORE THEM
JSR PC,POUTPU ;OUTPUT IF WE SHOULD
JMP @DOFRET ;AND NOW WE HAVE CLEANED UP
POUTPU: CMP #SRET,PSTOPR ;OUTPUTTING?
BNE POUTP1 ;NO
PUSHS TOPS1 ;PUSH OUTPUT ON THE STACK
CLR TOPS1 ;AND FLUSH THE GC-PROTECTION
POUTP1: RTS PC
PRCNTB: .BUG. ;REFENCE COUNT WAS NEGATIVE
RESPPS: SPOP E ;RESTORE P AND S PDLS
MOV CPDLP,A
CLR TF3
CLR TF7
BIT #1,A
BEQ 1$
MOV PC,TF3
1$: BIC #1,A ;ALWAYS EVEN
JSR PC,PPTA ;POP P TO (A)
POP CPDLP ;RESTORE OLD CPDLP
MOV CSPDLP,A
BIT #1,A
BEQ 2$
MOV PC,TF7
2$: BIC #1,A
JSR PC,PSTA ;POP S TO (A)
SPOP CSPDLP ;RESTORE OLD CSPDLP
JMP (E)
.GLOBL CURLIN,PROATM ;081
.GLOBL NCF,TOPS2 ;082
.GLOBL CLCNT,ERPROC ;083
RUN:
DO: JSR PC,CKSTG ;MAKE SURE THERE IS ROOM
MOV @S,A ;THE LIST TO RUN
MOV A,B ;COPY IT
BIC #7777,A ;GET TYPE
CMP #LIST,A ;IS IT A LIST
BEQ DO1 ;YES
ERROR+WTAB ;NO, THIS IS A LOSER THEN
DO1: JSR PC,BLSTI ;BUILD A LIST OF THE CHARACTERS OF THIS LIST
PUSH PCHR ;SAVE THE PRINTING ROUTINE
MOV #BLST,PCHR ;WHEN YOU PRINT A CHARACTER PUT IT INTO THIS LIST
CLR NBKTS ;NO BRACKETS NOW
JSR PC,PNODAB ;PRINT OUT THIS LIST
SPOP PCHR ;RESTORE THE PRINT ROUTINE
JSR PC,BLSTF ;NOW, FINISH THIS LIST
BEQ DO4 ;WAS THE EMPTYP LIST
MOV TOPS,@S ;PUT THE LIST WE BUILT ONTO THE STACK
JSR PC,SAVEVL ;SAVE THE EVAL STATE
PUSH #0 ;NUMBER OF ARGUMENTS
JSR PC,SAVPPS ;SAVE THE PDL POINTERS,
MOV S,A ;POINT TO THE TOP OF THE STACK
MOV (A),-(A) ;COPY THE TOKEN LIST TO CREATE A CELL FOR THE OLD COMMAND
;BUFFER
MOV ILINEL,2(A) ;STACK POINTER TO THE ILINE
MOV A,S ;FIX STACK POINTER
;HERE, WHEN A RESPPS IS DONE, THE TOP OF THE STACK IS
;THE OLD ILINEL
BIC #ERRF!CATCHF,FLAGS ;THIS CANNOT BE A BOTTOM ERROR OR CATCH FRAME
BIS #DORF,FLAGS ;THIS IS A DO FRAME!!!!!!
BIS #1,CPDLP ;I AM A PROCEDURE, PUSH ME....
MOV CPP,CURLIN+PROATM ;FAKE CPP POINTER FOR RESEVL
JSR PC,MREAD1 ;TURN CHARACTER STRING INTO THE BUFFER
BEQ 1$ ;NO TOKENS
JSR PC,EVLINE ;EVALUATE THE LINE
BNE 1$ ;DIDN'T OUTPUT
MOV #SRET,PSTOPR ;OUTPUT!!!!
BR 2$ ;RETURN....
1$: MOV #RET,PSTOPR ;JUST RETURN, NO OUTPUT
2$: MOV PSTOPR,DOFRET ;DITTOR
JMP POPFRM ;POP THE DO FRAME AND RETURN
DO4: POPS A ;POP OFF CHARACTER STRING
SEZ ;NO OUTPUT
RTS PC
.SBTTL CATCH AND THROW UP
CATCH: TST D
BNE 1$ ;BETTER BE AT LEAST ONE
2$: ERROR+WNA
1$: MOV S,A ;GET POINTER TO S PDL
DEC D ;IS THERE ONE ARGUMENT?
BEQ 3$ ;YES, JUST PUSH NULL TAG
DEC D ;BETTER JUST BE ONE MORE ARGUMENT
BNE 2$ ;NOPE, GIVE ERROR IN USER PROGRAM....
MOV 2(A),B ;GET THE LIST TO RUN
MOV (A)+,(A) ;PUT TAG BACK DOWN ON FRAME
MOV B,-(A) ;PUSH BACK THE LIST TO RUN
BR CATCH1 ;GO RUN THE LIST
3$: MOV (A),-(A) ;COPY LIST TO PUT ON TOP OF STACK
CLR 2(A) ;CLEAR THE TAG FIELD
MOV A,S ;PUT BACK POINTER
;HERE ON THE S PDL IS THE TAG AND THEN THE LIST TO RUN
CATCH1: BIS #CATCHF,FLAGS ;SET THE CATCH BIT IN FLAGS
JSR PC,DO ;ACT LIKE A RUN FRAME
BEQ 1$ ;DIDN'T OUTPUT, IGNORE IT
MOV S,A ;SHOVE DOWN ON THE S PDL
MOV (A)+,(A) ;SMASH OUTPUT ON TOP OF TAG
BIC #CATCHF,FLAGS ;CLEAR CATCH FLAG
MOV A,S ;PUT BACK POINTER
RTS PC
1$: ADD #2,S ;POP OFF THE TAG
BIC #CATCHF,FLAGS ;DONT CATCH ANYTHING ELSE
SEZ
RTS PC
;THIS IS CALLED TO THROW UP THE STACK
THROW: CLR TOPS1 ;NOT RETURNING A VALUE
TST D
BEQ THRNO ;NO ARGUMENTS, MATCH NEXT THROW
CMP #2,D ;RETURNING A VALUE?
BLO THRUP ;TWO MANY ARGS
BNE THROW1 ;NOPE, JUST SKIP THIS
SPOPS TOPS1 ;POP OFF THE OUTPUT
THROW1: SPOPS C ;GET THE TAG
BIT #7777,C ;IS IT EMPTY?
BNE THROW2 ;NO, IT IS A LEGAL TAG
CLR C ;EMPTY TAG IS SAME AS NO TAG
THROW2: MOV C,TOPS2 ;PROTECT THE TAG
MOV #THRLOP,DOFRET ;ON RETURN OF POP FRAME, COME BACK TO LOOP
MOV #THRLOP,PSTOPR
;HERE TOPS1 IS THE OUTPUT OR 0 IF NO OUTPUT
;C AND TOPS2 ARE THE POINTERS TO THE TAG ON THE THROW
THRLOP: BIT #CATCHF,FLAGS ;IS THIS A CATCH FRAME?
BNE 1$ ;YES, CHECK IT OUT
2$: TST FUNLEV ;ARE WE IN A PROCEDURE?
BNE 3$ ;YES
BIT #DORF,FLAGS ;ARE WE IN A DO OR READ FRAME?
BEQ 4$ ;NO, MUST BE AT TOP LEVEL, SO ERROR OUT
3$: JMP POPFRM ;OTHER WISE POP A FRAME
4$: ERROR+NCF ;NO CATCH FOUND
;HERE THE TOP THING ON THE PDL IS THE TAG FOR THIS CATCH OR 0
1$: MOV TOPS2,C ;GET THE TAG ON THE THROW
BEQ THRDON ;NO TAG ON THROW, MATCHES ANY CATCH
MOV @S,B ;GET THE TAG ON THE CATCH
BEQ 2$ ;A TAGGED THROW DOESN'T MATCH A UNTAGGED CATCH
JSR PC,EQUAL1 ;COMPARE THE TAGS
BEQ 2$ ;DIFFERENT TAGS, CONTINUE SEARCH
;HERE THE CURRENT FRAME IS CORRECT, JUST CHECK FOR OUTPUT
THRDON: CLR TOPS2 ;NO LONGER NEED TAG
TST TOPS1 ;OUTPUTTING?
BEQ 1$ ;NO, DONT OUTPUT
SPUSHS TOPS1 ;PUSH IS BACK ON S
CLR TOPS1 ;CLEAR THE GC PROTECT
CLZ
1$: RTS PC ;OUTPUT
THRNO: CLR C ;NO TAG FOR THIS THROW
BR THROW2
THRUP: ERROR+WNA ;BAD ARGUMENTS TO THROW
SAVEVL: POP F ;SAVE THE WORLD
SPUSH CPBND
SPUSH CLCNT
SPUSH CPLN
SPUSH CTP
SPUSH FLAGS
SPUSH CO
SPUSH CT
SPUSH IFLEV
SPUSH ERPROC
JMP (F)
RESEVL: POP F
SPOP ERPROC ;PROC, RESTORE REST OF WORLD
SPOP IFLEV
SPOP CT
SPOP CO
SPOP B
SPOP CTP
SPOP CPLN
SPOP CLCNT
SPOP CPBND
SAVE A
MOV @CPBND,A
MOV PROATM(A),CPP
REST A
JMP (F)
.SBTTL "TO" ETC.
.GLOBL EDITA,ELW,ETYO,LDE,PARRYS,TOPRNM ;084
.GLOBL $LINE,$TITLE,CTIT,NEC,PARRYF,PBEX,PNH,PRMTCH,TEMP ;085
.GLOBL PAE,REDFLG,UBL ;086
GTLN: JSR PC,GTUOEB ;GET LINE # FROM NEXT TOKEN INTO B
BEQ GTLN2 ;CANT FIND IT
MOV #SNUM,A
JSR PC,CONVER ;MAKE NEXT TOKEN INTO AN SNUM
GTLN2: RTS PC
GTLP: PUSH CPBND ;SAVE POINTER TO EXECUTING PROCEDURE
MOV PARRYS,CPBND ;GET POINTER TO EDITING PROCEDURE
JSR PC,GTLINE ;GET POINTER TO LINE IN B
BEQ GTLP2 ;LOSES
POP CPBND ;GET BACK CPBND
MOV B,F ;RETURN POINTER
MOV PARRYS,PBASE ;SET UP BASE POINTER
SUB @PBASE,F ;FIX THIS POINTER
RTS PC
GTLP2: SPOP CPBND ;ERROR OUT
ERROR+LDE ;LINE NOT HERE
EDTITL: TST TOPRNM
BNE 1$
ERROR+OIP ;ONLY IN PROCEDURE
1$: JSR PC,EDITA ;SET UP FOR EDIT BUFFER INSERT
PUSH PCHR
MOV #ETYO,PCHR
MOV TOPRNM,B
JSR PC,SHTITL ;"PRINT" TITLE LINE INTO EDIT BUFFER
BNE 2$
.BUG.
2$: MOV PC,EDTIF2
BR EDLIN1
EDLINE: TST TOPRNM
BNE 1$
ERROR+OIP
1$: JSR PC,GTLN ;GET LINE # IN B
BNE 2$
ERROR+ELW ;EDIT LINE WHAT
2$: JSR PC,GTLP ;GET PTR TO THAT LINE
JSR PC,EDITA
PUSH PCHR
MOV #ETYO,PCHR
JSR PC,PRLN ;"PRINT" THE LINE TO THE EDIT BUFFER
EDLIN1: POP PCHR
SEZ
RTS PC
.GLOBL SIZE
;HERE WE LOOK FOR THE TOKEN $LINE OR $TITLE, IF NOT THAT WE ERROR OUT,
EDITSY:
.IFNZ ENG
CMP #$TITLE,B ;IS IT EDIT TITLE?
BEQ EDTITL ;YES
CMP #$LINE,B ;IS IT EDIT LINE?
BEQ EDLINE ;YES
.ENDC
.IFNZ FR
CMP #$TITRE,B ;AS ABOVE BUT IN FRENCH
BEQ EDTITL
CMP #$LIGNE,B
BEQ EDLINE
.ENDC
ERROR+NEC ;CAN'T BE EDITED
EDIT: BIC #EDTIF,FLAGS ;SO THAT WE ARE NO LONGER EDITING TITLES
JSR PC,GTUOEB ;GET POINTER TO THE USER OBLIST ELEMENT
BNE EDITSY ;WASN'T A UOE
TST TOPRNM ;EDITING ANYTHING CURRENTLY?
BEQ EDIT2 ;NO
EDIT1: ERROR+CTIT ;CANT TO IN TO
EDIT2: MOV B,TEMP ;STORE THE POINTER TO THE ATOM
CLR TOPS ;MAKE SURE WE DONT CREATE A NEW BINDING
JSR PC,.BINDF ;SEE IF IT HAS A PROCEDURE BINDING
BNE EDIT4 ;IT DOES
ERROR+PNH ;PROCEDURE NOT HERE
EDIT4: TST PROSTK(B) ;IS THE PROCEDURE EXECUTING BACK UP THE STACK?
BEQ 1$ ;NO
ERROR+PBEX ;PROCEDURE BEING EXECUTED (HUNG)
1$: MOV (B),PARRYS ;SET UP FOR THE EDIT,
;POINTER TO BINDING NODE FOR THIS ARRAY
MOV SIZE(B),PARRYF ;POINT TO THE END OF THE ARRAY
SUB PROEND(B),PARRYF ;SUBTRACT POINTER TO THE END OF USED STORAGE AND DONE
EDIT5: MOV TEMP,TOPRNM ;STORE THE PROCEDURE NAME AWAY
MOV #'>,PRMTCH ;CHANGE PROMPTING CHARACTER TO >
CLR TOPS2
CLRTP1: CLR TOPS1
CLRTOP: CLR TOPS ;CLEAR ALL TEMPORARYS
RTS PC
TO: JSR PC,GTUOEB ;GET THE UOE POINTER
BEQ 1$ ;FINE
CMP #INFIX,A ;IS IT A SYSTEM FUNCTION
BHIS 2$ ;YES
ERROR+WTAB ;CANT EDIT LISTS AND SUCH
2$: ERROR+UBL ;USED BY LOGO
1$: BIC #170000,B ;GET ONLY THE POINTER PART
BIS #UFUN,B ;MAKE SURE IT IS A UFUN
MOV B,TOPS2 ;STORE IT AWAY
MOV B,TEMP ;FOR ERROR MESSAGE
CLR TOPS ;SO THAT WE DONT CAUSE A BINDING YET.
JSR PC,.BINDF ;GET THE PROCEDURE BINDING FOR PROC IN B
BEQ TO2 ;DOESN'T EXIST
BIT #EDTIF,FLAGS ;ARE WE EDITING THE TITLE?
BEQ 3$ ;NO, CHECK TO SEE IF READ FROM FILE
CMP TEMP,TOPRNM ;ARE WE USING THE SAME NAME?
BEQ TITLED ;YES, FINE
ERROR+PAE ;BARF, THIS PROCEDURE ALREADY EXISTS
3$: TST REDFLG ;IS IT INPUT FROM THE TTY?
BEQ 4$ ;YES, FAIL IMMEDIATELY
ADD CLCNT,CTP
ADD CLCNT,CTP ;MOVE POINTER TO END OF LINE
CLR CLCNT ;SAY END OF LINE
BIS #SPDF,FLAGS ;SAY WE ARE SKIPPING THIS PROCEDURE
BR EDIT5 ;CLEAN UP
4$: ERROR+PAE ;PROC (TEMP) ALREADY EXISTS
TO2: TST TOPRNM ;ARE WE IN EDIT MODE CURRENTLY?
BNE TITLED ;YES, WELL BETTER BE EDITING THE TITLE
JSR PC,TITLDF ;SET UP PROCEDURE ARRAY... RETURN POINTER IN B
MOV #FBIND,A ;SET UP THE FUNCTION BINDING TO POINT TO THE NEWLY
;CREATED ARRAY, C WAS SET UP BY .BINDF, AND IS USED
;BY GRBAD1
TOBND: MOV TEMP,PROATM(B) ;PUT THE POINTER TO THE PNAME OF THIS ATOM INTO
;THE FIRST DIMENSION
MOV B,PARRYS ;MAKE PARRYS, POINT TO THE ARRAY START
MOV #PARRYS,(B) ;AND THE ARRAY POINT TO PARRYS (FAKE A BINDING NODE)
JSR PC,GRBAD1 ;NEW FUNCTION BINDING FOR THIS ATOM
ASL C
ASL C ;MAKE POINTER TO THE NODE
ADD #NODESP+2,C ;MAKE POINTER TO THE BINDING NODE
MOV C,@PARRYS ;CLOBBER THE ARRAY TO POINT TO THE BINDING NODE
MOV PARRYS,(C) ;CLOBBER BINDING NODE TO POINT TO THE ARRAY
;IN LSI VERSION ARRAY MAY HAVE MOVED IN GRBAD1
MOV C,PARRYS ;SET UP POINTER TO THE START OF THE ARRAY
MOV F,S ;RESET S POPPING OFF ARGUMENTS TO TO: HERE, THE PROCEDURE
;IS ENTIRELY CONSISTENT AND GC MARKED
BR EDIT5 ;SET UP PROMPT AND CLEAN IT UP
;CALLED WITH C POINTING TO THE END OF THE BINDING LIST FOR THE NEW NAME
;OLD NAME IS IN TOPRNM
;TEMP POINTS TO THE NEW NAME
TITLED: BIT #EDTIF,FLAGS ;EDITING THE TITLE?
BEQ EDIT1 ;NO, CANT TO IN TO
SPUSH C ;SAVE POINTER TO THE BINDING NODE
JSR PC,CHKTIT ;CHECK THE TITLE, D <= THE NUMBER OF ELEMENTS ON LINE
;ARGUMENTS PUSHED ON THE S PDL
;F GETS THE REAL NUMBER OF ARGS
MOV @PARRYS,E ;THE START OF THE OLD ARRAY
ADD #HEADER,E ;POINT TO THE START OF THE PROCEDURE STRUCTURE
MOV F,2(E) ;PUT IN NEW NUMBER OF ARGUMENTS
SPUSH D ;SAVE ARGUMENTS
ASL D ;NUMBER OF BYTES NEEDED FOR THE ARUMENTS
ADD #2,D ;BECAUSE WE NEED A WORD SAYING HOW MANY ARGS,
SPUSH D ;SAVE THE LENGTH OF THE NEW LINE
SUB (E),D ;THE LENGTH DIFFERENCE IN BYTES
JSR PC,MAKSPA ;BYTE DIFFERENCE IN D, POINTER TO PLACE IN E
;WILL EITHER CONTRACT OR EXPAND ARRAY AS NEEDED
SPOP (E)+ ;POP THE LINE LENGTH
MOV F,(E)+ ;AND THE NUMBER OF ARGUMENTS
SPOP D ;GET THE NUMBER OF ARGUMENTS
BEQ 1$ ;NONE, FORGET IT
MOV D,A ;COPY IT
ASL A ;INTO BYTES
ADD S,A ;MAKE IT A RELATIVE POINTER TO THE S PDL
SPUSH A ;WHERE THE PDL POINTER WILL BE WHEN WE ARE DONE
2$: MOV -(A),(E)+ ;PUT IN THE ARGUMENTS
SOB D,2$ ;TAKE ALL THE ARGUMENTS OFF THE S PDL
SPOP S ;NOW RESTORE THE S-PDL
1$: CMP TEMP,TOPRNM ;ARE THE NAMES THE SAME?
BNE NEWTIT ;NO, WE MUST UNBIND THE OLD NAME, AND CREATE NEW BINDING
SPOP C ;JUST FLUSH THE NEW BINDING NODE POINTER
JMP EDIT5 ;AND CLEAN UP
NEWTIT: MOV #FBIND,A ;REMOVE THE FUNCTION BINDING
MOV TOPRNM,B ;UNBIND THE OLD ONE
SPUSH @PARRYS ;PUSH THE PROCEDURE ADDRESS
JSR PC,.UNBND ;DO THE DEED
SPOP B ;GET IT INTO B
SPOP C ;GET BACK POINTER TO WHERE THE NEW PROC BINDING GOES
MOV S,F ;PUT POINTER TO POP S TO IN F
BR TOBND ;BIND IT LIKE YOU WERE DOING A TO
GTUOEB: JSR PC,GNT ;GET UOE PTR FROM NEXT TOKEN IN B
BIT #CRF,FLAGS
BEQ 1$
ERROR+UEL ;UNEXPECTED END OF LINE
1$: BIC #7777,A ;SKIP UNLESS NEXT TOKEN NOT UOE. USES A
CMP #UFUN,A
BEQ GTU1
CMP #ATOM,A
BEQ GTU1
CMP #LSTR,A
BNE GTU2
MOV B,TOPS
JSR PC,.INTRN
GTU1: CLR TOPS
GTU2: RTS PC
CONTIN:
MOV #POPVAR,DOFRET ;POP OFF DO FRAMES
MOV #CNTIN1,PSTOPR ;AND CHECK FOR ERROR FRAMES
CNTIN1: TST FUNLEV ;IN A PROCEDURE?
BEQ CNTIN3 ;NOT ANY MORE
BIT #ERRF!BRKF,FLAGS ;IS THIS THE BOTTOM LEVEL ERROR PROCEDURE?
BNE CNTIN2 ;YES
JMP POPVAR ;POP A FRAME...
CNTIN2: MOV #CNTIN4,PSTOPR ;POP OFF THE ERROR FRAME
JMP POPVAR ;POP IT
CNTIN4: MOV #CNTIN5,DOFRET ;POP OFF ALL THE DO FRAMES
CNTIN5: BIT #DORF,FLAGS ;DO FRAME?
BEQ CNTIN6 ;NOPE
JMP POPVAR ;POP IT OFF
CNTIN6: JMP PMLOOP ;RESTART A MLOOP (I.E. THE NEXT LINE
;IF WE WANT TO ALLOW PROCEDES TO WIN TOTALLY, WE SHOULD
;MAKE SURE ALL ERROR+BRK GET CONTINUED CORRECTLY, AND
;HERE WE SHOULD CALL PSTOP. THAT IS ALL ERROR+BRKS MUST
;BE FOLLOWED BY A BRANCH TO A GOOD PLACE TO CONTINUE FROM
;JUST STOP THE ERROR FRAME, AND RETURN
CNTIN3: JMP TOPLEVEL ;JUST RETURN TO TOPLEVEL
RETURN: JSR PC,G1NARG ;GET THE LINE TO RETURN TO
MOV B,TMPBLK ;SAVE IT FOR A BIT
MOV #RETUR1,PSTOPR ;AND CHECK FOR ERROR FRAMES
MOV #POPVAR,DOFRET ;POP OFF DO FRAMES
RETUR1: TST FUNLEV ;IN A PROCEDURE?
BEQ CNTIN3 ;NOPE
BIT #ERRF!BRKF,FLAGS ;IS THIS THE BOTTOM LEVEL ERROR PROCEDURES
BNE RETUR2 ;YES, DO A JUMP TYPE THING
RETUR3: JMP POPVAR ;POP A FRAME
RETUR2: MOV #GOUNTL,PSTOPR ;AND POP THE ERROR PUSH, AND GET BACK TO PROCEDURE
BR RETUR3
GO: JSR PC,OIPTST ;MAKE SURE WE ARE IN A PROCEDURE
JSR PC,G1NARG ;GET THE LINE TO JUMP TO
MOV B,TMPBLK ;SAY IT
GOUNTL: MOV #GOUNTL,DOFRET ;COME HERE AGAIN IF IT IS A DO
BIT #DORF,FLAGS ;IS IT A DO FRAME?
BNE RETUR3 ;POP A DO FRAME
MOV CPDLP,A ;POP THE P STACK BACK TO THE START FOR THIS FRAME
BIC #1,A ;USED AS A FLAG
JSR PC,PPTA ;POP THE P TO (A)
MOV CSPDLP,A ;AND DO THE SAME TO S
BIC #1,A
JSR PC,PSTA ;POP THE S PDL TO (A)
MOV TMPBLK,B
JSR PC,GTLINE ;GET A POINTER TO THE LINE
BNE 1$
ERROR+LDE ;LINE B DOESN'T EXIST
1$: SUB @CPBND,B ;MAKE B RELATIVE
MOV B,CTP
MOV TMPBLK,CPLN
JMP PMLOOP ;JUST GO TO THE NEXT LINE
.GLOBL NSL,PROCAR,PRSIZE ;091
.GLOBL WIT ;092
.GLOBL LASTPR ;093
TITLDF: PUSH C
JSR PC,CHKTIT ;PUSH ARGUMENTS ON THE S-PDL, AND RETURN NUMBER IN D
MOV D,B ;NUMBER OF ARGUMENTS
ASL B ;NUMBER OF BYTES
ADD #4+HEADER+PRSIZE,B ;NUMBER OF BYTES IN ARRAY OVERHEAD, AND THE SIZE INIT
JSR PC,..ALLO ;ALLOCATE AN ARRAY OF THAT SIZE
BNE 1$ ;OKAY
ERROR+NSL ;NO STORAGE LEFT
1$: MOV A,C ;COPY IT
MOV A,PARRYS ;STORE THE START OF THE ARRAY (CLOBBERED LATER TO POINT TO THE
;BINDING NODE FOR THIS PROCDURE
MOV B,PARRYF ;NUMBER OF BYTES TO BE USED+HEADER LENGTH
CMP (C)+,(C)+ ;SKIP BACK POINTER TO ATOM, AND LENGTH
MOV #PROCAR,(C)+ ;PROCEDURE ARRAY
CLR (C)+ ;ONE DIMENSIONAL
CLR (C)+
CLR (C)+ ;THIS WILL BE THE TOTAL LENGTH OF THE PROCEDURE EVENTUALLY
ADD #10,C ;SKIP INFO FOR WINDOWS
MOV D,B ;NUMBER OF ARGS
INC B ;ONE FOR THE NUMBER
ASL B ;GET LENGTH IN BYTES
MOV B,(C)+
MOV F,(C)+ ;NUMBER OF ARGS
MOV S,F ;IN CASE WE BRANCH AROUND
TST D ;ANY ARGUMENTS?
BEQ TITDON ;NO, WE ARE FINISHED
MOV D,B ;NUMBER OF ARGUMENTS WE PUSHED ON S
ASL B ;INTO A BYTE NUMBER
ADD F,B ;GET NEW S POINTER
SPUSH B ;SAVE IT FOR LATER
ARGLOP: MOV -(B),(C)+ ;PUT IN POINTER TO THE ARUMENT
SOB D,ARGLOP ;FOR ALL OF THEM
SPOP F ;AND NOW SET F TO WHAT S SHOULD BE PUT BACK TO BY TOBND
TITDON: MOV PARRYS,B ;GET POINTER TO START OF THE ARRAY
SUB B,C ;GET NUMBER OF BYTES USED
MOV C,PROEND(B) ;PUT IN POINTER TO THE FIRST FREE LOCATION INTO 1 DIMENSION
SUB C,PARRYF ;AND SET UP NUMBER OF BYTES LEFT
SPOP C
RTS PC ;DONE
CHKTIT: CLR D ;COUNTER FOR NUMBER OF TOKENS
CLR F ;COUNTER FOR NUMBER OF ARGS
SAVE #2 ;FLAG
CMP SPUSHL,S ;ENOUGH ROOM ON THE S PDL?
BLOS CHKTI0 ;YES
JSR PC,SPSWPO ;SWAP OUT SOME OF S
CHKTI0: DEC CLCNT ;ANY MORE TOKENS ON THE LINE?
BMI CHKTI1 ;DONE
MOV CTP,A ;GET POINTER
ADD @CPBND,A ;RELOCATE
MOV (A),B ;GET TOKEN
MOV B,A ;COPY IT
ADD #2,CTP ;MOVE POINTER ONWARDS
BIC #7777,A
INC D
TST (P) ;ARE WE IN A COMMENT?
BLT 1$ ;NO ARGS WITHIN COMMENT
CMP #$LOCAL,B ;IS IT LOCAL?
BEQ 2$
STLANC
ENGINS < CMP #$USING,B ;USING?>
ENGINS < BEQ 2$ ;SAME>
ENDENG
FRINS < CMP #$AVEC,B ;AVEC?>
FRINS < BEQ 2$ ;TREAT AS WITH LOCAL>
ENDLAN
BR 3$ ;NOPE
2$: MOV #1,(P) ;CHANGE FLAG
BR CHKTI3 ;GO STORE IT AWAY
3$: CMP #UVAR,A
BEQ CHKTI3
CMP #UFUN,A ;BBN MODE OF VARIABLE DECLARE
BEQ CHKTI3
1$: CMP #$COMT,B ;IS IT ! ?
BNE CHKTER ;NOPE
NEG (P) ;FLIP COMMENT FLAG
CHKTI3: BIT #100001,(P) ;IS FLAG ODD OR NEGATIVE?
BNE 1$ ;COMMENT OR LOCAL ARG
INC F ;A REGULAR ARG
1$: CMP D,#MAXARG ;TO MANY ARGS?
BGE CHKTI0 ;YES, DONT PUSH ANY MORE
PUSHS B ;PUSH ON THE TOKEN
BR CHKTI0 ;AND GO FOR THE NEXT
CHKTER: TST (P) ;ARE WE IN A COMMENT?
BLT CHKTI3 ;YUP, ANYTHING GOES
TST A ;IS THE TYPE SFUN?
BNE 1$ ;NOPE, LOSER
CMP #$DOTS,B ;SPECIAL CASE
BEQ 1$
SAVE TEMP ;UGH
JSR PC,LSFUN ;CONVERT SFUN TO LSTR
MOV #UVAR,A ;TYPE FOR .INTRN
JSR PC,.INTRN ;FAKE UP AN ATOM
BIC #170000,B
BIS #UFUN,B ;FAKE UFUN
CLR TOPS
REST TEMP ;BLETCH
BR CHKTI3
1$: MOV B,CT
ERROR+WIT ;WRONG TYPE OF INPUT TO "TO"
CHKTI1: CMP #MAXARG,D
BGE CHKTI2
ERROR+TMAP ;TOO MANY ARGS (PROCEDURE)
CHKTI2: TST (P)+ ;FLUSH COMMENT FLAG
RTS PC
END: MOV TOPRNM,B
BNE 1$
ERROR+OIP ;ONLY IN PROCEDURE DEFINITION
1$: MOV B,LASTPR ;SAVE FOR "PO"
TST REDFLG
BEQ END4
BIT #SPDF,FLAGS
BEQ END3
END4: BIT #SPDF,FLAGS ;DOUBLE DEFINED?
BNE END5 ;YUP, GIVE MESSAGE
TST FUNLEV ;DON'T PRINT "FOO DEFINED" IF NOT AT TOP LEVEL
BEQ END5
BIT #BRKF,FLAGS
BEQ END3
END5: JSR PC,PPNAME
BIT #SPDF,FLAGS
BNE END1
STLANC
ENGINS <PRTXTC ^/ DEFINED/>
ENDENG
FRINS <PRTXTC ^/ EST DEFINI/>
ENDLAN
END3: MOV @PARRYS,B ;GET ADDRESS OF PROCEDURE JUST DEFINED
MOV SIZE(B),A ;GET TOTAL SIZE
SUB PROEND(B),A ;GET UNUSED SPACE
CMP #HEADER,A ;IS THERE ENOUGHROOM FOR A HEADER?
BHI END7 ;NOPE, LEAVE IT ALONE
SUB A,SIZE(B) ;GET RID OF EXCESS SPACE
ADD SIZE(B),B ;POINTER TO SPACE TO BE FREED
MOV A,SIZE(B) ;FAKE AN ARRAY HEADER
JSR PC,.RELES ;AND RELEASE THE SPACE
END7: CLR TOPRNM
BIC #SPDF,FLAGS
MOV #'?,PRMTCH
SEZ
RTS PC
END1:
STLANC
ENGINS <PRTXTC ^/ skipped/>
ENDENG
FRINS <PRTXTC ^/ a ete passe/>
ENDLAN
BR END7
.SBTTL UTILITY - COUNT LIST ELEMENTS
CLE: ;COUNT LIST ELEMENTS
;IN - LIST PTR IN C
;OUT - # OF ELEMENTS IN B
PUSH A
SPUSH C
CLR B
MOV C,A
CLE1: BIT #7777,A
BEQ CLE2
MOV A,C
JSR PC,.LDP1
INC B
BR CLE1
CLE2: POP C
SPOP A
RTS PC
.SBTTL UTILITY - ADD A LINE
;TAKES POINTER TO ATOM IN B, AND OUTPUTS NUMBER OF ARGUMENTS IN B
;SET Z IF PROCEDURE IS NOT FOUND
GNASN: PUSH A
SPUSH B
SPUSH C
JSR PC,.BNDFS ;GET THE BINDING INTO B
BNE 1$ ;FOUND IT
JMP RETC
1$: ADD #HEADER,B ;POINT TO THE START OF THE PROCEDURE
MOV 2(B),2(P) ;PUT THE # OF ARGS INTO B ON THE STACK
JMP SRETC
GTLINE: ;LINE NUMBER IN B, OUTPUT POINTER TO LINE IN B
;PROCEDURE POINTED TO BY CPADR
;SET Z IF NOT FOUND
SPUSH A
SPUSH B
SPUSH C
SPUSH D
MOV @CPBND,C ;GET POINTER TO THE START OF THE ARRAY
MOV PROEND(C),D ;POINTER TO THE END OF THE ARRAY
ADD C,D ;MAKE IT AN ABSOLUTE POINTER
ADD #HEADER,C ;POINT TO THE START OF THE DATA
GTLIN1: ADD (C)+,C ;GET TO THE NEXT LINE
CMP C,D ;ARE WE AT THE END OF THE PROC?
BEQ GTLINF ;YES, WE HAVE FAILED TO FIND IT
BHI GTLINB ;OOPS WE SHOULDN'T OVERSHOOT
CMP B,2(C) ;ARE THE LINE NUMBERS THE SAME?
BGT GTLIN1 ;THE ONE WE ARE LOOKING FOR IS FURTHER ON
BLT GTLINF ;WE PASSED WHERE IT SHOULD BE, FAIL
MOV C,4(P) ;CLOBBER B ON THE STACK
JMP SRETD ;AND RETURN
GTLINF: JMP RETD
GTLINB: .BUG.
;CALLED WITH THE LINE NUMBER IN B
;IF NEGATIVE DELETE THAT LINE
;IF NOT INSERT LINE POINTED TO BY CTP, CLCNT IS EXPECTED TO BE CORRECT
ADLN: JSR F,CACSAV ;CAREFULLY SAVE THE AC'S
CLR A ;A FLAG
MOV B,F ;THE LINE NUMBER
BPL FINLIN ;FIND THE LINE AND INSERT IT
NEG F ;GET THE REAL LINE NUMBER
INC A ;FLAG FOR JUST DELETING LIEN
FINLIN: MOV @PARRYS,E ;POINTER TO THE START OF THE ARRAY
MOV PROEND(E),B ;THE POINTER TO THE FIRST FREE LOCATION
ADD E,B ;MAKE IT ABSOLUTE
ADD #HEADER,E ;POINT TO THE BEGINNING OF THE PROCEDURE
LINLOP: ADD (E)+,E ;POINT TO THE NEXT LINE
CMP E,B ;ARE WE AT THE END?
BEQ ADDEND ;YES
BHI ADDBUG ;CANT BE...
CMP F,2(E) ;ARE THE LINE NUMBERS THE SAME?
BGT LINLOP ;NO, IT MUST BE FURTHER ON
BEQ LINEQ ;INSERT THE LINE (E)
ADDEND: TST A ;DELETING THE LINE?
BNE LINDN2 ;CANT FIND THE LINE TO DELETE IT
JSR PC,LINLEN ;GET THE LENGTH OF THE LINE IN BYTES INTO D+4 FOR
;LENGTH AND LINE NUMBER
JSR PC,MAKSPA ;AND MAKE SPACE FOR IT
SUB #2,D ;SUBTRACT FOR THE LENGTH WORD
MOV D,(E)+ ;SET IN THE LINE LENGTH
MOV F,(E)+ ;THE LINE NUMBER
LINDON: JSR PC,INSLIN ;AND THE LIST
LINDN2: JSR F,CACRES
RTS PC
ADDBUG: .BUG.
;HERE WE DELETE THE LINE (E), AND INSERT LINE POINTED TO BY A
LINEQ: TST A ;ANY LIST TO INSERT?
BNE NOLIST ;NO JUST DELETE THE LINE
JSR PC,LINLEN ;GET THE LENGTH OF THE LINE IN D
SUB #2,D ;BECAUSE WE DONT COUNT THE LENGTH WORD NOW
SPUSH D ;SAVE IT FOR LATER
SUB (E),D ;GET THE DIFFERENCE BETWEEN THE TWO LINES
JSR PC,MAKSPA ;MAKE SPACE FOR THE LINE
SPOP (E)+ ;SET IN THE LENGTH
MOV F,(E)+ ;AND LINE NUMBER
BR LINDON ;DONE WITH THE LINE
NOLIST: MOV (E),D ;GET THE NUMBER OF DELTA BYTES
ADD #2,D ;BECAUSE WE ARE DELETING THE LENGTH ALSO
NEG D ;IT IS GETTING SMALLER
JSR PC,MAKSPA ;FIX THIS LINE
BR LINDN2 ;JUST RETURN
;RETURN NUMBER OF BYTES NEEDED FOR THE LINE IN D
LINLEN: MOV CLCNT,D ;GET NUMBER OF TOKENS LEFT
ASL D ;FROM WORDS TO BYTES
ADD #4,D ;FOR THE LINE NUMBER, AND LENGTH
RTS PC
;PUT LINE POINTED TO BY CTP INTO ARRAY POINTED TO AT E
INSLIN: TST CLCNT ;ARE THERE ANY MORE TOKENS LEFT?
BEQ INSDON ;NO
MOV @CPBND,B ;GET POINTER TO THE START OF THE LINE'S PROCEDURE
ADD CTP,B ;POINT TO THE LINE TO INSERT
MOV CLCNT,C ;NUMBER OF TOKENS TO INSERT
ADD C,CTP ;MUST FIX CTP
ADD C,CTP ;TO POINT TO END OF LINE
1$: MOV (B)+,(E)+ ;COPY THE TOKENS
SOB C,1$
INSDON: RTS PC
.GLOBL PROINC ;098
;MAKE SPACE FOR D BYTES AT (E). IF D IS NEGATIVE COLLAPSE SPACE.
;IF D IS POSITIVE, EXPAND THE ARRAY IF NEEDED, COPY THE ARRAY, LEAVING D
;BYTES AT THE ORIGINAL E
;PARRYS AND PARRYF ARE UPDATED IF NEEDED, AND 1 DIMENSION OF ARRAY ALSO
MAKSPA: TST D
BEQ SPADON ;NOTHING NEED BE DONE
BPL SPAEXP ;NEED TO EXPAND MAYBE
JSR F,CACSAV ;SAVE THE AC'S
SUB D,PARRYF ;MAKE THE FREE SPACE A LITTLE LARGER
MOV @PARRYS,A ;POINT TO THE START OF THE ARRAY
MOV PROEND(A),B ;GET POINTER TO THE FIRST UNUSED LOCATION
ADD A,B ;MAKE IT AN ABSOLUTE POINTER
ADD D,PROEND(A) ;DECREASE THE POINTER BY THE AMOUNT SHIFTED DOWN
MOV E,F ;COPY POINTER TO WHERE WE ARE MUNGING
SUB D,F ;MAKE IT POINT AHEAD D BYTES
SUB F,B ;GET NUMBER OF BYTES TO TRANSFER
BLE SPADN1 ;NUMBER OF BYTES DELETING IS MORE THAN FROM (E) TO END OF PROC.
ASR B ;GET NUMBER OF WORDS
MAKSP1: MOV (F)+,(E)+ ;TRANSFER THEM
SOB B,MAKSP1 ;FOR ALL THE BYTES
SPADN1: JSR F,CACRES ;GET BACK THE AC'S
SPADON: RTS PC ;AND RETURN
SPAEXP: JSR F,CACSAV ;SAVE THE AC'S
CMP D,PARRYF ;IS THERE ENOUGH FREE SPACE TO WIN ON THIS PROCEDURE?
BLE NUFSPA ;YES
;HERE WE HAVE TO TRY TO EXPAND THE ARRAY
MOV @PARRYS,A ;POINT TO THE BEGINNING OF THE CURRENT ARRAY
MOV SIZE(A),B ;GET THE CURRENT SIZE
SUB A,E ;MAKE POINTER TO WHERE TO INSERT RELATIVE TO OLD ARRAY START
ADD D,B ;GET NEW NUMBER OF BYTES NEEDED
ADD #PROINC,B ;AND ADD A LITTLE EXTRA FOR EFFICIENCY
JSR PC,..ALLOC ;GET A NEW ARRAY OF THAT SIZE, POINTER IN A
BEQ NOSPA ;NO SPACE
MOV @PARRYS,C ;GET ADDRESS OF OLD ARRAY
ADD C,E ;MAKE IT POINT TO THE POSSIBLE NEW PLACE
;HERE THE OLD ARRAY IS CONSISTENT AGAIN, NEW ARRAY POINTED TO BY A, OLD BY C
;PARRYS IS NOT CONSISTANT YET
ADD #PROINC,PARRYF ;ADD SOME SPACE TO THE FREE COUNT
MOV C,B ;COPY POINTER TO OLD ARRAY
MOV A,F ;COPY POINTER TO THE NEW ARRAY
ADD #PROTYP,F ;POINT TO THE START OF THE INFO IN THE NEW ARRAY
ADD #PROTYP,B ;POINT TO THE START OF THE INFO IN THE OLD ARRAY
SUB B,E ;GET THE BYTE COUNT FROM BOTTOM TO INSERTED AREA
BEQ TOPPRT ;NO BYTES BELOW AREA, MOVE REST OF AREA UP
ASR E ;INTO A WORD COUNT
1$: MOV (B)+,(F)+ ;COPY UP THE BOTTOM OF THE ARRAY
SOB E,1$ ;ALL THE WORDS IN THE BOTTOM
TOPPRT: MOV F,10(P) ;CLOBBER THE STORED E ON THE STACK
SUB A,10(P) ;MAKE IT RELATIVE
ADD D,F ;SKIP D BYTES
MOV PROEND(C),E ;GET THE POINTER TO THE END OF THE ARRAY
ADD C,E ;MAKE IT UNRELATIVE AGAIN
SUB B,E ;SUBTRACT WHERE WE HAVE GOTTEN
BEQ SPADN2 ;DONE IF NO BYTES ABOVE THIS POINT
ASR E ;INTO A WORD COUNT
2$: MOV (B)+,(F)+ ;MOVE IT UP IN THE NEW ARRAY
SOB E,2$ ;FOR ALL THE WORDS IN THIS ARRAY
SPADN2: MOV A,@PARRYS ;UPDATE THE POINTER TO THE ARRAY
MOV (C),(A) ;SET UP BACK POINTER TO BINDING NODE
SUB A,F ;MAKE POINTER TO END RELATIVE AGAIN
MOV F,PROEND(A) ;SET IN POINTER TO THE END OF THE PROC
MOV C,B ;COPY POINTER TO THE OLD ARRAY
JSR PC,.RELES ;AND RELEASE IT
ADD @PARRYS,10(P) ;MAKE THE POINTER ON THE STACK ABSOLUTE AGAIN
BR SPADN1 ;AND FINISH UP
NOSPA: ERROR+NAS ;NOT ENOUGH ARRAY SPACE (MAYBE CHANGED TO NO STORAGE LEFT)
NUFSPA: SUB D,PARRYF ;DECREASE THE AMOUNT OF FREE SPACE
BMI MAKBUG ;BUG IF IT GOES NEGATIVE
MOV @PARRYS,A ;POINT TO THE START OF THE ARRAY
MOV PROEND(A),B ;GET THE POINTER TO THE END OF THE ARRAY
ADD A,B ;MAKE IT NON RELATIVE
ADD D,PROEND(A) ;MAKE THE POINTER A LITTLE HIGHER
MOV B,A ;COPY IT
SUB E,A ;GET THE NUMBER OF BYTES TO COPY
BEQ SPADN1 ;NOTHING TO COPY
ASR A ;GET THE NUMBER OF WORDS TO COPY
MOV B,C ;POINTER TO THE TOP OF THE ARRAY
ADD D,C ;POINT TO THE RIGHT SPOT ABOVE THE ARRAY
MAKSP2: MOV -(B),-(C) ;COPY IT UP
SOB A,MAKSP2
BR SPADN1 ;ALL DONE
MAKBUG: .BUG.
.SBTTL UTILITY - LOAD AND STORE
.LOADA: MOV A,B ;(A) -> A,,B
BR .LOAD
.LOADC: MOV C,B ;NODE ADDR IN C
;NODE RETURNED IN A,B
.LOADB:
.LOAD: BIC #170000,B ;NODE ADDR IN B
ASL B ;NODE RETURNED IN A,B
ASL B
ADD #NODESP,B
MOV (B)+,A
MOV (B),B
RTS PC
.STORE: SPUSH C ;NODE ADDR IN C
BIC #170000,C
ASL C ;NODE IN A,B IS STORED AT C
ASL C
ADD #NODESP,C
MOV A,(C)+
MOV B,(C)
SPOP C
RTS PC
.STP2: ;SAME AS .STP1 EXCEPT STORE IN 2ND WORD OF NODE
SEC ;THEN RESULT OF ROL'S WILL BE TWO GREATER THAN .STP1
BR .STP9
.STP1: CLC ;STORE (A) IN FIRST WORD OF NODE AT C
.STP9: SPUSH C ;NODE ADDR IN C
BIC #170000,C
ROL C
ROL C
ADD #NODESP,C
MOV A,(C)
SPOP C
RTS PC
.LDP2: SEC ;NODE ADDR IN C (TYPE FIELD =0)
BR .LDP9 ;LOAD 2ND WORD OF NODE INTO A
.LDP1: CLC ;SAME AS .LDP2 EXCEPT 1ST WORD
.LDP9: MOV C,A
BIC #170000,A
ROL A
ROL A
ADD #NODESP,A
MOV (A),A
RTS PC
.LDP2I: MOV C,A ;SAME AS .LDP2 EXCEPT C WILL
BIC #170000,A ;CONTAIN ADDR OF NEXT NODE
ASL A
ASL A
ADD #NODESP,A
MOV (A)+,C
MOV (A),A
RTS PC
.SBTTL UTILITY - BINDING
;INPUT: A=TYPE B=UOE POINTER
; TOPS=0 OR TYPE+VALUE POINTER
;OUTPUT: A - UCHANGED
; B - EITHER UNCHANGED OR VALUE POINTER
; C - POINTS TO BINDING NODE, EITHER
; RELEVANT ONE OR LAST IN BINDING LIST
; IF TOPS = 0, SKIPS IF BINDING FOUND
; IF TOPS NOT = 0, TOPS WILL BE INSERTED
; AS THE NEW VALUE POINTER (A NEW BINDING
; NODE WILL BE ADDED IF NECESSARY) NEVER SKIPS.
.BINDL: TST TOPS
BEQ .BIND
PUSHS TOPS
CLR TOPS
JSR PC,.BIND
BEQ .BNDL2
POPS TOPS
CLZ
RTS PC
.BNDL2L: POPS TOPS
SEZ
RTS PC
.BIND: PUSH D
SPUSH B
SPUSH A
MOV B,A
BINDF1: MOV A,C
JSR PC,.LOADC
MOV A,D
BIC #7777,D
CMP (P),D
BEQ BINDF4 ;FOUND IT
BIT #7777,A
BNE BINDF1
TST TOPS ;DIDNT FIND IT
BEQ BINDF2 ;SHOULD ONE BE CREATED?
SPOP A
MOV TOPS,B
JSR PC,GRBAD1
BINDF5: POP D ;OLD B
BINDF3: SPOP D
SEZ
RTS PC
BINDF2: POP A ;NO, DONT CREATE NODE
SPOP B
BR BINDF3
BINDF4: TST TOPS ;FOUND, CHANGE VALUE POINTER?
BEQ BINDF6
MOV TOPS,A ;YES + DONT SKIP
JSR PC,.STP2
POP A
BR BINDF5
BINDF6: POP A ;NO, LEAVE VALUE POINTER, BUT SKIP
SPOP D ;OLD B
SPOP D
CLZ
RTS PC
.UNBND: PUSH A ;ERASE TYPE (A) FROM UOE (B)
SPUSH B ;SKIP UNLESS NOT FOUND
SPUSH C
SPUSH D
MOV B,C
.UNB1: MOV C,D
MOV B,C
BIT #7777,C
BNE 1$
JMP RETD
1$: JSR PC,.LOADC
MOV A,B
BIC #7777,A
CMP 6(P),A
BNE .UNB1
MOV D,C
JSR PC,.LDP1
BIC #7777,A
BIC #170000,B
BIS B,A
JSR PC,.STP1
JMP SRETD
.BINDF:
.BNDFS: MOV #FBIND,A ;SAME AS .BINDF EXCEPT DONT SWAPIN
JSR PC,.BINDL
BIF1: RTS PC
.SBTTL .INTRN!!
.GLOBL TF5 ;103
.OBSCH: ;SAME AS .INTRN EXCEPT WONT INSERT IF ENTRY ISNT FOUND
;(ALSO SEE UOBSCH ON NEXT PAGE)
CLR TF5
BR OBSCH9
.INTRN: ;(ALSO SEE UINTRN ON NEXT PAGE)
;INPUT: TYPE IN A, LSTR IN "TOPS"
;OUTPUT: IF TYPE IS UFUN OR SFUN,
; SEARCH SYSTEM OBLIST FIRST.
; IF FOUND THERE, RETURN THAT PTR IN B,
; MAKING TYPE OF A TO "SFUN".
; IF NOT FOUND THERE, AND IF A=UFUN, OR IF TYPE
; IS > "UFUN", DO THE LOOKUP IN THE USER OBLIST.
; RETURN WITH THE UOE PTR IN B.
; DONT SKIP IF A NEW ONE HAD TO BE ADDED,
; OR IF IN SEARCHING FOR AN SFUN
; ONE WAS NOT FOUND.
;******* NOTE ********
;A NEW UOE IS "TOTALLY USELESS" AND SO MUST BE PROTECTED FROM G.C.
MOV PC,TF5
OBSCH9: PUSH A
SPUSH B
SPUSH C
MOV TOPS,C
CMP #UFUN,A ;IS TYPE SFUN OR UFUN
BLO INT2 ;NO
JSR PC,SSOL ;YES, SEARCH SYSTEM OBLIST
BEQ INT1 ;NOT THERE
MOV #SFUN,4(P) ;SET TYPE TO "SFUN"
BR INT5
INT1: CMP #SFUN,A ;IS A = TYPE SFUN
BEQ INT0 ;YES, DONE, DONT SKIP
INT2: JSR PC,HSSL ;NO, HASH TO AND SEARCH SUBLIST
BEQ INT3 ;NOT FOUND
INT5: MOV B,2(P)
JMP SRETC ;FOUND ATOM
INT3: TST TF5 ;NOT THERE, SHOULD IT BE ADDED
BEQ INT0 ;NO, RETURN AND DONT SKIP
SPUSH B ;SAVE WORD POINTER TO UHCT ENTRY TO SPLICE THIS INTO
MOV #LIST,A
MOV #ATOM,B
JSR PC,GRBAD ;CONS UP NEW LAST NODE
; (STRANGE TYPE LEST GARBAGE COLLECT)
BIS #LIST,C
PUSHS C ;SAVE POINTER TO IT, ALSO FOR G.C.
MOV #ATOM,A
MOV TOPS,B
JSR PC,GRBAD2 ;CONS UP ATOM NODE; NEW BUCKET NODE PTS TO IT
MOV C,4(P) ;SO WILL B ON RETURN
POPS C ;THE POINTER TO THE NEW BUCKET NODE WITH LIST TYPE
BIC #LIST,C ;GET BACK POINTER TO NEW BUCKET NODE
MOV @(P),A ;GET THE ENTRY THAT WAS IN THE UHCT IN THIS SLOT
BIS #BUKTEL,A ;MAKE THE NEW POINTER POINT TO THE REST OF THE ENTRIES
JSR PC,.STP1
BIS #BUKTEL,C ;MAKE THE POINTER A BUCKET POINTER
MOV C,@(P)+ ;PUT THE NEW POINTER INTO THE UHCT
INT0: JMP RETC
;"UNPURE" .INTRN AND .OBSCH
;BY "UNPURE" IT IS MEANT THAT THE INPUT STRING MAY INCLUDE
;NULL CHARACTERS
;SPECIFICATIONS ARE OTHERWISE IDENTICAL TO .INTRN AND .OBSCH
;ROUTINE TO PURIFY STRING
UINOB: PUSH A
PUSH B
PUSH C
MOV TOPS,B
JSR PC,CPYSTR ;OUTPUT POINTER IN B TO STRING WITH NO NULLS
BIS #LSTR,B
MOV B,TOPS
POP C
POP B
POP A
RTS PC
UINTRN: SPUSH #.INTRN
BR UINOB
UOBSCH: SPUSH #.OBSCH
BR UINOB
.SBTTL SEARCH SYSTEM OBLIST
.GLOBL ABRFLG,SOBP2,SOOMX ;105
.GLOBL HCC,UHCT ;106
SSOL: ;SEARCH SYSTEM OBLIST
;INPUT: C POINTS TO STRING
;OUTPUT: SKIP = FOUND AND SOE PTR IN B
; NO SKIP = NOT FOUND AND NO CHANGE
;NULL MUST BE USED AS FILLER CHAR BUT NOT BE IMBEDDED
PUSH A
SPUSH B
SPUSH C ; -> STRING (DESIRED PNAME)
SPUSH D ; -> CURRENT PNAME
SPUSH E ; 2^N
SPUSH F ; -> SYSTEM OBLIST ELEMENT
MOV SOBP2,E ;GET 2^N
MOV #SOBLST,F ;GET START OF OBLIST
SSOL1: ASR E ;HALVE 2^N
BIT #177776,E ;NOT FOUND IF 2^N = 1
BEQ SSOL5
ADD E,F ;ADD 2^N TO OBLIST PTR
CMP F,SOOMX ;OVERSHOT END OF LIST THEN UNDO ADD
BHIS SSOL2
MOV (F),D
ADD #4+SOBLST,D ;FIND START OF THIS PNAME
MOV C,A ;AND DESIRED PNAME
SSOL4: JSR PC,.LOADA ;GET TWO CHARS OF DESIRED
CMPB B,(D)+
BHI SSOL1 ;PNAME < DESIRED: ADD 2^(N-1)
BLO SSOL2 ;PNAME > DESIRED: UNADD 2^N AND ADD 2^(N-1)
SWAB B
CMPB B,(D)+
BHI SSOL1 ;PNAME < DESIRED
BLO SSOL2 ;PNAME > DESIRED
BIT #7777,A ;MORE PNAME TO COMPARE?
BNE SSOL4 ;YES
TSTB B ;MATCHING NULLS FOUND?
BEQ SSOL3 ;FOUND
TSTB (D) ;AT END OF STRING, IS IT END OF SYS PNAME
BNE SSOL2 ;NO: TRY ANOTHER (COUNT AS OVERSHOOT)
SSOL3: MOV (F),F ;POINTER TO OBLIST ELEMENT
.IFNZ ENG&FR
BIT LANG,SOBLST(F)
BEQ SSOL5
.ENDC
BIT #ABRFLG,SOBLST(F) ;IS IT AN ABBRVIATION?
BEQ 1$
MOV 2+SOBLST(F),F ;YES, "EXPAND" IT
1$: ASR F
MOV F,10(P) ;YES, SAVE F AS OUTPUT
JMP SRETF
SSOL5: JMP RETF
SSOL2: SUB E,F ;UNADD 2^N
BR SSOL1
.SBTTL HASH AND SEARCH USER SUB-OBLIST
HSSL: ;HASH, THEN SEARCH SUB-LIST
;INPUT: C POINTS TO LSTR
;OUTPUT: IF NOT FOUND, B IS A WORD POINTER
; TO THE UHCT ENTRY TO SPLICE IT INTO
; IF FOUND, B POINTS TO ATOM CELL, AND RETURN SKIPS.
PUSH A
SPUSH B ;PTR TO THIS PNAME
SPUSH C ;PTR TO DESIRED PNAME
SPUSH D ;NEXT OLE
SPUSH E ;THIS OLE
MOV C,A ;PTR TO STRING
CLR D ;SUM OF WORDS FOR HASHING
HSSLA: JSR PC,.LOADA ;GET A TWO-LETTER FRAGMENT
ADD B,D ;ADD IN
BIT #7777,A ;MORE FRAGMENTS?
BNE HSSLA ;YES
MOV D,B ;CREATE SUM OF ALL CHARS
SWAB B
ADD D,B ;IN LOWER BYTE (UPPER WON'T HURT)
CLR A
DIV #HCC,A
ASL B
ADD #UHCT,B
MOV B,-(P) ;SAVE THE POINTER TO THE UHCT ENTRY TO SPLICE IT INTO
MOV (B),A ;A POINTS TO FIRST OLE NOW
HSSL1: BIT #7777,A ;END OF BUCKET?
BNE HSSLB
MOV (P)+,6(P) ;YES: NOT-FOUND RETURN:
JMP RETE ;OUTPUT POINTER TO THE UHCT TO SPLICE IT INTO
HSSLB: MOV A,E ;SAVE PTR TO THIS OLE
JSR PC,.LOADA ;GET THIS OLE
MOV A,D ;SAVE PTR TO NEXT ONE
JSR PC,.LOADB ;GET FIRST NODE OF ATOM STRUCTURE
JSR PC,CSEQ ;CSEQ COMPARES STRINGS AT (B) AND (C)
BEQ HSSL2 ;NOT EQUAL: TRY NEXT OLE
MOV E,A ;EQUAL:
JSR PC,.LOADA ;OUTPUT ATOM POINTER
TST (P)+ ;POP OFF THE UHCT POINTER
MOV B,6(P)
JMP SRETE ;SKIP RETURN
HSSL2: MOV D,A ;NOT FOUND, CHECK NEXT BUCKET ELEMENT
BIC #LIST,E ;MAKE E A WORD PTR TO FIRST WORD OF PREV. NODE
ASL E ;IN CASE IT'S THE LAST ONE.
ASL E
ADD #NODESP,E
BR HSSL1
CSEQ: PUSH A ;COMPARE TWO STRINGS - POINTERS IN B & C
PUSH B ;SKIP IF EQUAL
PUSH C ;"NULL" (8-BIT ON) CHARACTERS
PUSH D ; DON'T MATCH CORRESPONDING 8-BIT OFF CHARS
MOV B,D ;SAVE STR 1 PTR
CSEQ1: BIT #7777,D ;CHECK IF EITHER STRING DONE
BEQ CSEQ3 ;FIRST IS: IS SECOND?
BIT #7777,C
BEQ CSEQ2 ;SECOND BUT NOT FIRST: NOT EQUAL
MOV D,A
JSR PC,.LOADA ;GET NEXT NODE OF STR 1: (A) TO A,,B
MOV A,D ;SAVE POINTER IN D
JSR PC,.LDP2I ;GET NEXT NODE OF STR 2: (C) TO C,,A
CMP A,B
BEQ CSEQ1 ;WELL, THESE WORDS MATCH
CSEQ2: JMP RETD ;STRINGS NOT EQUAL
CSEQ3: BIT #7777,C ;SEE IF BOTH STRINGS ARE DONE
BNE CSEQ2 ;NOPE, NOT EQUAL
JMP SRETD ;STRINGS EQUAL
.SBTTL UTILITY - GRAB NODE ROUTINES
.GLOBL FREE,NNIFSL ;108
GRBAD2: SEC ;GRAB A FREE NODE, FILL IT WITH A,,B
;IF C NOT =0, PUT PTR TO NEW NODE IN WORD 2 OF NODE(C)
;C ALSO GETS POINTER TO NEW NODE REGARDLESS
BR GRBAD9
GRBAD: CLR C ;SAME AS ABOVE EXCEPT NEW POINTER ALWAYS IN C
GRBAD1: CLC ;SAME AS ABOVE EXCEPT NEW PTR IN WORD 1
GRBAD9: SPUSH A
BIC #170000,C
BEQ GRB2 ;C IS ZERO, FORGET STORING NEW NODE PTR
ROL C
ROL C
ADD #NODESP,C ;ELSE MAKE NODE ADDRESS TO STORE AT
GRB2: BIT #MGCF,FLAGS2
BNE GRB4
MOV FREE,A
BNE GRB1
GRB4: JSR PC,.GCOLL
MOV FREE,A
BNE GRB1
CLR ERPROC ;DISABLE ERRSET IF 0 NODES
ERROR+NSL ;NO STORAGE LEFT
GRB1: DEC NNIFSL
BGE 1$ ;NEG NODES LEFT??
.BUG.
1$: TST C
BEQ GRB3
BIC #170000,A
BIC #7777,(C)
ADD A,(C)
GRB3: MOV A,C
JSR PC,.LDP1
; SPUSH A ;CHECK THAT NODE WAS IDLE
; BIC #7777,A
; CMP #IDLE,A
; BEQ 1$
; .BUG. ;GRABBED AN UNIDLE NODE!!!!!
;1$: SPOP A
BIC #170000,A
MOV A,FREE
SPOP A
JSR PC,.STORE
RTS PC
;.SBTTL UTILITY - FREE NODE ROUTINES
.FREE: SPUSH A ;RETURN NODE IN C TO FREE STORAGE
SPUSH B
MOV FREE,A
BIS #IDLE,A
CLR B ;MAKE SURE POINTER 2 IS ZERO
JSR PC,.STORE
BIC #170000,C
MOV C,FREE
INC NNIFSL
SPOP B
SPOP A
.FREE1: RTS PC
FRELST: BIT #7777,TOPS ;RETURN LIST (TOP-LEVEL ONLY) IN TOPS
;TO FREE STORAGE
BEQ .FREE1
PUSH A
SPUSH B
SPUSH C
MOV TOPS,C
FRL1: JSR PC,.LOADC
JSR PC,.FREE
BIT #7777,A
BEQ FRL2
MOV A,C
BR FRL1
FRL2: CLR TOPS
JMP RETC
.SBTTL READ A STRING
.GLOBL DRIBF,GCHR,RBRKF,TYI,TYO ;110
.GLOBL GETCNO,GNCN ;111
RDSTR7: MOV PC,RBRKF
SEZ
RDSTR8: RTS PC
RDSTR1: PRCR ;OUTPUT - PTR ON S, SKIP UNLESS EMPTY OR BREAK
RDSTR: CLR NBKTS
TST BRAKE
BNE RDSTR7
CMP #TYI,GCHR ;WILL CHARS BE COMING FROM TTY?
BNE RLINE1 ;NO
TST BRAKE
BEQ 1$
ERROR+BRK
1$: MOV PRMTCH,D
BEQ RLINE
BIT #BRKF,FLAGS
BEQ RLINE2
MOV FUNLEV,A
BEQ RLINE2
STLANC
ENGINS <MOV #'L,D>
ENDENG
FRINS <MOV #'N,D>
ENDLAN
JSR PC,TYO
JSR PC,PRDN
MOV PRMTCH,D
RLINE2: JSR PC,TYO
RLINE:
RLINE1: JSR PC,BLSTI
RDSTR2: JSR PC,@GCHR
CMP #TYI,GCHR
BNE RDST69
RDST2A: JSR PC,@DRIBF ;DRIBLE IT OUT IF DRIBBLING
RDST69: TST BRAKE
BNE RDSTR7
CMP #TYI,GCHR
BEQ RDSTR9
BIT #FILRED,@FILFLP
BNE RDSTR9
MOV #TYI,GCHR ;NON-TTY INPUT DONE
MOV #'],D ;FILL IN MISSING ]'S
TST NBKTS
RDSR10: BLE RDSTR4
JSR PC,BLST
DEC NBKTS
BR RDSR10
RDSTR9: CMP #TYI,GCHR ;READING FROM TTY?
BNE 1$ ;NOPE
CMP #'G-100,D ;BREAK TYPED?
BEQ RDSTR7 ;YES
CMP #'Z-100,D
BEQ RDSTR7
1$: TST NBKTS ;IN A LIST?
BGT RDSTR3 ;YES
CMP #15,D ;CR?
BEQ RDSTR4
RDSTR3: CMP #'[,D
BNE RDSTR6
INC NBKTS
RDSTR6: CMP #'],D
BNE RDSTR5
DEC NBKTS
RDSTR5: JSR PC,BLST
BR RDSTR2
RDSTR4: CLR RBRKF
JSR PC,BLSTF
BEQ RDSTR8
PUSHS TOPS
CLR TOPS
RDSTSR: CLZ
RTS PC
.SBTTL REQUEST, FILE READ & WRITE
RQUEST:
RQU1: PUSH PRMTCH
JSR PC,INPUTL
BEQ RQU5
MOV E,C ;E POINTS TO LAST NODE OF STRING
JSR PC,.LOADC ;NEED TO ADD A "]", IS THERE ROOM?
BIT #177400,B
BNE RQU2 ;YES
BIS #']*400,B ;NO - PUT A "]" THERE
JSR PC,.STORE
RQU3: MOV @S,GNCN
BIC #170000,GNCN
CLR F ;THIS IS PUSHED BY RDLST
JSR PC,RDLST
POPS TOPS
RQU4: MOV TOPS,@S
CLR TOPS
RQUR: POP PRMTCH
CLZ
RTS PC
RQU2: MOV #'],B
JSR PC,GRBAD1
BR RQU3
RQU5: MOV #LIST,@S
BR RQUR
INPUTL: MOV #'<,PRMTCH
JSR PC,GETCNO ;LAST INST OF GET CNO IS MOV (P)+,B SO FLAGS ARE SET
BEQ 1$
CLR PRMTCH
1$: JSR PC,RDSTR
BNE IPUL2
IPUL1: TST RBRKF
BEQ IPUL3
TST (P)+
SPOP PRMTCH ;NOW THE OLD PRMTCH
ERROR+BRK
IPUL3: PUSHS #LSTR
SEZ
IPUL2: RTS PC
TYPEIN: JSR PC,RQU1 ;INPUT A WORD FROM TTY
BIT #7777,@S
BNE TYPIN2
MOV #LSTR,@S
RTS PC
TYPIN2: JMP FIRST
.SBTTL READ -
.GLOBL COP,DTBL,DTBL2,OPERF,RDFLAG,SEPF,SOBLSU ;112
.GLOBL NNUMF ;113
.GLOBL LISTBD ;114
.GLOBL $DOTS ;115
.GLOBL NCHR ;116
READ: PUSH A
SPUSH B
SPUSH C
SPUSH D
SPUSH E
SPUSH F
CLR RDFLAG
MOV @S,GNCN
BIC #170000,GNCN
CLR F
READA: JSR PC,RDWRD
BEQ READB
BIS #SEPF,RDFLAG
JSR PC,CKDOTF
READC: JSR PC,LISTB
BIT #SEPF,RDFLAG
BEQ READA
READB: BIC #SEPF,RDFLAG ;CHECK SPECIAL CHAR IN D
JSR PC,CKDOTF ;FIRST CHECK FOR PENDING ":"
CMP #15,D
BEQ READR ;C-R
CMP #'",D
BEQ READS ;STRING
CMP #'[,D
BEQ READL ;LIST
CMP #'],D
BNE 1$
ERROR+COP ;CHAR (]) OUT OF PLACE
1$: CMP #':,D
BEQ READD ;DOTS
BITB #OPERF,DTBL(D) ;IS CHAR AN OPERATOR
BEQ READA ;NO
MOVB DTBL2(D),A
ASL A
MOV SOBLSU(A),B
;SET TYPE TO SFUN OR INFIX
MOV SOBLST(B),A ;THIS CROCK WORKS BECAUSE #SFUN=0
BIC #-INFIX-1,A ; AND #INFIX=10000
ASR B
BIS A,B ;SET IN THE TYPE (IF INFIX)
BR READC
READR: POPS A
CLR TOPS
TST F
BNE READR1
JMP RETF
READR1: MOV A,@S
JMP SRETF
READS: JSR PC,GNC
JSR PC,RDST
BIS #SEPF,RDFLAG
BR READC
READL: JSR PC,RDLST
POPS TOPS
BIC #SEPF,RDFLAG
BR READC
READD: BIS #DOTF,RDFLAG
BR READA
.SBTTL READ - READ WORD
;READ CHARS UP THRU NEXT SEPARATOR CHAR. IF JUST A SEP, RETURN
;WITH IT IN D. OTHERWISE NUMBERIFY OR INTERN CHAR STRING,
;SKIP RETURN WITH TOKEN IN A,,B
RDWRD: CLRB RDFLAG
JSR PC,BLSTI
RDWA: JSR PC,GNC
JSR PC,GETCHF ;GET FLAGS IN A
BIT #SEPF,A ;IS THIS CHAR A SEPARATOR?
BNE RDWB ;YES
BISB A,RDFLAG
JSR PC,BLST
BEQ RDWA
RDWB: JSR PC,BLSTF ;FINISH OFF STRING
BEQ RDWR+2
BIT #NNUMF,RDFLAG
BNE RDWC ;NOT A POSSIBLE NUMBER
MOV TOPS,B
MOV #LNUM,A
JSR PC,CONVER ;TRY MAKING A #
.IFNZ FPPF
BNE RDWR1
MOV #FNUM,A
JSR PC,CONVER ;IT MIGHT BE AN FNUM
.ENDC
BNE RDWR1
RDWC: MOV #UFUN,A ;TRY TO INTERN STRING IN TOPS AS A SYSTEM OR USER FUNCTION
BIT #DOTF,RDFLAG ; UNLESS DOTF ON, THEN AS USER VARIABLE
BEQ RDWD
MOV #UVAR,A
BIC #DOTF,RDFLAG
RDWD: JSR PC,.INTRN ;RDST COMES HERE ALSO
BEQ RDWE
JSR PC,FRELST
RDWE: BIC #170000,B
BIS A,B
CMP #UFUN,A ;IF WE GOT A UOE
BHI RDWR+2 ;THEN--
RDWR1: MOV B,TOPS ;PROTECT THIS NEWLY HATCHED UOE FROM G.C.
RDWR: CLZ
RTS PC
GETCHF: ;GET FLAGS FOR CHAR IN D INTO A
MOV #NNUMF,A
TSTB D ;CHECK FOR 200 BIT
BLT 1$
MOVB DTBL(D),A
1$: RTS PC
.SBTTL READ - READ STRING
;READ CHAR UP TO NEXT SPACE OR ] IF INSIDE
;A LIST. DONT ALLOW ] OR [.
; SKIPS UNLESS EMPTY STRING
RDST: CLRB RDFLAG
JSR PC,BLSTI
BR RDSB
RDSA: JSR PC,GNC
RDSB: JSR PC,GETCHF
BIT #SEPF,A
BEQ RDSE
JSR PC,SPACHK
BEQ RDSX
CMP #'],D
BEQ RDSC
CMP #'[,D
BEQ RDSX
CMP #15,D
BEQ RDSX
RDSE: BISB A,RDFLAG
JSR PC,BLST
BR RDSA
RDSC: TST LISTBD ;ARE WE IN LIST
BNE RDSX ;YES
RDSD: ERROR+COP ;CHAR (D) OUT OF PLACE
RDSX: MOV #LSTR,A
MOV #LSTR, B
JSR PC,BLSTF
BEQ RDWR+2
MOV #LSTR,A
MOV TOPS,B
BIT #NNUMF,RDFLAG
BEQ RDWR ;IT IS A POSSIBLE NUMBER
BIT #SEPF,RDFLAG
BNE RDWR+2 ;IT HAS A SEP CHAR IN IT
MOV #ATOM,A
BR RDWD ; INTERN IT
SPACHK: CMP #' ,D ;SPACE?
BEQ 1$ ;YUP
CMP #11,D ;TAB?
1$: RTS PC
;READ THRU MATCHING ] MAKING A LIST AS U GO
RDLST: CLRB RDFLAG
JSR PC,SLISTB
RDLA: JSR PC,GNC
JSR PC,SPACHK ;IS IT SPACE OR TAB?
BEQ RDLA ;SKIP OVER SPACES
CMP #'[,D
BEQ RDLB ;READ A LIST
CMP #'],D
BEQ RDLY ;DONE
JSR PC,RDST ;READ A STRING
RDLX: JSR PC,LISTB ;ADD THIS NODE TO LIST
CMP #'[,D
BEQ RDLB
CMP #'],D ;AT END?
BNE RDLA ;NO, GET NEXT ELEMENT
RDLY: JSR PC,FLISTB
RTS PC
RDLB: JSR PC,RDLST
POPS TOPS
CLR D
BR RDLX
.SBTTL READ - MISC
CKDOTF: BIT #DOTF,RDFLAG
BEQ LISTBR
BIC #DOTF,RDFLAG
PUSH A
SPUSH B
MOV #SFUN,A
MOV #$DOTS,B
JSR PC,LISTB
JMP RETB
LISTB: PUSH C
MOV F,C ;BUILD A LIST, ADD NODE IN A,,B TO
JSR PC,GRBAD1 ;LIST WHOSE LAST NODE PTR IS IN F
TST F ;CAREFUL - THE FIRST TIME IT IS CALLED, THE
;POINTER TO THE FIRST NODE IS PUSHED ONTO S
BNE LISTB1
PUSHS C
BIS #LIST,@S
LISTB1: MOV C,F
POP C
LISTBR: RTS PC
SLISTB: ;START LISTB
PUSHS F ;SAVE CURRENT LAST NODE PTR
CLR F
INC LISTBD
RTS PC
FLISTB: TST F
BNE FLSB1
PUSHS #LIST
FLSB1: POPS B ;THIS IS THE OUTPUT
MOV @S,F ;RESTORE OLD LAST NODE PTR
MOV B,@S ;THE RESULT
MOV #LIST,A
DEC LISTBD
RTS PC
BLSTI: CLR NCHR
MOV #100000,E
JMP CLRTOP
BLST: ;BUILD STRING - CHAR IN D, USES E
PUSH A
SPUSH B
SPUSH C
BIT #377,D ;CHECK IF NULL
BEQ BLSTRT
INC NCHR ;WE HAVE A CHAR
ADD #40000,E
BGE BLST2 ;IS IT THE SECOND
MOVB D,TEMP ;NO, 1ST
BLSTRT: JMP RETC
BLST2: MOVB D,TEMP+1 ;IT IS THE SECOND CHAR
MOV TEMP,B
;STORE THE CHARACTERS
JSR PC,BSAN
BIS #100000,E
BR BLSTRT
BLSTF: ;FINISH BUILDING STRING, PUT PTR IN TOPS.
; DONT SKIP IF EMPTY STRING (TOPS=0)
TST NCHR
BEQ BSANR ;EMPTY STRING
ADD #40000,E
BLT BSANR
PUSH A
SPUSH B
SPUSH C
MOVB TEMP,B ;YES
BIC #177400,B
JSR PC,BSAN
JMP SRETC
BSAN: MOV E,C
MOV #SSTR,A
JSR PC,GRBAD1
TST E
BNE BSAN1
MOV C,TOPS ;SAVE NEW STRING PTR ON S
BIS #LSTR,TOPS
BSAN1: MOV C,E
BSANR: RTS PC
.SBTTL GNC - GET NEXT CHAR
GNC: PUSH A ;GET NEXT CHAR INTO D
SPUSH B ;INITIALIZE BY MOVING LSTR PTR INTO GNCN
GNC4: MOVB GNCN+2,D ; AND CLEARING TYPE FIELD (#170000)
MOV GNCN,B ;PUTS CR (=#15) IN D IF NO MORE CHAR
BLT GNC1 ;JUST GOT 2ND CHAR
BNE GNC3
MOV #15,D
JMP RETB ;NONE LEFT
GNC3: JSR PC,.LOAD ;GET NEXT NODE
BIS #100000,A ;SET "STILL ANOTHER CHAR" BIT
MOV A,GNCN
MOVB B,D ;FOR OUTPUT
SWAB B
MOVB B,GNCN+2
GNC2: TST D
BEQ GNC4 ;IGNORE NULL CHARS
JMP RETB
GNC1: BIC #170000,GNCN ;CLEAR "STILL ..." BIT
BR GNC2
.SBTTL PRINT ROUTINES
PRLO: PUSH A ;PRINT LAST OPERATOR
SPUSH B
MOV LO,A
BEQ EMPTY
MOV A,B
BR PRCO1
PRCO: PUSH A, ;PRINT CURRENT OPERATOR
SPUSH B
MOV CO,A
MOV A,B
BEQ EMPTY
PRCO1: SPUSH D
JSR PC,PROAB
SPOP D
JMP RETB
PROAB: CMP A,#UFUN ;PRINT OPERATOR IN A,B
BLO PRCO2
JMP PPNAME ;PRINT PNAME
PRCO2: MOV B,A ;SYSTEM FUNCTION
BNE PRCO3
PRTXT ^\ CR.\
RTS PC
PRCO3:
BIC #170000,A ;CLEAR OUT THE INFIX TYPE
ASL A
ADD #4+SOBLST,A
BR PRAS ;PRINT ASCIZ PNAME
NOTPRO: ERROR+OOP ;SOMETHING OUT OF PLACE
EMPTY: PRTXT ^\ EMPTY \
JMP RETB
.GLOBL GETAML
ERTAS: SPUSH D
1$: SAVE A
JSR PC,GETAML
MOVB A,D
BEQ 2$
JSR PC,@PCHR
SWAB A
MOVB A,D
BEQ 2$
JSR PC,@PCHR
REST A
ADD #2,A
BR 1$
2$: REST <A,D>
ADD #2,A
RTS A
PRAS: SPUSH D ;PRINT ASCIZ STRING POINTED TO BY A
BR PRAS9
PRAS1: JSR PC,@PCHR
PRAS9: MOVB (A)+,D
BNE PRAS1
SPOP D
RTS PC
;GENERAL PRINT NUMBER ROUTINE
;CALL WITH A CLEAR, NUMBER TO BE PRINTED IN B
;MINIMUM NUMBER OF DIGITS TO PRINT IN C
;AND RADIX TO PRINT IN (=< 10.) IN D
PRN: DIV D,A
SAVE <B,#PRNDIG>
MOV A,B
CLR A
DEC C
BGT PRN
TST B
BNE PRN
RTS PC ;RETURN TO PRNDIG
PRNDIG: REST D ;DIGIT TO PRINT
ADD #60,D
JMP @PCHR
;PRINT A DECIMIAL NUMBER IN B WITH AT LEAST 2 DIGITS
ZPRDN: SAVE C
MOV #2,C ;AT LEAST 2 DIGITS
BR PRDN2
PRDN: SAVE C
CLR C
PRDN2: SAVE <A,B,D>
MOV A,B ;NEGATIVE?
BGE 1$
NEG B
MOV #'-,D
JSR PC,@PCHR
1$: MOV #10.,D
CLR A
PRDN1: JSR PC,PRN
REST <D,B,A,C>
RTS PC
PRON: SAVE C
CLR C
BR PRONL1
PRONL: SAVE C
MOV #6,C
PRONL1: SAVE <A,B,D>
MOV A,B
CLR A
MOV #8.,D
BR PRDN1
EMPTY1: JMP EMPTY
.GLOBL INVN ;121
.GLOBL WRTFLG ;122
PRS1: PUSH A ;PRINT TOP ELEMENT OF SS
SPUSH B
MOV IS,A ;COMPUTE RELATIVE S PD PTR
SUB S,A
ADD SPRBAO,A
CMP A,CSPDLP
BLOS EMPTY1
MOV @S,B
SPUSH D
JSR PC,PNODAB
SPOP D
JMP RETB
PNODAB: MOV B,A
BIC #7777,A
CMP #SSTR,A
BEQ PRS11
CMP #SNP,A
BLOS PRS11
ERROR+INVN ;INVALID NODE
PRS11: JSR PC,PRDATA
RTS PC
PRCT: PUSH A ;PRINT CURRENT TOKEN
SPUSH B
SPUSH D
MOV CT,A
MOV A,B
JSR PC,PRTAB
SPOP D
JMP RETB
PRTAB: BIC #7777,A ;PRINT TOKEN IN A,B
CMP A,#UVAR
BHIS 1$
JMP PROAB
1$: CMP A,#UVAR
BEQ PRUV
BR PRDATA
PRUV: MOVB #':,D ;PRINT USER VARIABLE IN A,B
JSR PC,@PCHR
PPNAME: BIC #PQF,FLAGS2 ;PRINT PNAME - UOE PTR IN B
PRUV1: JSR PC,.LOAD
JMP PRLSTR ;PRINT PNAME
PRDATA: CMP #INUM,A ;PRINT DATA IN A,B. 7777 FIELD OF A IS 0000
BEQ PRINUM ;NUMBER
.IFNZ FPPF
CMP #FNUM,A
BEQ PRFNUM
.ENDC
CMP #SNUM,A
BEQ PRSNUM
BIS #PQF,FLAGS2 ;SET PRINT QUOTE FLAG
PRPNM1: CMP #ATOM,A
BEQ PRUV1
CMP #LSTR,A
BEQ PRLSTR ;LONG STRING
CMP #SSTR,A
BEQ PRSSTR ;SHORT STRING
BIC #PQF,FLAGS2
CMP #LIST,A
BEQ PRLST
TST WRTFLG
BEQ PRSNP ;YES
PRTXT ^/" / ;OUTPUT EMPTY
BR PRSRET
PRSNP: PRTXT ^\%SNAP%\ ;CANT PRINT A SNAP
BR PRSRET
PRLSTR: JSR PC,.LOAD ;PRINT LONG STRING
PRSSTR: JSR PC,PRQQ ;PRINT SHORT STRING
PRSTR2: MOVB B,D
JSR PC,PRSPT
SWAB B
MOVB B,D
JSR PC,PRSPT
MOV A,B
BIC #170000,B
BEQ PRSRET
JSR PC,.LOAD
BR PRSTR2
PRSRET: RTS PC
PRQQ: BIT #PQF,FLAGS2 ;PRINT ' " ' IF PQF=1
BEQ PRSRET
BIT #DPQF,FLAGS2
BNE PRSRET
MOVB #'",D
JMP @PCHR
.IFNZ FPPF
PRFNUM: PUSH C
JSR PC,.FLOAD
MOV #FNUM,C
BR PRFNM1
.ENDC
PRSNUM: CLR A ;PRINT SNUM
TST B
BGE PRINM1
COM A
BR PRINM1
PRINUM: JSR PC,.LOAD ;PRINT INUM
PRINM1: PUSH C
.IFNZ FPPF
MOV #INUM,C ;SET FLAG FOR INUM ENTRY
.ENDC
PRFNM1: MOV E,TMPBLK+2
MOV F,TMPBLK+4
.IFNZ FPPF
CMP #FNUM,C
BNE 1$
JSR PC,.CFNST
BR 2$
1$:
.ENDC
JSR PC,.CINST ;CONVERT INUM IN A,,B TO STRING ON P
2$: MOV TMPBLK+2,E
MOV TMPBLK+4,F
MOV P,A
MOVB (A)+,D
BNE PRINM3
PRINM2: MOVB (A)+,D
BEQ PRINM4
PRINM3: JSR PC,@PCHR
BR PRINM2
PRINM4: INC A ;TO MAKE IT EVEN (??)
MOV A,P
POP C
PRSPT2: RTS PC
PRSPT: TSTB D
BEQ PRSPT2
BIT #CPTBF,FLAGS2
BEQ PRSPT1
CMPB #'%,D
BNE PRSPT1
MOV #' ,D
PRSPT1: JMP @PCHR
PRLST: PUSH A ;PRINT LIST, PTR IN B
SPUSH B
SPUSH C
TST NBKTS
BEQ PRL4
MOV #'[,D
JSR PC,@PCHR
PRL4: INC NBKTS
MOV B,C
PRL1: SPUSH FLAGS2
BIT #7777,C ;EMPTY LIST
BEQ PRL2 ;YES, DONE
BIS #DPQF,FLAGS2 ;DONT PRINT QUOTE BEFORE STRINGS
BR PRL3
PRL6: SPACE
PRL3: JSR PC,.LOADC ;GET THIS NODE
MOV A,C ;SAVE PTR TO NEXT
BIC #7777,A
JSR PC,PRTAB
BIT #7777,C
BNE PRL6
PRL2: DEC NBKTS
BEQ PRL5
MOV #'],D
JSR PC,@PCHR
PRL5: BIC #DPQF,FLAGS2
SPOP C ;GET OLD FLAGS2
BIC #<-DPQF-1>,C ;MASK ALL BUT DPQF
BIS C,FLAGS2 ;AND RESTORE IT
JMP RETC
.SBTTL PRINTOUT (ONCE KNOWN AS SHOW)
.GLOBL PODISP,SHW ;125
.GLOBL $DISPL,$PLOTT,$STTUR,ASSTPL,ASSTUR,ASTRDI,CTRDIS,CTRPLT,CTRTUR ;126
.GLOBL .POF ;127
SHALPR: ;SHOW ALL PROCEDURES
;USES A-F
JSR PC,GNOLEI
BR SHALP2
SHALP1: JSR PC,.CRLF
SHALP2: JSR PC,GNOLE
BEQ SHOWA1
JSR PC,BURYQX
BEQ SHALP2
JSR PC,PSHOW
BNE 1$
.BUG.
1$: CMP PCHR,#TYO
BNE SHALP2
BR SHALP1
POTS:
SHALTI: ;SHOW ALL TITLES
JSR PC,GNOLEI
SHATI1: JSR PC,GNOLE
BEQ SHOWA1
JSR PC,BURYQX
BEQ SHATI1
JSR PC,SHTITL
BR SHATI1
SHOWAL: JSR PC,SHALPR ;SHOW ALL PROCEDURES
JSR PC,SHALNA ;SHOW ALL NAMES
TST WRTFLG ;DON'T SHOW ARRAYS ON WRITE
BNE SHOWA1
JSR PC,POARR ;SHOW ALL ARRAYS
SHOWA1: SEZ
RTS PC
SHOW:
TST CLCNT ;ANY TOKENS LEFT
BNE SHOW00 ;YEP
MOV TOPRNM,B
BNE SHOW0
MOV LASTPR,B
BNE SHOW0
ERROR+SHW
SHOW00: JSR PC,GTUOEB
BNE SHOW1 ;THE TOKEN ISNT A USER PROC
SHOW0: JSR PC,PSHOW
BNE SHOWA1
ERROR+PNH ;PROCEDURE NOT HERE
SHOW1: CMP #SFUN,A
BNE SHOWE1
TST B ;IS IT CR?
BNE SHOW12 ;NO
MOV TOPRNM,B
BNE SHOW0
SHOWE1: ERROR+SHW
SHOW12: MOV #PODISP,A
SHOW13: CMP (A)+,B
BNE SHOW23
JMP @(A)
SHOW23: TST (A)+
TST (A)
BNE SHOW13
ERROR+SHW
.IFNZ DDF
CNTRL: CLR C
INC C
BR ALSO2
ALSO: CLR C
ALSO2: BIT #7777,CT
BNE ALSOW1
ALSOWH: ERROR+WTAB
ALSOW1: JSR PC,GNT
BIC #7777,A
CMP #SFUN,A
BNE ALSOWH
TST B
BEQ ALSOWH
.IFNZ ENG
CMP #$STTUR,B
BEQ TUR
.IFNZ NDISP
CMP #$DISPLAY,B
BEQ DIS
.ENDC
.IFNZ NPLOT
CMP #$PLOTTER,B
BEQ PLOT
.ENDC
.ENDC
.IFNZ FR
CMP #$TORTUE,B
BEQ TUR
.IFNZ NDISP
CMP #$ECRAN,B
BEQ DIS
.ENDC
.IFNZ NPLOT
CMP #$TRACEUR,B
BEQ PLOT
.ENDC
.ENDC
BR ALSOWH
.IFNZ NDISP
DIS: TST C
BEQ 1$
JMP CTRDIS
1$: JSR PC,EVAL
BEQ TUR2
JMP ASTRDI
.ENDC
TUR: TST C
BEQ TUR1
JSR PC,EVAL
BEQ TUR2
JMP CTRTUR
TUR1: JSR PC,EVAL
BNE TUR69
TUR2: ERROR+WTAB
TUR69: JMP ASSTUR
.IFNZ NPLOT
PLOT: TST C
BEQ 1$
JMP CTRPLT
1$: JMP ASSTPL
.ENDC
.ENDC
POT: MOV TOPRNM,B ;SHOW THIS TITLE
BEQ POL1
JSR PC,SHTITL
BNE POL2
.BUG.
POL: TST TOPRNM
BNE POL69
POL1: ERROR+OIP
POL69: JSR PC,GTLN ;GEN LINE NO. FROM NEXT TOKEN INTO B
BNE 1$
ERROR+SHW ;SHOW WHAT??
1$: JSR PC,GTLP ;GET POINTER TO LINE IN F
JSR PC,PRLN ;PRINT LINE
PRCR
POL2: SEZ
POL3: RTS PC
;PRINT PROC POINTED TO BY B
PSHOW: SAVE B
JSR PC,SHTITL ;CLZ IF IF PROC EXISTS; RETURNS WITH B POINTING TO ARRAY
;F POINTS TO THE FIRST LINE
BEQ PSHOW1 ;JUST RETURN
MOV @PBASE,B ;GET POINTER TO THE ARRAY
PUSH PROEND(B) ;PUSH RELATIVE POINTER TO THE END OF PROC
PSHLIN: CMP F,(P) ;AT THE END
BEQ PSHDON ;DONE
BHI PSHBUG ;ERROR
JSR PC,PRLN ;PRINT LINE OFFSET TO BY F, AND RETURN OFFSET TO NEXT LINE IN F
PRCR ;CARRIAGE RETURN
BR PSHLIN
PSHDON: TST (P)+ ;POP OFF POINTER TO THE END OF THE FILE
TST WRTFLG ;WRITING A FILE, OR PAPER TAPE
BNE 1$ ;YES, SO ALWAYS PRINT THE END
SUB TOPRNM,(P)
BIT #7777,(P)
BEQ PSHOW2 ;YES, DONT PRINT END
1$:
STLANC
ENGINS <PRTXTC ^\END\>
ENDENG
FRINS <PRTXTC ^\FIN\>
ENDLAN
PSHOW2: TST (P)+
CLZ
RTS PC
PSHOW1: TST (P)+
SEZ
RTS PC
PSHBUG: .BUG.
PON:
SHALNA: ;SHOW ALL NAMES
;USES A-F
JSR PC,GNOLEI
SHALN1: JSR PC,GNOLE ;GET NEXT UOE
BEQ POL2+2
MOV B,F
MOV #VBIND,A
JSR PC,.BINDL
BEQ SHALN1 ;NO THING FOR THIS UOE
MOV B,C ;SAVE VALUE PTR
MOV F,B ;GET UOE PTR
TST WRTFLG
BEQ SHALN2 ;NO
TST C ;IS VALUE = "UNBOUND"? (0?)
BEQ SHALN1 ;SKIP THIS ATOM
SPUSH B
STLANC
ENGINS <PRTXT ^/MAKE "/>
ENDENG
FRINS <PRTXT ^/RELIE "/>
ENDLAN
SPOP B
JSR PC,PPNAME ;PRINT THE NAME
PRTXT ^\ (\
BR SHALN3
SHALN2: JSR PC,PRUV ;PRINT THE NAME
STLANC
ENGINS <PRTXT ^/ IS/>
ENDENG
FRINS <PRTXT ^/ EST/>
ENDLAN
SHALN3: SPACE
SPUSHS C
INC NBKTS
JSR PC,PRS1
ADD #2,S
TST WRTFLG
BEQ SHALN4
PRTXT ^\ )\
SHALN4: PRCR
BR SHALN1
POARR: JSR PC,GNOLEI
POARR1: JSR PC,GNOLE ;GET NEXT UOE
.IFZ <ENG&FR>
BEQ POARR6
.IFF
BNE 1$
JMP POARR6
1$:
.ENDC
MOV B,F ;PTR TO UOE
MOV #ABIND,A
JSR PC,.BINDL ;GET ARRAY BINDING
BEQ POARR1 ;NO BINDING FOUND
JSR PC,POARR5 ;PRINT ARRAY NAME,SIZE,TYPE
BR POARR1 ;LOOK FOR MORE ARRAYS
POARR5: MOV B,C ;SAVE VALUE PTR
MOV F,B ;GET UOE PTR
JSR PC,PPNAME ;PRINT THE NAME
STLANC
ENGINS <PRTXT ^/ SIZE / >
ENDENG
FRINS <PRTXT ^/ DIMMENSION />
ENDLAN
MOV C,B ;SAVE VALUE PTR
PUSH B
JSR PC,ASIZE2 ;PUTS DIMS. OF ARAY IN LIST
MOV C,B ;PPTR TO LIST
JSR PC,PRLST ;PRINT IT
SPACE
PRTXT ^/ TYPE/
POP B ;VALUE PTR
MOV 4(B),B ;TYPE/DIM WORD IN ARRAY HEADER
BIC #7777,B ;GET THE TYPE
BEQ POARR2 ;TYPE POINTER
CMP #FNUM,B
BEQ POARR3 ;TYPE FNUM
STLANC
ENGINS <PRTXT ^/ INTEGER/>
ENDENG
FRINS <PRTXT ^/ NOMBRE ENTIER/>
ENDLAN
BR POARR4
POARR2:
STLANC
ENGINS <PRTXT ^/ POINTER/>
ENDENG
FRINS <PRTXT ^/ POINTEUR/>
ENDLAN
BR POARR4
POARR3:
STLANC
ENGINS <PRTXT ^/ FLOATING POINT/>
ENDENG
FRINS <PRTXT ^/ NOMBRE DECIMAL/>
ENDLAN
POARR4: PRCR ;CARRIAGE RETURN
SEZ
POARR6: RTS PC
PO1AR: JSR PC,GTUOEB
BEQ 1$
MOV B,F
1$: MOV #ABIND,A
JSR PC,.BINDL
.IFZ <ENG&FR>
BNE POARR5
ERROR+UDA
.IFF
BEQ 2$
ERROR+UDA
2$: JMP POARR5
.ENDC
CONTEN: ;MAKE A LIST OF ALL ATOMS THAT HAVE A PROCEDURE
CLR F
JSR PC,SLISTB
JSR PC,GNOLEI
CONTN1: JSR PC,GNOLE
BEQ CONTN2 ;DONE
JSR PC,BURYQX ;CHECK TO SEE IF IT IS BURRIED
BEQ CONTN1
MOV B,D
JSR PC,.BINDF ;A PROCEDURE
BEQ CONTN1 ;NOPE
MOV D,C
JSR PC,.LOADC ;GET PNAME
MOV #LSTR,A
JSR PC,LISTB
BR CONTN1
CONTN2: JSR PC,FLISTB
CLZ
RTS PC
;INPUT - UOE POINTER IN B
;OUTPUT - PRINTS TITLE LINE, OUTPUTS POINTER TO THE FIRST LINE OF PROC IN F, POINTER
; TO THE PROCEDURE IN B. SEZ IF NO PROCEDURE.
SHTITL: PUSH A
SPUSH B
SPUSH C
JSR PC,.BINDF ;GET POINTER TO THE FUNCTION IN B
BNE 1$ ;GOT THE BINDING
JMP RETC ;JUST RETURN
1$:
MOV (B),PBASE ;MOVE POINTER TO THE BINDING NODE INTO PBASE
STLANC
ENGINS <PRTXT ^\TO \>
ENDENG
FRINS <PRTXT ^\POUR \>
ENDLAN
MOV 2(P),B ;POINT TO THE ATOM AGAIN
JSR PC,PPNAME ;PRINT THE NAME OF THE ATOM
MOV #HEADER,F ;THE INITIAL OFFSET
ADD @PBASE,F ;MAKE IT ABSOLUTE FOR NOW
SPUSH (F)+ ;PUSH NUMBER OF BYTES IN THIS LINE
SUB @PBASE,F ;MAKE F RELATIVE
ADD F,(P) ;MAKE IT POINT TO THE NEXT LINE
ADD #2,F ;SKIP THE NUMBER OF VARIABLES
VARLOP: CMP F,(P) ;DONE?
BEQ VARDON ;YES
SPACE
ADD @PBASE,F ;MAKE POINTER ABSOLUTE
MOV (F)+,B ;GET THE POINTER TO THE VARIABLE
SUB @PBASE,F ;MAKE THE POINTER RELATIVE AGAIN
MOV B,A ;COPY IT
BIC #7777,A ;CLEAR THE POINTER PART
JSR PC,PRTAB ;PRINT THE TOKEN IN A,,B
BR VARLOP ;NEXT!!
VARDON: PRCR ;PRINT CR
SPOP F ;POP POINTER TO THE NEXT LINE
JMP SRETC ;RETURN
;INPUT - F IS OFFSET TO THE LINE TO PRINT, OUTPUT F OFFSETED TO THE NEXT LINE
PRLN: PUSH A
SPUSH B
SPUSH C
SPUSH D
ADD @PBASE,F ;MAKE F ABSOLUTE
SPUSH (F)+ ;PUSH NUMBER OF BYTES IN THIS LINE
ADD F,(P) ;MAKE IT A POINTER TO THE NEXT LINE
SUB @PBASE,(P) ;MAKE THE POINTER RELATIVE
INC NBKTS ;PRINT THE OUTER LIST BRACKETS
BIC #DPQF,FLAGS2 ;ALLOW PRINTING OF QUOTES
MOV (F)+,B ;THE LINE NUMBER
SUB @PBASE,F ;MAKE F RELATIVE AGAIN
MOV #SNUM,A ;PUT THE TYPE INTO A
JSR PC,PRTAB ;PRINT THE TOKEN IN A,,B
PRLN1: CMP F,(P) ;DONE?
BEQ PRLN2 ;YES
SPACE ;TYPE A SPACE
ADD @PBASE,F ;MAKE F ABSOLUTE
MOV (F)+,B ;GET THE NEXT TOKEN
SUB @PBASE,F ;MAKE IT RELATIVE AGAIN
MOV B,A ;COPY IT FOR THE TYPE
BIC #7777,A ;DELETE THE POINTER PART
JSR PC,PRTAB ;PRINT THE TOKEN IN B
BR PRLN1 ;NEXT TOKEN
PRLN2: DEC NBKTS ;FIX IT FOR THE NEXT CALL
SPOP F ;WELL RESTORE F
JMP RETD ;AND RETURN
.GLOBL BUG ;133
;LISTIFY THE PROCEDURE SPECIFIED
TEXTT: JSR PC,GUOEB ;GET POINTER TO THE ATOM
BNE 1$ ;OKAY
2$: ERROR+HNM ;WHAT DID YOU ASK TO TEXTIFY?
1$: JSR PC,.BINDF ;GET THE PROCEDURE BINDING
BEQ 2$ ;OUGHT TO HAVE A PROCEDURE BINDING
PUSH PROEND(B) ;PUSH THE FINISHING ADDRESS
MOV (B),PBASE ;SET UP POINTER TO THE PROCEDURE
MOV #HEADER,C ;THE INITIAL OFFSET
CLR F ;THIS IS USED BY LISTB
JSR PC,LSTIT ;LIST THE TITLE, OUTPUT IN TOPS, AND RETURNS A,,B
BR TEXTL1 ;PUT IN ON THE LIST
TEXTLP: JSR PC,LSTLIN ;LISTIFY'S LINE, AND PUSHES RETURNS IT IN A,,B
;GC-PROTECTED BY TOPS
MOV #LIST,A ;SAY THIS IS A LIST
TEXTL1: JSR PC,LISTB ;AND BUILD ME A LIST
CLR TOPS ;CLEAR THE GC-PROTECTION
CMP C,(P) ;ARE WE AT THE END OF THE PROC YET?
BLO TEXTLP ;NOT YET, GET NEXT LINE
BHI TEXTBG ;PAST IT, BUGGGGGG
TST (P)+ ;POP OFF END OF PROC MARKER
CLZ ;DONE
RTS PC
TEXTBG: ERROR+BUG
;TAKES OFFSET TO LINE IN C, LISTIFY'S IT, AND RETURNS IT IN A,,B, AND IN TOPS
LSTLIN:
MOV C,D ;COPY OFFSET TO TITLE LINE
ADD @PBASE,D ;MAKE IT ABSOLUTE
PUSH 2(D) ;SAVE THE LINE NUMBER
JSR PC,LTOK ;LISTIFY THE LINE
SPOP B ;GET THE LINE NUMBER
SPUSH C ;SAVE POINTER TO NEXT LINE
JSR PC,.CSNLS ;CONVERT IT TO AN LSTR
MOV B,TOPS ;GC-PROTECT THE NUMBER
MOV @S,A ;POINTER TO THE LINE
BIC #170000,A ;CLEAR THE TYPE
BIS #LSTR,A ;SAY THIS IS AN LSTR
JSR PC,GRBAD ;GET A NODE THAT POINTS TO THE NUMBER, AND THE LINE
BIS #LIST,C ;THIS IS THE POINTER TO THE LINE
MOV C,B ;COPY IT
MOV B,TOPS ;SAVE IT TO GC-PROTECT IT
MOV #LIST,A ;MAKE IT LIST TYPE
SPOP C ;AND GET BACK POINTER TO THE NEXT LINE
ADD #2,S ;POP OFF THIS LIST (IT ISN'T NEEDED)
RTS PC
.GLOBL $TOTO ;134
;TAKES POINTER TO THE PROCEDURE ARRAY IN PBASE AND B, AND OFFSET TO THE TITLE LINE IN C
;RETURNS C OFFSETED TO THE FIRST REAL LINE OF PROCEDURE
LSTIT:
ADD B,C ;MAKE C ABSOLUTE
MOV PROATM(B),B ;GET POINTER TO THE PROCEDURE ATOM
JSR PC,.LOAD ;AND GET POINTER TO THE PNAME
SPUSH B ;AND PUSH IT
SUB @PBASE,C ;MAKE C RELATIVE AGAIN
JSR PC,LTOK ;GET THE VARIABLES LISTIFIED, AND OUTPUT ON S PDL
SPUSH C ;SAVE POINTER TO THE NEXT LINE
MOV #LSTR,A ;MAKE THE LSTR POINT TO "TO"
STLANC
ENGINS <MOV #$TOTO,B>
ENDENG
FRINS <MOV #$POURX,B> ;GET POINTER TO "TO"
ENDLAN
JSR PC,GRBAD ;C POINTS TO NODE WITH "TO" IN IT
MOV C,TOPS ;THIS WILL BE POINTER TO THE LINE
MOV @S,A ;GET POINTER TO THE LIST OF VARIABLES
BIC #170000,A ;CLEAR OUT THE TYPE
BIS #LSTR,A ;THE PNAME IS AN LSTR
MOV 2(P),B ;THE POINTER TO THE PNAME OF THE ATOM
JSR PC,GRBAD1 ;MAKE THE "TO" NODE POINT TO A NODE CONTAINING A,,B
ADD #2,S ;POP OFF LINE WITH VARIABLES IN IT
MOV #LIST,A ;LIST TYPE
BIS A,TOPS ;SET IN THE TYPE
MOV TOPS,B ;GET BACK POINTER TO THE "TO" NODE
SPOP C ;GET POINTER TO NEXT LINE
TST (P)+
RTS PC
;ACCEPTS POINTER TO TOKEN STRING IN C, INCREMENTS C AND LISTIFIES WHAT IT POINTS TO
;PUSHES LIST ON S PDL
LTOK:
ADD @PBASE,C ;MAKE C ABSOLUTE
MOV (C)+,D ;GET THE COUNT
TST (C)+ ;SKIP THE "LINE NUMBER"
SUB @PBASE,C ;MAKE IT REALIVE AGAIN
LTOK1: SPUSH C ;SAVE POINTER
JSR PC,SLISTB ;START LIST BUILDING
ASR D ;INTO WORD COUNT
DEC D ;AND DECREMENT IT
BEQ LTOKDN
LTOKLP: SPOP C ;GET POINTER TO LINE
ADD @PBASE,C ;MAKE C ABSOLUTE
MOV (C)+,B ;GET THE NEXT TOKEN
SUB @PBASE,C ;MAKE IT RELATIVE AGAIN
SPUSH C ;AND PUT IT BACK ON
MOV B,A ;COPY FOR THE TYPE
BIC #7777,A ;CLEAR IT OUT
CMP A,#UFUN ;IS IT A SYSFUN, OR INFIX OPERATOR?
BLO LTOKSY ;SYSTEM FUNCTION
BEQ LTOKUF ;USER FUNCTION
MOV #':,C ;FOR USER VARIABLE
CMP #UVAR,A ;USER VARIABLE?
BEQ LTOKAD ;ADD CHARACTER IN D TO ATOM IN B
MOV #'",C ;ATOM PRINT "
CMP #ATOM,A ;ATOM?
BEQ LTOKAD ;ADD CHARACTER IN D TO ATOM IN B
CMP #LSTR,A ;IS IT ALREADY AN LSTR?
BNE LTOKLT ;NO, MUST BE INUM,FNUM, OR LIST, OKAY AS IS
JSR PC,CHRLST ;ADD " TO THE LSTR
LTOKL1: MOV TOPS,B ;POINTER TO THE NEW LSTR
LTOKL2: MOV #LSTR,A ;IT IS AN LSTR
LTOKLT: JSR PC,LISTB ;BUILD A LIST ELEMENT FROM A,,B
SOB D,LTOKLP ;GO BACK FOR MORE
LTOKDN: JSR PC,FLISTB ;FINISH LIST, AND PUT POINTER TO IT IN B
SPOP C ;RESTORE LINE POINTER
JMP CLRTOP
LTOKSY: JSR PC,LSFUN ;CONVERT THE FUNCTION TO LSTR POINTED TO BY TOPS
BR LTOKL1 ;ADD IT TO THE LIST
LTOKUF: JSR PC,.LOAD ;POINTER TO THE PNAME IN B, TYPE IN A
BR LTOKL2 ;ADD IT TO THE LIST
LTOKAD: JSR PC,CHRATM ;ADD CHARACTER TO PNAME
BR LTOKL1 ;ADD IT TO THE LIST
;APPEND CHARACTER IN C TO BEGINNING OF PNAME OF ATOM POINTED TO BY B
CHRATM: JSR PC,.LOAD ;GET THE POINTER TO PNAME IN B
;DROP INTO CHRLST
;APPEND CHARACTER IN D TO BEGINNING OF PNAME IN B, OUTPUT POINTER IN TOPS
;OUTPUT IS PROTECTED BY TOPS
CHRLST: MOV B,A ;POINTER TO THE REST OF THE PNAME
MOV C,B ;GET THE CHARACTER TO ADD
BIC #170000,A ;CLEAR OUT THE OLD TYPE
BIS #SSTR,A ;AND MAKE IT AN SSTR
JSR PC,GRBAD ;GET A NODE CONTAINING PNAME AND THE SINGLE CHARACTER
BIS #LSTR,C ;SAY IT IS AN LSTR
MOV C,TOPS ;GC-PROTECT IT
RTS PC
;CONVERT SFUN IN B TO AN LSTR, OUTPUT IN TOPS
LSFUN: SPUSH D ;SAVE THE NUMBER OF TOKENS
SPUSH PCHR ;SAVE THE PCHR
JSR PC,BLSTI ;INIT THE LIST BUILD
MOV #BLST,PCHR ;ROUTINE FOR ADDING CHARACTERS TO THE LSTR
MOV B,A ;COPY POINTER FOR PROAB
JSR PC,PROAB ;PRINT THE NAME OF THE FUNCTION
JSR PC,BLSTF ;FINISH THE LSTR
POP PCHR ;PUT BACK PRINT ROUTINE
SPOP D ;GET BACK NUMBER OF TOKENS
RTS PC
CVSFLS: JSR F,CACSAV ;SAVE AC'S
JSR PC,LSFUN ;AND CONVERT IT
JSR F,CACRES ;RESTORE AC'S
RTS PC
.SBTTL ILINE & ERSET STUFF
.GLOBL CURPNT,ERRPNT,LASTER,NLINEL,NPROCL,NTOKEL ;137
ILINE:
MOV #CURPNT,PBASE ;FAKE A BINDING NODE FOR THE CURRENT LINE
MOV #HEADER,C
CLR F
JSR PC,LTOK ;LISTIFY IT
CLZ ;AND RETURN IT
RTS PC
ERRPRO: ;OUTPUT NAME OF PROC EXTENT AT LAST ERROR
MOV NPROCL,B
BEQ ERRPR1
JSR PC,.LOAD
PUSHS B
CLZ
RTS PC
ERRPR1: PUSHS #LSTR
RTS PC
ERRLIN: ;OUTPUT LINE # EXTENT AT LAST ERROR
MOV NLINEL,B
BR NTOKE1
ERRTOK: ;OUTPUT TOKEN # EXTENT AT LAST ERROR
MOV NTOKEL,B
NTOKE1: JMP R1NARG
ERRLOC: ;OUTPUT ADDR OF LAST ERROR
MOV LASTER,B
BR NTOKE1
ERRNUM: ;OUTPUT NO. OF LAST ERROR
MOV ERRPNT,B
CMP (B)+,(B)+
JSR PC,GETERW
BR NTOKE1
ERRNAM: MOV #4,C ;MAX CHARS
MOV ERRPNT,ERRPT
JSR PC,BLSTI ;START AN LSTR
ERRNA2: JSR PC,GETERB
INC ERRPT
TST D
BEQ ERRNA1
JSR PC,BLST
SOB C,ERRNA2 ;CONTINUE UNLESS DONE
ERRNA1: JSR PC,BLSTF
BEQ ERRPR1
PUSHS TOPS
CLZ
RTS PC
.GLOBL BRAKEL ;138
.GLOBL ERSDIS ;139
.GLOBL PBE ;140
ERRBRE: ;OUTPUT BRAKE(U)
MOV BRAKEL,B
BR NTOKE1
ERRSET: JSR PC,GTUOEB
BEQ 1$
ERROR+HNM
1$: MOV B,ERPROC
SEZ
RTS PC
ERRCLE: CLR ERPROC
ERRC3: RTS PC
ERNAME: ;ERASE NAME
JSR PC,GTUOEB
BEQ ERN2
CMP #UFUN,A ;AN SFUN OR INFIX?
BGT 1$
ERROR+ERW
1$: JSR PC,CVSFLS
MOV #ATOM,A
JSR PC,.OBSCH
BEQ ERRC3
ERN2: MOV #VBIND,A
JSR PC,.UNBND
SEZ
RTS PC
.SBTTL ERASE
ERASE: JSR PC,GTUOEB ;GET THE PROCEDURE TO ERASE
BNE ERASE1 ;NOT A UOE, MUST BE A SYSTEM WORD
JSR PC,ERPR ;ERASE THAT PROCEDURE
BEQ 1$
2$: SEZ
RTS PC
1$: TST REDFLG ;IF READING FROM FILE
BNE 2$ ;IGNORE ERASE ERRORS
ERASER: ERROR+PNH ;CAN'T FIND THE STUPID THING
ERASE1: MOV #ERSDIS,A ;POINT TO THE ERASE DISPATCH TABLE
ERASE2: CMP (A)+,B ;IS IT THIS WORD?
BNE 1$ ;NO, SKIP THE ADDRESS
JMP @(A) ;GO DO THAT
1$: TST (A)+ ;PASS THE ADDRESS
TST (A) ;AT THE END OF THE TABLE?
BNE ERASE2 ;NO
ERASE3: ERROR+ERW ;ERASE WHAT?
ERALL: JSR PC,ERALPR ;ERASE ALL THE PROCEDURES
JSR PC,ERALNA ;ERASE ALL THE NAMES
JSR PC,ERARAS ;ERASE ALL THE ARRAYS
JMP TOPLEVEL ;RTS PC FOR NEW SYSTEM
;ERASE LINE
ERL:
ERLINE: TST TOPRNM ;EDITING A PROCEDURE?
BNE 1$ ;YES
ERROR+OIP
1$: JSR PC,GTLN ;GET LINE NUMBER IN B
BEQ ERASE3 ;LOSE LOSE
NEG B ;TO DELETE THIS LINE
JSR PC,ADLN ;DO THE DEED
ERLI1: SEZ
RTS PC
;ERASE PROCEDURE POINTED TO BY THE ATOM IN B
ERPR: BIC #170000,B ;CLEAR OUT THE TYPE
BIS #UFUN,B ;MAKE IT INTO A UFUN
CMP B,TOPRNM ;IS IT THE PROCEDURE BEING EDITED?
BNE ERPR2 ;NO, ALLOW IT TO HAPPEN
ERPR1: ERROR+PBE ;PROCEDURE BEING EDITED
ERPR2: JSR PC,.BINDF ;GET THE BINDING
BEQ ERLI1 ;CAN'T FIND IT, FORGET IT
DELPRO: TST PROSTK(B) ;IS IT REFERENCED ON THE STACK?
BEQ DELIT ;NO, JUST DELETE IT
MOV #-PROCAR,PROTYP(B) ;CHANGE TYPE TO DELETED
MOV (B),C ;POINTER TO THE 2ND WORD OF BINDING NODE
BIC #170000,-(C) ;CLEAR OUT THE TYPE OF THE FIRST WORD
BIS #DBIND,(C) ;SET IN DELETED PROCEDURE BINDING
RTS PC ;AND RETURN
DELIT: SPUSH B ;SAVE B
TST PROTYP(B) ;WAS IT DELETED PREVIOUSLY?
BMI DELHRD ;DELETE IT THE HARD WAY
MOV PROATM(B),B ;GET POINTER TO THE BINDING NODES
MOV #FBIND,A ;DELETE THE FUNCTION BINDING
JSR PC,.UNBND ;DELETE THE BINDING
DELARR: SPOP B ;GET BACK POINTER TO THE ARRAY
JSR PC,.RELES ;RELEASE IT
CLZ
RTS PC
DELHRD: MOV PROATM(B),B ;GET POINTER TO THE BINDING NODES
MOV B,C ;THIS IS THE POINTER TO THE PREVIOUS NODE
MOV B,A ;AND SET UP POINTER TO THE START ALSO
DELOP: MOV C,D ;GET POINTER TO THE PREVIOUS
MOV A,C ;THE NEXT NODE TO LOAD
JSR PC,.LOADC ;LOAD IT UP
CMP B,(P) ;IS IT POINTER TO THE SAME ADDRESS?
BNE DELOP ;NO, TRY TRY AGAIN
MOV A,B ;WHAT THE NODE POINTS TO
BIC #7777,A ;IS IT A DBINDED NODE?
CMP A,#DBIND ;WELL?
BEQ 1$ ;YES, ALL IS WELL
MOV B,A ;RESTORE A
BR DELOP ;AND TRY AGAIN
1$: MOV D,C ;POINTER TO THE NODE BEFORE THIS
JSR PC,.LDP1 ;GET WHAT IT POINTS TO
BIC #7777,A ;GET THE TYPE TO PUT ON THE NEW POINTER
BIC #170000,B ;CLEAR OUT THE POINTER
BIS B,A ;SET IN THE POINTER INTO THE TYPE
JSR PC,.STP1 ;AND CLOBBER THAT NODE TO POINT TO THE NEXT
BR DELARR ;NOW DELETE THE ARRAY
;ERASE ALL PROCEDURES
ERALPR: TST TOPRNM ;ANY BEING EDITED?
BEQ ERALP1 ;NO, CONTINUE
MOV TOPRNM,B ;GET UOE EDITED INTO B
BR ERPR1 ;TO REPORT THE ERROR
ERALP1: JSR PC,GNOLEI ;INITIALIZE THE GET NEXT OBLIST ROUTINE
ERALP2: MOV #FBIND,A ;THE BINDING TO LOOK FOR
JSR PC,GNOLE ;GET THE NEXT OBLIST ELEMENT
BEQ ERLI1 ;RETURN WHEN WE CANT GET ANY MORE
JSR PC,BURYQ ;IS IT BURIED?
;ALSO GETS INDEX TO ARRAY IN B
BEQ ERALP2 ;YES, OR ISN'T A PROCEDURE
JSR PC,DELPRO ;DELETE THE PROCEDURE, IF AT LEVEL 0, OR FIX
;IT TO BE DELETED LATER
BR ERALP2 ;FOR ALL THE PROCEDURES
.GLOBL $ALL,$TOUT,.DELET,.DELI,TF6 ;141
;ERASE ALL NAMES
ERALNA: JSR PC,GNOLEI ;INIT GET NEXT OBLIST ELEMENT
ERALN1: JSR PC,GNOLE ;GET THE NEXT OBLIST ELEMENT
BEQ ERALN2 ;DONE
MOV #VBIND,A ;DELETE VARIABLE BINDINGS
JSR PC,.UNBND
BR ERALN1 ;DELETE THEM ALL
ERALN2: RTS PC
BURY: MOV PC,TF6 ;SET THE FLAG SAYING WE ARE ENABLING THIS FEATURE
BR BURY1 ;GO DO IT
EBURY: CLR TF6 ;CLEAR A FLAG FOR LATER
BURY1: MOV #TPBF,D ;THE FLAG TO CHANGE
BR TRACE2 ;DO IT
STEP: MOV PC,TF6 ;SAY WE ARE TURNING ON STEP
BR STEP1
ESTEP: CLR TF6
STEP1: MOV #TPSF,D ;THE FLAG FOR STEPPING
BR TRACE2
TRACE: MOV PC,TF6
BR TRACE1
ETRACE: CLR TF6 ;CLEAR THE TRACE
TRACE1: MOV #TPTF,D ;THE TRACE FLAG
TRACE2: JSR PC,GTUOEB ;GET THE OBLIST ELEMENT INTO B
BNE TRCSYS ;WASN'T USERS PROC, GET A SYSTEM WORD
JSR PC,CSSTF ;SET THE CORRECT FLAG FOR PROC IN B
BNE TRCDON ;DONE WITH THIS
TRAERR: ERROR+PNH ;NO PROCEDURE TO DO THIS WITH
TRCSYS: CMP #SFUN,A ;IS IT A SYSTEM FUNCTION
BNE TRAERR ;NOPE
.IFNZ ENG
CMP #$ALL,B ;IS IT TRACE ALL?
BEQ TRCALL ;YES
.ENDC
.IFNZ FR
CMP #$TOUT,B ;IS IT TRACE TOUT?
BEQ TRCALL ;YES
.ENDC
ERROR+ERW ;TRACE WHAT?????
TRCALL: JSR PC,GNOLEI ;INIT GET NEXT USER OBLIST ELEMENT
TRCAL1: JSR PC,GNOLE ;GET THE NEXT ELEMENT
BEQ TRCDON ;FINISHED
CMP #TPBF,D ;IS IT AN ERASE BURY?
BEQ TRCAL3 ;YES, DO IT REGARDLESS, ELSE IF PROC'S ARE BURRIED, DONT
;TOUCH THEM
JSR PC,BURYQ ;IS IT BURIED?
BEQ TRCAL1 ;YES, DONT TOUCH THEM
TRCAL2: JSR PC,CSSTF1 ;SET OR CLEAR THE APPROPRIATE FLAG
BR TRCAL1 ;NEXT!!
TRCAL3: JSR PC,CSSTF ;CLEAR THE BURY FLAG
BR TRCAL1
TRCDON: SEZ
RTS PC
;THIS ENTRY SETS OR CLEARS A FLAG IN D, ACCORDING TO TF6, PROC POINTED TO BY UOE IN B
;CSSTF1 DOES THE SAME, EXCEPT WITH POINTER TO PROC IN B
CSSTF: JSR PC,.BINDF ;GET THE FUNCTION BINDING IN B
BEQ TRCDON ;FAILED MISERABLY
CSSTF1: MOV B,A ;GET POINER TO ARRAY INTO A
ADD #HEADER+2,A ;POINT TO THE FLAGS FOR THIS PROC
BIC D,(A) ;CLEAR THE FLAG
TST TF6
BEQ 1$ ;NO, FINE
BIS D,(A) ;WELL SET IT AFTER ALL
1$: CLZ
RTS PC
;THIS RETURNS WITH Z SET IF THE PROCEDURE IS BURRIED, B GETS CLOBBERED TO POINT TO THE
;ARRAY'S ADDRESS
BURYQ: PUSH A
SPUSH B
SPUSH C
JSR PC,.BINDF ;GET THE BINDING IF IT EXISTS
BEQ BURYQ1 ;NO PROCEDURE
MOV B,2(P) ;RETURN THIS POINTER
BURYQ3: BIT #TPBF,HEADER+2(B) ;IS THE BURY BIT ON?
BEQ BURYQ2 ;NO, RETURN WITH Z CLEARED
BURYQ1: JMP RETC
BURYQ2: JMP SRETC
BURYQX: PUSH A
SPUSH B
SPUSH C
JSR PC,.BINDF ;GET THE BINDING
BEQ BURYQ1 ;NO PROCEDURE
BR BURYQ3 ;OTHERWISE DO A PROBLEM
.IF NZ DEBUGR
STRACS: BIT #TRACEF,FLAGS2
BEQ STRA2
SPACE
BR STRA1
STRACE: BIT #TRACEF,FLAGS2 ;SYSTEM TRACE
BEQ STRA2
STRA1: INC NBKTS
PUSH A
PRTXT ^/CT=/
BIC #DPQF,FLAGS2
JSR PC,PRCT
PRTXT ^/ CO=/
JSR PC,PRCO
PRTXT ^/ S=/
BIC #DPQF,FLAGS2
JSR PC,PRS1
PRCR
CLR NBKTS
POP A
STRA2: RTS PC
SETSTF: BIS #TRACEF,FLAGS2 ;SET SYSTEM TRACE FLAG
BR SEZRTS
CLRSTF: BIC #TRACEF,FLAGS2
BR SEZRTS
.ENDC
FLEV: MOV FUNLEV,B ;RETURN USER PROC CALL DEPTH
FLEV1: JMP R1NARG
NODES: ;OUTPUT NO. OF NODES IN FREE STG LIST
MOV NNIFSL,B
BR FLEV1
.SBTTL UTILITY ROUTINES
.GLOBL ALEVN,CTYO1,LVERNF,RNSEED ;144
.GLOBL DEBSW,SECRET,SETTTY,TINECH ;145
.GLOBL .CLOS0,DELTMP,ERRORN,ERTAB,FBUG,RESTTY,SETCH0 ;146
.GLOBL ERRPT,NOADDR,ROTTAB ;147
.GLOBL ERCLR1,ERCLR2 ;148
.GLOBL BRKMOF,DSKERW,ENGDER,MUCWRD,NAME ;149
.GLOBL PPOPL,PPUSHL,SPOPL ;150
.GLOBL PDLEMR,POPLM,PPDLCP,PPEMR,PPLIMT,PSWPAD ;151
.GLOBL SPEMR,SPLIMT,SPOPLM,SSWPAD ;152
.GLOBL SPDLCP ;153
.GLOBL INLEN ;161
.GLOBL LNTB ;162
.GLOBL OOT ;163
.GLOBL BMT,GCBITS ;164
.GLOBL LMT,MKDC,SPMSWP ;165
.GLOBL GCMKL,PALETT,PALMAX ;168
.GLOBL DFLAGS,DSGCF ;169
.GLOBL LUNN,NNGC,NODTOP ;170
.GLOBL EXNODE ;171
VERSN: MOV LVERNF,B
BR RANDO1
RANDOM:
MOV RNSEED,B ;GET OLD SEED
MUL #71275,B ;MUL SEED BY GOOD NUMBER!!
ADD #13713,B ;ADD ANOTHER GOOD NUMBER!! TO LOW ORDER PART
MOV B,RNSEED ;THIS IS THE NEW SEED
MOV B,A
MUL #10.,A ;MULTIPLY IT BY 10
MOV A,B ;HIGH-ORDER PART IS THE DESIRED DIGIT
ADD #5,B
RANDO1: JMP R1NARG
BELL: MOV #7,B
JMP CTYO1
DEBUG: TST ALEVN
BEQ DEBUG1
PRTXTC ^\OFF\
CLR ALEVN
JMP TOPLEVEL
DEBUG1: PRTXTC ^\ON\
MOV #1,ALEVN
BR SEZRTS
SGCF: JSR PC,CKSST
BIS #MGCF,FLAGS2
SEZRTS: SEZ
RTS PC
CGCF: JSR PC,CKSST
BIC #MGCF,FLAGS2
BR SEZRTS
STATUS: BIT #SSF,FLAGS2
BNE STATU2 ;IF ON TURN OFF
JSR PC,TINECH
JSR PC,RDSTR ;READ A STRING
BEQ STATU2 ;EMPTY OR BREAK
MOV @S,B ;SEE IF EQUAL TO "SECRET
MOV #SECRET,C
JSR PC,EQ.TXT
BEQ STATU1 ;NOPE
BIS #SSF,FLAGS2 ;YES
POPS A ;POINTER TO STRING READ IN
PRTXTC ^\ON\
BR STATU3
STATU1: POPS A
STATU2: PRTXTC ^\OFF\
BIC #SSF,FLAGS2
STATU3: JMP SETTTY
CKSST: TST DEBSW
BNE CKSST1
BIT #SSF,FLAGS2
BEQ CKSST9
CKSST1: RTS PC
CKSST9: ERROR+HNM
SPNF: BIS #PNNLF,FLAGS2
BR SEZRTS
CPNF: BIC #PNNLF,FLAGS2 ;CLEAR IT
BR SEZRTS
COMT: .BUG. ;GNT SHOULD SWALLOW ALL COMMENTS;
.SBTTL ERRORS AND HANDLER
EMTBRK: MOV #SRET,(P) ;PRETEND TO FAKE SOMETHING OUT
RTT
ERRBRK:
ERRBK: LDFPS #40300
JSR F,CACSAV ;SAVE THE AC'S
TST REDFLG ;READING?
BEQ ERRBK1 ;NO
.IF NZ FILDSK
JSR PC,SETCH0
JSR PC,.CLOS0 ;GO CLOSE INPUT FILE
.ENDC
TST TOPRNM ;STILL DEFINING A PROCEDURE?
BEQ ERRBK1 ;NOPE
JSR PC,END ;WELL, FINISH IT UP
ERRBK1: CLR GCPREV ;DELETE PENDING WORD AND SENTENCE COMMANDS
.IIF NZ FILDSK, JSR PC,DELTMP ;DELETE THE CAPABILITY TO THE FILE
TST TOPRNM ;DEFINING PROC?
BEQ 1$ ;NO
MOV #'>,PRMTCH ;PROMPT WITH ">"
BR 2$
1$: MOV #'?,PRMTCH ;PROMPT WITH A "?"
2$: JSR PC,RESTTY ;RESTORE THE TTY STATUS
MOV #TYI,GCHR ;GET CHARACTERS FROM THE TTY NOW
MOV #TYO,PCHR ;AND PRINT TO THE TTY
MOV 6*2(P),A ;GET THE TRAP ADDRESS
MOV A,LASTER ;AND SAVE IT
SUB #2,A ;POINT TO THE TRAPPING CALL
JSR PC,GETAML ;GET IN A MEMORY LOCATION POINTED TO BY A
BIC #177600,A ;GET THE TRAP CODE
MOV A,ERRORN ;SAVE THE ERROR NUMBER
ASL A ;TURN IT INTO AN INDEX
MOV ERTAB(A),ERRPNT ;GET THE POINTER TO THE ERROR MESSAGE
CLR NLINEL ;NO ERROR LINE YET
CLR NPROCL ;CLEAR THE PROCEDURE ALSO
MOV BRAKE,BRAKEL ;SAVE THE STATE OF THE BREAK FLAG
TST FUNLEV ;IN A PROCEDURE?
BEQ 3$ ;NOPE
MOV CPP,NPROCL ;THE ERROR PROCEDURE
MOV CPLN,NLINEL ;SAVE THE LINE ERROR CAME FROM
3$: TST ERPROC ;ERROR SET?
BEQ ERRNOT ;NOPE
CMP A,#BUG*2 ;IS IT BUG?
BEQ ERRNOT ;YES, DONT ALLOW ERRSET
CMP A,#FBUG*2 ;SAME WITH FBUG?
BEQ ERRNOT
;FALLS THROUGH TO NEXT PAGE
;FALLS IN HERE
SPUSH BRAKE ;SAVE THIS
CLR BRAKE ;ERROR PROCEDURES DONT RUN UNDER THE SHADOW OF BRAKE
JSR PC,SAVEVL ;SAVE THE STATE OF THE WORLD
PUSH #0 ;MAKE IT LOOK LIKE A PROCEDURE CALL
JSR PC,SAVPPS ;AND SAVE THE PDLS
BIS #1,CPDLP ;SAY PROCEDURE PUSH
BIS #1,CSPDLP ;SAY AND ERRORSET PUSH (NOT NEEDED I THINK)
BIC #DORF,FLAGS ;NOT A DO OR READ FRAME
BIS #ERRF,FLAGS ;SAY WE HAVE AN ERROR!!!!
MOV ERPROC,CO ;MAKE IT THE CURRENT PROCEDURE
CLR ERPROC ;DONT ALLOW THIS TO BE ERRSET YET
JSR PC,PEVAL ;EVALUTATE THE PROCEDURE
BEQ ERRNT1 ;NO OUTPUT, JUST DO WHAT WE WERE GOING TO
JSR PC,PRS1 ;PRINT THE OUTPUT
JSR PC,RESPPS ;RESTORE PDLS
TST (P)+ ;POP NUMBER OF ARGS
JSR PC,RESEVL ;AND RESTORE EVAL
MOV B,FLAGS ;PUT BACK THE FLAGS
BR DEBUGL ;POP OFF EVERYTHING, AND RETURN
ERRNT1: JSR PC,RESPPS ;RESTORE THE PDLS
TST (P)+ ;POP OFF NUMBER OF ARGS
JSR PC,RESEVL ;AND GET BACK EVAL...
MOV B,FLAGS ;RESTORE THE FLAGS
SPOP BRAKE ;GET BACK BRAKE
ERRNOT: TST NOADDR ;ANY PRINT OCTAL ADDRESS?
BNE ERNOT1 ;NO
MOV LASTER,A ;GET THE ERROR ADDRESS
JSR PC,PRONL ;AND PRINT IT
SPACE ;WITH A SPACE
ERNOT1: JSR F,CACRES ;RESTORE THE AC'S
MOV ERRPNT,ERRPT ;GET THE ERROR MESSAGE POINTER
.IFZ NOERTX
ADD #6,ERRPT ;POINT TO THE START OF THE ERROR MESSAGE
.IFNZ ENG&FR
BIT #FRFLG,LANG ;IN FRENCH?
BEQ ERPRLP ;NO
INC ERRPT ;LOOK BACKWARDS FOR THE FIRST ZERO BYTE
1$: JSR PC,GETERB ;GET ERROR BYTE IN D
TSTB D
BNE 1$
INC ERRPT ;WE HAVE BACKED UP OVER THE FRENCH ERROR, NOW PRINT IT
.ENDC
ERPRLP: JSR PC,GETERB ;GET THE NEXT BYTE OF ERROR MESSAGE
INC ERRPT ;POINT TO THE NEXT BYTE
TST D
BEQ DEBUGL ;DONE PRINTING, DO THE RIGHT THING NOW
BLT ERPRL1 ;IS A CONTROL BYTE FOR A ROUTINE TO RUN
JSR PC,TYO ;OUTPUT THE CHARACTER
BR ERPRLP ;AND LOOP BACK
ERPRL1: BIC #177600,D ;IT IS THE WORD OFFSET INTO A TABLE, CLEAR THE SIGN EXTEND
ASL D ;INTO A WORD OFFSET
MOV ROTTAB(D),A ;THE ROUTINE TABLE
INC NBKTS ;PRINT BRACKETS
JSR PC,(A) ;CALL THE ROUTINE
BR ERPRLP ;AND ADVANCE THE POINTER
.IFF
MOV #4,A
1$: JSR PC,GETERB
BEQ 2$
JSR PC,TYO
INC ERRPT
SOB A,1$
2$: CMP ERRORN,#BRK ;IS IT BREAK?
BNE DEBUGL ;NO, IGNORE IT
JMP BRK.R ;PRINT BREAK OR PAUSE
.ENDC
PPLACE: MOV FUNLEV,A ;GET THE LEVEL DEEP
BEQ PPLAC1 ;DONT PRINT IT AT TOP LEVEL
STLANC
ENGINS <CPRTXT ^\AT LEVEL \>
ENDENG
FRINS <CPRTXT ^\AU NIVEAU \>
ENDLAN
JSR PC,PRDN ;PRINT THE LEVEL
STLANC
ENGINS <PRTXT ^\ LINE \>
ENDENG
FRINS <PRTXT ^\ LIGNE \>
ENDLAN
MOV CPLN,A ;GET THE CURRENT LINE NUMBER
JSR PC,PRDN ;AND PRINT IT
STLANC
ENGINS <PRTXT ^\ IN \>
ENDENG
FRINS <PRTXT ^\ DE \>
ENDLAN
MOV CPP,B ;THE CURRENT PROCEDURE NAME
JSR PC,PPNAME ;AND PRINT IT
PPLAC1: JMP .CRLF ;AND PRINT CR-LF
DEBUGL: JSR PC,PPLACE ;PRINT THE PLACE
CLR BRAKE ;NO BREAK
TST ALEVN ;SHOULD WE REALLY ENTER A BREAK LOOP?
BEQ TOPLEVEL ;NOPE, POP AWAY JOE!!
DBUGL1: TST FUNLEV ;TOP LEVEL?
BEQ TOPLEVEL ;YES, JUST FORGET IT
JSR PC,SAVEVL ;SAVE EVAL (AGAIN)
PUSH #0 ;OH WELL, PUSH NUMBER OF ARGS
JSR PC,SAVPPS ;SAVE THE PDLS AGAIN
BIS #1,CPDLP ;SAY THIS IS A PROCEDURE PUSH
BIC #DORF,FLAGS ;NOT DO OR READ FRAME
BIS #ERRF!BRKF,FLAGS ;SAY ERROR, AND BREAK LOOP
JMP MLOOP ;OH WELL, GIVE HIM THE TTY!!!
TOPLEVEL:
TST FUNLEV ;IN A PROCEDURE?
BEQ 1$ ;NO, JUST CLEAN UP OTHER RANDOM FRAMES
MOV #TOPLEVEL,PSTOPR ;KEEP GOING TO TOPLEVEL
JMP PSTOP1 ;AND STOP THIS PROCEDURE
1$: BIT #DORF,FLAGS ;IN A DO OR READ FRAME?
BEQ ERTL3 ;NO, MUST BE AT TOP LEVEL NOW
MOV #1$,DOFRET ;THE PLACE TO RETURN TO
JMP POPVAR ;AND POP THIS FRAME
ERTL3: CLR A ;CLEAR OUT THE PDLS
JSR PC,PPTA ;POP THE P TO THE BASE OF THE STACK
CLR A
JSR PC,PSTA ;POP THE S PDL TO THE BASE OF THE STACK
CLR CSPDLP ;NO PDL OFFSETS
CLR CPDLP
MOV #ERCLR1,A ;THE START OF THE AREA TO CLEAR
MOV #<ERCLR2-ERCLR1>/2,B ;THE LENGTH IN WORDS OF THE AREA TO CLEAR
3$: CLR (A)+ ;CLEAR IT OUT
SOB B,3$
BIC #ERRF+BRKF,FLAGS ;CLEAR ALL SORTS OF RANDOM FLAGS
JMP MLOOP ;AND GO TO TOP LEVEL
FBUGB: BPT ;BREAK ON A FATAL BUG
JMP TOPLEVEL ;TRY TO RECOVER
BRK.R: MOV BRAKE,A ;THE BREAK FLAG
CLR BRAKE ;CLEAR IT
SPUSH MUCWRD ;SAVE THE MUSIC STATUS WORD
.IIF NZ SITS, JSR PC,BRKMOF ;TURN OFF THE MUSIC BOX IF HE HAS IT
SPOP MUCWRD ;AND RESTORE IT
TST A ;IS IT CONTROL-Z?
BLT PAUS.R ;YES
STLANC
ENGINS <PRTXT ^\STOPPED!!\>
ENDENG
FRINS <PRTXT ^\ARRET\>
ENDLAN
JMP DEBUGL ;GO EITHER RETURN TO TOPLEVEL, OR ENTER BREAK LOOP
PAUSE:
PAUS.R: PRTXT ^\PAUSE\
JSR PC,PPLACE ;PRINT THE PLACE
JMP DBUGL1 ;AND ENTER BREAK LOOP
BUG.R: PRTXT ^\HELP!!! LOGO BUG VERSION #\
MOV #VERNF,A ;GET THE VERSION NUMBER
JSR PC,PRDN ;PRINT IT
SPACE ;PRINT A SPACE
TST DEBSW ;BEING DEBUGGED?
BEQ BUGBP1 ;NO
BUGBPT: BPT
BUGBP1: MOV LASTER,A ;GET THE ADDRESS
JSR PC,PRONL ;PRINT IT
JMP DEBUGL ;AND ENTER DEBUG LOOP
CTIT.R: MOV TOPRNM,B ;GET THE PROCEDURE NAME
JMP PPNAME ;AND PRINT IT
HNM.R: MOV B,A ;THE THING THAT HAS NO MEANING
BIC #7777,A ;GET THE TYPE
BIS #DPQF,FLAGS2 ;DONT PRINT " FOR AN ATOM
CMP A,#UFUN ;USER FUNCTION OR SYSTEM FUNCTION
BLOS 1$ ;YES
JMP PRPNM1 ;PRINT THE OTHER
1$: JMP PROAB ;PRINT THE NAME OF THE FUCTION
WTIB.R: MOV B,A ;LINE NUMBER SHOULD BE IN A
JMP PRDN ;AND PRINT IT
TDE.R: MOV E,A ;TERMINAL NUMBER
JMP PRDN ;PRINT THE NUMBER
PAE.R: MOV #UFUN,A ;THE TYPE
MOV TEMP,B ;THE NAME OF THE PROCEDURE
RTS PC ;AND RETURN
WTAA.R: PUSHS A ;PUSH THE OUTPUT
RTS PC
WTAB.R: PUSHS B ;PUSH IT ALSO
RTS PC
NCF.R: MOV TOPS2,A ;WAS THERE A TAG?
BNE 1$
MOV #LSTR,A ;PRINT EMPTY WORD
1$: PUSHS A ;TAG WE WERE LOOKING FOR
RTS PC
.SBTTL MISC ROUTINES
.GLOBL PPSWPO,PPSWPI
CACSAV: JSR PC,PPUSHT ;CAREFUL AC SAVE
ACSAV: MOV E,-(P)
MOV D,-(P)
MOV C,-(P)
MOV B,-(P)
MOV A,-(P)
JMP (F)
CACRES: JSR PC,PPOPT ;CAREFUL AC RESTORE
ACRES: TST (P)+
MOV (P)+,A
MOV (P)+,B
MOV (P)+,C
MOV (P)+,D
MOV (P)+,E
RTS F
PPUSHT: CMP P,PPUSHL
BLOS 1$
RTS PC
1$: JMP PPSWPO ;PDL REALLY OVERFLOWED
PPOPT: CMP P,PPOPL
BHIS 1$
RTS PC
1$: JMP PPSWPI
SPUSHT: SUB #2,S
CMP S,SPUSHL
BLOS 1$
RTS PC
1$: JMP SPSWPO
SPOPT: ADD #2,S
SPOPT1: CMP S,SPOPL
BHI 1$
RTS PC
1$: JMP SPSWPI
.SBTTL P AND S PDL POPPERS
PPTA: ;POP PP PDL TO (A) RELATIVE
;USES A,F
SPOP F
PPTA1: CMP A,PRBAO
BHIS PPTA3
MOV PPOPL,P
JSR PC,PPSWPI
BR PPTA1
PPTA3: SUB PRBAO,A
SUB IP,A
NEG A
CMP A,P
BHIS 1$
ERROR+FBUG ;OVER POPPING
1$: MOV A,P
JSR PC,PPOPT
JMP (F)
PSTA: ;POP S PDL TO (A) RELATIVE
;USES A
CMP A,SPRBAO
BHIS PSTA3
MOV SPOPL,S
JSR PC,SPSWPI
BR PSTA
PSTA3: SUB SPRBAO,A
SUB IS,A
NEG A
CMP A,S
BHIS 1$
ERROR+FBUG ;OVER POPPING
1$: MOV A,S
JMP SPOPT1
MLOOP: JSR PC,GETSTR
JSR PC,MREAD
BEQ MLOOP ;NO TOKEN LIST
JSR PC,EVLINE
BEQ MWDW
BR MLOOP ;LOOP BACK
MWDW: ERROR+WDW ;WHAT SHOULD I DOO WITH (S)
.SBTTL GET A STRING
GETSTR:
GETST0: JSR PC,RDSTR ;GET THE CHARACTERS FOR THE LINE INTO AN LSTR
BNE GETST1 ;GOT SOMETHING
TST RBRKF
BEQ GETST0 ;NOTHING, TRY AGAIN
ERROR+BRK ;ERROR OUT
GETST1: RTS PC
;CURRENT LINE POINTED TO BY A
LINSTP: PUSH GCHR ;SAVE THE PRINTING AND RECIEVING WORLD
SPUSH PCHR
SPUSH PRMTCH ;SAVE THE PROMPT CHARACTER
CLR PRMTCH ;DONT PROMPT AT ALL
MOV #TYI,GCHR ;RECIEVE CHARACTER FROM THE TTY
MOV #TYO,PCHR ;AND PRINT THE LINE THERE
MOV A,F ;GET THE POINTER TO THE CURRENT LINE
JSR PC,PRLN ;AND PRINT IT OUT
JSR PC,RDSTR ;READ A STRING
BEQ LINST1 ;EMPTYP, MIGHT BE A BREAK RECIEVED
POPS A ;IGNORE LINE TYPED IN
LINST2:
POP PRMTCH ;POP PROMPT AND REST OF WORLD
SPOP PCHR
SPOP GCHR
RTS PC
LINST1: TST RBRKF
BEQ LINST2 ;NOPE
POP PRMTCH ;NEED THE PROMPT CHARACTER
ERROR+BRK ;AND ERROR OUT
.SBTTL MORE READ ROUTINES!!!
MREAD:
MREAD1: CLR ILINEL
JSR PC,READ ;CONVERT CHAR STRING TO TOKEN LIST
BEQ MRD4 ;NO TOKENS
POPS A
MOV A,ILINEL ;GC PROTECT THIS CRUFT
JSR PC,WRTLIN ;WRITE LINE INTO THE COMMAND BUFFER
CLZ
MRD4: RTS PC
CKSTG: ;CKECK IF DISC OR NODES ARE ALMOST GONE
BIT #DSAMFL,FLAGS2
BNE CKSTG1
CMP NNIFSL,#NBN
BHIS MRD4
JSR PC,.GCOLL ;GC AND EXPAND IF NEEDED
CMP NNIFSL,#NBN
BHIS MRD4
CKSTG1: CLR ERPROC
ERROR+NSL
;WRITE LINE POINTED TO BY A INTO COMMAND BUFFER
WRTLIN: MOV #CURLIN+4+HEADER,C ;POINTER TO THE CURRENT LINE
CLR D ;COUNTER OF TOKENS
WRTLOP: JSR PC,.LOADA ;GET THE FIRST NODE IN A,,B
MOV B,(C)+ ;WRITE IT INTO THE BUFFER
INC D ;ONE MORE TOKEN
BIT #7777,A ;DONE?
BEQ WRTDON ;YES
CMP D,#INLEN ;HAVE WE DONE ALL OF THEM?
BNE WRTLOP ;NO
;HERE THE BUFFER IS FULL
ERROR+NAS ;NOT ENOUGH ARRAY SPACE (SHOULD BE TOO MANY TOKENS)
WRTDON: INC D ;SO THAT WE HAVE A LINE NUMBER
ASL D ;WANT A BYTE COUNT
MOV D,CURLIN+HEADER ;AND PUT IN THE LENGTH
MOV #HEADER,CTP
MOV #CURPNT,CPBND ;MAKE CPBND POINT TO SOMETHING
;THAT ALWAYS HAS CURLIN
RTS PC
.SBTTL EVAL 1 LINE
;EVAL THE LINE ON THE S PDL,
;IN THE NEW SCHEME, EVAL THE LINE POINTED TO BY CTP
EVLINE:
;THIS IS A SUPER HACK TO MAKE CONTINUE WORK (SORT OF)
TST BRAKE
BEQ 2$
ERROR+BRK
2$:
BIC #EVIFS,FLAGS
CLR CO
CLR NOR
CLR COF
CLR LO
JSR PC,IGNT
EVLI1: BIT #CRF,FLAGS
BNE EVLI2
TST TOPRNM ;IN PROCEDURE?
BNE EVLI4 ;NO, JUST FORGET IT
EVLI6: JSR PC,EVAL
BEQ EVLI3 ;NO OUTPUT, OK
JSR PC,CKSTG
SEZ
RTS PC
EVLI3: JSR PC,CKSTG
BIT #CRF,FLAGS
BNE EVLI2
JSR PC,GNT
BIS #RTF,FLAGS
BR EVLI1
EVLI4: BIC #7777,A
CMP #SNUM,A
BEQ EVLI5 ;AN SNUM
CMP #INUM,A
BEQ EVLI8 ;AN INUM
CMP #LSTR,A
BNE EVLI6 ;NOT AN SNUM, INUM OR LSTR
JSR PC,.CLSIN ;CONVERT LSTR TO INUM
BEQ EVLI6 ;NOT NO. OR TOO BIG
EVLI8: BIT #SPDF,FLAGS ;IS THIS PROC DEF. BEING SKIPPED?
BNE EVLI2
JSR PC,.CINSN ;CONVERT INUM TO SNUM
BEQ EVLI7 ;TOO BIG
TST B ;IS NO. TOO SMALL?
BGT 1$
ERROR+LNTB
1$: BIC #RTF,FLAGS ;DONT WANT TO REPEAT THIS TOKEN
EVLI5: JSR PC,ADLN
EVLI2: CLZ
RTS PC
EVLI7: ERROR+LNTB ;LINE # TOO BIG
.SBTTL GET NEXT TOKEN
GNT: MOV CT,B ;GET THE OLD CURRENT TOKEN
BIT #RTF,FLAGS ;SHOULD WE REPEAT THIS TOKEN
BEQ GNT1 ;NO
BIC #RTF,FLAGS ;CLEAR THE FLAG
TST B ;END OF LINE?
BNE 1$ ;NO
BIS #CRF,FLAGS ;SAY IT IS
1$: MOV B,A ;COPY IT
RTS PC
GNT1: BIC #PTLPF,FLAGS ;SET FLAG FOR PARENS
CMP #$LLPAR,B ;IS IT "!("
BEQ GNTPAR ;YES, OKAY
CMP #$LPAR,B ;IS IT "("
BNE GNT3 ;NO, LEAVE THE FLAG CLEAR
GNTPAR: BIS #PTLPF,FLAGS ;SET THE PARENS FLAG
GNT3: DEC CLCNT ;DECREMENT THE NUMBER OF TOKENS LEFT ON THIS LINE
BMI GNT2 ;DONE WITH THIS LINE
MOV CTP,A ;GET THE NEXT TOKEN POINTER
ADD @CPBND,A ;MAKE IT UNRELATIVE
MOV (A)+,B ;GET THE TOKEN
ADD #2,CTP ;POINT TO THE NEXT TOKEN
CMP #$COMT,B ;IS IT A COMMENT
BEQ SKPCOM ;SKIP THE COMMENT
GNT4: MOV B,CT ;PUT THE TOKEN INTO CT
MOV B,A ;COPY IT FOR SOME APPLICATIONS
RTS PC
GNT2: BIT #CRF,FLAGS ;AT THE END OF LINE THE TIME BEFORE?
BNE 1$ ;YES, LOSER
BIS #CRF,FLAGS ;SAY AT END OF LINE
CLR B ;SAY NO MORE TOKENS
BR GNT4 ;FINISH UP
1$: ERROR+OOT ;OUT OF TOKENS
SKPCOM: DEC CLCNT ;GET THE NEXT TOKEN
BMI GNT2 ;END OF LINE
MOV (A)+,B ;GET THE NEXT TOKEN
ADD #2,CTP
CMP #$COMT,B ;IS IT A COMMENT?
BNE SKPCOM ;NO, JUST CONTINUE
BR GNT3 ;GET THE NEXT TOKEN
IGNT: MOV CTP,B ;POINTER TO THE START OF THE LINE
ADD #4,CTP ;POINT TO THE FIRST TOKEN IN THE LINE
ADD @CPBND,B ;MAKE IT ABSOLUTE
BIC #CRF,FLAGS ;CLEAR THE END OF LINE FLAG
MOV (B),A ;GET THE NUMBER OF TOKENS IN THIS LINE
ASR A ;FROM BYTES TO WORDS
DEC A ;FOR THE LINE NUMBER
MOV A,CLCNT ;SET UP THE TOKEN COUNT
BEQ GNT2 ;SIGNAL END OF LINE IMEDIATELY
BIS #RTF,FLAGS ;REPEAT THIS TOKEN
BR GNT3 ;CONTINUE WITH THE REST OF THE LINE.
.SBTTL GARBAGE COLLECTOR
MARKNI: SPUSH A
SPUSH B
BR MARKN4
MARKN: SPUSH A ;MARK NODE(B)
SPUSH B
;DEBUGGING FEATURE
JSR PC,.LOAD ;ARE WE MARKING AN IDLE NODE
BIC #7777,A
CMP #IDLE,A
BNE 1$
.BUG.
1$: MOV (P),B
;
MARKN4: MOV B,A
BIC #170000,A
BIC #177770,B
MOVB BMT(B),B
ASH #-3,A
ADD GCBITS,A
BITB B,(A) ;ALREADY MARKED?
BEQ MARKN1 ;NO
MARKN3: SPOP B
SPOP A
SEZ
RTS PC
MARKN1: BISB B,(A)
MARKN2: SPOP B
SPOP A
CLZ
RTS PC
MARKDN: ;SKIP IF NODE (B) IS MARKED
SPUSH A
SPUSH B
MOV B,A
BIC #170000,A
BIC #177770,B
MOVB BMT(B),B
ASH #-3,A
ADD GCBITS,A
BITB B,(A) ;MARKED?
BEQ MARKN3 ;NO
BR MARKN2 ;YES-SKIP
MARKL: PUSH A ;MARK LIST
SPUSH B ;NODE ADDS IN B
SPUSH C
JSR PC,MKLIST
BR MARKV1
MARKV: PUSH A ;MARK VARIABLE
SPUSH B ;NODE ADDS IN B
SPUSH C
CLR A
MOV B,C
JSR PC,MARKF1 ;TREAT POINTER AS A FIRST PTR
MARKV1: SPOP C
SPOP B
POP A
MARKV2: RTS PC
MARKF: MOV A,C ;MARK FIRST OF A DATUM (NODE) IN A,,B
MARKF1: BIT #DSAMFL,FLAGS2
BEQ MARKF2 ;DISK NOT ALMOST FULL
.GLOBL MKSPSW
JSR PC,MKSPSW
CLR ERPROC
.IFNZ NDISP
ADD #2,S ;POP SNLIST OFF S PDL
.ENDC
ERROR+NSL
MARKF2: ASH #-11.,C
BIC #177741,C ;GET THE DATA TYPE
JMP @LMT(C) ;WHICH YOU MIGHT MARK ON
.IFNZ NDISP
MKSNAP: JSR PC,MKDC ;MARK DISPLAY CODE
.ENDC
MKLIST: BIT #7777,B ;IS THIS NODE REALLY HERE?
BEQ MARKV2 ;NO. RETURN
MKL1: PUSH A ;SAVE BUTFIRST OF CURRENT (I.E. PARENT) NODE
JSR PC, MARKN ;MARK NEXT NODE
BEQ MKL2
JSR PC,.LOAD ;GET NEXT NODE
JSR PC,MARKF ;MARK FIRST OF NEW NODE
JSR PC,MARKBF ;MARK BUTFIRST OF NEWTHIS NODE
MKL2: POP A
RTS PC
MKATOM: ;MARK ATOM CELL BUT NOTHING INSIDE IT
MKINUM: JMP MARKNI
GCDIE: ERROR+FBUG
MARKBF: BIT #7777,A ;MARK BUTFIRST OF LIST
BEQ MARKV2 ;AT END OF LIST
MKBF1: MOV A,B
JSR PC, MARKN ;MARK NEXT NODE
BEQ MARKV2 ;ALREADY MARKED, QUIT
JSR PC,.LOAD ;GET NEXT NODE
JSR PC,MARKF ;MARK FIRST OF NEW NODE
BR MARKBF ;MARK BUTFIRST OF NEW NODE
GCOLL:
.GCOLL: JSR F,ACSAV
.IF NZ METERS
SPUSH METERP
MOV #MTGCOL,METERP
TST MTFLAG
BNE 1$
INC MTGCCN
1$:
.ENDC
PUSH GNCN
SPUSH GNCN+2
SPUSH TMPBLK
JSR PC,LSBITM ;ON THE LSI IT MAY BE NESSECARY TO MAP IN THE BIT TABLE
.GCOL2: MOV GCBITS,A ;GARBAGE COLLECT
MOV #GCBTL/2,B ;CLEAR BIT TABLE
.GCOL1: CLR (A)+
SOB B,.GCOL1
;NOW MARK EVERYTHING POINTED BY OBLIST. DONT MARK OBLIST NODES YET
JSR PC,GNOLEI
MKUOBJ: JSR PC,GNOLE ;GET NEXT UOE PTR
BEQ MKTPS
MOV B,C
JSR PC,.LOADC ;GET THE NODE
MOV A,C
MKUOE: BIT #7777,C ;ONE OTHER NODE?
BEQ MKUOBJ ;NO
MOV C,B ;YES
JSR PC,MARKN ;MARK IT
JSR PC,.LOADC
MOV A,C
BIC #7777,A
CMP #FBIND,A
BEQ MKFB ;FUNCTION BINDING
CMP #VBIND,A
BEQ MKVB ;VARIABLE BINDING
CMP #ABIND,A
BEQ MKARR
CMP #SVBIND,A
BEQ MKSVB ;SWAPPED VB
CMP #DBIND,A ;DELETED PROC BINDING?
BEQ MKFB ;MARK LIKE REGULAR PROCEDURE BINGING
ERROR+FBUG ;BUG
MKVB: JSR PC,MARKV ;MARK VARIABLE
BR MKUOE
MKSVB: BR MKUOE
MKARR: TSTB 5(B) ;IS IT A POINTER ARRAY?
BNE MKUOE
MOV B,F ;POINT TO BEG OF ARRAY
MOV 2(B),-(P) ;PUSH COUNT
SUB #HEADER,(P)
ASR (P)
ADD #HEADER,F
MKAR1: MOV (F)+,B
JSR PC,MARKV
DEC (P)
BNE MKAR1
TST (P)+
BR MKUOE
MKFB: SPUSH C ;POINTS TO NEXT BINDING
SPUSH E ;USED BY GNOLE
MOV PROEND(B),F ;THE END OF THE PROCEDURE
ADD B,F ;MAKE IT ABSOLUTE POINTER
MOV B,D ;POINTER TO THE START OF THE PROCEDURE
ADD #HEADER,D ;POINT TO THE FIRST LINE OF THE PROCEDURE
MOV D,E ;SHOULD BE POINTER TO START OF NEXT LINE
MKLINE: CMP D,F ;AT THE END OF THE PROCEDURE?
BEQ MKFBD ;YES, JUST CONTINUE WITH NEXT BINDING
BHI MKFBUG ;BUGGY IF WE ARE PAST IT
ADD (E)+,E ;POINT TO THE START OF THE NEXT LINE
ADD #4,D ;POINT TO THE START OF THE ELEMENTS FOR THIS LINE
MKNTOK: CMP D,E ;ARE WE AT THE END OF THIS LINE?
BEQ MKLINE ;YES, TRY THE NEXT LINE
BHI MKFBUG ;ERROR IF WE ARE BEYOND THIS POINT
MOV (D)+,B ;GET THE VARIABLE TO MARK
MOV B,C ;COPY IT FOR THE TYPE
JSR PC,MARKF1 ;MARK THE FIRST OF IT (THE WHOLE TOKEN)
BR MKNTOK ;NEXT TOKEN
MKFBD: SPOP E ;POINTER TO NEXT OBLIST ELEMENT
SPOP C
BR MKUOE ;MARK THE NEXT BINDING FOR THIS ATOM
MKFBUG: ERROR+FBUG
;MARK FROM GCMKL LIST
MKTPS: MOV #GCMKL,F
MKRNDM: MOV (F)+,B ;POINTER TO POINTER
BEQ MKSPDL ;LAST ONE
MOV (B),B ;REAL NODE ADDRESS
BEQ MKRNDM ;NOTHING THERE
BIT #170000,B ;IS TYPE FIELD BLANK
BEQ MKRND1 ;YES, MAKE IT LIKE LIST
JSR PC,MARKV ;MARK VARIABLE
BR MKRNDM
MKRND1: JSR PC,MKL1
BR MKRNDM
MKSPDL: MOV IS,E
MKSP1: MOV -(E),B ;GET A S PDL WORD
CMP E,S ;END OF S PDL?
BLO MKSP2 ;YES
JSR PC,MARKV ;MARK S PDL WORD
BR MKSP1
.GLOBL MKSSP
MKSP2: JSR PC,MKSSP ;MARK THE SWAPPED PART OF THE S PDL
.IFNZ COLOR
MKPALETTE: ;Mark the palette.
MOV #PALETTE, E
MOV #PALMAX, F
MKPALUP:
MOV (E)+, B
JSR PC, MARKV
SOB F, MKPALUP
.ENDC
;OK, NOW MARK ALL UOE'S THAT POINT TO FUNCION OR VARIABLE BINDING
JSR PC,GNOLEI
MKOBL: JSR PC,GNOLE ;GET NEXT UOE PTR IN B
BEQ MKOBL6 ;NONE LEFT
MOV B,C
JSR PC,.LOADC ;GET THE PNAME NODE
MOV B,D
BIT #7777,A ;DOES IT POINT TO ANYTHING?
BNE MKOBL2 ;YES, MARK IT
MOV C,B ;NO WAS IT MARKED?
JSR PC,MARKDN
BEQ MKOBL3 ;NO - LINK IT OUT
BR MKOBL7 ;YES - ALSO MARK PNAME & BUCKET PTR
MKOBL2: ; - MARK THE UOE ETC.
MOV C,B ; -THE UOE NODE
JSR PC,MARKN
MKOBL7: MOV D,B ; -THE PNAME LSTR
JSR PC,MARKL
MOV GNCN+2,B ; -THE BUCKET LIST NODE
JSR PC,MARKN
BR MKOBL
;THIS UOE IS NOT MARKED AND POINTS TO NOTHING - LINK IT OUT
MKOBL3: MOV TMPBLK,C ;GET PTR TO PREDECESSOR NODE
BNE MKOBL4 ;NONE, SO UHCT WAS PRED.
MOV GNCN,-2(E) ;SO CHANGE IT
BR MKOBL5
MKOBL4: MOV GNCN,A ;CHANGE PTR IN PRED NODE
JSR PC,.STP1
MKOBL5: MOV C,GNCN+2 ;SO GNOLE WILL WORK
BR MKOBL
MKOBL6:
.IFNZ NDISP
BIT #DISPF,DFLAGS ;IF GUY HAS DISPLAY
BEQ GCDIS2
JSR PC,DSGCF ;GCOLL IT, TOO
GCDIS2:
GCDIS:
.ENDC
;FALLS THROUGH
;FALLS IN
;OK NOW RETURN ALL IN MARKED NODES
;RA ADDS OF LIT MAP
;RB NODE ADDS
;RC ACTUAL ADDER OF NODE
;RD BIT MAP
;RE POINT TO LIST OF FREE STORAGE RECYCLED NODES
;RF NUMBER NODES LEFT TO CHECK
;START COLLECTING AT LUNN(LOWEST UNPROTECTED NODE #)
CLR E
CLR NNGC
MOV #NODESP,C ;NODE ZERO ADDRESS
MOV NODTOP,F
SUB C,F ;COMPUTE LEGNTH OF NODESP
ASR F
ASR F ;COMPUTE NUMBER OF NODES
CLR B ;NODE ZERO
MOV GCBITS,A ;BIT TABLE ADDR
GCRT2A: MOV (A)+,D ;GET NEXT WORD OF BIT MAP
SEC
ROR D
GCRT2: BCS GCRT3
CMP B,#LUNN
BLOS GCRT3
TST E ;WE HAVE A FREE NODE; IS FIRST FREE FOUND?
BNE GCRT2B
MOV B,FREE ;NO, THIS IS IT
BR GCRT2C ;(NO LAST-FREE TO UPDATE)
GCRT2B: BIS B,(E) ;ELSE: ,E ;THIS NODE IS NEW LAST-FREE
GCRT2C: MOV C,E
MOV #IDLE,(C)+ ;MAKE NEW IDLE NODE, POINTS NOWHERE
CLR (C)+
INC NNGC
BR GCRT4
GCRT3: CMP (C)+,(C)+
GCRT4: INC B
DEC F
BLE GCRT5
CLC
ROR D
BNE GCRT2
BR GCRT2A
GCRT5: MOV NNGC,NNIFSL
;DEBUGGING FEATURE
BIT #PNNLF,FLAGS2
BEQ GCRT6
CPRTXT ^/[NODES LEFT /
MOV NNGC,A
JSR PC,PRDN
PRTXTC ^/ ]/
;
GCRT6:
GCRT7: POP TMPBLK
SPOP GNCN+2
SPOP GNCN
CMP NNIFSL,#200. ;LESS THAN A BLOCK LEFT
BHIS 1$
MOV NODTOP,-(P) ;SAVE OLD NODTOP
JSR PC,EXNODE ;EXPAND NODE SPACE
MOV (P)+,A
MOV A,B
SUB NODTOP,A
BEQ 1$ ;NOTHING ADDED
NEG A
ASH #-2,A ;NUMBER OF NODES ADDED
ADD A,NNIFSL
ADD A,NNGC
MOV B,C ;OLD NODTOP
SUB #NODESP,B
ASH #-2,B ;NUMBER OF FIRST NODE ADDED
MOV FREE,-(P)
MOV B,FREE
INC B
3$: MOV B,(C)
2$: BIS #IDLE,(C)+
CLR (C)+
INC B
SOB A,3$
SUB #4,C
MOV (P)+,(C)
BIS #IDLE,(C)
1$:
.IIF NZ METERS, POP METERP
JSR F,ACRES
SEZ
RTS PC
.SBTTL GET NEXT OBLIST ELEMENT
GNOLE: ;GET NEXT USER OBLIST ELEMENT - PTR
;INPUT - VIA GNOLEI
;OUTPUT - PTR TO THIS BUCKET IN B & GNCN
; " " NEXT " " GNCN+2
; " " PRED " " TMPBLK
; IF NO PREV BUCKET, TMPBLK = 0
;USES E. SKIPS UNTIL NO UOE PTRS LEFT
PUSH A
MOV GNCN,B
MOV GNCN+2,TMPBLK
GNOLE2: MOV B,GNCN+2
BIC #170000,B
BEQ GNOLE1
JSR PC,.LOAD ;GET NEXT PTR ON BUCKEN LIST
MOV A,GNCN
JMP SRETA
GNOLE1: CLR TMPBLK
MOV (E)+,B ;GET NEXT BUCKET LIST
BGE GNOLE2
JMP RETA ;DONE
GNOLEI: MOV #UHCT,E
CLR GNCN
RTS PC
Reference in New Issue View Git Blame Copy Permalink