; FORTH PROGRAMMING SYSTEM
;Martin S. Ewing, California Institute of Technology,
;Pasadena, CA 91125 213-795-6811
;12/17/77 - REG 16 FREED FOR FORTRAN.
;12/17/77 - RP/IC REG ASSIGNMENTS SWITCHED.
;12/16/77 - ADD SIN,COS,... EXTERNALS TO FORTRAN LIBRARY.
; (MUST NOW USE DUMMY FORTRAN RTN OR MACRO RTN TO LOAD!)
;08/28/77 - ADD "INTERPRET" FOR IN-CORE INTERPRETING.
;03/27/77 - ADD "FORSYS" "NOFORSYS" TO ALLOW SYSTEMS WITHOUT FORSYS.DAT.
;02/21/77 - WORDS "WOPEN", "WCLOSE" ENABLE OPENING BLOCK I/O FOR OUTPUT.
;12/31/76 - MAKE FORSYS.DAT READ ONLY UNTIL FLUSH TIME.
;12/12/76 - FIX UP 'CORE' WORD: TAKE # OF KWDS ON STACK.
RADIX 8
TITLE FORTH PROGRAMMING SYSTEM
SUBTTL ASSEMBLY PARAMETERS
.DIRECTIVE FLBLST ;FIRST LINE BINARY LIST ONLY
SALL
.FORT==0 ;IF DEFINED, INCLUDES FORTRAN LIBRARY RTNS
IFDEF ..FORT <
EXTERN SIN.,COS.,SQRT.,ATAN.,ATAN2.,EXP.
EXTERN IFX.2,ASIN.,CEXP.,FLT.2,ALG10.,ALOG.
>
EXTERN .JBDDT,.JBSA,.JBREN,.JBREL
;Word header format: word 0: LINK ADR, 0
; Word 1: CNT, C0, C1, C2, C3
;(Last bit of word 1 is the precedence.)
;ASSEMBLY PARAMETERS
;TWSEG== 0 ;SIGNAL TWO SEGMENT ASSEMBLY, IF PRESENT
IFDEF TWSEG,<TWOSEG>
PWR== 4 ;LOG BASE 2 OF NUMBER OF DICT. THREADS
NWAY== 1_PWR ;NUMBER OF DICT. THREADS
MSK== NWAY-1 ;CORRESPONDING BIT MASK
KORE=2 ;2K EXTRA CORE
RPSIZ=100 ;RETURN STACK SIZE
DCH=0 ;DISK'S SOFTWARE CHANNEL
CHPWD=4 ;MAXIMUM NUMBER OF CHARACTERS PER FORTH 'WORD'
WDLIM=^D72 ;MAX NUMBER OF CHARACTERS CONVERTIBLE BY "WORD"
;REGISTERS = LOW CORE
R0= 0
R1= 1
R2= 2
R3= 3
R4= 4
R5= 5
R6= 6
R7= 7
V= 10
DP= 11
T= 12
TT= 13 ;NOTE TT MUST = T+1!
SP= 14
IC= 15
;R16 == FORTRAN PARAMETER BLOCK REG.
RP= 17
SUBTTL MACROS
;MACROS TO ASSEMBLE DICTIONARY ENTRIES
DEFINE CODE.(X,NAME< >) <
LK.NEW==.
XWD LK.OLD,0 ;;LINK ADR, 0
LK.T== LK.OLD ;;(TEMPORARY)
LK.OLD==LK.NEW
N==0
IRPC X,<N==N+1> ;;COUNT CHARACTERS IN X
M==N
IFG M-CHPWD,<M==CHPWD> ;;CLIP AT MAX LIMIT
I==0
ZZ==N ;;TOTAL CHARACTER COUNT
IRPC X, < ;;CHARACTER LOOP
I==I+1
IFLE I-4, <
IFLE I-M,<Q.=="X">
IFG I-M,<Q.==" ">
ZZ==ZZ_7+Q.
>
>
REPEAT 4-I,<ZZ==ZZ_7+" "> ;;IF LESS THAN 4 CHARS IN NAME
ZZ==ZZ_1 ;;FINAL ALIGNMENT
ANAME==. ;;REMEMBER PLACE
EXP ZZ
IFNB <NAME>,<NAME:> ;;LABEL IF REQUESTED
> ;;END CODE.
DEFINE IMMED <
QQQQ==.
RELOC ANAME
EXP ZZ!1 ;;SET PRECEDENCE BIT
RELOC QQQQ
>
DEFINE DEF(X,NAME< >) <
CODE.(<X>,<NAME>)
PUSHJ RP,COLON
> ;;END DEF
DEFINE CONST(X,VALUE) <
CODE.(<X>)
HRREI T,VALUE ;;18-BITS ONLY
JRST PUSH1
> ;;END CONST
DEFINE USE(LIST) <IRP LIST,<
EXP LIST>>
DEFINE NEXT <AOJA IC,@0(IC)> ;NOTE IC UPDATED AFTER ADR CALC!
SUBTTL CONSTANTS, INTEGERS, BUFFERS
HEAD: BLOCK NWAY ;FILLED AT ENTRY
STATE: 0
LAST: 0
OPX: 0
DP00: XWD 0,DP0
SP00: XWD -1,SP0
RP00: XWD 0,RP0-1
MSGPTR: POINT 7,MSG
SPLIM: XWD SP0-DP0-40,0 ;-40 FOR SAFETY
OUT: POINT 7,MSG
BASE0: 12 ;DECIMAL ******** NOTE!
DELIM: " "
PREV: BUFF1
ALT: BUFF2
EMPTY: 0
D: 0
L: 0
F: 0
IN: 0
SCR: 0
OKFLG: 0
LWD=400
BUFF1: BLOCK LWD+1 ;LAST WD IS BLOCK NUMBER
0 ;UPDATE FLAG
BUFF2: BLOCK LWD+1
0
OUTMSG: BLOCK 33 ;132 CHARACTERS OUTPUT
MSG: BLOCK 21 ;72 CHARACTERS INPUT
MSGTOP: ASCII/
/
GUARD: 0 ;FOR "WORD" TO INSERT DELIM
DSK: 016 ;.IODPR MODE: DUMP RECORDS, NON-BUFFERED
SIXBIT/DSK/
XWD 0,0
DIN: XWD 0,5 ;EXTENDED FORM FOR LOOKUP
0
SIXBIT/FORSYS/
SIXBIT/DAT/
0
RBSIZ: 0 ;WILL BE LENGTH OF FILE IN WORDS
DOUT: SIXBIT/FORSYS/
SIXBIT/DAT/
0
0
PROGR: IOWD 200,1 ;I/O PROGRAM (DUMMY ADR)
IOWD 200,1 ;TWO '10 BLOCKS PER FORTH BLOCK
0
IOENBL: -1 ;PERMIT OPENING OF FORSYS.DAT
IFDEF TWSEG,<
LOWLIM== .
RELOC 400000> ;SWITCH TO HIGH SEGMENT
OKMSG: ASCIZ/ok/
CRMSG: ASCIZ/
/
FTBL: IFX.2 ;TABLE OF FORTRAN ENTRIES
ALG10.
ALOG.
ASIN.
ATAN2.
ATAN.
CEXP.
COS.
FLT.2
SIN.
SQRT.
EXP.
SUBTTL ABORT, ETC.
LK.OLD== 0 ;ORIGIN OF DICTIONARY
CODE.(QUESTN,QUESTN) ;******** QUESTN
ABORT: HRRZ T,DP
ADD T,[POINT 7,1]
MOVE SP,SP00
MOVE RP,RP00
SETOM EMPTY
SETZM SCR
SETZM STATE
MOVEI TT," "
MOVEM TT,DELIM
MOVEI IC,ABORT2
JRST PUSH1
ABORT2: USE<COUNT,TYPE,LIT.>
POINT 7,[BYTE (7)2,077,040] ;QUESTION MARK
USE<COUNT,TYPE,QUERY>
CODE.(FORSYS) ;******** FORSYS
SETOM IOENBL ;ENABLE OPENING OF FORSYS.DAT
RELEASE DCH, ;IN CASE ALREADY OPEN
JSP R2,OPNR ;OPEN FORSYS.DAT
NEXT ;(DEFAULT)
CODE.(NOFORSYS) ;******** NOFORSYS
SETZM IOENBL ;DISABLE FORSYS.DAT
RELEASE DCH, ;RELEASE CHANNEL
NEXT
SUBTTL OPENING
OPNR: RESET ;FOR START OR RESTART
MOVE TT,IOENBL ;CHECK IF FORSYS
JUMPE TT,(R2) ;IS ENABLED
SETZM DOUT+2
SETZM DOUT+3
MOVE 1,[POINT 7,MSG]
MOVEM 1,OUT ;RE-INITIALIZE OUTPUT PTR
OPEN DCH,DSK ;OPEN DISK FILE (TTY ALWAYS OPEN)
JRST ERR
LOOKUP DCH,DIN
JRST ERR
JRST (R2) ; NOTE USE OF R2
ERR: OUTSTR [ASCIZ /'FORSYS.DAT' cannot be opened for input./]
JRST EOF
CODE.(REOPEN) ;******** REOPEN
JSP R2,OPNR
NEXT
CODE.(WOPEN) ;******** WOPEN
MOVEI R0,0
HRRM R0,DOUT+1
SETZM DOUT+2
SETZM DOUT+3
MOVEI R0,4 ;NUMBER OF RETRIES ALLOWED
WOPL: ENTER DCH,DOUT ;TRY TO OPEN FORSYS FOR OUTPUT
JRST WOPERR ;NO, TRY TO RECOVER
NEXT ;NORMAL OPEN
WOPERR: OUTSTR [ASCIZ/'FORSYS.DAT' unavailable for output. /]
SOSGE R0
JRST ABORT ;CAN'T RECOVER
MOVEI R1,5 ;WAIT 5 SEC.
SLEEP R1,
OUTSTR [ASCIZ/Will try again.
/]
JRST WOPL
CODE.(WCLOSE) ;******** WCLOSE
CLOSE DCH,2 ;CLOSE OUTPUT ON FORSYS
NEXT
SUBTTL TTY ROUTINES
BASE== R0
Q== R1
PTR== R2
OP== R3
CODE.(CONVERT,CONVERT) ;******** CONVERT
JUMPGE SP,ABORT ;UNDERFLOW?
MOVE BASE,BASE0
MOVE Q,T ;SIGNED VALUE
MOVM T,T ;MAGNITUDE
HRRZ PTR,DP
ADDI PTR,^D19 ;ALLOWS ABOUT 64 CHARACTERS
CNV1: IDIV T,BASE
ADDI T+1,"0"
PUSH PTR,T+1
SKIPE T
JRST CNV1
MOVEI T,"-"
SKIPGE Q
PUSH PTR,T ;PUT MINUS IF NEGATIVE
HLRE T,PTR ;??
SUB T,F ;COMPARE AGAINST FIELD LENGTH
JUMPGE T,CNV2
MOVEI Q," "
PUSH PTR,Q
AOJL T,.-1 ;PAD WITH BLANKS
CNV2: HRRZ OP,DP ;REMEMBER DP IS XWD COUNT,ADR
ADD OP,[POINT 7,4] ;(WILL PACK BYTES IN FORWARD ORDER)
MOVEM OP,OPX ;IF NEEDED LATER
HLRZ T,PTR ;COUNT
IDPB T,OP ;GOES IN FIRST BYTE
CAIG PTR,777777
JRST .+4
POP PTR,T ;GET A CHAR
IDPB T,OP ;PACK IT
JRST .-4
MOVE T,OPX ;RETURN A BYTE POINTER
JRST PUT ;PUT STARTING ADDRESS
CODE.(COUNT,COUNT) ;******** COUNT (ILDB)
ILDB T,0(SP) ;LOAD CHAR COUNT,LEAVE BYTE POINTER
;INCREMENTED FOR TYPE.
JRST PUSH1
CODE.(TYPE,TYPE) ;******** TYPE
OP== R1
IP== R0
CAILE T,^D132 ; OVER SIZE?
MOVEI T,^D132 ; YES, CLIP
MOVE OP,[POINT 7,OUTMSG]
MOVE IP,1(SP) ;BYTE PTR TO 1ST CHAR OF MSG
TYPE2: ILDB TT,IP ;TRANSFER BYTES
IDPB TT,OP
SOJG T,TYPE2
MOVEI TT,0
IDPB TT,OP ;END OF MSG
OUTSTR OUTMSG ;OUTSTR IS FASTER THAN OUTCHR
SETZM OKFLG ;INHIBIT OK
JRST POP2
;DEF( CR LF) ------- MANUALLY CODED TO SUIT MACRO-10
LK.NEW== .
XWD LK.OLD,0 ;LINK ADR, 0
LK.OLD== LK.NEW
BYTE (7)2,015,012,040,040(1)1 ;CR,LF,BLANK,BLANK, PRECEDENCE
SKIPE OKFLG ;TYPE OK?
OUTSTR OKMSG
SETOM OKFLG
SETOM EMPTY
JRST CRSND
CODE.(CR) ;******** CR
CRSND: OUTSTR CRMSG ;SEND CR,LF
NEXT
CODE.(QUERY,QUERY) ;******** QUERY
MOVEI IC,GO
MOVE TT,SCR
SKIPGE TT
NEXT ;LOADING FROM CORE (SCR<0)
CAILE TT,2
NEXT ;WE ARE LOAD'ING
SKIPN EMPTY ;NEED NEW MSG BUFFER?
NEXT ;NO
JSP R2,RECEIV
SETZM EMPTY
SETOM OKFLG
NEXT
IP== R0
Q== R1
RECEIV: MOVE IP,MSGPTR
MOVEM IP,IN
MOVEI Q,WDLIM ;CHARACTER LIMIT
INCH: INCHWL TT
CAIN TT,015 ;CAR RETN
JRST RCLF
IDPB TT,IP
SOJG Q,INCH
JRST ABORT ;RUN OUT
RCLF: MOVEI TT," " ;SPECIAL BLANK INSERTED
IDPB TT,IP
MOVEI TT,015 ;CR
IDPB TT,IP
INCHRW TT ;PRESUMABLY LF
IDPB TT,IP
MOVEI TT," " ;BLANK FOR SAFETY
IDPB TT,IP
JRST (R2)
CODE.(LOAD) ;******** LOAD
MOVE TT,[POINT 7,0]
JRST INT0
CODE.(INTERPRET) ;******** INTERPRET
MOVE TT,T ;WORD ADDRESS FROM STACK
IOR TT,[POINT 7,0] ;MADE INTO BYTE PTR
MOVEI T,0
INT0: PUSH RP,IN ;SAVE INFO ON CURRENT INPUT STREAM
PUSH RP,SCR
PUSH RP,IC
MOVEM TT,IN ;USUALLY POINT 7,0
MOVEM T,SCR ;SET NEW BLOCK NUMBER
;OR TTY(0) OR INTRPT ADR(<0)
MOVEI IC,GO ;SET UP INTERPRETER
JRST POP1
CODE.(<;S>) ;******** ;S
POP RP,IC ;RESTORE INPUT STREAM, ETC
POP RP,SCR
POP RP,IN
JUMPL RP,ABORT
NEXT
SUBTTL STACKS & ARITHMETIC
CODE.(OCTAL) ;******** OCTAL
IMMED
MOVEI R0,10
PBASE: MOVEM R0,BASE0
NEXT
CODE.(DECIMAL) ;******** DECIMAL
IMMED
MOVEI R0,12
JRST PBASE
CODE.(DROP) ;******** DROP
JRST POP1
POP2: AOBJP SP,SUFLO ;POP 2 WORDS
POP1: AOBJP SP,SUFLO ;POP A WORD
MOVE T,(SP) ;UPDATE T WITH TOP OF STACK
NEXT
CODE.(SWAP) ;******** SWAP
EXCH T,1(SP)
PUT: MOVEM T,0(SP)
NEXT
CODE.(<+>) ;******** +
ADDB T,1(SP) ;RESULT IN T AND 1(SP)
AOBJP SP,SUFLO
NEXT
BINARY: AOBJP SP,SUFLO
MOVEM T,0(SP)
NEXT
CODE.(DUP) ;******** DUP
PUSH1: POP SP,V ;DECR SP, IGNORE DATA!
MOVEM T,0(SP)
NEXT ;OK
SUFLO: OUTSTR [ASCIZ/Stack underflow! /]
JRST ABORT
SUBTTL COMPILATION WORDS
DEF(WORD,WORD) ;******** WORD
USE<SCR1,BLOCK.,WORD1,SEMI>
SCR1: MOVE T,SCR ;CHECK INPUT SOURCE
JUMPGE T,SCRX
MOVEI T,0 ;INTERPRET FROM CORE
AOJA IC,PUSH1 ;I.E. SCR<0
SCRX: JUMPN T,PUSH1 ;YES, HAVE TO DO BLOCK
AOJA IC,PUSH1 ;NO, SKIP&PUSH
IP== R1
OP== R2
CT== R3
CH== R4
WORD1: MOVE IP,IN ;BYTE PTR TO FAST CORE
ADD IP,T ;ZERO IF BLOCK 0, BUFF ADDR OTHERWISE
MOVE OP,[POINT 7,0] ;BYTE PTR SKELETON
HRR OP,DP ;ADDR FOR OUTPUT=NEXT DICT ENTRY
ADDI OP,1 ;PLUS 1
SETZM (OP) ;MAKE SURE LAST BIT IS ZERO
;(WORKS ON 1ST WORD ONLY!
MOVEM OP,OPX ;SAVE INITIAL POINTER
MOVE TT,DELIM
DPB TT,[POINT 7,GUARD,6] ;INSURE EXISTENCE OF A DELIM
MOVEI CT,WDLIM ;MAXIMUM NUMBER OF CHARACTERS ALLOWED
IDPB CT,OP ;VALUE IS FIRST BYTE
ILDB CH,IP ;GET CHAR
CAMN CH,DELIM ;THROW OUT EXTRA DELIMITERS
JRST .-2
IDPB CH,OP
ILDB CH,IP
CAME CH,DELIM
SOJG CT,.-3
MOVEI TT,7 ;GUARANTEE LAST WD PADDED WITH BLANKS
MOVEI CH," "
IDPB CH,OP
SOJG TT,.-1
MOVN CT,CT
ADDI CT,WDLIM+1 ;WHAT IS TRUE COUNT?
MOVE OP,OPX ;RESET TO FIRST OUTPUT CHAR
IDPB CT,OP ;TRUE COUNT TO FIRST CHARACTER
SUB IP,T ;UNDO THE DAMAGE FROM ABOVE
MOVEM IP,IN ;SAVE INPUT PTR
MOVEI 0," "
MOVEM 0,DELIM ;FORCE DELIM=BLANK AFTER WORD
JRST POP1
CODE.(FIND,FIND) ;******** FIND
HRLZI TT,FF1 ;PHASE IN LOOP
BLT TT,6
MOVE TT,1(DP)
MOVE R7,TT
LSH R7,-^D22
ANDI R7,MSK ;SELECT PROPER HEAD
MOVE T,HEAD(R7) ;MUST RESTORE LATER
JRST F1
FF1: PHASE 0 ;TO BE RELOCATED IN LOW MEMORY
F1: JUMPE T,SKIPX
MOVE R7,1(T)
ANDCMI R7,1 ;RESET LSB (PRECEDENCE)
CAMN TT,R7
JRST F3
HLRZ T,0(T)
JRST F1
DEPHASE ;END OF RELOCATED SEGMENT
F3: MOVEM T,L ;L(IN CORE) POINTS TO LK,CA FIELD
MOVE T,0(SP)
NEXT
SKIPX: MOVE T,0(SP)
SKIP: ADDI IC,2 ;SKIP USED ELSEWHERE
NEXT
EXECUT: MOVE V,L
DO: MOVE TT,1(V) ;NAME & PRECEDENCE
ANDI TT,1 ;PREC. ONLY
CAML TT,STATE ;STATE=0 OR 1
EX1: JRST 2(V) ;EXECUTE
ADDI V,2 ;POINT TO 1ST PARM WD
COMPIL: HRRZM V,0(DP) ;COMPILE ADDR OF 1ST PARM WD
AOBJN DP,.+1
NEXT
CODE.(LITERAL,LITERAL) ;******** LITERAL
RETN: MOVE TT,STATE
JUMPG TT,LITC ;COMPILING?
MOVE T,L ;NO, PUSH THE NUMBER ON STACK
JRST PUSH1
LITC: MOVEI V,LIT. ;WE WILL COMPILE IT
MOVEM V,0(DP) ;CALL TO LIT
MOVE TT,L
MOVEM TT,1(DP) ;NUMBER IS PARAMETER
ADD DP,[XWD 2,2]
NEXT
LIT.: MOVE T,0(IC) ;GET PARAM
AOJA IC,PUSH1 ;SKIP LITERAL PARM
SEMIC: PUSHJ RP,EXCOL ;LEAVE COMPILE MODE
JRST COMPIL ;COMPILE SEMI OR SCODE
CODE.(<;>) ;******** ;
IMMED
JSP V,SEMIC
SEMI: POP RP,IC ;NOTE RP POINTS TO LAST USED WORD
NEXT
ENCOL: MOVE TT,LAST ;ENTER COMPILE MODE
AOS -1(TT)
AOS -1(TT) ;FLIP LAST WD NAME
MOVEI TT,1
MOVEM TT,STATE ;SET COMP STATE
AOBJN DP,.+1 ;LEAVE ROOM FOR JSP OR PUSHJ
POPJ RP,
EXCOL: MOVE TT,LAST ;EXIT COMPILE MODE
SOS -1(TT)
SOS -1(TT) ;UNFLIP LAST WD NAME
SETZM STATE ;RESET STATE
POPJ RP,
CODE.(<;CODE>) ;********** ;CODE
IMMED
JSP V,SEMIC
SCODE: HRRZ TT,IC ;NOTE IC HAS FLAGS IN LEFT HALF
ADD TT,[JSP V,0]
SCODEC: MOVEM TT,@LAST ;LAST POINTS TO 1ST PARM WD, PUSHJ,
JRST SEMI ;OR JSP.
CODE.(<;:>) ;********** ;:
IMMED
MOVEI TT,SCODE
MOVEM TT,0(DP)
MOVE TT,[PUSHJ RP,COLON]
MOVEM TT,1(DP)
ADD DP,[XWD 2,2]
NEXT
; CODE.(:<) ;******** :<
LK.NEW==.
XWD LK.OLD,0
LK.OLD==LK.NEW
BYTE (7)2,072,074,040,040(1)1
PUSHJ RP,EXCOL ;LEAVE COMPILE MODE
MOVEI TT,COLBRK
MOVEM TT,0(DP)
AOBJN DP,.+1
SETZM 0,STATE
NEXT
COLBRK: MOVE V,IC
POP RP,IC
JRST (V)
; CODE.(>:) ;******** >:
LK.NEW==.
XWD LK.OLD,0
LK.OLD==LK.NEW
BYTE (7)2,076,072,040,040(1)0
PUSHJ RP,ENCOL ;ENTER COMPILE MODE
MOVE TT,[PUSHJ RP,COLON]
MOVEM TT,-1(DP)
NEXT
DEF(CODE,CODE) ;******** CODE
USE<WORD,ENTER,SEMI>
ENTER: MOVE TT,1(DP)
LSH TT,-^D22
ANDI TT,MSK
HRRZ R0,DP
EXCH R0,HEAD(TT)
HRLM R0,0(DP)
ADD DP,[XWD 2,2]
HRRZM DP,LAST ;LAST POINTS TO [LINK,0]
NEXT
DEF(<:>) ;******** : (COLON)
USE<CODE,COLONS>
COLONS: PUSHJ RP,ENCOL ;ENTER COMPILE MODE
MOVE TT,[PUSHJ RP,COLON] ;INSTALL PUSHJ FOR COLON ONLY
JRST SCODEC
COLON: EXCH IC,(RP)
NEXT
CODE.(<,>) ;******** ,
COMMA: MOVEM T,0(DP)
AOBJN DP,.+1
JRST POP1
CONS: MOVE TT,[JSP V,CON]
MOVEM TT,@LAST
AOBJN DP,.+1
JRST COMMA
CON: MOVE T,0(V) ;CON PUSHES A NUMBER FROM PARM LIST
JRST PUSH1
DEF(FORGET) ;******** FORGET
USE<WORD,FIND,PARE,SEMI,QUESTN>
PARE: MOVE R0,L
CAIGE R0,DP0
MOVEI R0,DP0 ;DON'T TRIM OBJECT
MOVEI R1,NWAY-1 ;THREAD INDEX
THLP: MOVE R2,HEAD(R1)
THLP2: CAMGE R2,R0
JRST THTRNC
HLRZ R2,0(R2)
JRST THLP2
THTRNC: MOVEM R2,HEAD(R1)
SOJGE R1,THLP
MOVE DP,R0 ;RECLAIM SPACE
NEXT
LOC.: AOS L
AOS L
JRST RETN ;WHERE IT IS PUSHED OR COMPILED
DEF(<'>) ;******** '
IMMED
USE<WORD,FIND,LOC.,SEMI,QUESTN> ;FIND MAY SKIP
SUBTTL "GO" (TEXT) INTERPRETER
;INTERPRETER LOOP FOR DICTIONARY REFERENCES BY NAME
GO: USE<WORD,FIND,EXECUT,QUERY>
USE<NUMBER,LITERAL,QUERY>
USE<QUESTN>
SUBTTL BLOCK I/O
CORE: MOVE TT,PREV ;A BUFFER ADDR (THE LAST READ OR WRITTEN)
CAMN T,LWD(TT) ;IS IT OUR BLOCK?
JRST GOT ;YES
MOVE Q,ALT ;ANOTHER ADDR
CAME T,LWD(Q) ;WILL IT BE ALT?
NEXT ;NO, HAVE TO READ
MOVEM TT,ALT ;YES, SWITCH BUFFERS
MOVEM Q,PREV
MOVE TT,Q
GOT: MOVE T,TT
ADDI IC,2 ;SKIP OVER 2
JRST PUT ;PUT THE GOOD BUFFER ADDR
CODE.(FLUSH,FLUSH) ;******** FLUSH
MOVE Q,PREV ;SWITCH
MOVE TT,ALT
MOVEM Q,ALT
MOVEM TT,PREV
SKIPN LWD+1(TT) ;THE UPDTE FLAG
NEXT
PUSH RP,TT
MOVE TT,LWD(TT) ;INFORMALLY PASSING THE BLOCK NUMBER
PUSHJ RP,WDISK ;WRITE BACK TO DISK
POP RP,TT
SETZM LWD+1(TT)
NEXT
READ: MOVE TT,T ;BLOCK NUMBER
MOVE T,PREV ;BUFFER ADDRESS
MOVEM TT,LWD(T)
PUSHJ RP,RDISK
JRST PUT
DEF(BLOCK,BLOCK.) ;******** BLOCK
USE<CORE,FLUSH,READ,SEMI>
CODE.(UPDATE) ;******** UPDATE
MOVE TT,PREV
SETOM LWD+1(TT) ;SET UPDATE FLAG -1
NEXT
CODE.(<ERASE-CORE>) ;******** ERASE-CORE
SETZM BUFF1+LWD
SETZM BUFF2+LWD
NEXT
RDISK: CAIG TT,0 ;******** (RDISK) (BLOCK IN TT)
MOVEI TT,1
IMULI TT,2 ;DOUBLE BLOCKS
SUBI TT,1 ;NO. 1 IS FIRST AVAILABLE TO US
PUSHJ RP,CHKBLK ;IN BOUNDS?
USETI DCH,(TT) ;SET UP FOR INPUT OF CORRECT BLOCK
RRD: MOVE TT,PREV
SUBI TT,1
HRRM TT,PROGR ;CORE ADDRESS (-1)
ADDI TT,200 ;SECOND PDP-10 BLOCK
HRRM TT,PROGR+1
IN DCH,PROGR
POPJ RP, ;OK
OUTSTR [ASCIZ/Block input error. /]
JRST ABORT
WDISK: CAIG TT,0 ;******** (WDISK) (BLOCK IN TT)
MOVE TT,1
IMULI TT,2
SUBI TT,1
PUSHJ RP,CHKBLK ;IN BOUNDS?
USETO DCH,(TT)
MOVE TT,PREV
SUBI TT,1
HRRM TT,PROGR
ADDI TT,200
HRRM TT,PROGR+1
OUT DCH,PROGR
POPJ RP,
OUTSTR [ASCIZ/Block output error. /]
JRST ABORT
CHKBLK: MOVE R0,RBSIZ ;WORD LENGTH OF FILE
IDIVI R0,200 ;IN BLOCKS (PDP-10)
CAML R0,TT
POPJ RP,0 ;OK RETURN
OUTSTR [ASCIZ/Block number too high! /]
JRST ABORT
SUBTTL CONSTANT WORDS
DEF(CONSTANT,CONSTA) ;******** CONSTANT
USE<CODE,CONS,SEMI>
CONST(PUSH,PUSH1)
CONST(PUT,PUT)
CONST(BINARY,BINARY)
CONST(POP,POP1)
CONST(COMMA,COMMA)
CONST(ABORT,ABORT)
CONST(BASE,BASE0)
CONST(FORTH,1) ;YOU CAN SAY "FORTH LOAD"
IFDEF ..FORT <
CONST(FORTRAN,FTBL) ;FORTRAN ENTRY TABLE
>
SUBTTL ASSEMBLER
DEF(CPU) ;******** CPU
USE<CONSTA,SCODE>
MOVE TT,0(V) ;OP CODE DEPOSITED EARLIER
LSH TT,4
IOR T,TT ;OR IN AC FROM STACK HEAD
ROT T,-^D13 ;MOVE TO HIGH ORDER 13 BITS
IOR T,1(SP) ;SECOND STACK IS I,X,Y (ADDRESS)
AOBJP SP,SUFLO ;POP 1, SECOND POPPED BY COMMA
JRST COMMA
SUBTTL MISCELLANY
DEF(<(>) ;***** ( ***** ALLOW COMMENTS
IMMED
USE<LPAR1,WORD,SEMI>
LPAR1: MOVEI 0,")"
MOVEM 0,DELIM
NEXT
CODE.(DDT) ;******** DDT
HRRZ TT,.JBDDT ;FROM JOB DATA AREA (PDP-10)
JUMPE TT,ABORT ;DDT NOT LOADED
JRST (TT) ;GO TO DDT
CODE.(SAVE) ;******** SAVE
SETZM BUFF1+LWD ;DO 'ERASE-CORE'
SETZM BUFF2+LWD
MOVEI 0,REST ;RESTORE ADDRESS
HRRM 0,.JBSA ;DEFINED FOR NEXT START
MOVEM DP,STATE ;CONVENIENT PLACE TO KEEP DP
JRST EOF
REST: JSP R2,OPNR ;NOTE USE OF R2
MOVE DP,STATE ;RESTORE DP
JRST ABORT
CODE.(NUMBER,NUMBER) ;******** NUMBER
IP== R1
LL== R2
BASE== R3
PLACES==R4
SIGN== R5
CH== R6
MOVE IP,[POINT 7,0,6] ;BYTE POINTER SKELETON
HRR IP,DP
ADDI IP,1 ;PT TO CH STRING FROM WORD
MOVEI LL,0
MOVE BASE,BASE0
MOVNI PLACES,1000 ;LARGE NEGATIVE NUMBER
ILDB CH,IP ;FETCH CHARACTER
MOVE SIGN,CH
CAIN CH,"-" ;GET ANOTHER IF WE GOT A MINUS
ILDB CH,IP
CAIN CH,"+" ;ALLOW + SIGN
ILDB CH,IP
JRST NATURL+2
NATURL: MOVE BASE,BASE0 ;RESET BASE FROM POSSBILE ":"
ILDB CH,IP
SUBI CH,"0"
JUMPL CH,NONDIG
CAML CH,BASE ;TOO HIGH?
JRST NONDIG ;WE'D BEST REJECT IT
DIGIT: JOV .+1 ;BE CAREFUL OF OVFL
IMUL LL,BASE
JOV .+2
JRST .+2
IOR LL,[XWD 400000,0]
ADD LL,CH
ADDI PLACES,1
JRST NATURL
NONDIG: ADDI CH,"0"
CAIE CH,":" ;FOR SEXIGESIMAL
JRST .+3
MOVEI BASE,6
JRST NATURL+1
CAIE CH,"."
JRST .+3
MOVEI PLACES,0
JRST NATURL
MOVEM PLACES,D ;STORE NUMBER OF DIGITS TO RT OFDECIMAL
CAIN SIGN,"-"
MOVN LL,LL ;NEGATE
MOVEM LL,L
CAMN CH,DELIM ;DELIM USUALLY " "
NEXT ;DONE OK
JRST SKIP ;NOT CONVERTIBLE AS NUMBER
CODE.(<CORE?>) ;******** CORE?
HRRZ T,SP00 ;CALCULATE REMAINING
HRRZ R0,DP ;DICT+STACK SPACE
SUB T,R0
JRST PUSH1 ;RETURN # WORDS LEFT.
CODE.(CORE) ;******** CORE
IMULI T,2000 ;INPUT IN KILOWORDS,NOW WORDS
SUBI T,1 ;SO 6 --> 6K WORDS, ETC.
HRRZ R0,DP ;CHECK THAT WE
ADDI R0,RPSIZ+100 ;DON'T CUT OFF CURRENT
CAMGE T,R0 ;DICT AND STACK
MOVE T,R0 ;CLIP
MOVE R0,T ;SAVE
CAMG T,.JBREL ;CHECK FOR SENSE OF CHANGE
JRST CLWR ;WE WANT TO SHRINK
CALLI T,11 ;CORE CALL
JRST ABORT ;ERROR
CLWR: SUBI R0,RPSIZ+1
HRRZ R2,SP00 ;MOVE STACK DATA
HRRZ R1,SP
SUB R1,R2
ADD R1,R0 ;TO=R0+SP-SP00
HRL R1,SP ;FROM=SP
MOVE R3,R0
HRRZ R4,SP00
SUB R3,R4 ;R0-SP00
HRRZ R2,RP
ADD R2,R3 ;END=RP+OFFSET
BLT R1,@R2 ;DO IT
ADD SP,R3 ;SP=SP+OFFSET
ADD RP,R3 ;RP=RP+OFFSET
MOVE T,R0 ;RESTORE IF NEEDED
CAML T,.JBREL ;SHRINKING?
JRST CBIGR ;NO
CALLI T,11 ;SHRINK
JRST ABORT
CBIGR: MOVEM R0,RP00 ;RESET STACKS
HRROM R0,SP00
HRRZ R0,.JBREL ;GET HIGH ADR
HRLM R0,.JBSA ;FOR RUN AFTER SAVE
JRST POP1 ;GET RID OF INPUT
HEAD0: CODE.(GOODBY) ;******** GOODBY
EOF: RELEASE DCH,0 ;RELEASE DISK
EXIT
LIT
IFDEF TWSEG,<RELOC LOWLIM> ;GO BACK TO LOW SEGMENT
VAR
DP0: Z
BYTE (7)8,7,110,105,114 ;BELL HEL
BYTE (7)114,117,15,12 ;LO <CRLF>
ENTRY: JSP R2,OPNR ;REENTRANT CALL USING R2
OUTSTR [ASCIZ/Forth 12-19-77! /]
MOVEI R0,ABORT
MOVEM R0,.JBREN ;SET REENTER ADDRESS
MOVE DP,DP00
MOVEI R1,HEAD0 ;TRUNCATE DICTIONARY
MOVEM R1,HEAD
IFG NWAY-1,<
MOVE R1,[XWD HEAD,HEAD+1]
BLT R1,HEAD+NWAY-1>
JRST ABORT
LIT
BLOCK KORE*2000 ;CAN BE CHANGED BY "CORE"
SP0: Z
RP0: BLOCK RPSIZ
END ENTRY
