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