--- /dev/null
+;Set FTKCN non-zero to include debugging count code
+
+TITLE TOPS-20 MIM INTERPRETER (MIMI)
+
+.SYMTAB 8001.,5000.
+
+IF1,[ .TNXDF
+ .DECSAV
+ XJRST==JRST 5, ; DOESN'T SEEM TO EXIST??
+ SS%EPN==10000 ; MAGIC BIT
+IFNDEF SWTRP%,SWTRP%==JSYS 573
+IFNDEF XSIR%,XSIR%==JSYS 602
+IFNDEF SMAP%,SMAP%==JSYS 767
+ XGVEC==JSYS 606
+ XSVEC==JSYS 607
+
+]
+
+FLIP==1 ; FLAG TO DO SECTION FLIPPING
+MON==0
+SBRFY==0 ; ENABLE "SUBRIFY" STUFF
+
+XBLT==123000,,[020000,,]
+
+A=1
+B=2
+C=3
+D=4
+E=5
+
+OP=6
+PC=7
+
+O1=10
+O2=11
+O3=12
+
+R=12
+M=13
+SP=14
+F=15
+
+TP=16
+P=17
+
+PV%OFF==3 ; OFFSET FOR CODE IN PURVEC
+TOPGC==777000-1
+TOPMGC==777000-1
+
+
+ENTMAX==0
+
+ZZZ==.
+
+LOC 136 ; POINTERS TO INTERESTING THING
+ MIMSEC,,TTBIND
+ MIMSEC,,BINDID ; VARIABLE BINDING ID
+ MIMSEC,,MPATM ; ATOM TO CALL FOR MAPPING
+ MIMSEC,,PURVEC ; PURE VECTOR
+ MIMSEC,,DBVEC ; OTHER PURE INFO
+ MIMSEC,,MINFO ; POINTER TO INFO VEC
+ MIMSEC,,TOPOBL ; OBLIST TABLE
+ MIMSEC,,PAGPTR ; POINTER TO PAGE TABLE
+ MIMSEC,,UWATM ; UNWIND ATOM
+ MIMSEC,,ICATM ; INTERRUPT ATOM
+ MIMSEC,,ECATM ; ERROR ATOM
+ MIMSEC,,NCATM ; UNDEFINED CALL ATOM
+
+DEFINE PR NM
+ PRILOC NM,\NM
+ TERMIN
+
+DEFINE PRILOC M,N
+PRINTC /M = N
+/
+TERMIN
+
+COMPERR:
+ JRST @[MIMSEC,,CMPERR]
+PR COMPERR
+FROBBS: SETZ CIEMP
+ SETZ CINTH
+ SETZ CIRST
+ SETZ CIMON
+ SETZ CIGAS
+ SETZ CIGVL
+FROBL==.-FROBBS
+
+PR FROBBS
+
+INGCPT: MIMSEC,,INGC
+
+PR INGCPT
+
+NOZONE: MIMSEC,,RCL ; POINTER TO NON-ZONE GC-PARAMS
+
+IRDBLK: 10
+ RD%JFN ; JFNS COMING
+ .PRIOU ; FOR EDITING
+ 0 ; DESTINATION STRING
+ 0
+ 0
+ 0
+ IRDBRK ; FOR FUTURE EXPANSION
+ 0
+
+IRDBRK: 20000,,400 ; BREAK ON CONTROL-D
+ 0
+ 0
+ 0
+ARDBRK: BLOCK 4 ; ALTERNATE BREAK MASK FOR READ
+
+DOSOUT: SOUT
+ POPJ P,
+CZONE: 0 ; current fs zone
+FRAMID: 0
+NARGS: 0
+UWATM: 0
+;DOCMPR: 0
+;DIDCMP: 0
+PNTRET: MIMSEC,,RET2
+PNTSTK: MIMSEC,,STKERR
+;TRACE: 0
+DOJSYS: XCT O1
+; JUMP 16,.+2 ;errors on sin/sout go to EXEC
+ AOS (P)
+ POPJ P,
+ 0
+\f
+SUBTTL MACROS
+
+;Feature test switches:
+ FTKCN==0 ;ne 0 to include kernel testing code
+
+LOWOP==1000
+
+CUROP==0
+
+DEFINE ENTRY ENTLOC,JSPQ
+ %!ENTLOC==CUROP
+IFE FTKCN,{SETZ ENTLOC }
+IFN FTKCN,{
+IFSE JSPQ,,1,,kercal ;;all dispatches through this address
+IFSN JSPQ,,1,,kerjsp
+IF2,{ ZZZ==.
+ loc kcltab+curop ;;hide real address in
+ xwd 1,entloc ;;other table (fake multi-sectioning)
+ LOC ZZZ
+}
+}
+ IFG <%!ENTLOC+ENTVEC-ENTMAX>,ENTMAX==%!ENTLOC+1+ENTVEC
+ IFL <CUROP-LOWOP>,LOWOP==CUROP
+ CUROP==CUROP+1
+TERMIN
+
+IFN FTKCN,{
+
+;;Some routines are JRST'd to, so we can't account them...
+DEFINE OENTRY ENTLOC,JSPQ
+ %!ENTLOC==CUROP
+ SETZ ENTLOC
+ IFG <%!ENTLOC-ENTMAX+ENTVEC>,ENTMAX==%!ENTLOC+1+ENTVEC
+ IFL <CUROP-LOWOP>,LOWOP==CUROP
+ CUROP==CUROP+1
+TERMIN
+};End FTKCN
+
+IFE FTKCN,{
+ DEFINE OENTRY ENTLOC,JSPQ
+ ENTRY ENTLOC,JSPQ
+TERMIN
+};End NFTKCN
+
+DEFINE TYPREC TBL,NAM\
+ $W!NAM=[$TYPCNT_6+$PRECORD,,0]
+ $T!NAM=$TYPCNT_6+$PRECORD
+ZZZ==.
+ LOC RECTBL+<$TYPCNT*2>
+ $TFIX,,0
+ SETZ TBL
+ LOC ZZZ
+$TYPCNT==$TYPCNT+1
+TERMIN
+
+DEFINE TYPMAK PT,NAM\
+ $W!NAM=[$TYPCNT_6+PT,,0]
+ $T!NAM=$TYPCNT_6+PT
+$TYPCNT==$TYPCNT+1
+TERMIN
+
+\f
+ENTVEC:
+PR ENTVEC
+SUBTTL OPCODE DEFINITIONS
+
+ ENTRY FRAME,T
+ oENTRY MCALL,T
+ oENTRY ACTIVATION,T
+ oENTRY AGAIN
+ oENTRY RETURN
+RETOFF==.-ENTVEC
+ oENTRY RTUPLE
+ oENTRY INCALL,T
+ ENTRY ARGS,T
+ ENTRY TUPLE,T
+ ENTRY NEXTS,T
+ ENTRY MAKTUP,T
+ ENTRY RETRY
+ ENTRY CONTENTS,T
+ ENTRY PFRAME,T
+ ENTRY LEGAL,T
+ ENTRY NEWTYPE,T
+ ENTRY LIST
+ ENTRY UBLOCK
+ ENTRY RECORD
+ ENTRY NTHU
+ ENTRY NTHR
+ ENTRY PUTU
+ ENTRY PUTR
+ ENTRY RESTU,T
+ ENTRY BACKU,T
+ ENTRY TOPU,T
+ ENTRY CONS,T
+ ENTRY BIND,T
+ ENTRY FIXBIND,T
+ ENTRY UNBIND,T
+ ENTRY OPENX
+ ENTRY CLOSEX
+ ENTRY READX
+ ENTRY PRINTZ
+ ENTRY RESETX
+ ENTRY SAVEX
+ ENTRY RESTORE
+ ENTRY ATIC
+ ENTRY INTGO
+ ENTRY QUIT
+ ENTRY RANDOM,T
+ ENTRY MARKL,T
+ ENTRY MARKU,T
+ ENTRY MARKR,T
+ ENTRY MKL,T
+ ENTRY MKU,T
+ ENTRY MKR,T
+ ENTRY SWNEXT,T
+ ENTRY TMPTBL,T
+ ENTRY XRECOR
+ ENTRY RELL,T
+ ENTRY RELU,T
+ ENTRY RELR,T
+ oENTRY UNWCNT
+ ENTRY SETZON,T
+ ENTRY SINX
+ ENTRY SOUTX
+ ENTRY GTJFNX
+ ENTRY JFNSX
+ ENTRY ERSTRX
+ ENTRY GTJFNL
+ ENTRY IOERR
+ oENTRY ACALL
+ ENTRY SFRAME,T
+ oENTRY MRETUR
+ ENTRY RNTIME
+ ENTRY SUNWAT,T
+ ENTRY TYPEW,T
+ ENTRY DFATAL,T
+ ENTRY IENABLE
+ ENTRY UUBLOCK
+ ENTRY SBLOCK
+ ENTRY USBLOCK
+ ENTRY ILVAL,T
+ ENTRY IASS,T
+ ENTRY ISET,T
+ ENTRY MOVSTR,T
+ ENTRY SETSIZ
+IFN SBRFY,[
+ ENTRY SBFPMP,T
+ ENTRY SBFRAM,T
+]
+ENDENT==.
+PR ENDENT
+\f
+SUBTTL Kernel stuff left in section 0 for max winnage
+
+IFN SBRFY,[
+SBRFLN==7
+SBRMYT==-6
+SBRMYM==-5
+SBRCLL=-4
+SBRFRM==-2
+SBRPC==-1
+SBRPRV==0
+
+SBFRAM: MOVE O1,@3(M) ; get atom of current MSUBR
+ PUSH TP,(O1)
+ ADDI TP,SBRFLN-1
+ MOVEM M,SBRMYM(TP)
+ SETZM SBRCLL(TP)
+ MOVEM 0,SBRPC(TP)
+ SKIPL O1,-1(F)
+ HRROI O1,(F)
+ HRRZ 0,O1
+ SUBI 0,SBRCLL-SBRFRM(TP)
+ HRL O1,0
+ MOVEM O1,SBRFRM(TP)
+ MOVEM F,SBRPRV(TP)
+ JRST (PC)
+]
+
+SFRAME: PUSH TP,[$TSFRAM+$FRMDOPE,,0]
+ JRST .+2
+FRAME: PUSH TP,[$TFRAME+$FRMDOPE,,0]
+ ADDI TP,FR.LN
+ SETZM -FR.LN+1(TP)
+ JRST (PC)
+
+BIND: PUSH TP,[$TBIND+$FRMDOPE,,0]
+ ADDI TP,8
+ SETZM -7(TP)
+ MOVEI A,-6(TP)
+ HRLI A,-7(TP)
+ BLT A,(TP)
+ MOVEM SP,-2(TP)
+ XMOVEI B,-7(TP)
+ MOVE SP,B
+ MOVE A,[$TBIND,,16.] ; LENGTH CHANGED (WAS 6)
+ JRST (PC)
+
+FIXBIN: MOVE A,SP
+ MOVEI 0,(F)
+
+FIXBLP: MOVE B,2(A) ; THE ATOM FOR THIS BINDING
+ CAMLE A,1(B) ; Survivored frob, we've already fixed this
+ JRST FIXBL1 ; guy
+ MOVE O1,1(B) ; get section
+ CAMLE O1,TP ; skip if not top level binding
+FIXBL1: CAILE 0,(A) ; ARE WE BEHIND THE CURRENT FRAME?
+ JRST (PC)
+FIXBL2: MOVEM A,1(B) ; MAKE ATOM POINT TO THIS BINDING
+ SKIPE A,5(A) ; GET PREVIOUS BINDING AND LOOP
+ JRST FIXBLP
+ JRST (PC)
+
+MCALL:
+IFN FTKCN,< AOS @[MIMSEC,,KCNTAB+%CALL]> ;Count calls
+ SUB PC,R
+ HRLI PC,(SETZ (R))
+CALLZ:
+CALLR:
+; SKIPE TRACE
+; PUSHJ P,@[MIMSEC,,TRACIN]
+CALLRX: MOVE C,O2 ; SAVE # OF ARGUMENTS
+ SKIPN B,(O1) ; GET GLOBAL BINDING
+ JRST @[MIMSEC,,CALNGS] ; BARF, NOT GASSIGNED!
+ HLRZ A,(B) ; LOAD GVAL
+ CAIE A,$TMSUBR ; IS IT AN MSUBR?
+ JRST @[MIMSEC,,CALNGS] ; OH, FOO!
+ MOVE D,1(B) ; GET MSUBR
+ICRET:
+IFN FTKCN,{ SKIPE @[MIMSEC,,TRACNT] ;Trace count?
+ PUSHJ P,@[MIMSEC,,TRINCT] ; Yup
+};End FTKCN
+ SKIPE B,@1(D) ; POINT TO GVAL OF ATOM OF IMSUBR
+ SKIPN M,1(B)
+ JRST COMPER ; If IMSUBR is not assigned...
+ SKIPL A,-1(F) ; GET PREVIOUS GLUED FRAME
+ SKIPA A,F ; OR ELSE CURRENT FRAME
+ HLL A,F
+ HRRM SP,FR.SP(A) ; SAVE BINDING POINTER
+ MOVEM PC,FR.PC(A) ; SAVE PC (THIS IS WRONG)
+ LSH C,1
+ SUBM TP,C ; POINT ABOVE FIRST ARG
+ MOVEM D,FR.MSA-1(C) ; STORE MSUBR IN FRAME
+ SKIPL (F)
+ SUBI F,FR.OFF
+ MOVEM F,FR.FRA-1(C) ; STORE PTR TO PREV FRAME
+ AOS F,FRAMID ; GET A UNIQUE ID
+ HRL F,O2 ; SAVE # ARGS IN LH
+ MOVEM F,FR.ARG-1(C) ; STORE ARGS,,ID
+ XMOVEI F,-1(C) ; POINT AT FRAME
+ SETZM (F) ; FOR WINNAGE
+ MOVE D,7(D) ; OFFSET
+ HLRZ A,(M) ; CHECK FOR FBIN TYPE KLUDGE
+ MOVE R,1(M)
+ CAIE A,$TPCODE
+ JRST .+3
+ SKIPN R,PV%OFF(R)
+ PUSHJ P,@[MIMSEC,,DMAPIN]
+ HRLI D,400000+R
+ SKIPE INTFLG
+ PUSHJ P,@[MIMSEC,,INTGOC]
+; SKIPE DOCMPR
+; JRST @[MIMSEC,,STKERR]
+STKMNG:
+IFE FLIP&0,[ JRST @D ]
+IFN FLIP&0,[
+ TLNN M,1 ; ODD/EVEN CHECK
+ JRST EVNSEC
+ HRLI TP,EVSEC
+ HRLI F,EVSEC
+ HRLI P,EVSEC
+ JRST @D
+
+EVNSEC: HRLI TP,ODDSEC
+ HRLI F,ODDSEC
+ HRLI P,ODDSEC
+ JRST @D ]
+
+
+UNBIND: SUBI PC,(R)
+ HRLI PC,(SETZ (R))
+IUNBIN: MOVEI C,0 ; IN CASE NO BINDINGS FLUSHED
+ SETZB A,B ; IN CASE UNWINDER FOUND
+ HRRZS O1
+IUNBNL: CAIL O1,(SP) ; IS BINDING POINTER ACCURATE?
+ JRST IUNBNQ ; YES, RETURN
+ SKIPN D,2(SP) ; THE ATOM BOUND
+ JRST NXTBND
+ CAMN D,UWATM ; REALLY AN UNWIND?
+ JRST @[MIMSEC,,DOUNWI] ; AND LOOP UNTIL ALL DONE
+UNJOIN: MOVE C,6(SP) ; THE OLD BINDING FOR THIS ATOM
+ MOVEM C,1(D) ; STUFF OLD BINDING INTO ATOM
+NXTBND: MOVE C,SP ; SAVE LAST BINDING FLUSHED
+ MOVE SP,5(SP) ; POINT TO PREVIOUS BINDING
+ JRST IUNBNL ; YES, GO HANDLE IT
+
+IUNBNQ: JRST @PC
+; JUMPE C,@PC
+; HLL C,TP
+; CAMGE C,TP ; NEED STACK TO FLUSH?
+; XMOVEI TP,-2(C) ; FLUSH BINDING DW AS WELL
+; JRST @PC
+
+RETURN:
+IFN FTKCN,< AOS @[MIMSEC,,KCNTAB+%RETUR]>
+; SKIPE DIDCMP ; SEE IF MUST CHECK FOR OVFL PAGE HACK
+; JRST @[MIMSEC,,RET2]
+RET3: SKIPL C,(F) ;NOTE THIS INSTRUCTION CAN BE MUNGED!!!
+ JRST IRET1
+ XMOVEI TP,-2(F)
+ HRR F,1(F)
+IFE SBRFY,[ JRST @C]
+IFN SBRFY,[ TLZN C,SBRCAL ; SKIP IF SUBRIFY
+ JRST @C
+ MOVE M,-2(TP) ; CALLER'S M
+ SUBI TP,4
+ HLRZ 0,(M) ; CHECK FOR PMAPPED
+ MOVE R,1(M)
+ CAIN 0,$TPCODE
+ SKIPE R,PV%OFF(R)
+ JRST @C
+ PUSHJ P,@[MIMSEC,,DMAPI1]
+ JRST @C]
+
+IRET1:
+; SKIPE TRACE
+; PUSHJ P,@[MIMSEC,,TRACOUT]
+ JSP E,FRMFIX
+ JRST @PC
+
+FRMFIX: MOVEI O1,-FR.LN(F)
+ CAIGE O1,(SP) ; DO WE NEED SOME UNBINDING?
+ JSP PC,IUNBNL ; YES. DO THEM
+ XMOVEI TP,-FR.LN(F)
+ HRR F,FR.FRA(F) ; GET PREVIOUS FRAME
+ SKIPL (F)
+ JRST [ADDI F,FR.OFF
+ MOVE C,F
+ MOVEI O2,0
+ JRST CHPCO]
+ MOVE C,FR.FRA(F)
+ SETCM O2,C
+ HLL C,F
+CHPCO: MOVE PC,FR.PC(C) ; RESTORE PC FROM FRAME
+ SKIPN M,FR.MSA(C) ; RESTORE MSUBR PTR FROM FRAME
+ JRST RESTPC
+ MOVE M,@1(M) ; POINT TO GBIND THROUGH ATOM
+ MOVE M,1(M) ; GET IMSBUR INTO M
+RESTPC: JUMPE M,(E)
+ HLRZ O1,(M) ; CHECK FOR FBIN TYPE KLUDGE
+ MOVE R,1(M)
+ CAIE O1,$TPCODE
+ JRST .+3
+ SKIPN R,PV%OFF(R)
+ PUSHJ P,@[MIMSEC,,DMAPI1]
+IFN SBRFY,[
+ TLNN O2,-1
+IFE FLIP&0,[ JRST (E)]
+IFN FLIP&0,[ JRST NOSBR]
+ HLRZS O2 ; FIND FRAME OF SUBRIFIED THING
+ ADD C,O2 ; THROUGH GROSS HAIR
+ DMOVE R,@(C) ; ONLY WORKS CAUSE R=M-1
+ JRST RESTPC
+NOSBR: ]
+IFE FLIP&0,[ JRST (E) ]
+IFN FLIP&0,[
+ TLNN M,1 ; ODD/EVEN CHECK
+ JRST EVNSE3
+ HRLI TP,EVSEC
+ HRLI F,EVSEC
+ HRLI P,EVSEC
+ JRST (E)
+
+EVNSE3: HRLI TP,ODDSEC
+ HRLI F,ODDSEC
+ HRLI P,ODDSEC
+ JRST (E) ]
+
+; MAKTUP -- 0/ TOTAL ARGS PASSED, O1/ REQUIRED+OPT ARGS, O2/ #TEMPS
+
+MAKTUP:
+ SUB 0,O1 ; SUBTRACT REQUIRED ARGUMENTS
+ LSH O2,1 ; O2 IS NUMBER OF TEMPS
+ ADJSP TP,(O2) ; BUMP TP TO REFLECT THIS
+ SKIPG A,0 ; A NOW HAS LENGTH OF TUPLE IN RH
+ JRST IMAKET ; ZERO LENGTH TUPLE
+ LSH O1,1 ; WORDS WORTH OF REQUIRED ARGS
+ MOVN C,0 ; # ARGS TO MOVE (NEG FOR XBLT)
+ ASH C,1 ; TO NUMBER OF WORDS
+ MOVEI D,2(O1) ; D/ # OF REQ ARGS+2
+ ADD D,F ; D POINT TO FIRST TUPLE WORD
+ SUB D,C ; NOW LAST TUPLE WORD+1
+ MOVE E,D ; COMPUTE DEST
+ ADD E,O2 ; ADD IN DELTA
+ XBLT C,
+ HRLI A,$TTUPLE
+ MOVE B,E
+ JRST PUSHDW
+
+IMAKET:
+ MOVSI A,$TTUPLE
+ XMOVEI B,1(TP) ; POINT AT DOPE WORD FOR EMPTY TUPLE
+PUSHDW: LSH 0,1 ; MAKE IT BE # OF WORDS INSTEAD OF ELTS
+ HRLI 0,$TTUPLE+$FRMDOPE ; GENERATE A DOPE WORD
+ PUSH TP,0
+ PUSH TP,[0] ; MUST PUT IN OTHER DOPE WORD
+ SKIPGE FR.TP(F) ; SKIP IF MUST MUNG FRAME
+ JRST (PC)
+ MOVEI 0,(F)
+ SUBI 0,(TP)
+ HRLM 0,FR.ARG(F) ; INDICATE IN FRAME
+ JRST (PC)
+
+CONS: JSP OP,ICELL1 ; GET LIST CELL
+ JRST @[MIMSEC,,CONS1] ; REQS A GC
+
+ MOVEM E,(A)
+ DMOVEM C,1(A)
+ MOVE B,A
+ MOVSI A,$TLIST
+ JRST (PC)
+
+
+ICELL1: SKIPN B,CZONE
+ XMOVEI B,NOZONE-GCPOFF
+ MOVE B,GCPOFF(B)
+ SKIPE A,RCLOFF(B)
+ JRST [MOVE 0,(A)
+ MOVEM 0,RCLOFF(B)
+ JRST 1(OP)]
+; MOVE 0,GCFLGO(B)
+; TLNE 0,$GC%PB ; ONLY PAGES FROM ZONE?
+; JRST CMPERR
+ICELL2: MOVE A,GCSBOF(B)
+ MOVEI 0,3
+ ADDB 0,GCSBOF(B)
+ CAMG 0,GCSMXO(B)
+ JRST 1(OP) ; SKIP RET, ALL IS WELL
+ JRST (OP)
+
+TUPLE: MOVE B,TP ; POINT TO STACK
+ MOVE A,O1 ; SAVE LENGTH
+ LSH O1,1
+ SUBI B,-1(O1)
+ HRLI O1,$TTUPLE+$FRMDOP
+ PUSH TP,O1
+ PUSH TP,[0]
+ HRLI A,$TTUPLE ; TYPE/LENGTH IN A
+ JRST (PC)
+
+SUBTTL OPEN COMPILER UTILITIES
+
+CIEMP:
+IFN FTKCN,<AOS @[MIMSEC,,KCNTAB+CUROP]>
+ MOVE 0,A ; POSSIBLE COUNT
+ LDB A,[220300,,A] ; ISOLATE PRIMTYPE
+ JUMPE A,COMPER
+ JRST CIMON1
+CIMON:
+IFN FTKCN,<AOS @[MIMSEC,,KCNTAB+CUROP+1]>
+ MOVE 0,A ; POSSIBLE COUNT
+ LDB A,[220300,,A] ; GET PRIMTYPE
+CIMON1: CAIN A,$PLIST
+ JUMPN B,CIMON3
+ CAIL A,$PBYTES
+ TRNN 0,-1
+ ADDI PC,1
+CIMON3: MOVE A,0
+ JRST (PC)
+
+;CIMTBL: SKIPA
+; SKIPE B
+; SKIPA ; THIS IS REALLY WRONG!!!
+; SKIPA
+; TRNE 0,-1
+; TRNE 0,-1
+; TRNE 0,-1
+; TRNE 0,-1
+
+CINTH:
+IFN FTKCN,<AOS @[MIMSEC,,KCNTAB+CUROP+2]>
+ LDB A,[220300,,A]
+ XCT CINTBL(A)
+ JRST (PC)
+
+CINTBL: JRST COMPER
+ DMOVE A,1(B)
+ JRST COMPER
+ JRST COMPER
+ JRST DOILD1
+ JRST [MOVSI A,$TCHARACTER
+ JRST DOILDB ]
+ JRST [MOVE B,(B)
+ MOVSI A,$TFIX
+ JRST (PC)]
+ DMOVE A,(B)
+
+DOILD1: MOVSI A,$TFIX
+DOILDB: ILDB B,B
+ JRST (PC)
+
+CIRST:
+IFN FTKCN,<AOS @[MIMSEC,,KCNTAB+CUROP+3]>
+ LDB 0,[220300,,A]
+ ADDI 0,CIRTBL
+ TLO 0,(SETZ)
+ JRST @0
+
+CIRTBL: JRST COMPER
+ JRST [MOVE B,(B)
+ MOVSI A,$TLIST
+ JRST (PC)]
+ JRST COMPER
+ JRST COMPER
+ JRST [HRLI A,$TBYTES
+ JRST DOIBP]
+ JRST DOIBP1
+ AOJA B,[HRLI A,$TUVECTOR
+ SOJA A,(PC)]
+ ADDI B,2
+ HRLI A,$TVECTOR
+; CAMG B,[TPSEC+2,,] ; Win with tuples???
+; HRLI A,$TTUPLE
+ SOJA A,(PC)
+
+DOIBP1: HRLI A,$TSTRING
+DOIBP: IBP B
+ SOJA A,(PC)
+
+CONSTANTS
+
+
+INSDIS: .+1
+INSDO: 0
+ JRST @INSRE1
+ JRST @INSRE2
+INSRE1: 0
+INSRE2: 0
+INSEFF: 0
+INTFLG: 0
+ENDP1==.
+PR ENDP1
+\f
+
+RH==2200
+LH==222200
+
+STACKL==20000.
+PDLLEN==1000.
+
+LENWRD==2200 ; LENGTH WORD
+TYPWRD==222200 ; TYPE WORD
+
+UPTBYT==220200 ; UBLOCK-PRIMTYPE PART OF TYPE WORD
+PTPBYT==220300 ; PRIMTYPE PART OF TYPE WORD
+TYPBYT==301200 ; TYPE PART OF TYPE WORD
+RTYBYT==061200 ; FOR A TYPE IN THE RH
+MONBYT==250200 ; MONITOR PART OF TYPE WORD
+$FRMDOPE==40 ; LH BIT FOR DOPE WORD
+$DOPEBIT==400000
+$QSFRB==100000 ; BIT IN GLUED FRM PC IF SEG CALL
+ ; **** CAUTION SUSPECT IN FUTURE
+ ; VERSIONS OF THE 20 ****
+SBRCAL==200000 ; BIT IF "SUBRIFY CALL"
+; Flags associated with gc spaces (see GCSFLGs) (LEFT HALF WORD)
+
+$GC%DW==400000 ; don't create dope words
+$GC%PB==200000 ; only on page boundaries
+
+LOC 1000
+
+SPCSET: BLOCK 20.
+SPCGET: BLOCK 20.
+
+STPG==._<-9.>
+
+RECTBL: BLOCK 256.*2 ; Each entry is a type/val pair
+FNBLK: BLOCK 40.
+GTJFBK: BLOCK 20
+GTJFB2=GTJFBK+1
+GTJFOS=GTJFB2+.GJCPP
+
+; UVECTOR of machine dependent information
+
+MINF: 100 ; jfn for tty input
+ 101 ; jfn for tty output
+ 36. ; bits per word
+ 7. ; bits per character
+ 512. ; words per page
+ 5 ; characters per word
+ 0 ; shift for address in word terms
+ 4 ; bytes per word
+ 377777777777 ; largest possible number (float)
+ 400000000001 ; smallest possible number (float)
+
+BOOTYP: 0
+
+; WHAT FOLLOWS IS THE INITIAL SET OF GC-PARAMS, USED UNTIL THE
+; FS SYSTEM IS STARTED.
+
+RCL: 0
+
+; RCLV IS A POINTER STRUCTURE OF FREE NON-LIST STORAGE.
+; IT IS CHAINED TOGETHER SUCH THAT MOVE AC,(AC) WILL GET THE
+; NEXT FREE BLOCK OF STORAGE. THE LENGTH OF A GIVEN BLOCK
+; POINTED AT BY AC IS TWO PLUS THE RIGHT HALF OF -1(AC).
+; THIS WORD, I.E. -1(AC) IS THE FIRST DOPE WORD OF THE BLOCK
+; WHICH WAS RECYCLED.
+; BELOW IS A SCHEMATIC REPRESENTATION OF RCLV
+
+; BITS,,LENGTH-2 BITS,,LENGTH-2
+; RCLV -> NEXT FREE BLOCK -> NEXT FREE BLOCK -> ... -> 0
+
+; 0 ; 'TYPE WORD' FOR RCLV (ALWAYS 0)
+RCLVOF==.-RCL
+RCLV: 0 ; RECYCLE VECTOR
+; 0
+0
+RCLV2O==.-RCL
+RCLV2: 0
+; 0
+RCLV3O==.-RCL
+RCLV3: 0
+; 0
+RCLV4O==.-RCL
+RCLV4: 0
+; 0
+0
+0
+RCLV7O==.-RCL
+RCLV7: 0
+; 0
+RCLV8O==.-RCL
+RCLV8: 0
+; 0
+0
+RCL10O==.-RCL
+RCLV10: 0
+GCSBOF==.-RCL
+GCSBOT: 0 ; CURRENT GC POINTER
+GCSMIO==.-RCL
+GCSMIN: GCSTRT
+GCSMXO==.-RCL
+GCSMAX: 0
+GCFLGO==.-RCL
+GCFLGS: 0
+GCPL==.-RCL
+
+SAVAC: BLOCK 20
+SAVPC: 0
+
+;TRACE: 0
+TRACL: 10
+TRACTM: 0
+
+
+ICMPER: 0
+ JRST CMPERR
+
+UUOH: 0
+ XJRST .+1
+ 0
+ MIMSEC,,UUOH1
+PAGTLN==512.
+PAGTBL: REPEAT PAGTLN,0
+INGC: 0
+ 0
+PCLEV1: 0 ; two words per int pc for multi-sec
+ 0
+PCLEV2: 0
+DUALPC: 0
+ 0
+RUNINT: 0 ; IF NON-ZERO, RUN INTS IMMEDIATELY
+MLTUUP: 0 ; HOLDS UUO (SWAPPED SORT OF)
+MLTPC: 0 ; 23 BIT PC
+UUOE:
+MLTEA: 0 ; EFF ADDR OF UUO INSTRUCTION
+MLTUUH: MIMSEC,,MLTUOP ; RUN IN MIMSEC
+
+INITZN==1 ; for now...
+
+$TANY==0
+$TBOOLEAN==0
+
+$PFIX==0
+$PLIST==1
+$PRECORD==2
+$PSTRING==5
+$PUVECTOR==6
+$PVECTOR==7
+$PBYTES==4
+$PBITS==7
+
+$TYPCNT==0
+
+; Offsets associated with FRAMEs
+
+FR.LN==6 ; Length of full frame
+FR.OFF==4 ; Offset from F to real frame ptr
+FR.ACT==1 ; Offset for PC for activation
+FR.SP==0 ; Offset for saved binding (rh)
+FR.TP==0 ; Offset for saved TP (lh)
+FR.FRA==-1 ; Offset for previous frame
+FR.ARG==-2 ; Offset for # of args to this guy (lh)
+FR.ID==-2 ; Offset for frame id (rh)
+FR.PC==-3 ; Offset for saved PC
+FR.MSA==-4 ; Offset for save MSUBR pointer
+FR.HDR==-5 ; Offset for FRAME header
+\f
+SUBTTL MULTIS
+
+; In multi-section/extended addressing mode, MIMI20 lives in section 1.
+; it is mapped there at startup time. MIMI should be able to run in either
+; single or multi section mode. The TP stack lives in a section of its own
+; and everything else is GC space (for now).
+
+MIMSEC==1 ; MIMI sections
+TPSEC==1 ; STACK sections
+IFE FLIP,[ INIGC==TPSEC+2 ; First GC section
+ ]
+IFN FLIP,[ INIGC==TPSEC+2
+ IFE TPSEC&1,[ ODDSEC==TPSEC+1
+ EVSEC==TPSEC ]
+ IFN TPSEC&1,[ ODDSEC==TPSEC
+ EVSEC==TPSEC+1 ] ]
+
+COMPAG==0 ; page mapped into all sections except
+ ; stack
+NUMSEC==12 ; total # of initial sections
+ ; (initial value of CURSIZ...)
+STRTTP==200000 ; begin control stack to avoid paging
+ ; problems
+STPDL==777000 ; put P stack in a strange place also
+PGPDL==<<TPSEC_9>\<<STPDL>_<-9>>> ; P STACK PAGE
+TPENDP==PGPDL-1 ; illegal page to end TP
+TPWARN==TPENDP-5 ; page to warn of end
+\f
+
+
+SUBTTL TYPE DEFINITIONS
+
+ TYPMAK $PFIX,UNBOUND
+ TYPMAK $PFIX,FIX
+ TYPMAK $PFIX,CHARACTER
+ TYPMAK $PFIX,FLOAT
+
+ TYPMAK $PLIST,LIST
+ TYPMAK $PLIST,FALSE
+ TYPMAK $PLIST,DECL
+
+ TYPMAK $PSTRING,STRING
+ TYPMAK $PUVECTOR,MCODE
+
+ TYPMAK $PVECTOR,VECTOR
+ TYPMAK $PVECTOR,MSUBR
+
+ TYPREC FRMTBL,FRAME
+ TYPREC BNDTBL,BINDING
+ TYPREC ATMTBL,ATOM
+ TYPREC ATMTBL,OBLIST
+ TYPREC GBNTBL,GBIND
+
+ TYPMAK $PLIST,FORM
+
+; TYPES STARTING HERE SHOULD BE HANDLED DIFFERENTLY AT SOME
+; FUTURE DATE.
+
+ TYPMAK $PFIX,TYPC
+ TYPMAK $PFIX,TERMIN
+
+ TYPMAK $PLIST,SEGMENT
+ TYPMAK $PLIST,DEFER
+ TYPMAK $PLIST,FUNCTION
+ TYPMAK $PLIST,MACRO
+
+ TYPMAK $PVECTOR,CHANNEL
+ TYPMAK $PVECTOR,ENTRY
+ TYPMAK $PVECTOR,ADECL
+ TYPMAK $PVECTOR,OFFSET
+
+ TYPREC ATMTBL,LVAL
+ TYPREC ATMTBL,GVAL
+ TYPREC ATMTBL,LINK
+
+ TYPMAK $PVECTOR,TUPLE
+ TYPMAK $PUVECTOR,UVECTOR
+ TYPMAK $PVECTOR,IMSUBR
+ TYPREC QFTBL,QFRAME
+ TYPMAK $PVECTOR,TAT
+ TYPMAK $PVECTOR,I$SDTABLE
+ TYPMAK $PVECTOR,I$DISKCHANNEL
+ TYPMAK $PVECTOR,MUDCHAN
+ TYPMAK $PFIX,WORD
+ TYPMAK $PUVECTOR,PCODE
+ TYPMAK $PVECTOR,ZONE
+ TYPMAK $PUVECTOR,GCPARAMS
+ TYPMAK $PUVECTOR,AREA
+ TYPREC FRMTBL,SFRAME
+ TYPMAK $PBYTES,BYTES
+ TYPMAK $PFIX,TYPW
+ TYPREC QFTBL,QSFRAM
+ TYPMAK $PFIX,BITS
+\f
+
+MPATM: 0
+PURVEC: 0
+DBVEC: 0 ; LOCATIONS WHERE PURE VEC STUFF IS STORED
+MINFO: MINF
+TOPOBL: 0
+ 0
+PAGPTR: $TUVEC,,PAGTLN
+ 0
+ICATM: 0
+ECATM: 0
+NCATM: 0
+BINDID: 0 ; USED IN BININING
+TTBIND: 0 ; TOP LEV BIND
+
+CURSIZ: NUMSEC ; Number of sections we have
+
+PURZON: 0
+ATMZON: 0
+
+RETPUR: MOVE A,PURVEC
+ MOVE B,DBVEC
+ HALTF
+ MOVE A,[SAVAC+B,,B] ; Restore ACs
+ BLT A,P
+ MOVE B,PURZON ; Pick up pure zone
+ MOVE C,ATMZON ; and atom zone
+ MOVEM A,INTSAV ; Make sure flag set
+ PUSHJ P,SAV1 ; Go do the save
+ HALTF
+
+IFN FTKCN,{
+;storage for metering
+ksava: block 1 ;save ac a
+kcntab: block 400 ;count of calls
+kcltab: block 400 ;addresses of routines to call
+;storage for trace counting
+tracnt: block 1 ;0 means don't count calls
+ tranum==4000 ;number of different atoms we may see:
+tratab: block tranum+1 ;tbluk table for atom names
+trascr: block tranum*3 ;scratch space for atom names
+traptr: block 1 ;pointer to first free word in scratch space
+tranam: block 10 ;temp space for atom name before lookup
+trsava: block 2 ;save a,b
+trsavc: block 2 ;save c,d
+trsav5: block 2 ;save 5,6
+initra: push p,a
+ movei a,trascr ;address of scratch space
+ movem a,traptr ;is first free at startup
+ hrrzi a,tranum ;0,,num
+ movem a,tratab ;tbluk table header
+ pop p,a ;restore ac
+ popj p, ;and return init'd
+;print out the table (and zero it)
+pritab: dmovem a,trsava
+ dmovem c,trsavc
+ dmovem 5,trsav5
+priget: hrroi a,[asciz/Output file for trace: /]
+ PSOUT
+ move a,[gj%sht+gj%fns]
+ move b,[.priin,,.priout]
+ GTJFN
+ jrst priget
+ move b,[070000,,300000] ;7-bit read/write
+ OPENF
+ jrst priget ;clever error handling
+prilup: hlrz 5,tratab ;number of entries in table
+ movn 5,5 ;negate
+ jumpe 5,pridun ;done?
+ hrlz 5,5 ;in left half
+ setz 3, ;largest count so far....
+
+plup: hrrz 4,tratab+1(5) ;get a canditate count
+ caml 4,3 ;bigger or equal?
+ jrst [ hrrz 6,5 ;yes, store new index
+ hrrz 3,tratab+1(6) ;and new count
+ jrst .+1]
+ aobjn 5,plup ;iterate
+;index of largest entry in ac 6 now
+ setzb 3,4
+ hrroi b,[asciz/
+/]
+ SOUT
+ hlro b,tratab+1(6) ;name
+ SOUT
+ hrrz b,tratab+1(6) ;count
+ move c,[100010,,12] ;8 columns, leading filler, decimal
+ NOUT
+ jfcl
+ hlrz 4,tratab ;table size
+ move 3,tratab+1(4) ;top entry
+ exch 3,tratab+1(6) ;flush out biggest entry
+ sos 4 ;decrement used size
+ hrlm 4,tratab ;save nwe count
+ jrst prilup ;and iterate
+pridun: CLOSF ;close the file
+ jfcl ;clever error handling
+ dmove a,trsava
+ dmove c,trsavc
+ dmove 5,trsav5
+ popj p, ;and return to caller
+;here to count a call
+trinct: dmovem a,trsava
+ dmovem c,trsavc
+ move b,3(d) ;get name of msubr
+ move a,3(b) ;get string (count,,address)
+ hrrz b,2(b) ;count into b
+ move c,[440700,,tranam] ;temp space for name
+ ildb d,a ;get bytes
+ idpb d,c ;and put them
+ sojg b,.-2 ;until there ain't no more (assumes 1 or more)
+ setz d, ;null terminator
+ idpb d,c
+ movei a,tratab ;table address
+ move b,[440700,,tranam] ;point to string
+ TBLUK ;is it there?
+ tlne b,40000 ;set if exact match
+ jrst [aos (a) ;bump count
+ jrst trret] ;and return this call
+;not in table, must add it
+ move c,traptr ;get address of first free
+ hrli c,440700 ;byte pointer
+ move a,[440700,,tranam] ;
+ ildb d,a ;get bytes
+ idpb d,c ;and put them
+ jumpn d,.-2 ;do til null
+ movei a,tratab ;table address
+ hrlz b,traptr ;address,,0
+ aos b ;,,1 initial count
+ TBADD ;add to table
+ aos c ;bump pointer to next word boundary
+ hrrzm c,traptr ;and store it
+trret: dmove a,trsava
+ dmove c,trsavc
+ popj p,
+
+;Dispatch routine to use for metering calls into the kernel
+kerjsp: movem a,ksava ;called with JSP PC,
+ hrrz a,-1(pc) ;get table offset
+ aos kcntab-entvec(a) ;bump counter
+ move a,kcltab-entvec(a) ;get real addr
+ exch a,ksava ;restore a and setup to call
+ jrst @ksava
+kercal: movem a,ksava ;save a
+ move a,(p) ;return address
+ sos a ;caller's address
+ hrrz a,(a) ;table offset used in call
+ subi a,entvec ;table index relative to table start
+ aos kcntab(a) ;count calls to this routine
+ move a,kcltab(a) ;get address of routine being called
+ exch a,ksava ;restore a and save routine address
+ jrst @ksava ;do the real kernel call
+
+};End FTKCN
+
+LOC <<.+777>&777000>
+
+SUBTTL STACK OPERATIONS & FLOW OF CONTROL
+
+; LEGAL? TAKES ARGUMENT IN A & B
+
+LEGAL: HLRZ C,A ; GET TYPE OF FROBBIE
+ CAIN C,$TFRAME
+ JRST LGLFRM
+ CAIN C,$TBIND
+ JRST LGLBND
+ MOVE C,B
+ TLZ C,770000 ; CLEAR OUT BYTE POINTER BITS
+ CAML C,[INIGC,,0] ; SKIP IF IN STACK AREA
+ JRST LGLTRU
+ HRRZ C,TP
+ HRRZ D,B
+ CAMLE D,C ; SKIP IF ON STACK
+ JRST LGLFLS ; NO, A LOSER
+ LDB D,[220300,,A] ; GET SAT
+ JRST @LGLTAB(D) ; DISPATCH
+LGLTRU: MOVSI A,$TFIX
+ JRST (PC)
+LGLTAB: SETZ LGLTRU
+ SETZ LGLTRU
+ SETZ LGLTRU
+ SETZ LGLTRU
+ SETZ LGLBYT
+ SETZ LGLSTR
+ SETZ LGLUVC
+ SETZ LGLTUP
+LGLBYT:
+LGLSTR: TLZ A,-1
+ IBP A,B ; REST TO END OF STRING
+ ADDI A,1 ; TO NEXT WORD
+LGLCOM: HLRZ B,(A)
+ TRNN B,$FRMDOPE ; DOPE WORD?
+ JRST LGLFLS ; NO, LOSER
+ HRRZ B,(A)
+ MOVE D,(A)
+ SUB A,B
+ CAME D,-1(A)
+ JRST LGLFLS
+ JRST LGLTRU
+LGLUVC: TLZ A,-1
+ MOVE C,B
+ ADD A,C
+ JRST LGLCOM
+
+LGLFRM: MOVSI D,<$TFRAME+$FRMDOPE>
+ MOVSI E,<$TSFRAM+$FRMDOPE>
+LGLFR1: HRRZ C,B
+ CAILE C,(TP)
+ JRST LGLFLS
+ HLL C,TP
+ MOVE C,-1(B)
+ MOVSI A,$TFIX
+ CAME C,E
+ CAMN C,D
+ JRST (PC)
+LGLFLS: SETZ B,
+ MOVSI A,$TFALSE
+ JRST (PC)
+
+LGLBND: CAML B,[INIGC,,0]
+ JRST LGLTRU
+ MOVSI D,<$TBIND+$FRMDOPE>
+ MOVE E,D
+ JRST LGLFR1
+
+LGLTUP: HRRZ C,B
+ CAILE C,(TP)
+ JRST LGLFLS
+ HRRZS A
+ LSH A,1
+ HLL B,TP
+ ADD A,B
+ HLRZ D,(A)
+ CAIE D,$TVECTOR+$FRMDOPE
+ CAIN D,$TTUPLE+$FRMDOPE
+ JRST LGLTRU
+ HLRZ D,-FR.LN-1(B) ; SEE IF ARGS OF A FRAME
+ CAIE D,$TFRAME+$FRMDOPE
+ CAIN D,$TSFRAM+$FRMDOPE
+ JRST LGLTRU
+
+;here to check for rested args of a frame
+
+ MOVE D,F ; start at current frame
+LGLTU3: SKIPL (D) ; glued frame
+ JRST LGLTU2
+ HRRZ D,-1(D) ; get real frame
+ HLL D,F
+LGLTU2: CAMG D,B ; skip if frame above tuple
+ JRST LGLTU1
+ MOVE D,-1(D)
+ SKIPL (D)
+ ADDI D,FR.OFF
+ JRST LGLTU3
+LGLTU1: HLRE C,FR.ARG(D) ; get arg count
+ JUMPL C,LGLFLS
+ LSH C,1
+ ADDI D,2(C) ; should be tuple end
+ CAME D,A
+ JRST LGLFLS
+ JRST LGLTRU
+
+PFRAME: HLL O1,TP
+ MOVE B,3(O1)
+ SKIPL (B)
+ JRST IPFRM1
+ HRRZ B,-1(B)
+ SUBI B,FR.OFF
+ HLL B,F
+IPFRM1: MOVE A,$WFRAME
+ JRST (PC)
+
+IENABLE:
+ SUBM R,(P)
+ PUSH P,O1
+ PUSHJ P,RINTGO
+ POP P,RUNINT
+ SUBM R,(P)
+ POPJ P,
+
+SUNWAT:
+IFN FLIP,[
+ MOVEM O1,@[MIMSEC,,UWATM]
+ MOVEM O1,@[MIMSEC+1,,UWATM]
+]
+IFE FLIP MOVEM O1,UWATM
+ JRST (PC)
+
+ARGS: HLRE A,FR.OFF+FR.ARG(O1) ; COUNT OF ARGUMENTS
+ JUMPL A,IARG1 ; FUNNY, CASE
+ HRLI A,$TTUPLE ; SET TYPE WORD
+ MOVEI B,6(O1) ; POINT AT ARGUMENT BLOCK
+ HLL B,F
+ JRST (PC)
+
+IARG1: SUBM O1,A ; POINT TO DW OF TUPLE
+ HRRZ B,FR.OFF-1(A) ; GET LENGTH
+ SUBM A,B
+ HRRZ A,FR.OFF-1(A)
+ LSH A,-1
+ HRLI A,$TTUPLE
+ ADDI B,FR.OFF-1
+ HLL B,F
+ JRST (PC)
+
+INCALL:
+IFN FTKCN,< AOS KCNTAB+%INCAL> ;Count calls
+ MOVE B,PC
+ JSP PC,FRAME
+ SUB B,R
+ HRLI B,(SETZ (R))
+ SKIPL A,-1(F) ; GET PREVIOUS GLUED FRAME
+ MOVE A,F ; OR ELSE CURRENT FRAME
+ XHLLI A,(F)
+ HRRM SP,FR.SP(A)
+ MOVEM B,FR.PC(A)
+ MOVE 0,FR.MSA(A) ; SO RETURN WINS
+ XMOVEI A,(F)
+ SKIPL (A)
+ SUBI A,FR.OFF
+ MOVEM A,-2(TP)
+IFN FLIP,[
+ AOS F,@[MIMSEC,,FRAMID]
+ MOVEM F,@[MIMSEC+1,,FRAMID]
+]
+IFE FLIP AOS F,FRAMID
+ HRRZM F,-3(TP)
+ XMOVEI F,-1(TP)
+ MOVEM 0,FR.MSA(F) ; SO RETURN WINS
+ SETZM (F)
+ ADDI B,1 ; NOTE: DONT CHANGE TO AOJA!!!
+ JRST @B
+
+ACALL:
+IFN FTKCN,< AOS KCNTAB+%ACALL> ;Count calls
+ LDB 0,[222000,,A]
+ CAIN 0,$TMSUBR
+ JRST [ MOVE D,B ; GET ATOM
+ SUB PC,R
+ HRLI PC,(SETZ (R))
+ MOVE C,O2
+ JRST ICRET ]
+ MOVEI O1,0
+ SUB PC,R
+ HRLI PC,(SETZ (R))
+ JRST CALNGS
+
+CALNGS: SKIPN NCATM ; CALL'ED ATOM IS NOT GASSIGNED
+ PUSHJ P,HALTX
+ ADJSP TP,2 ; ROOM FOR EXTRA ARG
+ XMOVEI OP,(TP)
+ SKIPN E,O2 ; # OF ARGS TO B
+ JRST CALNG5
+ DMOVE C,-3(OP)
+ DMOVEM C,-1(OP)
+ SUBI OP,2
+ SOJG E,.-3 ; MAKE ROOM
+
+CALNG5: JUMPE O1,CALNG2 ; JUMP IF NOT A CALL TO AN ATOM
+
+CALNG1: MOVE B,[$TATOM,,$LATOM]
+ MOVEM B,-1(OP)
+ MOVEM O1,(OP)
+CALNG3: MOVE O1,NCATM
+ AOJA O2,CALLR
+
+CALNG2: DMOVEM A,-1(OP) ; MUNG IN WHATEVER IT IS
+ JRST CALNG3
+
+
+CALNMS: PUSHJ P,HALTX ; VALUE OF CALL'ED ATOM ISN'T MSUBR
+
+ACTIVA:
+IFN FTKCN,< AOS KCNTAB+%ACTIVA> ;Count calls
+ MOVEI A,(PC)
+ SUBI A,(R)
+ HRRM A,FR.ACT(F)
+ HRRZ A,TP
+ SUBI A,(F) ; REL TP TO FRAME
+ HRLM A,FR.TP(F)
+ JRST (PC)
+
+RETRY: XMOVEI F,FR.OFF(O1)
+ HLRE B,FR.ARG(F) ; SEE IF TUPLE CASE
+ JUMPGE B,BLTDON
+ SUBM F,B ; B POINTS TO DW
+ HRRZ A,-1(B) ; A IS REAL # ARG
+ LSH A,-1
+ HRLM A,FR.ARG(F) ; FIX UP # ARGS
+ LSH A,1 ; TO # WORDS
+ SUBI B,1(A) ; B IS SOURCE (I.E. 1ST ARG WORD)
+ XMOVEI C,2(F) ; FIRS DEST
+ XBLT A,
+BLTDON: PUSH P,FR.ARG(F) ; SAVE FOR NEW FRAME
+ PUSH P,FR.MSA(F)
+ JSP E,FRMFIX
+ PUSH P,PC
+ JSP PC,FRAME
+ POP P,PC
+ POP P,D
+ POP P,O2
+ HLRZS C,O2
+ ADJSP TP,(O2)
+ ADJSP TP,(O2)
+ JRST ICRET
+
+AGAIN:
+IFN FTKCN,< AOS KCNTAB+%AGAIN> ;Count
+ ADDI O1,FR.OFF
+ SKIPGE (F) ; CHECK FOR GLUEDNESS
+ HRR F,-1(F) ; GET THE REAL FRAME
+ CAMN F,O1
+ JRST IAGN1
+ MOVE F,O1
+ HLRZ O1,FR.TP(F)
+ ADD O1,F
+ JSP PC,IUNBIN
+ MOVE M,FR.MSA(F)
+ MOVE M,@1(M) ; GET ATOM OF IMSUBR
+ MOVE M,1(M) ; AND FINALLY IMSUBR
+ HLRZ A,(M) ; CHECK FOR FBIN TYPE KLUDGE
+ MOVE R,1(M)
+ CAIN A,$TPCODE
+ JRST [ SKIPN R,PV%OFF(R) ; GET POINTER
+ ; NOT THERE, MAP IT IN
+ PUSHJ P,MAPIN
+ JRST .+1 ]
+IAGN1: HRRZ PC,FR.ACT(F)
+ JUMPE PC,CMPERR
+ ADD PC,R
+ HLRZ TP,FR.TP(F)
+IFE FLIP&0,[ ADD TP,F
+ JRST (PC) ]
+IFN FLIP&0,[
+ TLNN M,1 ; ODD/EVEN CHECK
+ JRST EVNSE1
+ HRLI F,EVSEC
+ HRLI P,EVSEC
+ ADD TP,F
+ JRST (PC)
+
+EVNSE1: HRLI F,ODDSEC
+ HRLI P,ODDSEC
+ ADD TP,F
+ JRST (PC) ]
+
+; HERE TO HANDLE AN UNWINDER
+
+DOUNWI: SKIPN O2,1(SP) ; GET UNWIND FRAME
+ JRST UNJOIN
+ SKIPN M,FR.MSA+FR.OFF(O2) ; RESTORE MSUBR PTR FROM FRAME
+ JRST CMPERR
+ MOVE M,1(M) ; POINT TO ATOM
+ MOVE M,(M) ; POINT TO GBIND
+ MOVE M,1(M) ; GET IMSBUR INTO M
+ HLRZ C,(M) ; CHECK FOR FBIN TYPE KLUDGE
+ MOVE R,1(M)
+ CAIN C,$TPCODE
+ JRST [ SKIPE R,PV%OFF(R) ; GET POINTER
+ JRST .+1
+ PUSH TP,A ; NOT THERE, MAP IT IN
+ PUSH TP,B
+ PUSH P,O1
+ PUSH P,O2
+ PUSHJ P,MAPIN
+ POP P,O2
+ POP P,O1
+ POP TP,B
+ POP TP,A
+ JRST .+1 ]
+ HRRZ C,4(SP) ; GET PC OFFSET
+ MOVEI D,(SP)
+ SUBI D,(TP)
+ ADJSP TP,6(D) ; MUNG IT
+ ADD C,R
+ PUSH TP,A
+ PUSH TP,B
+ PUSH TP,$WFRAM
+ PUSH TP,F
+ PUSH TP,$WBIND
+ PUSH TP,O1
+ PUSH TP,$WFIX
+ PUSH TP,PC
+ PUSH TP,$WFIX
+ PUSH TP,E
+ XMOVEI F,FR.OFF(O2)
+IFE FLIP&0,[ JRST (C) ]
+IFN FLIP&0,[
+ TLNN M,1 ; ODD/EVEN CHECK
+ JRST EVNSE2
+ HRLI TP,EVSEC
+ HRLI F,EVSEC
+ HRLI P,EVSEC
+ JRST (C)
+
+EVNSE2: HRLI TP,ODDSEC
+ HRLI F,ODDSEC
+ HRLI P,ODDSEC
+ JRST (C) ]
+
+UNWCNT:
+IFN FTKCN,< AOS KCNTAB+%UNWCN> ;Count calls
+ MOVE E,(TP)
+ MOVE PC,-2(TP)
+ MOVE O1,-4(TP)
+ MOVE F,-6(TP)
+ ADJSP TP,-10
+ POP TP,B
+ POP TP,A
+ MOVE D,2(SP) ; REALLY UNBIND IT IF SUCCESSFUL
+ JRST UNJOIN
+
+; HERE TO HANDLE FIXUP AFTER STACK LOSSAGE FROM RETURN
+RET2: MOVEI C,(TP)
+ CAIL C,<<TPWARN>_9.> ; ARE WE BELOW
+ JRST [ SKIPL C,(F)
+ JRST RET3+1
+ JRST RET3+2 ]; NO
+ PUSH P,A
+ PUSH P,B
+ MOVSI A,(SETZ)
+ HRRI A,TPWARN
+ MOVSI B,0
+ SPACS
+ HRRI A,TPWARN+1000
+ SPACS
+ POP P,B
+ MOVSI A,(SKIPL C,(F))
+ MOVEM A,RET3 ; MUNG THAT INS!!!
+ MOVEM A,@[MIMSEC+1,,RET3]
+ POP P,A
+ JRST RET3
+
+; RTUPLE WILL NOT RUN IN MIM MODE
+
+MRETUR: TDZA D,D
+
+RTUPLE: MOVEI D,1
+
+IFN FTKCN,[ SKIPN D
+ AOSA KCNTAB+%RTUPL
+ AOS KCNTAB+%MRETU
+]
+ SKIPN O2 ; 0 ==> MRET FROM CURRENT FRAME
+ XMOVEI O2,-FR.OFF(F) ; UPDATE FRAME
+MRET2: SKIPGE C,FR.OFF(O2) ; GLUED FRAME?
+ JRST GRTUPL
+ JUMPN D,MRET3 ; JUMP IF RTUPLE
+ HLRZ C,FR.HDR+FR.OFF(O2) ; SEE IF SEG FRAME
+ CAIN C,$TSFRAM+$FRMDOP
+ JRST MRET3
+ MOVE A,FR.FRA+FR.OFF(O2) ; Previous frame
+ SKIPGE C,FR.OFF(A) ; Glued?
+ JRST [HRR A,-1(A) ; Point to real frame
+ JRST MRETFO]
+ MOVE C,FR.OFF+FR.PC(A) ; Get return PC if not glued
+MRETFO: MOVE M,FR.MSA+FR.OFF(A) ; MSUBR
+ MOVE M,@1(M)
+ MOVE M,1(M) ; IMSUBR
+ HLRZ 0,(M)
+ MOVE R,1(M)
+ CAIE 0,$TPCODE ; skip if fbin
+ JRST .+3
+ SKIPN R,PV%OFF(R) ; skip if already mapped in
+ PUSHJ P,@[MIMSEC,,DMAPI1] ; Map the guy in
+ MOVE B,@C ; THIS KLUDGE SEES IF WE CAN STEP TO
+ ; NEXT FRAME FOR THIS MRETURN
+ CAMN B,[JRST @<RETOFF+ENTVEC>] ; IS IT A RETURN
+ JRST [ MOVE O2,FR.OFF+FR.FRA(O2) ; YES, MRETURN FROM IT
+ SKIPGE (O2) ; skip if not glued frame
+ SUBI O2,FR.OFF ; fix up pointer
+ JRST MRET2 ] ; try this all again
+ MOVE C,TP
+ SUB C,O1
+ SUB C,O1
+ JSP PC,FRAME
+ PUSH TP,[$TFRAME,,$LFRAME]
+ PUSH TP,O2
+ MOVEI O2,1(O1)
+
+ JUMPE O1,MRET4
+MRET5: PUSH TP,1(C)
+ PUSH TP,2(C)
+ ADDI C,2
+ SOJG O1,MRET5
+MRET4:
+ MOVE O1,ECATM
+ JSP PC,CALLZ
+ JRST COMPER
+
+MRET3: XMOVEI F,FR.OFF(O2)
+ PUSH P,O1 ; SAVE NUMBER OF ITEMS
+ PUSH P,TP ; SAVE POINTER TO STACK
+ PUSH P,C
+ PUSH P,D
+ JSP E,FRMFIX ; UNBIND, DO RETURN
+ POP P,E
+ POP P,D
+ POP P,A ; GET BACK STACK
+ MOVE C,(P) ; GET BACK TUPLE LENGTH
+ LSH C,1 ; TWICE THAT FOR # OF WORDS
+ SUB A,C ; POINT TO FIRST ELEMENT
+ XMOVEI B,1(TP) ; SAVE POINTER TO TUPLE
+ JUMPN E,IRTPL2
+ ADDI PC,1
+IRTPL2: JUMPE C,IRTPLE ; AN EMPTY TUPLE
+IRTPLP: PUSH TP,1(A) ; PUSH AN ELEMENT OF THE TUPLE
+ PUSH TP,2(A)
+ ADDI A,2 ; MOVE THROUGH TUPLE
+ SUBI C,2 ; DECREMENT COUNT
+ JUMPN C,IRTPLP ; LOOP UNTIL DONE
+IRTPLE: JUMPE E,IRTPL3
+ POP P,A ; RESTORE LENGTH
+ HRLI A,$TTUPLE
+ JRST @PC ; WIN AWAY
+
+IRTPL3: POP P,B
+ MOVSI A,$TFIX
+ JRST @PC
+
+
+GRTUPL: XMOVEI E,FR.OFF-2(O2) ; SAVE A COPY OF GLUED FRAME
+ ; POP OF GLUED FRAME
+ MOVE F,FR.OFF+1(O2) ; GET RESTORED
+ MOVE A,O1 ; COPY # OF ELEMENTS
+ LSH O1,1 ; TO NUMBER OF WORDS
+ MOVE O2,TP
+ SUB O2,O1 ; POINT TO FIRST
+ XMOVEI B,1(E)
+ MOVE O1,A
+ JUMPN D,IGRTP3 ; JUMP IF RTUPLE NOT MRETURN
+ TLZE C,$QSFRB ; SEG CALL
+ AOJA C,IGRTP3 ; YES, SKIP RETURN WITH STUFF ON STACK
+ MOVE B,@C ; THIS KLUDGE SEES IF WE CAN STEP TO
+ ; NEXT FRAME FOR THIS MRETURN
+ CAMN B,[JRST @<RETOFF+ENTVEC>] ; IS IT A RETURN
+ JRST MRET2
+ JUMPE O1,COMPER ; MUST HAVE AT LEAST ONE ARG
+ DMOVE A,1(O2) ; RET 1ST ELEMENT
+ MOVE TP,E
+ JRST @C
+
+IGRTP3: JUMPE O1,IGRTP1
+IGRTP2: PUSH E,1(O2)
+ PUSH E,2(O2)
+ ADDI O2,2
+ SOJG O1,IGRTP2
+
+IGRTP1: MOVE TP,E
+ JUMPE D,IGRTP4 ; IF MRET, RET # OF ARGS
+ HRLI A,$TTUPLE
+ JRST @C
+
+IGRTP4: MOVEI B,(A)
+ MOVSI A,$TFIX
+ JRST @C
+\f
+SUBTTL CODE TO TRY TO MAP IN A FROB
+
+IFN SBRFY,[
+SBFPMP: MOVE R,1(M) ;pointer to pcode
+ SKIPE R,PV%OFF(R)
+ JRST (PC)
+
+SBFPM1: PUSH TP,$TFIX
+ PUSH TP,5(B)
+ PUSH TP,$TFIX
+ PUSH TP,O2
+ PUSHJ P,MAPIN
+ MOVE O2,(TP)
+ MOVE 0,-2(TP)
+ SUBI TP,4
+ JRST @0
+]
+DMAPIN: PUSH P,D ; NOT THERE, MAP IT IN
+ PUSH P,O2
+IFE FLIP, PUSH P,NARGS
+IFN FLIP,[
+ PUSH P,@[MIMSEC,,NARGS]
+ PUSH P,@[MIMSEC+1,,NARGS]
+]
+ PUSHJ P,MAPIN
+IFE FLIP, POP P,NARGS
+IFN FLIP,[
+ POP P,@[MIMSEC+1,,NARGS]
+ POP P,@[MIMSEC,,NARGS]
+]
+ POP P,O2
+ POP P,D
+ POPJ P,
+
+DMAPI1: PUSH P,PC ; NOT THERE, MAP IT IN
+ PUSH P,E
+ PUSH TP,A ; SAVE RET VAL
+ PUSH TP,B
+ PUSHJ P,MAPIN
+ DMOVE A,-1(TP)
+ ADJSP TP,-2
+ POP P,E
+ POP P,PC
+ POPJ P,
+
+MAPIN: SKIPN O1,MPATM ; HAVE WE BEEN SUPPLIED WITH ATOM?
+ JRST COMPERR
+ JSP PC,FRAME ; CREATE A FRAME
+ PUSH TP,(M) ; CALL WITH THE PURVE PNTR OF INTEREST
+ PUSH TP,1(M)
+ MOVEI O2,1 ; ONE ARG
+ JSP PC,CALLZ ; GO FOR IT
+ MOVE R,1(M) ; SET UP R NOW
+ SKIPN R,PV%OFF(R) ; FROM THE VECTOR
+ JRST COMPER ; OOPS?
+ POPJ P,
+\f
+
+CIGAS:
+ MOVSI A,$TFIX
+ SKIPE B,@(TP)
+ SKIPN B,(B)
+ MOVSI A,$TFALSE
+ JRST FOOADJ
+
+CIGVL: SKIPN B,@(TP)
+ JRST COMPER
+ DMOVE A,(B)
+FOOADJ: ADJSP TP,-8.
+ POPJ P,
+
+\f
+SUBTTL UTILITY
+
+HALTX: PUSH P,A
+ HRROI A,[ASCIZ /MIMI20 Not Running
+/]
+ PSOUT
+ POP P,A
+ HALTF
+ JRST .-1
+
+; GET THE NEXT ELEMENT ON THE STACK. POINTER INTO THE STACK
+; IS THE ARGUMENT (LOCAL). RETURNS AN OBJECT, OR A #UNBOUND -1
+; IF THERE IS NOTHING ELSE ON THE STACK
+
+NEXTS: SKIPN O1
+ JRST [MOVE B,CZONE
+ MOVE B,GCPOFF(B)
+ IRP %A,,[RCLOFF,RCLVOF,RCLV2O,RCLV3O,RCLV4O,RCLV7O,RCLV8O
+ RCL10O]
+ SETZM %A(B) ; THIS IS THE START OF A GC
+ TERMIN ; SO RELEASE EVERYTHING
+ MOVEI O1,STRTTP
+ HLL O1,TP
+; SETOM INGC ; DONT PERMIT INTERRUPTS
+ JRST INEXT4]
+INEXT2: HLRE B,(O1)
+ TRNE B,$FRMDOPE ; IS THIS A RECORD DOPE WORD?
+ JRST [CAIN B,$TTUPLE+$FRMDOPE
+ JRST INEXT3
+ LDB A,[000300,,B] ; GET SAT
+ CAIE A,$PRECORD ; RECORD?
+ JRST INEXT6 ; NO, SKIP IT (STACK STRUCTURE)
+ LDB B,[RTYBYT,,B] ; YES. GET RECORD TYPE
+ ASH B,1
+ MOVE B,@RECTBL+1(B) ; GET LENGTH FROM TABLE
+ LSH B,-1 ; DIVIDE BY TWO FOR 36-BIT WORDS
+ ADDI O1,1(B) ; ADD ONE FOR HEADER WORD
+ JRST INEXT5] ; REENTER CODE
+INEXT3: ADDI O1,2 ; POINT TO NEXT ELEMENT
+INEXT5: XMOVEI B,(TP) ; ARE WE DONE YET?
+ CAML O1,B
+ JRST [MOVEI B,0 ; YUP
+ JRST INEXT1 ]
+INEXT4: HLRE B,(O1)
+ JUMPL B,[ADDI O1,3 ; SKIP PSEUDO-FRAME
+ JRST INEXT5] ; TRY THAT
+
+ TRNE B,$FRMDOPE
+ JRST [ LDB A,[000300,,B]
+ CAIE A,$PRECORD
+ CAIN A,$PVECTOR
+ JRST INEXT7
+ JRST INEXT6 ]
+
+INEXT7: SKIPN 1(O1) ; DONT RETURN 0 POINTER
+ JRST [ CAIE B,$TBIND+$FRMDOPE
+ JRST INEXT2
+ JRST .+1 ]
+ MOVE B,O1
+INEXT1: MOVE A,$WFIX
+ JRST (PC)
+INEXT6: HRRZ B,(O1)
+ ADDI O1,2(B)
+ JRST INEXT5 ; SKIP STRUCTURE, TRY AGAIN
+
+CONTEN: DMOVE A,(O1) ; GET THE PAIR FROM THE STACK
+ TLZE A,$FRMDOPE ; IS THE TYPE-WORD A DOPE WORD?
+ XMOVEI B,1(O1) ; POINT PAST THE DOPE WORD
+ JRST (PC) ; RETURN RECORD POINTER
+
+\f
+SUBTTL TYPE MANIPULATION
+
+NEWTYP: LDB B,[300,,O1] ; GET PRIMTYPE BITS
+ MOVE A,$WTCNT ; GET TYPE COUNT
+ AOS $WTCNT
+ CAIL A,1024. ; MAX NUMBER
+ PUSHJ P,COMPER ; DIE
+ DPB A,[61300,,B] ; STUFF NEW TYPE CODE
+ MOVE A,$WFIX ; AND RETURN IT
+ JRST (PC)
+
+; TYPEW - build a type word O1/ type-code O2/ type-code of prim
+
+TYPEW: LDB B,[600,,O2]
+ MOVSI A,$TTYPW
+ CAIE B,$PRECORD
+ JRST [ HRLZ B,O1
+ JRST (PC) ]
+ LDB O2,[061200,,O2]
+ ASH O2,1
+ MOVE O2,RECTBL+1(O2) ; GET POINTER TO RECORD TABLE
+ HRRZ B,(O2) ; GET LENGTH FROM TABLE
+ HRL B,O1
+ JRST (PC)
+
+; Add user template information to internal record table"
+
+TMPTBL: LSH O1,1
+ DMOVEM A,RECTBL(O1)
+ JRST (PC)
+
+XRECOR: SUBM R,(P) ; RELATIVIZE PC IN CASE OF GC
+ MOVEI A,2(O2)
+ PUSH P,E
+ PUSH P,O1
+ PUSH P,O2
+ JSP PC,IBLOCK
+ POP P,C
+ MOVE D,C ; CHANGED BY MARC (BAD DOPE WORD)
+ ADD C,A ; POINT TO DW
+ POP P,O1
+ HRL D,O1
+ TLO D,$DOPEBIT
+ TLNN 0,$GC%DW ; SKIP IF NO DW
+ MOVEM D,(C)
+ MOVE B,A
+ POP P,A
+ HRL A,O1
+ ANDI O1,$PBITS
+ CAIN O1,$PSTRING
+ ADD B,[657777,,-1] ; MAKE GLOBAL BP
+ CAIN O1,$PBYTES
+ ADD B,[577777,,-1]
+RPOPJ: SUBM R,(P)
+ POPJ P,
+\f
+SUBTTL STRUCTURE CREATION
+
+LIST: SUBM R,(P)
+ SETZ B, ; INITIALIZE CDR
+LISTL: SOJL O1,LISTE ; LOOP UNTIL DONE
+ PUSH TP,$WLIST
+ PUSH TP,B
+ PUSH P,O1
+ PUSHJ P,ICELL ; GET A CELL IN 'A'
+ POP TP,(A)
+ ADJSP TP,-1
+ POP TP,2(A) ; POP VALUE
+ POP TP,1(A) ; AND TYPE/LENGTH INTO CELL
+ POP P,O1
+ MOVE B,A ; UPDATE CDR POINTER
+ JRST LISTL ; AND LOOP
+
+LISTE: MOVE A,$WLIST ; TYPE-WORD LIST
+ SUBM R,(P)
+ POPJ P,
+
+UBLOCK: TLNE O2,-1
+ JRST COMPER ; either negative of too big
+ SUBM R,(P)
+ HRLZS O1
+ PUSHJ P,UBLOKR
+ SUBM R,(P)
+ POPJ P,
+
+UBLOKR: MOVE A,O1
+ HRR O1,O2 ; MAKE TYPE WORD (WRONG FOR STRING, BYTES)
+ MOVE D,O2
+ LSH D,1
+ PUSH P,D
+ SUBM TP,D ; POINT D AT FIRST ELEMENT
+ LDB A,[220200,,A]
+ JRST @UBLTBL(A)
+
+UBLTBL: SETZ UBLB
+ SETZ UBLS
+ SETZ UBLU
+ SETZ UBLV
+
+UBLB: MOVEI A,4
+ MOVSI B,441000
+ HRLOI C,577777
+ PUSHJ P,DOSTR
+ PUSH P,A ; PUT # WORDS WHERE EXPECTED
+ JRST UBLR1
+
+UBLS: MOVEI A,5
+ MOVSI B,440700
+ HRLOI C,657777
+ PUSHJ P,DOSTR
+ PUSH P,A
+ JRST UBLR1
+
+; COUNT IS IN O2; POINTER IN D. RETURN COUNT IN A; CAN CLOBBER D.
+STRCNT: MOVEI A,0
+ PUSH P,B
+ PUSH P,C
+ MOVE B,O2
+ JUMPE B,STRCDN
+STRCLP: LDB C,[220304,,1]
+ JUMPN C,STRCST ; A CHARACTER
+ AOJA A,STRELP
+STRCST: HRRZ C,1(D)
+ ADD A,C ; LENGTH OF STRING/BYTES
+STRELP: ADDI D,2
+ SOJG B,STRCLP
+STRCDN: POP P,C
+ POP P,B
+ POPJ P,
+
+; BYTE POINTER IN B, ARG POINTER IN D, ARG COUNT IN O2, A IS SACRED
+; (BYTE POINTER IS (A)).
+STRMOV: LDB C,[220304,,1] ; SAT OF THING IN 1(D)
+ JUMPN C,STRMVB
+ MOVE C,2(D)
+ IDPB C,B ; STUFF OUT A BYTE
+STRMEL: ADDI D,2
+ SOJG O2,STRMOV
+ POPJ P,
+STRMVB: HRRZ E,1(D)
+ JUMPE E,STRMEL
+ MOVE 0,2(D)
+STRMVL: ILDB C,0
+ IDPB C,B
+ SOJG E,STRMVL
+ JRST STRMEL
+
+DOSTR: ADJSP P,3 ; SPACE FOR EXTRA STUFF
+ PUSH P,A ; BYTES/WORD
+ PUSH P,B ; FROB TO MAKE LOCAL BYTE POINTER
+ PUSH P,C ; FROB TO MAKE GLOBAL BP WHEN DONE
+ PUSH P,D
+ PUSHJ P,STRCNT
+ HRR O1,A ; FIX UP SAVED TYPE WORD
+ ADD A,-3(P)
+ SUBI A,1 ; ROUND UP TO NEXT FULL WORD
+ IDIV A,-3(P)
+ MOVEM A,-6(P) ; # OF WORDS FOR FROB
+ ADDI A,2
+ PUSH P,O1
+ PUSH P,O2
+ JSP PC,IBLOCK ; GET STORAGE
+ POP P,O2
+ POP P,O1
+ POP P,D
+ MOVEM A,-4(P)
+ MOVEM 0,-3(P) ; SAVE ADDRESS AND FLAGS
+ MOVE B,-1(P) ; ARGUMENT FROM B
+ TLO B,1 ; MAKE BP (A)
+ JUMPE O2,STRMDN ; OBVIOUSLY EMPTY?
+ PUSH P,D
+ PUSHJ P,STRMOV
+ POP P,D
+STRMDN: MOVE 0,-3(P) ; FLAGS
+ MOVE B,-4(P) ; ADDRESS
+ MOVE C,-5(P) ; # WORDS
+ ADD C,B ; POINT TO DOPE WORDS
+ ADD B,(P) ; GLOBAL BP
+ ADJSP P,-5 ; FLUSH ALL BUT # OF WORDS
+ POP P,A ; VALUES IN A,B,C
+ POPJ P,
+
+UBLR: POP P,B ; TP BECOMES PLACE OF FIRST ARG.
+ MOVE C,(P) ; # OF WORDS IN THE UBLOCK
+ ADD C,B
+UBLR1: POP P,D ; # OF WORDS
+ TLNN 0,$GC%DW ; MAYBE STUFF INTO DOPE WORDS
+ HRRM D,(C)
+ MOVE D,O1 ; OTHER HALF OF DOPE WORD
+ TLO D,$DOPEBIT
+ TLNN 0,$GC%DW
+ JRST [HLLM D,(C)
+ SETZM 1(C)
+ JRST .+1]
+ POP P,D
+ MOVNS D
+ ADJSP TP,(D)
+ MOVE A,O1
+ POPJ P,
+
+UBLU: MOVE A,O2 ; GET # ARGUMENTS
+ PUSH P,A
+ ADDI A,2 ; ADD DOPE WORDS
+ PUSH P,O1
+ PUSH P,D
+ PUSH P,O2
+ JSP PC,IBLOCK ; GET CORE
+ POP P,O2
+ POP P,D
+ POP P,O1
+ PUSH P,A ; SAVE LOCATION
+ JUMPE O2,UBLR
+UBLUL: MOVE B,2(D)
+ MOVEM B,(A)
+ ADDI D,2
+ ADDI A,1
+ SOJN O2,UBLUL ; AND LOOP
+ JRST UBLR
+
+UBLV: MOVE A,O2 ; GET # ARGUMENTS
+ LSH A,1 ; 2 36-BIT WORDS FOR EACH
+ PUSH P,A
+ ADDI A,2 ; ADD DOPE WORDS
+ PUSH P,O1
+ PUSH P,D
+ PUSH P,O2
+ JSP PC,IBLOCK ; GET CORE
+ POP P,O2
+ POP P,D
+ POP P,O1
+ PUSH P,A ; SAVE LOCATION
+ JUMPE O2,UBLR ; CHOMPING EMPTY VECTOR
+UBLVL: MOVE B,1(D)
+ MOVEM B,(A)
+ MOVE B,2(D)
+ MOVEM B,1(A) ; STUFF
+ ADDI D,2
+ ADDI A,2
+ SOJN O2,UBLVL ; AND LOOP
+ JRST UBLR
+
+; RETURN UNINITIALIZED STORAGE. ARGS JUST LIKE UBLOCK (O1 TYPE, O2 # ELEMENTS),
+; BUT NOTHING ON STACK.
+UUBLOCK:
+ TLNE O2,-1
+ JRST COMPER ; either negative or too big!
+ HRLZS O1
+ SUBM R,(P) ; IN CASE OF GC
+ LDB A,[220200,,O1] ; GET TYPE
+ JRST @UUBLTB(A) ; TYPE DISPATCH
+UUBLTB: SETZ UUBLB
+ SETZ UUBLS
+ SETZ UUBLU
+ SETZ UUBLV
+
+UUBLB: MOVEI A,4
+ JRST UUBLS1 ; LIKE STRING, WITH 4 BYTES/WORD
+UUBLS: MOVEI A,5
+UUBLS1: MOVE B,O2 ; # OF ELEMENTS
+ ADDI B,-1(A) ; ROUND UP
+ IDIV B,A ; # OF WORDS NEEDED
+ PUSHJ P,UIB ; BUILD THE STORAGE
+ HRLOI C,657777
+ CAME O1,[$TSTRING,,0]
+ HRLOI C,577777
+ ADD B,C ; MAKE A BYTE POINTER
+UUBLR: SUBM R,(P)
+ POPJ P,
+UUBLU: MOVE B,O2
+ PUSHJ P,UIB
+ JRST UUBLR
+UUBLV: MOVE B,O2
+ LSH B,1
+ PUSHJ P,UIB
+ PUSHJ P,CLRVEC ; THIS HAS TO BE ZEROED
+ JRST UUBLR
+; TYPE IN O1, LENGTH IN O2, # WORDS (EXCLUSIVE OF DW) IN B. RETURN
+; POINTER IN A, B (SOMEBODY ELSE MAKES BYTE POINTER FOR STRINGS, BYTES
+UIB: CAILE B,777000-2 ;length better be less than a section
+ JRST COMPER
+ PUSH P,B
+ PUSH P,O1
+ PUSH P,O2
+ MOVEI A,2(B) ; # WORDS, WITH DW
+ JSP PC,IBLOCK ; GET THE STORAGE
+ POP P,O2
+ POP P,O1
+ TLNN 0,$GC%DW
+ JRST [MOVE B,A
+ ADD B,(P) ; POINT AT DOPE WORDS
+ MOVE D,O1
+ TLO D,$DOPEBIT
+ HLLM D,(B)
+ MOVE D,(P)
+ HRRM D,(B)
+ JRST .+1]
+ ADJSP P,-1
+ MOVE B,A
+ MOVE A,O1
+ HRR A,O2
+ POPJ P,
+
+; BUILD STACK STRUCTURES. O1 IS TYPE WORD, O2 IS # ELTS.
+SBLOCK: TLNE O2,-1 ; skip if not negative or too big
+ PUSHJ P,COMPER
+ HRLZS O1
+ MOVE D,O2
+ LSH D,1
+ SUBM TP,D ; POINT AT FIRST ARGUMENT (-1)
+ LDB A,[220200,,O1] ; GET LOW BITS OF SAT
+ JRST @SBTBL(A)
+SBTBL: SETZ SBBYT
+ SETZ SBSTR
+ SETZ SBUVC
+ SETZ SBVEC
+
+SBVEC: EXCH O1,O2 ; THIS IS ALMOST LIKE TUPLE
+ JSP PC,TUPLE
+ HLL A,O2
+ POPJ P,
+SBUVC: HRR O1,O2
+ MOVE A,O1 ; TYPE WORD
+ TLO O1,$FRMDOPE ; DOPE WORD
+ MOVEM O1,1(D) ; STUFF OUT FIRST DOPE WORD
+ XMOVEI C,2(D)
+ MOVE B,C ; SAVE POINTER
+ JUMPE O2,SBUVCD
+SBUVCL: MOVE E,2(D) ; PICK UP A FROB
+ MOVEM E,(C) ; STUFF IT OUT
+ ADDI D,2 ; UPDATE POINTER TO SOURCE
+ ADDI C,1 ; AND TO DEST
+ SOJG O2,SBUVCL ; JUMP IF NOT DONE
+SBUVCD: MOVEM O1,(C) ; OTHER DOPE WORD
+ MOVE TP,C ; UPDATE STACK
+ POPJ P, ; DONE
+
+; STACK BYTES AND STRINGS. D STILL HAS POINTER TO FIRST ARGUMENT
+SBBYT: MOVEI A,4
+ MOVSI B,441000
+ HRLOI C,577777
+ PUSHJ P,STKSTR
+ POPJ P,
+
+SBSTR: MOVEI A,5
+ MOVSI B,440700
+ HRLOI C,657777
+ PUSHJ P,STKSTR
+ POPJ P,
+
+STKSTR: PUSH P,O1
+ PUSH P,O2
+ PUSH P,A
+ PUSH P,B
+ PUSH P,C
+ PUSH P,D
+ PUSHJ P,STRCNT ; GET LENGTH OF NEW STRING INTO A
+ PUSH P,A ; SAVE IT
+ ADD A,-4(P)
+ SUBI A,1
+ IDIV A,-4(P) ; # WORDS FOR STRING
+ HRR O1,A ; SAVE FOR DOPE WORDS
+ ADDI A,2 ; PLUS DOPE
+ TLO O1,$FRMDOPE ; MAKE IT A DOPE WORD
+ MOVE B,O2
+ LSH B,1 ; WORDS OF ARGUMENT
+ MOVE C,-1(P) ; BEGINNING OF BLOCK, ALMOST
+ ADDI C,1 ; REAL BEGINNING OF BLOCK
+ PUSH P,C ; WHICH WILL BE LOC OF 1ST DOPE WORD
+ MOVE D,C
+ CAML A,B ; ENSURE NO BACKWARDS BLT PROBLEMS
+ JRST [ADD D,A
+ JRST SSBCNT]
+ ADD D,B
+SSBCNT: MOVEM D,-2(P) ; SAVE IT
+ XBLT B, ; BLT THE ARGS DOWN THE STACK
+ POP P,A ; GET POINTER TO STACK AREA WE'RE USING
+ MOVEM O1,(A) ; DUMP OUT FIRST DW
+ ADDI A,1
+ PUSH P,A ; SAVE ADDRESS OF RESULT
+ MOVE B,-4(P) ; LOCAL BYTE POINTER
+ TLO B,1 ; MAKE IT BE (A)
+ MOVE O2,-6(P)
+ JUMPE O2,SSBNOM
+ MOVE D,-2(P)
+ SUBI D,1 ; SHOULD POINT BEFORE ARG BLOCK
+ PUSHJ P,STRMOV ; COPY THE STUFF IN
+SSBNOM: MOVE B,(P) ; RESULT POINTER
+ HRRI C,(O1)
+ ADDI B,(C) ; POINT TO LAST DOPE WORD
+ MOVEM O1,(B) ; STUFF OUT DOPE WORD
+ MOVE TP,B
+ POP P,B ; POINTER
+ POP P,A
+ HLL A,O1
+ TLZ A,$FRMDOPE
+ ADD B,-1(P)
+ ADJSP P,-6
+ POPJ P,
+
+; RETURN UNINITIALIZED STORAGE ON STACK. O1 IS TYPE WORD, O2 IS # ELTS.
+; SAVE ACS EXCEPT A AND B.
+USBLOCK:
+ TLNE O2,-1
+ JRST COMPER ; either negative or too big
+ HRLZS O1
+ PUSH P,C
+ LDB A,[220200,,O1]
+ JRST @USTBL(A)
+USTBL: SETZ USBYT
+ SETZ USSTR
+ SETZ USUVC
+ SETZ USVEC
+USBYT: MOVEI A,3(O2)
+ IDIVI A,4 ; # WORDS, EXCLUDING DOPE WORDS
+ MOVE C,O1
+ TLO C,$FRMDOPE
+ HRRI C,(A)
+ PUSH TP,C
+ XMOVEI B,1(TP)
+ ADJSP TP,(A)
+ PUSH TP,C
+ ADD B,[577777,,-1]
+USRET: MOVE A,O1
+ HRR A,O2
+ POP P,C
+ POPJ P,
+USSTR: MOVEI A,4(O2)
+ IDIVI A,5
+ MOVE C,O1
+ TLO C,$FRMDOPE
+ HRRI C,(A)
+ PUSH TP,C
+ XMOVEI B,1(TP)
+ ADJSP TP,(A)
+ PUSH TP,C
+ ADD B,[657777,,-1]
+ JRST USRET
+
+USUVC: MOVE C,O1 ; MAKE A DOPE WORD
+ TLO C,$FRMDOPE
+ HRRI C,(O2) ; # ELTS + 2 FOR DOPE WORD
+ PUSH TP,C ; PUSH HEADER DOPE WORD
+ XMOVEI B,1(TP) ; SAVE POINTER
+ ADJSP TP,(O2) ; CREATE SPACE
+ PUSH TP,C ; PUSH TRAILER DOPE WORD
+ JRST USRET ; RETURN
+
+USVEC: MOVE A,O2
+ LSH A,1
+ MOVE C,O1
+ TLO C,$FRMDOPE
+ HRRI C,(A)
+ XMOVEI B,1(TP)
+ ADJSP TP,(A)
+ PUSH TP,C
+ PUSH TP,[0]
+ MOVE A,O1
+ HRR A,O2
+ PUSHJ P,CLRVEC
+ POP P,C
+ POPJ P,
+
+; ZERO A VECTOR
+CLRVEC: TRNN A,-1
+ POPJ P, ; EMPTY
+ PUSH P,C ; SAVE ACS
+ PUSH P,D
+ PUSH P,E
+ HRRZ C,A ; GET LENGTH IN WORDS
+ LSH C,1
+ SUBI C,1 ; LESS FIRST WORD
+ SETZM (B) ; CLEAR FIRST WORD
+ MOVE D,B ; SOURCE BLOCK
+ XMOVEI E,1(B) ; DEST BLOCK
+ XBLT C, ; DO IT
+ POP P,E
+ POP P,D
+ POP P,C
+ POPJ P,
+
+RECORD: SUBM R,(P)
+ HRLZS O1
+ PUSHJ P,RECORR
+ SUBM R,(P)
+ POPJ P,
+
+RECORR: LDB A,[301200,,O1]
+ ASH A,1
+ MOVE A,RECTBL+1(A) ; GET POINTER TO RECORD TABLE
+ ADDI A,1 ; POINT TO FIRST ENTRY
+ PUSH P,O1 ; SAVE TYPE WORD FOR RETURN
+ PUSH P,A ; SAVE POINTER TO TABLE
+
+; HLRZ C,-1(A)
+; HRRM C,-1(P)
+; HRRZ A,-1(A) ; GET # 1/2 WORDS NEEDED FOR RECORD
+
+; THE SEMI'ED LINES ABOVE ARE CHANGED TO THE TWO FOLLOWING
+; SHOULD CHANGE THE LENGTH FIELD OF RECORDS TO BE 'RIGHT'
+; I.E. THE NUMBER OF 1/2 WORDS IN THE RECORD
+
+ HRRZ A,-1(A)
+ HRRM A,-1(P)
+
+ ASH A,-1
+ PUSH P,A ; SAVE THIS FOR A MOMENT
+ ADDI A,2 ; ADD FOR DOPE WORDS
+ PUSH P,O1
+ PUSH P,O2
+ JSP PC,IBLOCK ; HERE THEY ARE
+ POP P,O2
+ POP P,O1
+ MOVE C,A ; HOLD ON TO RECORD POINTER
+ ADD A,(P) ; POINT TO THE DOPE WORD
+ POP P,B ; HERE'S THE # WORDS AGAIN
+ TLNN 0,$GC%DW
+ JRST [TLO O1,$DOPEBIT ; SET THE DOPEWORD BIT
+ HLLM O1,(A) ; PUT TYPE WORD IN DOPES
+ HRRM B,(A) ; STORE IT IN DOPE WORD
+ SETZM 1(A)
+ JRST .+1]
+ POP P,A ; RESTORE TABLE POINTER
+ PUSH P,C ; SAVE POINTER TO RECORD FOR RETURN
+ MOVE D,C
+ MOVSI C,222200+D ; MAKE BP TO RECORD
+ MOVE E,O2 ; GET COUNT OF ELEMENTS
+ LSH E,1 ; 2 WORDS PER ELEMENT
+ PUSH P,E
+ SUBM TP,E ; E POINTS TO FIRST ARG
+ ADDI E,1
+RECORL: HLRZ C,1(A) ; BYTE OFFSET
+ ADJBP C,[222200+D,,0]
+ HRRZ B,1(A) ; SIZE OF THIS ELEMENT IN RECORD
+ PUSHJ P,@PUTRTB-1(B) ; DO A 'PUTR'
+ ADDI A,2 ; ADVANCE POINTER IN TABLE
+ ADDI E,2 ; ADVANCE POINTER TO ELEMENT
+ SOJN O2,RECORL ; LOOP UNTIL DONE
+ POP P,D
+ MOVNS D
+ ADJSP TP,(D) ; RESTORE TP
+ POP P,B ; RESTORE VALUE WORD (POINTER)
+ POP P,A ; RESTORE TYPE/LENGTH WORD
+ POPJ P,
+
+\f
+SUBTTL STRUCTURE MANIPULATION
+
+NTHU: LDB A,[UPTBYT,,A] ; TYPE IN A, PTR IN O1, NUM IN O2
+ JRST @NTHUTB(A)
+
+NTHUTB: SETZ NTHUS
+ SETZ NTHUS
+ SETZ NTHUU
+ SETZ NTHUV
+
+NTHUB: ADJBP O2,O1
+ LDB B,O2
+ MOVE A,$WFIX
+ POPJ P,
+
+NTHUS: ADJBP O2,O1
+ LDB B,O2
+ MOVE A,$WCHARACTER
+ POPJ P,
+
+NTHUU: SUBI O2,1
+ ADD O2,O1
+ MOVE A,$WFIX
+ MOVE B,(O2)
+ POPJ P,
+
+NTHUV: SUBI O2,1
+ LSH O2,1
+ ADD O2,O1
+ DMOVE A,(O2)
+ POPJ P,
+
+;; NTHR CODE
+
+NTHR:
+NTHRR: ASH A,1
+ SKIPN A,RECTBL+1(A) ; AND POINTER TO TABLE
+ PUSHJ P,HALTX
+ LSH O2,1 ; 4 16-BIT WORDS / ENTRY
+ ADDI A,-1(O2) ; POINT TO CORRECT ENTRY
+ HRRZ B,1(A) ; GET SIZE OF ITEM TO EXTRACT
+ HLRZ C,1(A) ; WORD OFFSET TO START FROM
+ MOVE O2,O1 ; COPY IN CASE MULTI SECT
+; HRLI O1,222240 ; MAKE WORK IN MULTI SECT
+ MOVSI O1,222200+O2
+ ADJBP C,O1 ; MAKE BYTE POINTER TO ITEM
+ ; IN MULTI SECT, C & D ARE BPTR
+ JRST @NTHRTB-1(B) ; DISPATCH
+
+NTHRTB: SETZ NTHRBB ; BOOLEAN
+ SETZ NTHRE ; ERROR - SHOULDN'T HAPPEN
+ SETZ NTHRBB ; ENUMERATION
+ SETZ NTHRBB ; SUB-RANGE
+ SETZ NTHRBB ; SUB-RANGE (SBOOL)
+ SETZ NTHRLF ; LIST OR FIX
+ SETZ NTHRLF ; LIST OR FIX (SBOOL)
+ SETZ NTHRS3 ; STRUC IN 3 HALF WORDS
+ SETZ NTHRS3 ; SAME WITH SBOOL
+ SETZ NTHRS2 ; STRUC WITH DEFINED LENGTH
+ SETZ NTHRS2 ; SAME SBOOL
+ SETZ NTHRA ; ANY
+ SETZ NTHRHW ; SPECIAL TYPE-C CASE
+
+; HERE TO EXTRACT A BOOLEAN
+
+NTHRBB: LDB B,C ; GET WORD OF BOOLEANS
+ LSH B,18. ; SHIFT OVER
+ ILDB C,C ; GET NEXT 16 BITS
+ IOR B,C ; THEN OR THEM TOGETHER
+ LDB C,[111100,,(A)] ; GET LEFT SHIFT
+ LSH B,(C) ; SHIFT IT
+ LDB C,[001100,,(A)] ; GET RIGHT SHIFT
+ MOVNS C
+ LSH B,(C) ; SHIFT RIGHT
+ HLLZ A,(A)
+ POPJ P,
+
+; HERE FOR LOSER
+
+NTHRE: PUSHJ P,COMPER
+
+; HERE TO EXTRACT LIST OR FIX
+
+NTHRLF: HLLZ A,(A) ; GET TYPE/LENGTH FROM TABLE
+ LDB B,C ; GET VALUE BYTE
+ LSH B,18. ; SHIFT OVER
+ ILDB C,C ; GET NEXT 16 BITS
+ IOR B,C ; THEN OR THEM TOGETHER
+ POPJ P,
+
+; HERE TO EXTRACT 2-WORD ITEM
+
+NTHRS3: HLLZ A,(A) ; GET TYPE/LENGTH FROM TABLE
+ LDB 0,C ; LOAD FIRST 16 BITS
+ ILDB B,C ; GET NEXT 16 BITS
+ LSH B,18. ; SHIFT OVER
+ ILDB C,C ; GET NEXT 16 BITS
+ IOR B,C ; THEN OR THEM TOGETHER
+ HRR A,0
+NTHRX: JUMPN B,CPOPJ
+ MOVE A,$WFALSE
+CPOPJ: POPJ P,
+
+; HERE TO EXTRACT STRUC WITH KNOWN LENGTH ITEM
+
+NTHRS2: LDB B,C ; GET LENGTH WORD
+ LSH B,18. ; SHIFT OVER
+ ILDB C,C ; GET NEXT 16 BITS
+ IOR B,C ; THEN OR THEM TOGETHER
+ MOVE A,(A) ; GET TYPE WORD FROM TABLE
+ ILDB C ; FIX POINTER (SHOULD BE IBP)
+ JRST NTHRX
+
+; HERE TO EXTRACT 4-WORD ITEM (ANY)
+
+NTHRA: LDB B,C ; GET TYPE WORD
+ HRLZS B
+ ILDB A,C ; GET LENGTH WORD
+ IOR A,B ; PUT EM TOGETHER
+ ILDB B,C ; LOAD FIRST 16 BITS
+ LSH B,18. ; SHIFT OVER
+ ILDB C,C ; GET NEXT 16 BITS
+ IOR B,C ; THEN OR THEM TOGETHER
+ POPJ P,
+
+NTHRHW: LDB B,C ; GET POSSIBLE TYPE CODE
+ CAIN B,-1
+ JRST [ MOVEI B,0
+ MOVSI A,$TFALSE
+ POPJ P, ]
+ HLLZ A,(A) ; TYPE FROM TABLE
+ POPJ P,
+
+PUTU: LDB A,[UPTBYT,,A]
+ JRST @PUTUTB(A)
+
+PUTUTB: SETZ PUTUS
+ SETZ PUTUS
+ SETZ PUTUU
+ SETZ PUTUV
+
+PUTUS: ADJBP O2,B
+ DPB D,O2
+ POPJ P,
+
+PUTUU: ADDI B,-1(O2)
+ MOVEM D,(B)
+ POPJ P,
+
+PUTUV: SUBI O2,1
+ LSH O2,1
+ ADD B,O2
+ DMOVEM C,(B)
+ POPJ P,
+
+PUTR: ASH A,1
+ SKIPN A,RECTBL+1(A) ; AND POINTER TO TABLE
+ PUSHJ P,HALTX
+ PUSH TP,(D) ; SAVE VALUE
+ PUSH TP,1(D)
+ LSH O2,1 ; 4 16-BIT WORDS / ENTRY
+ ADDI A,-1(O2) ; POINT TO CORRECT ENTRY (REMEMBER TOP)
+ HRRZ B,1(A) ; GET SIZE OF ITEM TO EXTRACT
+ HLRZ C,1(A) ; WORD OFFSET TO START FROM
+ MOVE O2,O1
+ XMOVEI E,-1(TP) ; SEND VALUE IN E
+; HRLI O1,LH+40
+ MOVSI O1,LH+O2
+ ADJBP C,O1 ; MAKE BYTE POINTER TO ITEM
+ PUSHJ P,@PUTRTB-1(B) ; DISPATCH
+ ADJSP TP,-2
+ POPJ P,
+
+PUTRTB: SETZ PUTRBB ; BOOLEAN
+ SETZ PUTRE ; ERROR - SHOULDN'T HAPPEN
+ SETZ PUTRBB ; ENUMERATION
+ SETZ PUTRBB ; SUB-RANGE
+ SETZ PUTRBB ; SUB-RANGE (SBOOL)
+ SETZ PUTRLF ; LIST OR FIX
+ SETZ PUTRLF ; LIST OR FIX (SBOOL)
+ SETZ PUTRS3 ; STRUC IN 3 HALF WORDS
+ SETZ PUTRS3 ; SAME WITH SBOOL
+ SETZ PUTRS2 ; STRUC WITH DEFINED LENGTH
+ SETZ PUTRS2 ; SAME SBOOL
+ SETZ PUTRA ; ANY
+ SETZ PUTRHW ; SPECIAL CASE FOR TYPE-C
+
+; HERE TO SET A BOOLEAN
+
+PUTRBB: LDB 0,[111100,,(A)] ; GET LSHIFT
+ LDB A,[001100,,(A)] ; GET RSHIFT
+ MOVE B,A
+ SUB B,0
+ LSH B,30. ; BUILD BYTE POINTER
+ MOVEI 0,36.
+ SUBI 0,(A)
+ LSH 0,24.
+ IOR 0,B ; HAVE LH OF BYTE POINTER
+ LDB B,C
+ LSH B,18.
+ ILDB A,C
+ IOR A,B
+ HRRI 0,A ; POINT TO AC
+ MOVE B,1(E) ; NEW VAL
+ DPB B,0 ; SMASH REGISTER
+ DPB A,C ; PUT IT BACK
+ MOVNI B,1
+ ADJBP B,C ; SMASH OTHER BYTE
+ HLRZS A
+ DPB A,B ; OTHER HALF BACK IN
+ POPJ P,
+
+
+PUTRE: PUSHJ P,COMPER
+
+PUTRLF: LDB B,[LH,,1(E)] ; GET LH OF VALUE OF 3RD ARG
+ DPB B,C ; AND STUFF
+ LDB B,[RH,,1(E)] ; GET RH OF VALUE OF 3RD ARG
+ IDPB B,C ; AND STUFF
+ POPJ P,
+
+PUTRS2: HLRZ B,(E) ; TYPE OF ARG
+ CAIN B,$WFALSE
+ SETZM 1(E) ; MAKE SURE 0
+ JRST PUTRLF
+
+; HERE FOR 3 WORD ITEM (IE LENGTH AND POINTER)
+
+PUTRS3: LDB B,[LENWRD,,(E)] ; GET LENGTH
+ DPB B,C ; STUFF IT
+ ILDB C ; FIX POINTER (SHOULD BE IBP)
+ JRST PUTRS2
+
+; HERE TO SET 4-WORD ITEM (ANY)
+
+PUTRA: LDB B,[TYPWRD,,(E)] ; GET TYPE
+ DPB B,C ; AND STUFF IT
+ LDB B,[LENWRD,,(E)]
+ IDPB B,C
+ ILDB B,C
+ JRST PUTRLF
+
+PUTRHW: LDB B,[TYPWRD,,(E)] ; TYPE OF ARG
+ CAIE B,$TFALSE ; FALSE ==> ZERO SLOT
+ SKIPA B,1(E) ; NOT FALSE USE TYPEC
+ MOVEI B,-1
+ DPB B,C ; STORE IT
+ POPJ P,
+
+BACKU: MOVNS O2
+RESTU: LDB C,[UPTBYT,,A]
+ JRST @RESUTB(C)
+
+RESUTB: SETZ RESUB
+ SETZ RESUS
+ SETZ RESUU
+ SETZ RESUV
+
+RESUU: SUB A,O2
+ ADD B,O2
+ HRLI A,$TUVECTOR
+ JRST (PC)
+
+RESUB: SUB A,O2
+ EXCH B,O2
+ ADJBP B,O2
+ HRLI A,$TBYTES
+ JRST (PC)
+
+RESUS: SUB A,O2
+ EXCH B,O2
+ ADJBP B,O2
+ HRLI A,$TSTRING
+ JRST (PC)
+
+RESUV: SUB A,O2
+ LSH O2,1
+ ADD B,O2
+ HRLI A,$TVECTOR
+; CAMG B,TP
+; HRLI A,$TTUPLE ; Win with tuples???
+ JRST (PC)
+
+TOPU: HRRZ C,A
+ LDB D,[UPTBYT,,A]
+ JRST @TOPUTB(D)
+
+TOPUTB: SETZ TOPUB
+ SETZ TOPUS
+ SETZ TOPUU
+ SETZ TOPUV
+
+TOPUB: MOVEI D,60
+ MOVEI E,4
+ HRLI 0,$TBYTES
+ JRST TOPUS1
+
+TOPUS: MOVEI D,66
+ MOVEI E,5
+ HRLI 0,$TSTRING
+TOPUS1: ADJBP C,B ; ADJUST TO THE END
+ MOVE B,C
+ LDB C,[360600,,B]
+ SUBI C,(D) ; # BYTES UNUSED IN LAST WORD
+ TLZ B,770000 ; MAKE WORD POINTER
+ HRRZ A,1(B) ; THIS IS TOTAL LENGTH (FROM DOPE)
+ SUB B,A ; TO WORD ADDRESS OF STRING START
+ IMUL A,E
+ LSH D,12.
+ TLO B,(D) ; MAKE CORRECT GLOBAL BP
+ ADD A,C ; ADJUST LENGTH
+ HLL A,0 ; MAKE A TYPE WORD
+ JRST (PC)
+
+TOPUU: ADD B,C ; POINT TO DOPE WORD
+ HRRZ A,(B) ; GET TOTAL LENGTH
+ SUB B,A ; BACK IT UP
+ HRLI A,$TUVECTOR ; HERE'S THE TYPE WORD
+ JRST (PC)
+
+TOPUV: LSH C,1
+ ADD B,C ; POINT TO DOPE WORD
+ HRRZ A,(B) ; HERE IS TOTAL LENGTH
+ SUB B,A ; POINTS TO TOP OF VECTOR
+ LSH A,-1 ; GET LENGTH
+ HRLI A,$TVECTOR ; AND FINISH TYPE WORD
+ JRST (PC)
+
+; HERE FOR CONS NEEDING GC
+
+CONS1: PUSH P,PC
+ SUBM R,(P)
+ PUSH TP,C
+ PUSH TP,D
+ PUSH TP,$WLIST
+ PUSH TP,E ; IN CASE A GC OCCURS
+ PUSHJ P,ICELL
+ POP TP,(A)
+ ADJSP TP,-1
+ POP TP,2(A)
+ POP TP,1(A)
+ MOVE B,A
+ MOVE A,$WLIST
+ JRST RPOPJ
+
+
+\f
+SUBTTL INPUT / OUTPUT
+
+BPS: 440700,,(D)
+ 350700,,(D)
+ 260700,,(D)
+ 170700,,(D)
+ 100700,,(D)
+
+OPENX: MOVE E,D
+ PUSHJ P,OPNAM ; MAKE FILE NAME STRING
+ HRROI B,FNBLK
+ XCT GTJMOD(O1) ; PERFORM GTJFN BITS MAGIC
+ GTJFN
+ JUMP 16,JFSERR
+ MOVE B,O2
+ LSH B,30.
+ XCT OPNMOD(O1) ; PERFORM OPENF BITS MAGIC
+ OPENF
+ JUMP 16,JFSERR
+ MOVE B,$WFIX ; RETURN JFN NUMBER
+ EXCH A,B
+ POPJ P,
+
+OPNAM: MOVE B,[440700,,FNBLK] ; BP TO FILE NAME BLOCK
+ HRRZS C
+OPNAML: ILDB 0,E ; GET CHARACTER
+ IDPB 0,B ; AND STUFF IT
+ SOJN C,OPNAML ; LOOP UNTIL DONE
+ SETZ 0,
+ IDPB 0,B ; MAKE IT ASCIZ
+ POPJ P,
+
+GTJMOD: MOVSI A,(GJ%SHT+GJ%OLD)
+ MOVSI A,(GJ%SHT+GJ%FOU)
+ JRST COMPER
+ JRST COMPER
+
+OPNMOD: HRRI B,OF%RD
+ HRRI B,OF%WR
+ JRST COMPER
+ JRST COMPER
+
+CLOSEX: CLOSF ; ATTEMPT TO CLOSE JFN
+ JRST RETERR ; CHOMP
+ MOVE A,$WFIX ; RETURNS 1 IF WINNING
+ MOVEI B,1
+ POPJ P,
+
+RESETX: POPJ P,
+
+ATIC: AOS A,ATICNM'
+ MOVEI C,35.
+ SUB C,A
+ MOVEI B,1
+ LSH B,(C)
+ TDNN B,[770000,,003777]
+ JRST ATIC ; TRY different char
+ MOVEI A,.FHSLF
+ AIC
+ JUMPL O1,ATICDN ; If not a char, don't do ATI
+ MOVE A,ATICNM
+ HRL A,O1
+ CAIN O1,7 ; store channel for ^G and ^A
+ MOVEM B,CTLGCH
+ CAIN O1,1
+ MOVEM B,CTLACH
+ ATI
+ATICDN: MOVE A,$WFIX
+ MOVE B,ATICNM
+ POPJ P,
+
+RETERR: PUSH P,A ; SAVE ERROR CODE
+ PUSHJ P,ICELL ; GET A LIST CELL
+ MOVE B,$WFIX ; STUFF THE CELL WITH ERROR CODE
+ SETZM (A)
+ MOVEM B,1(A)
+ POP P,2(A)
+ MOVE B,A
+ MOVE A,$WFALSE ; AND RETURN AS FALSE
+ POPJ P,
+
+IOERR: SUBM R,(P)
+ MOVEI A,400000 ; GET ERROR
+ GETER
+ HRRZ A,B
+ PUSHJ P,RETERR ; CONS IT UP
+ MOVEI O2,1
+ JRST CMPER2 ; GO GIVE IT TO USER
+
+; Return run time of process, in seconds, as float
+RNTIME: PUSH P,C
+ MOVEI A,.FHSLF
+ RUNTM
+ FLTR B,A
+ FDVR B,[1000.0]
+ MOVE A,$WFLOAT
+ POP P,C
+ POPJ P,
+
+PRINTZ: MOVNS C
+ SOUT
+ POPJ P,
+
+READX: PUSH P,C
+ PUSH P,D
+ MOVEM OP,.RDRTY+IRDBLK ; SET UP PROMPT
+ JUMPN OP,READX1
+ PUSH TP,$WFALSE ; SAVE IF NO PROMPT
+ PUSH TP,OP
+ JRST READX4
+READX1: MOVEI D,1 ; OTHERWISE, GET LENGTH, SAVE STRING
+READX3: ILDB C,OP
+ JUMPE C,READX2
+ AOJA D,READX3
+READX2: HRLI D,$TSTRING
+ PUSH TP,D
+ PUSH TP,.RDRTY+IRDBLK
+READX4: MOVEI C,IRDBRK
+ MOVEM C,.RDBRK+IRDBLK ; SETUP BREAK MASK
+ PUSH TP,$WFIX
+ PUSH TP,[0]
+ JUMPE E,READNM
+ SETOM (TP)
+ SETZM ARDBRK
+ MOVE C,[ARDBRK,,ARDBRK+1]
+ BLT C,ARDBRK+3
+ MOVEI C,ARDBRK
+ MOVEM C,.RDBRK+IRDBLK
+ SKIPA C,[4] ; Turn on ctrl-D
+READLP: ILDB C,E
+ JUMPE C,READNM
+ IDIVI C,32.
+ MOVSI OP,400000
+ MOVNS D
+ LSH OP,(D)
+ IORM OP,ARDBRK(C)
+ JRST READLP
+READNM: MOVE C,-1(P)
+ MOVE D,(P)
+ HRLM A,.RDIOJ+IRDBLK ; INPUT JFN
+ MOVEM B,.RDBFP+IRDBLK ; DESTINATION BUFFER POINTER
+ MOVEM B,.RDBKL+IRDBLK ; BACKUP LIMIT
+ SUB C,D ; GET LENGTH OF STRING
+ MOVEM C,.RDDBC+IRDBLK ; AND SUBTRACT CHRS ALREADY READ
+ ADJBP D,B ; ADJUST STRING FOR CHRS ALREADY READ
+ MOVEM D,.RDDBP+IRDBLK ; DESTINATION STRING
+ MOVEI C,.NULIO
+ CAIN A,.PRIIN
+ MOVEI C,.PRIOU
+ HRRM C,.RDIOJ+IRDBLK
+ PUSH TP,$WFIX
+ PUSH TP,IRDBLK+.RDIOJ
+ MOVE C,-1(P) ; STRING LENGTH
+ HRLI C,$TSTRING
+ PUSH TP,C
+ PUSH TP,IRDBLK+.RDBFP
+ MOVE C,IRDBLK+.RDBRK
+ PUSH TP,$WFIX
+ PUSH TP,(C)
+ PUSH TP,$WFIX
+ PUSH TP,1(C)
+ PUSH TP,$WFIX
+ PUSH TP,2(C)
+ PUSH TP,$WFIX
+ PUSH TP,3(C)
+ ADJSP P,-2 ; NOW NOTHING ON P STACK
+BRESTA: MOVEI A,IRDBLK
+ TEXTI ; DO IT
+RRESTA: JFCL
+; This now has a giant kludge to make ctrl-D redisplay the buffer without
+; clearing the screen.
+ LDB B,.RDDBP+IRDBLK ; Look at last character read
+ CAIE B,^D ; ctrl-D?
+ JRST DTEXTI
+ HRRZ A,.RDIOJ+IRDBLK ; Yes, pick up output jfn to use
+ MOVEI B,^M ; do crlf
+ BOUT
+ MOVEI B,^J
+ BOUT
+ SKIPN B,.RDRTY+IRDBLK
+ JRST NOPRMP
+ MOVEI C,0
+ SOUT ; Output prompt
+NOPRMP: MOVE B,.RDBFP+IRDBLK ; pick up pointer to buffer beginning
+ HRRZ C,-11(TP) ; ORIGINAL LENGTH OF BUFFER
+ AOS .RDDBC+IRDBLK ; ADD 1 TO CHARS AVAILABLE
+ SUB C,.RDDBC+IRDBLK ; REAL NUMBER CHARS IN BUFFER
+ MOVNS C ; - # CHARS IN BUFFER
+ SKIPE C ; don't print if none there
+ SOUT ; print buffer
+ MOVEM B,.RDDBP+IRDBLK ; update dest string pointer
+ MOVEI A,IRDBLK
+ JRST BRESTA ; try again
+
+DTEXTI: HRRZ B,-11(TP) ; GET ORIGINAL LENGTH
+ SUB B,.RDDBC+IRDBLK ; FIXUP COUNT
+ MOVE A,$WFIX
+ ADJSP TP,-20 ; EIGHT THINGS PUSHED ON STACK
+ POPJ P,
+
+SOUTX: SKIPA O1,[SOUT]
+
+SINX: MOVE O1,[SIN]
+RSINX: MOVEI O2,1
+ PUSH P,B
+ PUSH P,0
+ LDB 0,[220300,,0]
+ CAIN 0,$PUVECT
+ JRST [HLL 0,B
+ HRLI B,444400
+ HRRI 0,DOJSYS
+ PUSHJ P,@0
+ MOVEI O2,0 ; INDICATE FAILURE
+ POP P,A
+ POP P,C
+ SKIPLE B
+ ADDI B,1
+ SUBM B,C
+ SUBI A,(C)
+ JRST SINXXX]
+ PUSH P,0 ; SAVE TYPE OF FROB
+ CAIE 0,$PSTRIN
+ CAIN 0,$PBYTES
+ CAIA
+ JRST COMPER
+ XCT O1
+ JUMP 16,[ MOVEI O2,0
+ JRST .+1 ]
+ HRL O1,A ; SAVE JFN
+ POP P,0
+ LDB E,[360600,,B] ; GET BYTE PART
+ LDB A,[360600,,-1(P)] ; OF BOTH
+ SUB E,A ; ODD BYTES
+ MOVE C,B ; COPY POINTER
+ TLZ C,770000 ; JUST WORD POINTER
+ POP P,A ; GET ORIGINAL COUNT WORD
+ POP P,D ; AND ORIG PNTR
+ TLZ D,770000
+ SUB C,D
+ CAIE 0,$PBYTES
+ JRST [IMULI C,5
+ JRST SINXX1]
+ IMULI C,4
+SINXX1: ADD C,E
+ SUBI A,(C) ; AND FIX IT
+SINXXX: SKIPE O2 ; IF ERROR, SKIP
+ POPJ P,
+
+SINLSR: PUSH TP,A
+ PUSH TP,B
+ MOVEI A,400000 ; GET ERROR
+ GETER
+ MOVEI A,(B) ; ERROR TO A
+ CAIN A,IOX4 ; IS THIS EOF
+ JRST [ POP TP,B ; yes just return rested string
+ POP TP,A
+ POPJ P,]
+ PUSH TP,$WFIX ; save SIN/SOUT and JFN
+ PUSH TP,O1
+ PUSH TP,$WFIX
+ POP P,0
+ SUB 0,R
+ PUSH TP,0 ;relativized ret PC
+ PUSH TP,-5(TP)
+ PUSH TP,-5(TP)
+ PUSHJ P,RETERR ; cons up error code
+ PUSH TP,A
+ PUSH TP,B
+ PUSHJ P,ICELL ; include buffer in false
+ MOVE B,(TP)
+ MOVEM A,(B)
+ ADJSP TP,-2
+ POP TP,2(A)
+ POP TP,1(A)
+ SKIPN O1,ECATM ; call error-in compiled code handler
+ JRST CMPERX
+ JSP PC,FRAME
+ PUSH TP,$WFALS
+ PUSH TP,B
+ MOVEI O2,1
+ JSP PC,CALLZ
+ MOVE PC,(TP) ; returned from error, try i/o again
+ ADD PC,R
+ PUSH P,PC
+ MOVE O1,-2(TP) ; unrelativized PC to stack
+ DMOVE A,-5(TP) ; buffer back
+ MOVEI C,(A)
+ MOVNS C
+ MOVE 0,A
+ HLRZ A,O1
+ HRLI O1,(JSYS)
+ ADJSP TP,-6
+ JRST RSINX
+
+GTJFNX: TLNN A,(GJ%FNS) ; STRING ARG?
+ JRST [MOVE E,B
+ PUSHJ P,OPNAM ; FORCE ASCIZ IN THIS SECTION
+ HRROI B,FNBLK
+ JRST GTJFN1 ]
+GTJFN1: GTJFN
+ JUMP 16,JFSERR
+ MOVE B,A
+ MOVSI A,$TFIX
+ POPJ P,
+
+JFNSX: CAIGE A,177 ; SKIP IF JFNSing to a string
+ JUMPGE A,[ JFNS ; DO IT
+ JUMP 16,JFSERR
+ MOVSI A,$TFIX
+ POPJ P,]
+
+ MOVE O1,A
+ HRROI A,FNBLK
+ JFNS
+ JUMP 16,JFSERR ; LOSE...
+
+ EXCH E,O1
+ MOVE C,[440700,,FNBLK]
+ MOVEI B,0
+JFNSL: ILDB 0,C
+ JUMPE 0,JFNSM
+ ADDI B,1
+ IDPB 0,E ; MOVE CHARS
+ CAMN C,A ; ARE WE DONE
+ JRST JFNSM
+ SOJG O1,JFNSL
+
+ MOVNS B ; RETURN NEGATIVE LENGTH
+JFNSM: MOVSI A,$TFIX
+ POPJ P,
+
+JFSERR: MOVEI A,400000 ; GET ERROR
+ GETER
+ MOVEI A,(B) ; ERROR TO A
+ JRST RETERR
+
+ERSTRX: CAIG A,177 ; SKIP IF TO STRING
+ JUMPGE A,[ ERSTR
+ JUMP 16,RETF1
+ JRST RETF2
+ MOVSI A,$TFIX
+ POPJ P,]
+
+ MOVE O2,A ; SAVE ORG STR PNTR
+ ERSTR
+ JUMP 16,RETF1
+ JRST RETF2
+
+ LDB B,[360600,,A] ; GET BYTE PART
+ LDB 0,[360600,,O2]
+ SUB B,0
+ TLZ A,770000
+ TLZ O2,770000
+ SUB A,O2
+ IMULI A,5
+ ADD B,A
+ MOVSI A,$TFIX
+ POPJ P,
+
+RETF1: TDZA A,A
+RETF2: MOVEI A,1
+ AOJA A,RETERR
+
+; do long form GTJFN
+
+GTJFNL: MOVNI A,(O1) ; FIND BASE OF ARGS
+ ADD A,A
+ MOVE O2,TP ; COPY STACK POINTER
+ ADJSP O2,(A) ; POINT TO FIRS ARG
+ MOVE B,[440700,,FNBLK] ; FOR COPIED STRINGS
+ MOVEI A,GTJFBK ; POINT TO ARG BLOCK
+ PUSH P,O2
+ PUSH P,O1
+
+GTJFLP: HLRZ 0,1(O2)
+ CAIE 0,$TSTRING ; STRING
+ JRST [ MOVE 0,2(O2) ; NO GET FIX
+ MOVEM 0,(A) ; INTO BLOCK
+ JRST GTJFNA]
+
+ HRRZ C,1(O2) ; STRING LENGTH
+ JUMPE C,[ SETZM (A)
+ JRST GTJFNA]
+ MOVEM B,(A) ; STORE BYTE POINTER
+ MOVE E,2(O2) ; STR PNTR
+ PUSHJ P,OPNAML ; FORCE ASCIZ IN THIS SECTION
+GTJFNA: ADJSP O2,2 ; NEXT ARG
+ ADDI A,1
+ SOJG O1,GTJFLP
+
+ MOVE B,GTJFBK
+ MOVEI A,GTJFB2
+ MOVE O2,GTJFOS
+ GTJFN ; DO THE GTJFN
+ JUMP 16,GTERR ; ERROR
+
+ POP P,O1
+ POP P,TP
+ MOVE B,A
+ MOVSI A,$TFIX
+ SKIPN GTJFOS
+ POPJ P,
+
+ MOVE D,.GJCPP+.GJCPP+4(TP)
+ HRRZ C,.GJCPP+.GJCPP+3(TP)
+
+ ILDB 0,O2
+ IDPB 0,D
+ SOJG C,.-2
+ POPJ P,
+
+GTERR: POP P,O1
+ POP P,TP
+ JRST JFSERR
+
+; MOVED TO PAGE ZERO SO EXCESSIBLE FROM ALL SECTIONS
+;IRDBLK: 10
+; RD%BRK+RD%JFN ; JFNS COMING
+; .PRIOU ; FOR EDITING
+; 0 ; DESTINATION STRING
+; 0
+; 0
+; 0
+; IRDBRK ; FOR FUTURE EXPANSION
+; 0
+
+;IRDBRK: 0
+; 0
+; 0
+; 0
+
+\f
+SUBTTL ARITHMETIC
+
+RANDOM: GTAD
+ IDIV A,O1
+ ADDI B,1
+ MOVE A,$WFIX
+ JRST (PC)
+
+SUBTTL LVAL MANIPULATION
+
+;ILVAL RECEIVES ATOM IN IN O1
+
+ILVAL: SKIPN O2,1(O1) ;SEE IF BINDING
+ JRST ILVAL1
+ MOVE 0,7(O2) ; GET BINDID
+ CAME 0,BINDID ; SKIP IF OK
+ JRST ILVAL1
+ DMOVE A,(O2) ; GET VALUE
+ JUMPN A,(PC) ; RETURN IF BOUND
+ILVAL2: PUSH P,PC
+ JSP PC,FRAME ; Have binding with no value
+ PUSH TP,[$TATOM,,$LATOM] ; So strictly error case of EICC
+ PUSH TP,O1
+ MOVEI O2,1
+ MOVE O1,ECATM ; ERROR IN COMPILED CRUFT...
+ POP P,PC
+ JRST MCALL
+
+ILVAL1: MOVE A,PC ; SAVE PC
+ JSP PC,IASS ; SEE IF ASSIGNED AT ALL
+ MOVEI O2,0 ; IF NOT , SO INDICATE
+ MOVE PC,A
+ JUMPE O2,ILVAL2 ; GENERATE ERROR
+ DMOVE A,(O2)
+ JRST (PC)
+
+;IASS -- ASSIGNED? O1 IS ATOM, SKIP IF ASSIGNED?
+
+IASS: SKIPN O2,1(O1) ; BINDING PNTR?
+ JRST (PC) ; NO, NO SKIP
+ MOVE 0,7(O2) ; BIND ID?
+ CAME 0,BINDID ; SKIP IF NO SEARCH
+ JRST IASS1
+IASS4: SKIPE (O2) ; BOUND?
+ ADDI PC,1
+ JRST (PC)
+
+IASS1: MOVE O2,SP ; SEARCH
+IASS2: CAMN O1,2(O2) ; SKIP IF NOT IT
+ JRST IASS4 ; CHECK VALUE OK
+ SKIPE O2,5(O2) ; NEXT BINDING
+ JRST IASS2
+ MOVE O2,TTBIND ; SAME THING FOR TOP BINDING
+IASS3: CAMN O1,2(O2)
+ JRST IASS4
+ SKIPE O2,5(O2)
+ JRST IASS3
+ JRST (PC)
+
+;ISET -- RECEIVES ATOM IN O1 , NEW VAL IN A,B
+
+ISET: SKIPN O2,1(O1) ;SEE IF BINDING
+ JRST ISET1
+ MOVE 0,7(O2) ; GET BINDID
+ CAME 0,BINDID ; SKIP IF OK
+ JRST ISET1
+ DMOVEM A,(O2) ; SET VALUE
+ JRST (PC) ; RETURN
+
+ISET1: PUSH P,PC
+ JSP PC,FRAME
+ PUSH TP,[$TATOM,,$LATOM]
+ PUSH TP,O1
+ PUSH TP,A
+ PUSH TP,B
+ MOVEI O2,2
+ MOVE O1,ECATM ; ERROR IN COMPILED CRUFT...
+ POP P,PC
+ JRST MCALL
+
+;MOVSTR - O1 FROM, O2 TO, O #CHARS
+
+MOVSTR: SKIPG C,0 ; make sure something to move
+ JRST (PC) ; ret immediately
+ MOVE A,O1 ; compute word addrs of strs
+ MOVE D,O2
+ MOVE E,0
+ ADJBP C,A ;C is end of from
+ ADJBP E,D ;E is end of to
+ TLZ O1,770000 ; clear byte pntr part, O1 start of from
+ TLZ O2,770000 ; O2 start of to
+ TLZ C,770000
+ TLZ E,770000
+ CAMG O1,E ; skip if start from is grtr than end to
+ CAMLE O2,C ; dont skip if start of to is grt end from
+ JRST NOOVER ; jump to use movestr instruction
+
+ CAMN O1,O2 ; same word, check bp
+ JRST [ CAMG A,D
+ JRST MOVBAK
+ JRST MOVFWD ]
+ CAMG O1,O2
+ JRST MOVBAK ; must go backwards
+MOVFWD: ILDB O1,A
+ IDPB O1,D
+ SOJG 0,MOVFWD
+ JRST (PC)
+
+;hairy back move
+
+MOVBAK: MOVE O1,0
+ MOVE O2,0
+ ADJBP O1,A ; point to last byte in both
+ ADJBP O2,D
+
+MOVBK1: LDB C,O1 ; move a byte
+ DPB C,O2
+ADJBP1: MOVNI A,1 ; now tediously backup the 2 bps
+ ADJBP A,O1
+ TLNE A,770000 ; check for micro code bug
+ JRST .+3
+ AOS BUGS
+ JRST ADJBP1
+ MOVE O1,A
+ADJBP2: MOVNI A,1
+ ADJBP A,O2
+ TLNE A,770000 ; check for micro code bug
+ JRST .+3
+ AOS BUGS
+ JRST ADJBP2
+ MOVE O2,A
+ SOJG 0,MOVBK1
+ JRST (PC)
+
+; here if strings dont overlap 0 & A & C are setup ok
+
+MOVSLJ==123000,,[016000,,]
+
+NOOVER: MOVE C,0
+ SETZB B,E ; superstition
+ MOVSLJ 0,
+ JRST COMPER
+ JRST (PC)
+
+\f
+SUBTTL GARBAGE COLLECTION UTILITIES
+
+MARKR: CAMG B,[INIGC,,] ; DON'T MARK STACK OBJECTS
+ JRST (PC)
+ HRRZ D,A
+ LSH D,-1
+ ADD B,D ; MOVE TO DOPE WORD
+ JRST MRKUX
+
+MARKU: LDB D,[UPTBYT,,A]
+ JRST @MRKTBL(D)
+
+MRKTBL: SETZ MRKUS
+ SETZ MRKUS
+ SETZ MRKUU
+ SETZ MRKUV
+
+MRKUS: ANDI A,-1
+ ADJBP A,B
+ TLZ A,770000
+ XMOVEI B,1(A)
+ JRST MRKUX
+
+MRKUU: HRRZ D,A
+ JRST MRKUUV
+
+MRKUV: HRRZ D,A
+ LSH D,1
+MRKUUV: ADD B,D
+MRKUX: MOVSI D,200000
+ JUMPE C,[ANDCAM D,(B)
+ JRST (PC)]
+ CAME C,[200000,,]
+ MOVEM C,1(B) ; STORE RELOCATION
+ IORM D,(B)
+ JRST (PC)
+
+MARKL: JUMPE B,(PC)
+ ADDI B,1
+ JUMPE C,MRKUX
+ MOVSI C,200000
+ JRST MRKUX
+
+; HERE FOR MARK PREDICATE
+
+MKL: JUMPE B,[MOVEI B,1
+ JRST IMKL1]
+ LDB B,[MARKBIT,,1(B)]
+ JUMPE B,IMKL1 ; JUMP IF NOT MARKED
+ MOVE B,(B) ; RETURN RELOCATION
+ MOVSI A,$WLIST
+ JRST (PC)
+
+IMKL1: MOVE A,$WFIX
+ JRST (PC)
+
+MKR: CAMG B,[INIGC,,] ; SAY IT'S MARKED IF ITS ON THE STACK
+ JRST MKRT
+ HRRZ D,A
+ LSH D,-1
+ ADD B,D ; MOVE TO DOPE WORD
+ LDB B,[MARKBIT,,(B)] ; MUNG IT
+ JUMPE B,MKRT
+ MOVE B,1(B) ; RELOCATED WITH OLD TYPE
+ SUBI D,1(D) ; BACK TO TOP
+ JRST (PC)
+
+MKRT: MOVE A,$WFIX
+ JRST (PC)
+
+MKU: LDB C,[UPTBYT,,A]
+ JRST @MKTB(C)
+
+MKTB: SETZ MKUS
+ SETZ MKUS
+ SETZ MKUU
+ SETZ MKUV
+
+MKUS: ANDI A,-1 ; GET TO DW
+ MOVE 0,A
+ ADJBP A,B
+ LDB B,[MARKBIT,,1(A)]
+ JUMPE B,MKRT
+ SKIPN B,2(A)
+ AOJA B,MKRT
+ HRRZ A,1(A)
+ SUB B,A
+ JRST (PC)
+
+MKUU: HRRZ C,A
+ JRST MKUUV
+
+MKUV: HRRZ C,A
+ LSH C,1
+MKUUV: ADD B,C
+ LDB B,[MARKBIT,,(B)]
+ JUMPE B,MKRT
+ MOVE B,1(B)
+ SUBI B,1(C)
+ JRST (PC)
+
+MARKBIT==420100
+
+; SWEEP PHASE INSTRUCTIONS
+
+; SWEEPNEXT - GIVEN IN O1 A POINTER TO GC SPACE, IN A A POINTER TO
+; GC PARAMS
+; RETURNS A POINTER TO THE NEXT FROB IN GC SPACE
+
+SWNEXT: SKIPN B,O2
+ MOVE B,GCSBOF(A)
+ LDB E,[PTPBYT,,O1]
+ CAIE E,$PSTRING
+ CAIN E,$PBYTES
+ TLZ B,770000
+ CAMG B,GCSMIO(A)
+ JRST [SETZ B,
+ MOVE A,$WFIX
+ JRST (PC)]
+ MOVE A,-2(B) ; GET THE DOPE WORD
+ TLZE A,$DOPEBIT ; IS THE DOPE BIT SET?
+ JRST ISWVR ; YES. EITHER A UBLOCK OR RECORD
+ SUBI B,3 ; NEXT FROB IS THREE BACK
+ MOVE A,$WLIST
+ JRST (PC)
+
+ISWVR: HRRZ D,A ; GET LENGTH
+ SUBI B,2(D) ; FIND THE NEXT ONE
+ LDB E,[PTPBYT,,A] ; GET THE TYPE WORD
+ CAIN E,$PRECORD
+ JRST [ADDI A,(A) ; RECORD DOPE WORD IS FULL WORDS (SIGH)
+ JRST (PC)]
+ CAIN E,$PVECTOR ; VECTOR DOPE WORD HAS TWICE LENGTH (SIGH)
+ JRST [LSH D,-1
+ HRR A,D
+ JRST (PC)]
+ CAIN E,$PSTRING
+ JRST ISWVRS
+ CAIN E,$PBYTES
+ JRST ISWVRB
+ JRST (PC)
+; The byte pointers returned here are NOT standard--they are
+; 440700,,x rather than 010700,,x-1. This works because everyone
+; deals with them the adjbp and such; it avoids confusion in the
+; sweep phase due to the x-1.
+ISWVRS: TLO B,610000 ; FIXUP STRING POINTER
+ IMULI D,5 ; AND TYPE WORD
+ HRR A,D ; SIGH. THIS SEEMS KLUDGY...
+ JRST (PC)
+ISWVRB: TLO B,540000
+ IMULI D,4
+ HRR A,D
+ JRST (PC)
+
+RELL: SKIPN C,CZONE
+ XMOVEI C,-GCPOFF+IGCPR
+ MOVE C,GCPOFF(C)
+ MOVE 0,RCLOFF(C) ; GET FREE LIST POINTER
+ MOVEM 0,(B) ; CHAIN FREE LIST
+ MOVEM B,RCLOFF(C) ; UPDATE FREE LIST POINTER
+ SETZM 1(B)
+ SETZM 2(B)
+ JRST (PC)
+
+RELR: HRRZ D,A
+ LSH D,-1
+ ADD D,B
+ ADDI D,1
+ JSP OP,RELB
+ JRST (PC)
+
+RELU: LDB C,[UPTBYT,,A] ; GET THE PRIMTYPE
+ JSP E,@RELUTB(C) ; POINT D AT THE DOPE WORDS
+ JSP OP,RELB ; RECYCLE THE BLOCK OF STORAGE
+ JRST (PC) ; DON'T WORK EITHER
+
+RELUTB: SETZ RELUB
+ SETZ RELUS
+ SETZ RELUU
+ SETZ RELUV
+
+RELUB:
+
+RELUS: HRRZ C,A ; GETLENGTH
+RELUSX: ADJBP C,B ; ADJUST TO THE END
+ MOVE D,C ; ROUND UP
+ TLZ D,770000
+ ADDI D,2 ; POINT TO SECOND DOPE WORD
+ JRST (E)
+
+RELUU: HRRZ C,A ; GET LENGTH
+RELUX: MOVE D,B ; POINT TO UVECTOR
+ ADDI D,1(C) ; POINT TO SECOND DOPE WORD
+ JRST (E)
+
+RELUV: HRRZ C,A ; GET LENGTH
+ LSH C,1 ; TIMES TWO FOR GOOD LUCK
+ JRST RELUX ; REJOIN CODE
+
+
+; set the current free storage zone (arg in A and B)
+; if passed 0, return current, if current is zero, return gc params
+
+SETZON: JUMPN B,SETZN1 ; set it
+ SKIPE B,CZONE ; get current if any
+ JRST [MOVE A,[$TZONE,,7]
+ JRST (PC)]
+ HRRZ B,IGCPR
+ HRLI B,MIMSEC
+ MOVE A,[$TUVEC,,GCPL]
+ JRST (PC)
+
+SETZN1:
+; SETZM INGC ; THIS TENDS TO HAPPEN AFTER A GC
+ SKIPE ONOISY
+ JRST [ HRROI A,[ASCIZ /OK int soon/]
+ PSOUT
+ SETZM ONOISY
+ JRST .+1 ]
+IFN FLIP,[
+ MOVEM B,@[MIMSEC,,CZONE]
+ MOVEM B,@[MIMSEC+1,,CZONE]
+ MOVE B,SECL(B) ; FIRST AREA
+ MOVE B,@2(B) ; BOUND OF AREA
+ TLNN B,1 ; ODD/EVEN CHECK
+ JRST STZSE2
+ HRLI TP,EVSEC
+ HRLI F,EVSEC
+ HRLI P,EVSEC
+ JRST (PC)
+
+STZSE2: HRLI TP,ODDSEC
+ HRLI F,ODDSEC
+ HRLI P,ODDSEC
+ JRST (PC) ]
+IFE FLIP,[
+ MOVEM B,CZONE
+ JRST (PC)
+]
+
+IGCPR: -GCPL,,RCL
+
+; HERE IS THE BLOCK STORAGE RECYCLER
+; D POINTS TO THE SECOND DOPE WORD OF THE FROB BEING RECYCLED
+
+; RCL IS A LIST OF FREE CELLS
+
+GCPOFF==1
+GCFCN==3
+SECL==11.
+RCLOFF==0
+
+RCLTB: PUSHJ P,COMPER ; ZERO LENGTH?
+ PUSHJ P,COMPER ; ONE LENGTH?
+ XMOVEI B,RCLV2O(A)
+ XMOVEI B,RCLV3O(A)
+ XMOVEI B,RCLV4O(A)
+ XMOVEI B,RCLVOF(A)
+ XMOVEI B,RCLVOF(A)
+ XMOVEI B,RCLV7O(A)
+ XMOVEI B,RCLV8O(A)
+ XMOVEI B,RCLVOF(A)
+ XMOVEI B,RCL10O(A)
+
+RELB: HRRZ E,-1(D) ; FIRST GET BLOCK LENGTH
+ ADDI E,2
+ CAIG E,2
+ JRST RELB1 ; JUST DOPE WORDS
+ MOVE B,D
+ SUBI B,-2(E) ; ZERO EVERYTHING EXCEPT DOPE WORDS
+ SETZM -1(B)
+ HRLI B,-1(B)
+ CAILE E,3
+ BLT B,-2(D)
+RELB1: SKIPN B,CZONE
+ XMOVEI B,-GCPOFF+IGCPR
+ MOVE A,GCPOFF(B)
+ CAILE E,10.
+ XMOVEI B,RCLVOF(A)
+ CAIG E,10.
+ XCT RCLTB(E)
+ TLZ OP,400000
+ MOVEI 0,(B)
+ CAIE 0,RCLVOF(A)
+ TLO OP,400000
+ SKIPN A,(B) ; GET THE POINTER TO THE CHAIN
+ JRST [MOVEM D,(B)
+ SETZM (D)
+ TLZ OP,400000
+ JRST (OP) ]
+ MOVE A,B ; START FROM RCLV
+
+RECBL: MOVE B,(A) ; GET POINTER TO NEXT FREE BLOCK
+ CAML B,D ; DOES IT GO HERE?
+ JRST RECIN ; YES. INSERT IT
+ JUMPE B,RECIN
+ MOVE A,B ; GO ON TO NEXT FREE BLOCK
+ JRST RECBL
+
+RECIN: TLZE OP,400000
+ JRST RECIN1
+ MOVE C,D ; GET POINTER TO OUR BLOCK
+ SUB C,E ; BACK OFF TO THE TOP
+ CAMN C,A ; DOES IT TOUCH PREVIOUS BLOCK?
+ JFCL ; THIS GETS HAIRY. MORE CODE TO FOLLOW
+ MOVE C,B ; GET CDR FOR THIS BLOCK
+ HRRZ 0,-1(B) ; GET ITS LENGTH+2
+ ADDI 0,2
+ SUB C,0 ; SUBTRACT OFF THE BLOCK
+ CAMN C,D ; DO WE TOUCH ON THE BOTTOM?
+ JRST [ADDM E,-1(B) ; YES. SIMPLY UPDATE LENGTH
+ JRST (OP)]
+RECIN1: MOVEM B,(D) ; CHAIN THE NEW BLOCK IN
+ MOVEM D,(A)
+ MOVEI B,$TUVECTOR+$DOPEBIT
+ HRLM B,-1(D) ; MAKE SURE THIS IS A UV
+ JRST (OP)
+
+\f
+SUBTTL CORE ALLOCATION
+
+ICELL: JSP OP,ICELL1
+ CAIA
+ POPJ P,
+ MOVEI A,3 ; # WORDS NEEDED
+ PUSHJ P,RUNGC
+ JRST ICELL
+
+; HERE TO THE GARBAGE COLLECTOR FOR THE CURRENT ZONE
+
+RUNGC: JSP PC,FRAME
+ PUSH TP,$WFIX
+ PUSH TP,A
+ SKIPN A,CZONE ; MUST HAVE A ZONE
+ HALTF
+ MOVE O1,GCFCN(A)
+ MOVEI O2,1
+ JSP PC,CALLZ
+ POPJ P,
+
+
+IBLOCK: MOVE E,A
+ SKIPN B,CZONE
+ XMOVEI B,-GCPOFF+IGCPR
+ MOVE A,GCPOFF(B)
+ XMOVEI B,RCLVOF(A) ; DEFAULT RCL CHAIN
+ MOVE 0,GCFLGO(A) ; IF NO DWS, FUDGE HERE
+ TLNE 0,$GC%DW
+ SUBI E,2
+; TLNE 0,$GC%PB ; ONLY EVEN # OF PAGES?
+; TRNN E,777
+; CAIA
+; JRST COMPERR
+ CAIG E,10.
+ XCT RCLTB(E) ; GET POINTER TO CORRECT RCL CHAIN
+ SKIPN (B) ; DON'T BOTHER IF NOTHING'S ON THE CHAIN
+ JRST IBLNEW ; OLD STYLE BLOCK ALLOCATOR
+ MOVEI 0,(B)
+ CAIE 0,RCLVOF(A)
+ JRST IBLFIX ; FIXED SIZE OBJECT
+ MOVE D,B ; SETUP BACK POINTER
+ MOVE B,(B) ; GET THE RECYCLE CHAIN ITSELF
+IBLCL: HRRZ C,-1(B) ; HOW MUCH STUFF HERE
+ ADDI C,2 ; PLUS DOPE WORDS
+ CAMN C,E ; IS THIS AN EXACT MATCH?
+ JRST IBLC1 ; YES. DO THE RIGHT THING
+
+ CAIL E,-2(C) ; CAN IT BE BROKEN UP
+ JRST IBLC2 ; NO, KEEP LOOKING
+
+ SUBI C,2(E) ; C ==> LENGTH OF REMAINDER
+ HRRM C,-1(B) ; STORE IT
+ CAILE C,10. ; SKIP IF MUST PUT IT ON OTHER CHAIN
+ JRST IBLC3
+ MOVE 0,(B) ; SPLICE IT OUT
+ MOVEM 0,(D)
+ SETZM (B) ; FLUSH OLD POINTER
+ PUSH P,A
+ PUSH P,B
+ PUSH P,C
+ PUSH P,E
+ PUSH P,OP
+ MOVE D,B
+ JSP OP,RELB ; CALL BLOCK RECYCLER
+ POP P,OP
+ POP P,E
+ POP P,C
+ POP P,B
+ POP P,A
+
+IBLC3: SUBI B,2(C) ; NEW DW
+ SUBI E,2
+ HRRZM E,-1(B) ; DW LENGTH
+ SETZM (B)
+ MOVE 0,GCFLGO(A) ; GET FLAGS
+ MOVE A,B ; PNTR TO A
+ SUBI A,1(E) ; POINT TO TOP
+IBLRET: TLNE 0,$GC%PB ; REQUIRE PAGE BOUNDARY?
+ TRNN A,777
+ JRST (PC) ; NO RETURN
+ JRST CMPERR
+
+IBLC2: MOVE D,B ; GET NEW BACK POINTER
+ SKIPN B,(B) ; GET NEXT ENTRY
+ JRST IBLNEW ; END OF CHAIN
+ JRST IBLCL ; LOOP WITH NEW BLOCK
+
+IBLC1: MOVE (B) ; FOUND AN EXACT MATCH
+ MOVEM (D) ; UPDATE CHAIN POINTER
+ SETZM (B) ; CLEAR CHAIN POINTER
+ MOVE 0,GCFLGO(A) ; FLAGS
+ MOVE A,B
+ SUBI A,-1(C) ; SUBTRACT OFF TO GET TO TOP
+
+IBLPOP:
+ JRST (PC)
+
+IBLNEW: MOVE 0,GCSBOF(A)
+ ADDB E,GCSBOF(A)
+ SUBI E,1
+ CAMLE E,GCSMXO(A)
+ JRST [ADDI E,1
+ SUB E,0
+ PUSH P,E
+ PUSH P,PC
+ MOVEM 0,GCSBOF(A)
+ MOVE A,E ; # WORDS NEEDED
+ PUSHJ P,RUNGC
+ POP P,PC
+ POP P,A
+ JRST IBLOCK ] ; WILL GC
+ MOVE A,GCFLGO(A) ; RET FLAGS IN 0
+ EXCH A,0
+ JRST (PC)
+
+IBLFIX: MOVE 0,GCFLGO(A)
+ MOVE A,(B)
+ MOVE E,(A)
+ SETZM (A)
+ MOVEM E,(B)
+ HRRZ C,-1(A)
+ SUBI A,1(C)
+ JRST (PC)
+
+$WTCNT: $TYPCNT
+
+\f
+SUBTTL KNOWN RECORD TYPE TABLES
+
+ATMTBL: 5,,$LATOM
+ $TGBIND,,$LGBIND
+ 0,,11.
+ $TBIND,,$LBIND
+ 2,,11.
+ $TSTRING,,$LANY
+ 5,,8.
+ $TOBLIST,,$LATOM
+ 8,,11.
+ $TTYPC,,0
+ 4.,,13.
+
+FRMTBL: 8.,,$LFRAME
+ $TMSUBR,,4
+ 0,,10.
+ $TFIX,,0
+ 2,,6
+ $TFIX,,<<0._9.>\18.>
+ 4,,3
+ $TFIX,,<<18._9.>\18.>
+ 4,,3
+ $TFRAME,,8.
+ 6,,10.
+ $TFIX,,<<0._9.>\18.>
+ 8.,,3
+ $TBIND,,<<18._9.>\18.>
+ 8.,,3
+ $TFIX,,0
+ 10.,,6
+
+BNDTBL: 6,,$LBIND
+ $TANY,,$LANY
+ 0,,12.
+ $TATOM,,$LATOM
+ 4,,11.
+ $TANY,,$LANY
+ 6,,12.
+ $TBIND,,$LBIND
+ 10.,,11.
+ $TBIND,,$LBIND
+ 12.,,11.
+ $TFIX,,0
+ 14.,,6
+
+GBNTBL: 3,,$LGBIND
+ $TANY,,$LANY
+ 0,,12.
+ $TATOM,,$LATOM
+ 4,,11.
+ $TANY,,$LANY
+ 6,,12.
+
+QFTBL==. ; will build tabel later
+
+$LANY==0
+$LATOM==10.
+$LFRAME==12.
+$LGBIND==10.
+$LBIND==16.
+\f
+SUBTTL ERROR ROUTINES & UTILITIES
+
+CMPERR: MOVEI O2,0
+CMPER2: SKIPE O1,ECATM
+ JRST CMPER1
+CMPERX: HRROI A,[ASCIZ /Error in Compiled Code
+/]
+ PSOUT
+ PUSHJ P,HALTX
+
+CMPER1: PUSH P,02
+ JSP PC,FRAME
+ JUMPE O2,CMPER3
+ PUSH TP,A
+ PUSH TP,B
+CMPER3: MOVEI A,.FHSLF ; in case turned off by ill mem
+ MOVSI B,(<<SETZ>_<-PREAD>>+<<SETZ>_<-PWRIT>>)
+ AIC
+ JSP PC,CALLZ
+ POP P,O2
+ JUMPE O2,CMPERR
+ JRST RPOPJ
+
+\f
+SUBTTL DEBUGGING UTILITIES
+
+; CALL TO SAVE FROM THE INTERPRETER
+; PASSED: A/ JFN
+; B/ 0 or pointer-to-pure-zone
+; C/ 0 or pointer-to-frozen-atom-zone
+
+SAVEX: MOVEM A,INTSAV'
+ MOVEM B,PURZON
+ MOVEM C,ATMZON ; SAVE ZONES IN CASE NEED TO RE-SAVE
+ TLO A,400000
+ CLOSF ; LIKE RESTORE, FILE SHOULDN'T BE OPEN...
+ HALTF
+ MOVE E,(P) ; GET RETURN PC
+ CAIA
+
+SAV: SETZM INTSAV
+
+SAV1: MOVEI SAVAC
+ BLT SAVAC+17
+ MOVEI A,400000
+ MOVEI B,4
+ MOVEI C,[JRST RST
+ JRST [XJRST [0
+ MIMSEC,,CMPERR] ]
+ -1
+ JRST RETPUR ]
+ SKIPE INTSAV ; DIFFERENT STARTING ADDRESS FOR .SAVE
+ MOVEI C,[JRST RST1
+ JRST [XJRST [0
+ MIMSEC,,CMPERR] ]
+ -1
+ JRST RETPUR ]
+ XSVEC
+ SKIPE A,INTSAV
+ JRST SAV2
+ HRROI A,[ASCIZ /Output name: /]
+ PSOUT
+ MOVE A,[GJ%FOU+GJ%SHT+GJ%NEW+GJ%FNS]
+ MOVE B,[100,,101]
+ GTJFN
+ HALTF
+SAV2: ; Special save for multi sect
+; Here to write out multi-sect file
+;
+MSSAVE:
+; FORMAT of extended page map for file
+;
+; even words: -count,,flags
+; odd words: starting job page number
+;
+ MOVEI 0,SVMAP+6 ; SET UP MAP
+ MOVEM 0,SVMAPP
+ SKIPE O1,CZONE ; zones set up?
+ JRST ZND1 ; yes, do it for them
+
+ MOVE O1,GCSBOT ; get bounds
+ MOVE O2,GCSMIN
+
+ PUSHJ P,PMSEC
+ JRST ZND3A
+
+ZND1: MOVE B,SAVAC+2 ; restore possible pure zone
+ MOVE C,SAVAC+3 ; and atom zone
+ SKIPN INTSAV ; skip if from user
+ SETZB B,C ; otherwise, no pure or atom zones
+ PUSH P,B
+ PUSH P,C
+ZND6: PUSH P,SECL(O1) ; list of section bounds
+ MOVE O1,GCPOFF(O1)
+ PUSH P,GCSBOF(O1)
+ PUSH P,GCSMIO(O1)
+
+ZND2: SKIPE E,-2(P) ; any more bounds
+ JRST ZND4
+
+ SKIPN O1,-3(P) ; atom zone?
+ JRST ZND5
+ SETZM -3(P) ; dont look again
+ ADJSP P,-3 ; remove old zone
+ JRST ZND6
+
+ZND5: SKIPN O1,-4(P)
+ JRST ZND3
+ SETZM -4(P)
+ ADJSP P,-3
+ JRST ZND6
+
+ZND4: MOVE O1,2(E) ; pointer to UVEC
+ MOVE 0,3(O1) ; areas flags
+ MOVE O2,1(O1) ; bounds of gcspace
+ CAMN O2,(P) ; current zone?
+ JRST [ MOVE O2,-1(P)
+ MOVEM O2,(O1)
+ JRST .+1 ]
+ DMOVE O1,(O1)
+ MOVE E,(E)
+ MOVEM E,-2(P)
+ PUSHJ P,PMSEC ; write it out
+ JRST ZND2
+
+PMSEC: MOVE B,O2
+ SUB B,O1
+ JUMPE B,CPOPJ
+; SUBI B,777 ; dividing neg number by shift, so
+ ; dont' round
+ ASH B,9.
+ HRRI B,SS%RD+SS%CPY+SS%EXE+SS%EPN
+ TRNE 0,2 ; skip if not read-only
+ HRRI B,SS%RD+SS%EXE+SS%EPN
+ MOVE D,SVMAPP
+ MOVEM B,(D)
+ MOVE B,O2
+ LSH B,-9.
+ MOVEM B,1(D)
+ ADDI D,2
+ MOVEM D,SVMAPP
+ POPJ P,
+
+ZND3: ADJSP P,-5
+ZND3A: MOVEI B,STRTTP-777 ; compute pages of stack
+ SUBI B,(TP)
+ ASH B,9.
+ HRRI B,SS%RD+SS%CPY+SS%EXE+SS%EPN
+ MOVE D,SVMAPP
+ MOVEM B,(D)
+ MOVEI B,<TPSEC_9.>+<STRTTP_-9.> ; add in core page for stack
+ MOVEM B,1(D)
+ SETZM 2(D)
+
+; now write out the actual cruft
+
+ HRLI A,400000
+ MOVEI B,SVMAP
+ MOVEI C,0
+ SSAVE
+ ERJMP SAVLOS
+ SKIPN INTSAV
+ JRST [ HALTF ; give chance to save symbols
+ JRST RST2 ]
+ MOVE A,$WFIX
+ MOVEI B,0
+ POPJ P,
+SAVLOS: SKIPN INTSAV
+ JRST [HRROI A,[ASCIZ /?/]
+ ESOUT
+ MOVEI A,.PRIOU
+ MOVE B,[.FHSLF,,-1]
+ MOVEI C,0
+ ERSTR
+ JFCL
+ JFCL
+ HALTF]
+ MOVEI A,.FHSLF
+ GETER
+ HRRZ A,B
+ PUSHJ P,RETERR ; return a false with error code
+ POPJ P,
+
+RST: SETZM INTSAV
+RST1:
+IFN <MIMSEC-TPSEC>,[
+ MOVEI A,0
+ MOVE B,[.FHSLF,,MIMSEC] ; create brand new section
+ MOVE C,[PM%CNT+PM%RD+PM%EX+PM%WR+1] ; bits for mapping
+ SMAP%
+]
+ MOVE D,[.FHSLF,,1]
+RMAPLP: MOVE A,D
+ RMAP
+ TLZN B,(RM%PEX)
+ JRST RNXTMP
+ MOVSI C,(PM%RD+PM%WR+PM%EX)
+ MOVE A,D
+ MOVE B,D
+ ADDI B,<MIMSEC_9.>
+ PMAP
+IFN FLIP,[
+ MOVSI C,(PM%RD+PM%WR+PM%EX)
+ MOVE A,D
+ MOVE B,D
+ ADDI B,<<MIMSEC+1>_9.>
+ PMAP
+]
+RNXTMP: ADDI D,1
+ CAME D,[.FHSLF,,1000]
+ JRST RMAPLP
+IFN FLIP,[
+ MOVE A,[.FHSLF,,<<TPSEC_9>+<STRTTP_<-9>>>]
+ MOVE B,A
+ ADDI B,1000
+ MOVSI C,(PM%RD+PM%WR+PM%EX+PM%CNT)
+ HRRI C,1000-<STRTTP_<-9>>
+ PMAP
+]
+RSTTPD: MOVE 0,CURSIZ
+ LSH 0,-1
+; MOVEI 0,<<NUMSEC+INIGC>_<-1>>
+ MOVE A,[.FHSLF,,1000]
+IFN FLIP,MOVE B,[.FHSLF,,3000]
+IFE FLIP,MOVE B,[.FHSLF,,2000]
+ MOVSI C,(PM%RD+PM%WR+PM%EX)
+
+RSTX: HRRI A,1000
+ PMAP
+IFN FLIP,[
+ ADDI B,1000
+ HRRI A,2000
+ PMAP
+]
+ ADDI B,1000
+ SOJG 0,RSTX
+
+RST2: MOVSI SAVAC
+ BLT 17
+ PUSHJ P,INTON
+ MOVSI SAVAC
+ BLT 17
+ MOVE O1,B
+ XJRST [0
+ MIMSEC,,.+1]
+ ADJSP P,-1
+
+ MOVEI A,.FHSLF
+ MOVEI B,2 ; CODE FOR SETUP OF UUO TABLE
+ MOVE C,[MIMSEC,,MLTUUP]
+ SWTRP%
+
+ MOVE A,[TPWARN_9]
+ MOVES (A)
+ MOVES <<TPENDP-TPWARN>_9>(A)
+ ADD A,[1,,]
+ MOVES (A)
+ MOVES <<TPENDP-TPWARN>_9>(A)
+ MOVSI A,(SETZ)
+ HRRI A,TPENDP
+ MOVSI B,0
+ SPACS
+ MOVSI A,(SETZ)
+ HRRI A,TPWARN
+ MOVSI B,0
+ SPACS
+IFN FLIP,[
+ MOVSI A,(SETZ)
+ HRRI A,TPENDP+1000
+ MOVSI B,0
+ SPACS
+ MOVSI A,(SETZ)
+ HRRI A,TPWARN+1000
+ MOVSI B,0
+ SPACS
+]
+ SKIPE INTSAV
+ JRST [MOVE A,$WFIX
+ MOVEI B,1
+ JRST (E)]
+ PUSH P,PC
+ JSP PC,FRAME
+ POP P,PC
+ MOVEI O2,0
+ JRST CALLR
+
+; RESTORE CALLED FROM MUM
+; TAKES JFN IN ACCUMULATOR A
+
+RESTOR: MOVE D,A
+ MOVNI A,1
+ MOVE B,[.FHSLF,,TPWARN]
+ MOVE C,[PM%CNT\<<TPENDP-TPWARN>+1>] ; unmap end-of-stack warning
+ PMAP
+IFN FLIP,[
+ MOVE B,[.FHSLF,,<TPWARN+1000>]
+ MOVE C,[PM%CNT\<<TPENDP-TPWARN>+1>]
+ PMAP
+]
+ MOVNI A,1
+ MOVE B,[SETZ INIGC] ; FLUSH MANY SECTIONS
+ MOVE C,CURSIZ
+ SMAP% ; FLUSH LOTS OF STUFF
+ MOVE A,D ; RESTORE CHANNEL
+ SETOM INTSAV ; CALLED FROM MUM
+ TLO A,400000 ; KEEP THE JFN
+ CLOSF ; FOR REASONS KNOWN ONLY TO GOD, AND
+ HALTF ; I EVEN DOUBT THAT, THE FILE CAN'T
+ HRLI A,.FHSLF ; BE OPEN WHEN A GET IS DONE. SIGH.
+ MOVE C,[GET]
+ MOVE D,[MOVEI A,.FHSLF]
+ MOVE E,[XGVEC]
+ MOVE OP,[JRST @C]
+ JRST C
+
+; Take fix or false in A/B. If false, return first GC sec,,# GC secs;
+; otherwise, set.
+SETSIZ: PUSH P,C
+ LDB C,[TYPWRD,,A]
+ CAIE C,$TFALSE
+ JRST SETSZ1
+SETSZD: MOVSI A,$TFIX
+ MOVE B,CURSIZ
+ HRLI B,INIGC
+SETSZ0: POP P,C
+ POPJ P,
+SETSZ1: MOVEM B,CURSIZ
+ JRST SETSZ0
+
+DFATAL: PUSH TP,A
+ PUSH TP,B
+ PUSH P,C
+ HRROI A,[ASCIZ /Fatal error--/]
+ ESOUT
+ MOVEI A,.PRIOU
+ POP TP,B
+ POP TP,C
+ TLZ C,-1
+ MOVNS C
+ SOUT
+ POP P,C
+ HALTF
+ JRST (PC)
+
+QUIT: HALTF
+ POPJ P,
+
+TRACIN: PUSH P,A
+ PUSH P,B
+ PUSH P,C
+ PUSH P,D
+ PUSHJ P,TRACSP
+ MOVEI A,">
+ PBOUT
+ DC
+ HRROI A,[ASCIZ / (/]
+ PSOUT
+ MOVE A,(O1)
+ MOVE A,1(A)
+ MOVE B,1(A)
+ MOVE B,(B)
+ MOVE B,1(B)
+ MOVE B,1(B)
+ ADD B,7(A)
+ MOVE A,$WFIX
+ PUSHJ P,UPDISP
+ HRROI A,[ASCIZ /.) [/]
+ PSOUT
+ MOVE C,O2 ; # OF ARGUMENTS
+ MOVE D,C
+ LSH C,1
+ SUBM TP,C ; POINT THERE
+TRACA: SOJL D,TRACB
+ DMOVE A,1(C)
+ PUSH P,C
+ PUSH P,D
+ PUSHJ P,UPDISP
+ POP P,D
+ POP P,C
+ ADDI C,2
+ MOVEI A,40
+ PBOUT
+ JRST TRACA
+
+TRACB: AOS TRACL
+ AOS TRACL
+ MOVEI A,"]
+ PBOUT
+ SKIPE A,TRACTM
+ DISMS
+TRACEX: MOVEI A,^M
+ PBOUT
+ MOVEI A,^J
+ PBOUT
+ POP P,D
+ POP P,C
+ POP P,B
+ POP P,A
+ POPJ P,
+
+TRACOU: SOS TRACL
+ SOS TRACL
+ PUSH P,A
+ PUSH P,B
+ PUSH P,C
+ PUSH P,D
+ PUSHJ P,TRACSP
+ MOVEI A,"<
+ PBOUT
+ MOVEI A,40
+ PBOUT
+ DMOVE A,-3(P)
+ PUSHJ P,UPDISP
+ JRST TRACEX
+
+TRACSP: MOVEI A,40
+ MOVE B,TRACL
+ SOJL B,CPOPJ
+ PBOUT
+ JRST .-2
+
+\f
+
+SVMAPP: SVMAP
+SVMAP: -ENDPG,,SS%CPY+SS%RD+SS%EXE+SS%EPN
+ 0
+ -1,,SS%CPY+SS%RD+SS%EXE+SS%EPN
+ <MIMSEC_9>
+ -1,,SS%CPY+SS%RD+SS%EXE+SS%EPN
+ <<MIMSEC+1>_9>
+ BLOCK 30.
+
+
+\f
+SUBTTL INTERRUPT HANDLER
+
+LEVTAB: 0,,PCLEV1
+ 0,,PCLEV2
+ 0
+
+CHNTAB: REPEAT 36.,[ 2,,CHNS+<.RPCNT*2>
+ ]
+
+CHNS: REPEAT 36.,[ PUSH P,[.RPCNT]
+ JRST CHNSRV
+ ]
+
+CHNSRV: EXCH A,(P)
+ PUSH P,B
+ PUSH P,C
+ CAIE A,PREAD
+ CAIN A,PWRIT ; have we touched "magic" page
+ JRST STKCHK
+ MOVEI B,1
+ MOVEI C,35.
+ SUB C,A
+ LSH B,(C)
+ MOVE C,@[MIMSEC,,INTFLG]
+IFN FLIP,[
+ IORM B,@[MIMSEC,,INTFLG]
+ IORM B,@[MIMSEC+1,,INTFLG]
+]
+IFE FLIP, IORM B,INTFLG
+ AND C,B
+ HRRZ A,PCLEV2
+ CAIN A,RRESTA
+ JRST CHNS1
+ CAME B,CTLGCH
+ CAMN B,CTLACH
+ CAIA
+ JRST CHNS3
+ SKIPE INGC
+ JRST [ SKIPN NOISY
+ JRST CHNS3
+ HRROI A,[ASCIZ /GCing--please wait../]
+ PSOUT
+ SETOM ONOISY
+ JRST CHNS3 ]
+ AOS C,CTLGS ; how many successive ^G or ^As
+ CAIGE C,3 ; if more than 5, int anyway
+ JRST CHNS3
+
+ HRROI A,[ASCIZ /Forced interrupt, here's hoping...
+/]
+ PSOUT
+
+ SETZM CTLGS
+ POP P,C
+ POP P,B
+ POP P,A
+ JRST CHNS41
+
+CHNS3: POP P,C
+ POP P,B
+ POP P,A
+ SKIPGE PCLEV2 ; REALLY DEBRK?
+ JRST [ EXCH A,PCLEV2
+ TLZ A,400000
+ EXCH A,PCLEV2
+ JRST @PCLEV2 ]
+ SKIPN RUNINT
+ DEBRK
+; Come here when interrupts enabled
+ EXCH A,@LEVTAB+1
+ TLNN A,10000 ; Test for user mode
+ JRST CHNS4
+ EXCH A,@LEVTAB+1
+ DEBRK
+CHNS4: EXCH A,@LEVTAB+1
+CHNS41: PUSHJ P,SAVALL
+ XMOVEI B,CHNS5
+ DMOVEM A,@LEVTAB+1
+ DEBRK ; Leave int level, go to rest of handler
+CHNS5: PUSHJ P,RINTGO ; Process interrupts
+CHNS52: SUBM R,-1(TP) ; Get real PC back
+ SOS A,-1(TP) ; Back it up
+ HRRZ C,(A)
+ LDB B,[331100,,(A)] ; Get opcode
+ SKIPN -12.(TP) ; skip if from JSYS
+ AOJA A,CHNS51
+ CAIE B,104 ; Not JSYS; assume XCT 0
+ HRRZ C,-11.(TP)
+ ADDI A,1
+ CAIE C,BIN
+ JRST CHNS51
+ PUSH P,A
+ MOVEI A,.FHSLF
+ MOVEI B,IOX4 ; Return with error code
+ SETER
+ POP P,A
+ MOVE A,(A) ; Get ERJMP instruction
+ TLZ A,777760
+ TLO A,400000
+ XMOVEI A,@A ; Get address of error routine
+CHNS51: PUSH P,A
+RSTALL: MOVE 0,-15(TP) ; saved CZONE
+ CAME 0,CZONE ; no, change -- no GC
+ SKIPE -14(TP)
+ CAIA ; here if either no GC, or doesn't matter
+ JRST [ HRROI A,[ASCIZ /GC has occurred, you may lose..
+/]
+ PSOUT
+ JRST .+1
+]
+ MOVE O2,-2(TP)
+ MOVE O1,-3(TP)
+ MOVE PC,-4(TP)
+ MOVE OP,-5(TP)
+ MOVE E,-6(TP)
+ MOVE D,-7(TP)
+ MOVE C,-10(TP)
+ MOVE B,-11(TP)
+ MOVE A,-12(TP)
+ MOVE 0,-13(TP)
+ SKIPE -14(TP)
+ SETOM RUNINT ; Re-enable interrupts
+ ADJSP TP,-18.
+ POPJ P, ; Back into code
+
+CHNS1: MOVEI B,CHNS2
+ HRRM B,PCLEV2 ; Go back to section originally in
+ JRST CHNS3
+
+SAVALL: PUSH TP,[$TUVEC+$FRMDO,,16.]
+ ADDI TP,3
+ PUSH TP,CZONE
+ PUSH TP,RUNINT
+ SETZM RUNINT
+ PUSH TP,0
+ PUSH TP,A
+ PUSH TP,B
+ PUSH TP,C
+ PUSH TP,D ; Save ACs for system call
+ PUSH TP,E
+ PUSH TP,OP
+ PUSH TP,PC
+ PUSH TP,O1
+ PUSH TP,O2
+ DMOVE A,@LEVTAB+1
+ PUSH TP,B
+ PUSH TP,[$TUVEC+$FRMDO,,16.]
+ SUBM R,-1(TP) ; Save rel PC
+ POPJ P,
+
+; come here when interrupt out of TEXTI. Everything needed for TEXTI
+; except .rddbp and .rddbc is on tp; those two can be computed.
+CHNS2: PUSH TP,$WFIX
+ PUSH TP,IRDBLK+.RDDBC ; SAVE BYTE COUNT
+ PUSHJ P,RINTGO ; HACK INTERRUPTS
+ MOVE A,-20(TP) ; PROMPT
+ MOVEM A,IRDBLK+.RDRTY
+ MOVEI A,IRDBRK
+ SKIPE -16(TP)
+ MOVEI A,ARDBRK
+ MOVE B,-10(TP)
+ MOVEM B,(A)
+ MOVE B,-6(TP)
+ MOVEM B,1(A)
+ MOVE B,-4(TP)
+ MOVEM B,2(A)
+ MOVE B,-2(TP)
+ MOVEM B,3(A) ; GET BREAKS SET UP
+ MOVEM A,IRDBLK+.RDBRK ; Restore right word
+ MOVE A,-14(TP) ; JFN WORD
+ MOVEM A,IRDBLK+.RDIOJ
+ MOVE A,-12(TP) ; ORIGINAL STRING
+ MOVEM A,IRDBLK+.RDBFP
+ MOVEM A,IRDBLK+.RDBKL
+ HRRZ B,-13(TP)
+ SUB B,(TP) ; # CHARS USED
+ ADJBP B,A ; POINT TO EMPTY PAART
+ MOVEM B,IRDBLK+.RDDBP
+ MOVE B,(TP)
+ MOVEM B,IRDBLK+.RDDBC ; SPACE REMAINING
+ ADJSP TP,-2
+ JRST BRESTA ; FALL BACKK INTO TEXTI
+
+INTGO: HALTF
+
+INTGOC: SKIPE INGC ; DONT INTERRUPT POOR GC
+ POPJ P,
+ SETZM CTLGS
+ PUSH TP,$WFIX
+ PUSH TP,(P)
+ PUSH TP,$WFIX
+ PUSH TP,D
+ PUSH TP,$WFIX
+ PUSH TP,O2
+IFN FLIP,[
+ PUSH TP,$WFIX
+ PUSH TP,@[MIMSEC,,NARGS]
+ PUSH TP,$WFIX
+ PUSH TP,@[MIMSEC+1,,NARGS]
+]
+IFE FLIP,[
+ PUSH TP,$WFIX
+ PUSH TP,NARGS
+]
+ PUSHJ P,RINTGO
+IFN FLIP,[
+ POP TP,@[MIMSEC+1,,NARGS]
+ ADJSP TP,-1
+ POP TP,@[MIMSEC,,NARGS]
+ ADJSP TP,-1
+]
+IFE FLIP,[
+ POP TP,NARGS
+ ADJSP TP,-1
+]
+ POP TP,O2
+ ADJSP TP,-1
+ POP TP,D
+ ADJSP TP,-1
+ POP TP,(P)
+ ADJSP TP,-1
+ POPJ P,
+
+RINTGO: PUSH TP,$WFIX
+ PUSH TP,(P)
+
+INTLP: SETZM CTLGS
+ MOVE A,INTFLG
+ JFFO A,INTL1
+ POP TP,(P)
+ ADJSP TP,-1
+ POPJ P,
+
+INTL1: MOVEI A,36.
+ SUB A,B
+ MOVEI C,1
+ LSH C,-1(A)
+IFN FLIP,[
+ ANDCAM C,@[MIMSEC,,INTFLG]
+ ANDCAM C,@[MIMSEC+1,,INTFLG]
+]
+IFE FLIP, ANDCAM C,INTFLG ; AND CLEAR IT
+INTL2: JSP PC,FRAME
+ PUSH TP,$WFIX
+ PUSH TP,B
+ MOVE O1,ICATM
+ MOVEI O2,1
+ JSP PC,CALLZ
+ JRST INTLP
+
+INTINI: MOVE A,[-36.,,CHNTAB]
+ HLRZ 0,(A)
+ LSH 0,12. ; move level over
+ IORI 0,MIMSEC ; cause it to run int MIM
+ HRLM 0,(A)
+ AOBJN A,.-4
+
+ MOVEI 0,MIMSEC
+ HRLM 0,LEVTAB ; also mung LEVTAB
+ SOS LEVTAB
+ HRLM 0,LEVTAB+1
+ SOS LEVTAB+1
+ HRLM 0,LEVTAB+2
+
+INTON: SETZM ATICNM
+ MOVEI A,.FHSLF
+ MOVEI B,[ 3
+ LEVTAB
+ CHNTAB ]
+ XSIR% ; enable ints
+ EIR
+PWRIT==17. ; Bit for page write int
+PREAD==16.
+INFINT==19. ; bit for inferior interrupt
+ MOVEI A,.FHSLF
+ MOVSI B,(<<SETZ>_<-PREAD>>+<<SETZ>_<-PWRIT>>)
+ TRO B,<SETZ>_<-INFINT>
+ AIC ; Activate the int
+ POPJ P,
+\f
+;Here to see if illegal page access is really stack overflow
+
+STKCHK: XMOVEI B,1(TP) ; lets see which page
+ LSH B,-9 ; to page number
+ CAIE B,TPWARN+1000
+ CAIN B,TPWARN ; warning page?
+ JRST [MOVSI A,(SETZ)
+ HRRI A,TPWARN
+ MOVSI B,(PA%RD+PA%EX+PA%WT)
+ SPACS
+ HRRI A,TPWARN+1000
+ SPACS
+ MOVE A,[JRST @PNTSTK]
+ MOVEM A,STKMNG
+ MOVEM A,@[MIMSEC+1,,STKMNG]
+ JRST CHNS3 ]
+
+ HRROI A,[ASCIZ /Fatal error: stack overflow
+/]
+ CAIE B,TPENDP+1000
+ CAIN B,TPENDP
+ CAIA
+ JRST CNLOSE
+ PSOUT
+ POP P,C
+ POP P,B
+ POP P,A
+ JRST HALTX
+
+MONBIT==100
+
+CNLOSE:
+; MOVEI A,.FHSLF
+; PUSH P,[3]
+; XMOVEI B,(P)
+; PUSH P,[0]
+; PUSH P,[0]
+; XGTPW% ; get info about lossage
+; MOVE C,(P) ; get address
+; TLNE C,MONBIT ; monitored?
+; JRST DOMON ; yes, handle it, else lose
+ PUSH P,D ; need more regs
+ PUSH P,E
+ PUSH P,OP
+ DMOVE A,@LEVTAB+1 ; get instruction
+ PUSHJ P,EFFADR
+ LDB D,[331100,,A] ; and opcode
+ TLZE E,MONBIT ; is it monitored
+ JRST NOTBP
+ CAIL D,134 ; see if a bp ins
+ CAILE D,137
+ JRST REALER ; this is a real lossage
+
+ SKIPG A,(E) ; get byte pointer (skip if
+ ; local)
+ CAMG A,[450000,,0] ; skip if global
+ JRST [ MOVE B,E
+ PUSHJ P,EFFADR ; treat like ins
+ JRST GBPTR1 ]
+ MOVE B,E ; point to where BP is
+ MOVE E,A
+GBPTR1: TLZN E,MONBIT
+ JRST REALER
+ SKIPN INGC
+ JRST MONIT ; not int GC, cause monitor
+ MOVE A,@PCLEV2+1 ; get ins
+ TLON A,1000 ; skip if no incr
+ IBP (B) ; ok
+NOTBP: SKIPN INGC
+ JRST MONIT
+NOTBP1: TLZ A,37 ; kill index etc.
+ MOVEM E,INSEFF
+ HRRI A,INSEFF
+ TLO A,20
+ MOVEM A,INSDO ; set up to do ins
+ AOS A,PCLEV2 ; get pc
+ TLZ A,400000
+ MOVEM A,INSRE1
+ ADDI A,1
+ MOVEM A,INSRE2
+ XMOVEI B,INSDO
+ SKIPGE PCLEV2
+ TLO B,400000
+ MOVEM B,PCLEV2
+ JRST GCNT
+
+REALER: MOVSI B,(<<SETZ>_<-PREAD>>+<<SETZ>_<-PWRIT>>)
+ MOVEI A,.FHSLF
+ DIC ; turn of interrupt
+GCNT: POP P,OP ; need more regs
+ POP P,E
+ POP P,D
+ JRST CHNS3
+
+MONIT: POP P,OP
+ EXCH E,(P)
+ EXCH D,-1(P)
+ EXCH C,-2(P)
+ EXCH B,-3(P)
+ EXCH A,-4(P)
+ PUSHJ P,SAVALL
+ POP P,-16(TP) ; save monitored address
+ SUBI P,3
+ POP P,-17(TP)
+; MOVE A,PCLEV2
+; MOVEM A,-20(TP)
+ XMOVEI A,MONIT1 ; here to trigger monitor
+ MOVEM A,PCLEV2 ; set to disable ints
+ DMOVE A,-17(TP) ; leave funny in A
+ DEBRK
+
+MONIT1: JSP PC,FRAME
+ PUSH TP,$WFIX
+ PUSH TP,A
+ PUSH TP,$WFIX
+ PUSH TP,B
+ MOVE O1,ICATM
+ MOVEI O2,2
+ JSP PC,CALLZ
+ PUSH P,-1(TP)
+ PUSH P,-16(TP)
+ PUSH P,-17(TP)
+ PUSHJ P,RSTALL
+ EXCH A,-2(P)
+ EXCH B,-1(P)
+ EXCH C,(P)
+ PUSH P,D
+ PUSH P,E
+ PUSH P,OP
+ SUBM R,A
+ TLO A,400000 ; SO WE DONT DEBRK
+ MOVEM A,PCLEV2
+ MOVE E,B
+ MOVE A,C
+ JRST NOTBP1
+
+MONIT2:
+
+; Compute effective address
+; B/ pc of ins
+
+
+EFFADR: MOVE A,(B) ; get ins
+ HRRE E,A
+ LDB D,[220400,,A] ; get index
+ MOVEI OP,0 ; indirect?
+ TLNE A,20
+ MOVEI OP,1 ; yes
+
+ PUSH P,A
+ HRRES E ; make negative offsets work
+
+EFF1: JUMPE D,EFF2 ; jump if no index field
+
+ CAIG D,OP ; reg on stack?
+ ADDI D,-8.(P)
+ SKIPN D,(D) ; get its contents
+ JRST EFF2 ; zero in index, ignore
+
+ TLNE D,-1 ; skip if rh only (local index)
+ JUMPG D,EFF3 ; jump if global index
+
+ ADD E,D ; do local indexing
+ ANDI E,-1 ; but prevent overflowing
+ JRST EFF2
+
+EFF3: ADD E,D ; add global index
+
+EFF2: CAIGE E,17 ; AC?
+ JRST EFF6
+ TLNN E,400000 ; negative addr also get current section
+ TLNN E,-1 ; skip if section already here
+ HLL E,B ; use PC section
+
+EFF6: JUMPE OP,EFF5 ; no indirection, leave
+
+ PUSHJ P,GETVAL ; get indirect word
+
+ JUMPGE A,EFF7 ; jump if global ind
+
+ LDB D,[220400,,A] ; get index field
+ TLNN A,20 ; skip if indirect
+ MOVEI OP,0 ; turn it on
+ HRRE E,A ; keep original section with new address
+ JRST EFF1 ; loop back
+
+EFF7: LDB D,[360400,,A]
+ TLNN A,200000 ; global indirect bit?
+ MOVEI OP,0
+ TLZ A,770000 ; kill index and indirect
+ MOVE E,A
+ JRST EFF1
+
+EFF5: POP P,A
+ POPJ P,
+
+; here to extract value
+
+GETVAL: TLZ E,MONBIT
+ CAIG E,OP ; skip if register
+ ADDI E,-9.(P)
+ TLZ E,777740
+ MOVE A,(E) ; get word
+ POPJ P,
+
+
+DOMON: JFCL
+STKERR:
+IFE FLIP&0,[ MOVE 0,[JRST @D]]
+IFN FLIP&0,[ MOVE 0,[TLNN M,1]]
+ MOVEM 0,STKMNG
+ MOVEM 0,@[MIMSEC+1,,STKMNG]
+ MOVE 0,[JRST @PNTRET] ; CHANGE INS IN RETURN
+ MOVEM 0,RET3
+ MOVEM 0,@[MIMSEC+1,,RET3]
+ MOVEI O2,1
+ MOVE A,$WFIX
+ MOVEI B,0
+ JRST CMPER2
+
+\f
+SUBTTL DEBUGGING UUOS
+
+ZZZ==.
+LOC 40
+ 0
+ JSR UUOH
+LOC ZZZ
+
+UUOCT==0
+UUOTAB: SETZ ILUUO
+ IRPS X,,[FRM DP DC TON TOFF EX GVERR MADJBP]
+ UUOCT==UUOCT+1
+ X==UUOCT_33
+ SETZ U!X
+ TERMIN
+
+UUOMAX==.-UUOTAB
+MLTUOP: PUSH P,MLTUUP
+ PUSH P,MLTPC
+ JRST UUOSAV
+
+UUOH1: PUSH P,UUOH
+
+; Here if in multi-section mode but running a section 0 uuo
+
+ EXCH 0,(P) ;GET PC AND SAVE 0
+ HRRZM 0,MLTPC
+ HLLZM 0,MLTUUP
+ MOVE 0,40
+ HRRZM 0,MLTEA
+ HLRM 0,MLTUUP
+ POP P,0
+ XJRST .+1
+ 0
+ MIMSEC,,MLTUOP
+
+UUOSAV: PUSH P,
+ PUSH P,A
+ PUSH P,B
+ PUSH P,C
+ PUSH P,D
+ MOVE @UUOE
+ MOVEM UUOD' ; CONTENTS OF EFF ADR
+ MOVE B,UUOE ; EFF ADR
+ LDB A,[050400,,MLTUUP] ; GET UUO AC,
+ LDB C,[110400,,MLTUUP] ; AND OPCODE
+ JRST UUODSP
+
+UUODS1: LDB A,[270400,,40] ; GET UUO AC,
+ LDB C,[330600,,40] ; OP CODE
+UUODSP: CAIL C,UUOMAX
+ MOVEI C,0 ; GRT=>ILLEGAL
+ JRST @UUOTAB(C) ; GO TO PROPER ROUT
+
+UUORET: POP P,D
+ POP P,C
+ POP P,B
+ POP P,A ; RESTORE AC'S
+UUORT1: POP P,
+ POP P,MLTPC
+ POP P,MLTUUP
+ XJRST MLTUUP
+
+ILUUO: HALTF
+
+; KLUDGE TO DO ADJBP GIVEN MICROCODE BUG
+UMADJBP:
+ CAILE A,D ; CHECK AC ARG
+ JRST ADJB2 ; Not pushed, so continue
+ SUBI A,D ; Make A point to stack slot
+ ADD A,P
+ADJB2: MOVE C,(A) ; PICK UP AC
+ IBP C,UUOD ; Do the IBP
+ TLNE C,770000 ; Skip if lost
+ JRST ADJBO
+ AOS BUGS ; Count it
+ JRST ADJB2 ; And try again
+ADJBO: MOVEM C,(A) ; Won, stuff bp out
+ JRST UUORET ; And return
+
+UGVERR: SUBM R,-5(P) ; RELATIVE RETURN PC
+ SKIPN O1,ECATM
+ JRST CMPER2
+ JSP PC,FRAME
+ PUSH P,O2
+ CAIGE B,20 ; IF EA IS REGISTER, HACK IT
+ JRST [ PUSH TP,[$TGVAL,,$LATOM]
+ CAIG B,D
+ JRST [ ADDI B,-4(P)
+ HLL B,P
+ JRST UGVER1 ]
+ HRLI B,1
+ JRST UGVER1 ]
+ MOVE 0,-1(B) ; CHANGE ATOM TO GVAL
+ CAME 0,[$TGBIND,,$LGBIND]
+ MOVE 0,[$TGVAL,,$LATOM]
+ PUSH TP,0 ; PUSH GBIND POINTER OR ATOM POINTER
+UGVER1: PUSH TP,(B)
+ MOVEI O2,1
+ JSP PC,CALLZ ; CALL EICC
+ POP P,O2
+ ADJSP P,-4 ; PRESERVE NEW CONT. OF A AND B
+ SUBM R,-1(P)
+ AOS -1(P) ; SKIP RETURN
+ JRST UUORT1
+
+UFRM: SKIPGE (F)
+ JRST [HRRZ C,-1(F)
+ SUBI C,FR.OFF
+ XHLLI C,(F)
+ JRST .+2]
+ XMOVEI C,-FR.OFF(F)
+ SETO D,
+UFRML: AOJ D,
+ MOVE B,(C)
+ DP 2(B)
+ HRROI A,[ASCIZ / /]
+ PSOUT
+ MOVSI A,$TVECT
+ SKIPGE 2(C)
+ JRST [HRROI A,[ASCIZ /< TUPLE >/]
+ PSOUT
+ JRST UFRMLX]
+ HLR A,2(C)
+ XMOVEI B,6(C)
+ PUSH TP,A
+ PUSH TP,B
+ DP -1(TP)
+ ADJSP TP,-2 ; SUB TP,[2,,2]
+UFRMLX: HRROI A,[ASCIZ /
+/]
+ PSOUT
+ SKIPGE C,3(C) ; GET NEXT FRAME
+ JRST [HRROI A,[ASCIZ / <GLUED FRAME(S)>
+/]
+ PSOUT
+ HRRZ C,-1(C) ; GET REAL FRAME
+ XHLLI C,(F)
+ SUBI C,FR.OFF
+ JRST .+1]
+ SKIPGE (C)
+ JRST [HRROI A,[ASCIZ / <GLUED FRAME(S)>
+/]
+ PSOUT
+ HRRZ C,-1(C)
+ SUBI C,FR.OFF
+ XHLLI C,(F)
+ JRST .+1]
+ JUMPG C,UFRML
+ JRST UUORET
+
+UDC: MOVE B,3(O1)
+ PUSHJ P,UDPSTR
+ JRST UUORET
+
+UDP: MOVE A,(B) ; TYPE WORD
+ MOVE B,1(B)
+ PUSHJ P,UPDISP
+ JRST UUORET
+
+UPDISP: HLRZ C,A
+ TLZE C,200000 ; IS IT MARKED?
+ JRST [PUSH P,A
+ MOVEI A,"@
+ PBOUT
+ POP P,A
+ JRST .+1]
+ JUMPE C,UDPUNB
+ CAIN C,$TFORM
+ JRST UDPFRM
+ CAIN C,$TTUPLE
+ JRST UDPTUP
+ CAIN C,$TOBLI
+ JRST UDPOBL
+ CAIN C,$TATOM
+ JRST UDPATM
+ CAIN C,$TSTRING
+ JRST UDPSTR
+ CAIN C,$TFIX
+ JRST UDPFIX
+ CAIN C,$TFALS
+ JRST UDPFLS
+ CAIN C,$TCHAR
+ JRST UDPCHR
+ CAIN C,$TFLOAT
+ JRST UDPFLT
+ CAIN C,$TLIST
+ JRST UDPLST
+ CAIN C,$TMSUBR
+ JRST UDPMSB
+ CAIN C,$TMCODE
+ JRST UDPMCD
+ CAIN C,$TVECTOR
+ JRST UDPVCT
+ CAIN C,$TCHANNEL
+ JRST UDPSTM
+ HRROI A,[ASCIZ /??/]
+UPOUT: PSOUT
+ POPJ P,
+
+UDPUNB: HRROI A,[ASCIZ /#UNBOUND /]
+ PSOUT
+ JRST UDPFIX
+
+UDPMCD: HRROI A,[ASCIZ /#MCODE |??|/]
+ JRST UPOUT
+
+UDPFLS: HRROI A,[ASCIZ /#FALSE ()/]
+ PSOUT
+ POPJ P,
+
+UDPMSB: HRROI A,[ASCIZ /#MSUBR ??/]
+ PSOUT
+ POPJ P,
+
+UDPCHR: HRROI A,[ASCIZ /!\/]
+ PSOUT
+ MOVE A,B
+ PBOUT
+ POPJ P,
+
+UDPFIX: MOVEI A,.PRIOU
+ MOVEI C,10.
+ NOUT
+ JFCL
+ POPJ P,
+
+UDPFLT: MOVEI A,.PRIOU
+ FLOUT
+ JFCL
+ POPJ P,
+
+UDPSTR: PUSH P,A
+ HRROI A,[ASCIZ /"/]
+ PSOUT
+ POP P,A
+ HRRZ C,A
+ MOVEI A,.PRIOU
+ SOUT
+ HRROI A,[ASCIZ /"/]
+ PSOUT
+ POPJ P,
+
+UDPOBL: HRROI A,[ASCIZ /#OBLIST /]
+ PSOUT
+UDPATM: HRRZ C,2(B)
+ MOVE B,3(B)
+ PUSH P,C
+ POP P,C
+ MOVEI A,.PRIOU
+ SOUT
+ POPJ P,
+
+UDPTUP: PUSH P,A
+ HRROI A,[ASCIZ /#TUPLE /]
+ PSOUT
+ POP P,A
+UDPVCT: PUSH P,B
+ HRRZ C,A
+ PUSH P,C
+ HRROI A,[ASCIZ /[/]
+ PSOUT
+ JUMPE C,UDPVCE
+UDPVCL: MOVE A,(B)
+ MOVE B,1(B)
+ PUSHJ P,UPDISP
+ SOSG (P)
+ JRST UDPVCE
+ AOS -1(P)
+ AOS B,-1(P)
+ HRROI A,[ASCIZ / /]
+ PSOUT
+ JRST UDPVCL
+
+UDPVCE: HRROI A,[ASCIZ /]/]
+ PSOUT
+ ADJSP P,-2 ; SUB P,[2,,2]
+ POPJ P,
+
+UDPFRM: HRROI A,[ASCIZ /#FORM /]
+ PSOUT
+UDPLST: HRROI A,[ASCIZ /(/]
+ PSOUT
+ JUMPE B,UPLSTE
+UPLSTL: PUSH P,B
+ DMOVE A,1(B)
+ PUSHJ P,UPDISP
+ POP P,B
+ MOVE B,(B)
+ JUMPE B,UPLSTE
+ HRROI A,[ASCIZ / /]
+ PSOUT
+ JRST UPLSTL
+
+UPLSTE: HRROI A,[ASCIZ /)/]
+ PSOUT
+ POPJ P,
+
+UDPSTM: PUSH P,A
+ HRROI A,[ASCIZ /#CHANNEL [/]
+ PSOUT
+ POP P,A
+ PUSH P,B
+ PUSH P,C
+ MOVE A,(B)
+ MOVE B,1(B)
+ PUSHJ P,UPDISP
+ MOVEI A,40
+ PBOUT
+ MOVE B,-1(P)
+ MOVE A,4(B)
+ MOVE B,5(B)
+ PUSHJ P,UPDISP
+ MOVEI A,"]
+ PBOUT
+ ADJSP P,-2
+ POPJ P,
+
+UTON:; SETOM TRACE
+ JRST UUORET
+
+UTOFF:; SETZM TRACE
+ JRST UUORET
+
+UEX: MOVE D,(P)
+ MOVE C,-1(P)
+ MOVE B,-2(P)
+ MOVE A,-3(P)
+ MOVE 0,-4(P)
+ XCT @MLTEA ; get ins to execute
+ JRST UUORET
+\f
+SUBTTL END OF THE ROAD
+
+CONSTANTS
+NOISY: 1 ; non-zero, say if int in GC
+ONOISY: 0 ; non-zero, say ok after GC
+BUGS: 0 ; count bad ADJBP
+CTLGS: 0 ; count ^Gs and ^As
+CTLGCH: 0 ; int channel for ^G
+CTLACH: 0 ; int channel for ^A
+PAT:
+PATCH: BLOCK 100
+PATEND: 0
+VARIABLES
+
+IFN MON,.INSRT M20:INSINT.MID
+
+;MUMBLE: BLOCK 1000
+LOC <<.+777>&777000> ; GO TO PAGE BOUNDARY
+ENDPG==<.+777>_<-9.>
+
+STACK: BLOCK STACKL
+PDL: BLOCK 256.
+
+LOC <<.+777>&777000>
+
+GCSTRT==.
+GCSPST==._<-9.>
+\f
+SUBTTL BOOTSTRAP MSUBR READER
+
+ZZZ==.
+BOOTGC==15000.
+LOC STACK+BOOTGC
+
+BSATBL: BLOCK 256.
+BSAPTR: -256.,,BSATBL-1
+
+BOOTER: MOVE A,GCSMIN
+ MOVEM A,GCSBOT
+ SETZM (A)
+ MOVEI B,1(A)
+ HRLI B,(A)
+ MOVE A,[MIMSEC,,PAGTBL]
+ MOVEM A,PAGPTR+1
+ MOVE A,[MIMSEC,,MINF]
+ MOVEM A,MINFO
+ MOVEI A,TOPGC
+ MOVEM A,GCSMAX
+ HRROI A,[ASCIZ /MIMI20 Initialization
+/]
+ PSOUT
+ SKIPN A,BOOTYP
+ JRST BNIN
+ HRRO A,[[ASCIZ /Using msubrs
+/]
+ [ASCIZ /Using mbins
+/]
+ [ASCIZ /Using big mbins
+/]]+1(A)
+ PSOUT
+ JRST BNIN1
+BNIN: HRROI A,[ASCIZ /Enter type (1 big mbins, 0 mbins, -1 msubrs): /]
+ PSOUT
+ MOVEI A,.PRIOUT
+ MOVEI C,10.
+ NIN
+ JRST BNIN
+ MOVEM B,BOOTYP
+
+BNIN1: MOVE P,[-PDLLEN,,PDL-1]
+ MOVE TP,[-STACKLEN,,STACK-1]
+
+ PUSHJ P,SMAPIT ; setup multi sections
+
+ PUSHJ P,INTINI
+ MOVEI A,<238.*2>
+ JSP PC,IBLOCK
+ MOVE B,[$TVECTOR,,237.]
+ MOVEM B,TOPOBL
+ MOVEM A,TOPOBL+1
+ MOVEI B,237.
+ MOVE C,$WLIST
+ MOVEM C,(A)
+ SETZM 1(A)
+ ADDI A,2
+ SOJN B,.-3
+ MOVE B,[$DOPEBIT+$TVECT,,<237.*2>]
+ MOVEM B,(A)
+ SETZM 1(A)
+
+ MOVSI A,(GJ%SHT+GJ%OLD)
+ HRROI B,[ASCIZ /<MIM.BOOT>BOOT.MSUBR/]
+ GTJFN
+ JRST BSNOF
+ MOVE B,[070000,,OF%RD]
+ OPENF
+ JRST BSNOF
+ MOVEM A,BSJFN'
+ SETZM BSCHR'
+ PUSHJ P,BSREAD
+ SKIPN BSENDF'
+ JRST .-2
+ MOVE A,BSJFN
+ CLOSF
+ JFCL
+ HRROI D,BSATBL
+ MOVE C,[.BYTE 7 ? "B ? "O ? "O ? "T]
+ PUSHJ P,BSLKPL ; GET ATOM BOOT IN A/B
+ CAIA
+ JRST BSNOB
+ MOVE O1,B
+ SETZB O2,F
+ SETZM STACK
+ MOVE A,[STACK,,STACK+1]
+ BLT A,STACK+300
+ JSP PC,FRAME ; MAKE A FRAME
+ XMOVEI F,-1(TP)
+ JSP PC,FRAME
+ HRROI A,[ASCIZ /Bootstrap Loaded
+/]
+ PSOUT
+ PUSH TP,$WFIX
+ PUSH TP,BOOTYP
+ MOVEI O2,1 ; Actually call with 1 arg
+ MOVEI SP,0 ; START SP IN RIGHT SECT
+ JSP PC,CALLZ ; CALL BOOTSTRAP WITH NO ARGS
+ JRST SAV ; AND ATTEMPT TO SAVE OURSELVES
+
+BSSEP: CAIE B,"
+ CAIN B,^J
+ POPJ P,
+ CAIE B,^L
+ CAIN B,^M
+ POPJ P,
+ CAIE B,"]
+ CAIN B,^J
+ POPJ P,
+ CAIE B,""
+ CAIN B,")
+ POPJ P,
+ CAIE B,^Z
+ CAIN B,0
+ JRST BSEND
+POPJ1: AOS (P)
+ POPJ P,
+
+BSEND: SETOM BSENDF
+ POPJ P,
+
+BSREAD: SKIPE BSENDF
+ POPJ P,
+ MOVE A,BSJFN
+ SKIPN B,BSBRK
+ BIN
+BSRD1: SETZM BSBRK
+ CAIN B,"|
+ JRST BSCOD
+ CAIN B,"#
+ JRST BSTYP
+ CAIN B,"[
+ JRST BSVEC
+ CAIN B,"(
+ JRST BSLST
+ CAIN B,"%
+ JRST BSIMM
+ CAIN B,""
+ JRST BSSTR
+ CAIE B,")
+ CAIN B,"]
+ JRST [MOVE A,$WUNBOUND
+ POPJ P,]
+ CAIN B,"!
+ JRST BSCHAR
+ PUSHJ P,BSSEP
+ JRST BSREAD
+ CAIL B,"0
+ CAILE B,"9
+ JRST BSATM
+ JRST BSFIX
+
+; HERE TO READ # FORMAT
+
+BSTYP: PUSHJ P,BSREAD ; GET TYPE NAME
+ MOVE B,3(B) ; GET PNAME
+ TLZ B,770000
+ MOVE C,1(B)
+ TRZ C,377
+ CAMN C,[.BYTE 7 ? "M ? "S ? "U ? "B]
+ PUSH P,$WMSUBR
+ CAMN C,[.BYTE 7 ? "I ? "M ? "S ? "U]
+ PUSH P,$WIMSUB
+ CAMN C,[.BYTE 7 ? "D ? "E ? "C ? "L]
+ PUSH P,$WDECL
+ CAMN C,[.BYTE 7 ? "U ? "N ? "B ? "O]
+ PUSH P,$WUNBOUND
+ CAMN C,[.BYTE 7 ? "F ? "A ? "L ? "S]
+ PUSH P,$WFALSE
+ PUSHJ P,BSREAD ; GET PRIMITIVE STRUCTURE
+ HLL A,(P) ; GET NEW TYPE WORD
+ ADJSP P,-1
+ HLLZ C,A
+ CAME C,$WIMSUB
+ CAMN C,$WMSUBR
+ CAIA
+ POPJ P,
+ PUSH TP,A
+ PUSH TP,B
+ PUSH TP,A
+ PUSH TP,B
+ REPEAT 4,PUSH TP,[0]
+ MOVE O1,$WGBIND
+ MOVEI O2,3
+ PUSHJ P,RECORR ; MAKE A BINDING
+ PUSH P,B
+ POP TP,B
+ POP TP,A ; RESTORE THE MSUBR
+ MOVE C,3(B) ; THE ATOM
+ CAMN C,$WMSUBR
+ MOVE C,1(B)
+ POP P,A
+ MOVEM A,(C) ; STUFF BINDING IN ATOM
+ MOVEM C,2(A) ; STUFF ATOM IN BINDING
+ POPJ P,
+
+
+; HERE TO READ A FIX
+
+BSFRC: 0
+
+BSFIX: SETZM BSFRC
+ MOVEI C,-"0(B) ; C WILL HOLD FIX
+ SETZ D, ; D IS FRACTION / E IS # OF DIGITS
+ MOVEI E,1
+BSFIXL: BIN ; GET NEXT CHARACTER
+ PUSHJ P,BSSEP ; IS IT A SEPARATOR
+ JRST BSFIXE ; YES, FINISH
+ SKIPE BSFRC
+ JRST [IMULI D,10. ; UPDATE INFO
+ ADDI D,-"0(B)
+ IMULI E,10.
+ JRST BSFIXL]
+ CAIN B,". ; DECIMAL?
+ JRST [SETOM BSFRC
+ JRST BSFIXL]
+ IMULI C,10. ; SHIFT OVER SOME
+ ADDI C,-"0(B) ; ADD IN THE NEXT DIGIT
+ JRST BSFIXL ; AND LOOP
+
+BSFIXE: MOVEM B,BSBRK'
+ MOVE A,$WFIX
+ SKIPE BSFRC
+ JRST [FLTR C,C
+ FLTR D,D
+ FLTR E,E
+ FDVR D,E
+ FADR C,D
+ MOVE A,$WFLOAT
+ JRST .+1]
+ MOVE B,C
+ POPJ P,
+
+; HERE TO READ A CHARACTER
+
+BSCHAR: BIN
+ CAIE B,"\
+ HALTF
+ BIN
+ MOVE A,$WCHARACTER
+ POPJ P,
+
+; HERE TO READ A STRING
+
+BSSTR: PUSH P,[0] ; CLEAR COUNT (PREPARE TO MAKE STRING)
+BSSTRL: BIN
+ SKIPE BSQUOT
+ JRST [SETZM BSQUOT
+ JRST BSSTR1]
+ CAIN B,"\
+ SETOM BSQUOT'
+ CAIN B,""
+ JRST BSSTR2
+BSSTR1: PUSH TP,$WCHARACTER ; PUT CHARACTER ON STACK
+ PUSH TP,B
+ AOS (P)
+ JRST BSSTRL ; AND LOOP
+BSSTR2: MOVE O1,$WSTRING
+ POP P,O2
+ PUSHJ P,UBLOKR ; MAKE THE STRING
+ POPJ P,
+
+; HERE TO READ AN ATOM
+
+BSATM: PUSH P,[0] ; CLEAR COUNT (PREPARE TO MAKE STRING)
+ JRST BSATM1
+BSATML: BIN
+ PUSHJ P,BSSEP
+ JRST BSATM2
+BSATM1: PUSH TP,$WCHARACTER ; PUT CHARACTER ON STACK
+ PUSH TP,B
+ AOS (P)
+ JRST BSATML ; AND LOOP
+BSATM2: MOVEM B,BSBRK
+ MOVE O1,$WSTRING
+ POP P,O2
+ PUSHJ P,UBLOKR ; MAKE THE STRING
+ TLZ B,770000
+ PUSHJ P,BSLKP
+ POPJ P,
+BSGBND: TLO B,660000
+ PUSH TP,A
+ PUSH TP,B
+ PUSH TP,$WUNBOUND
+ PUSH TP,[0]
+ PUSH TP,[0]
+ PUSH TP,[0]
+ PUSH TP,[0]
+ PUSH TP,[0]
+ MOVE O1,$WGBIND
+ MOVEI O2,3
+ PUSHJ P,RECORR
+ POP TP,D
+ POP TP,C
+ PUSH TP,A ; PUSH GLOBAL BINDING
+ PUSH TP,B
+ PUSH TP,$WFIX ; PUSH LOCAL BINDING
+ PUSH TP,[0]
+ PUSH TP,C ; PUSH PNAME
+ PUSH TP,D
+ TLZ D,770000
+ PUSH P,1(D)
+ MOVE O1,$WATOM
+ MOVEI O2,3
+ PUSHJ P,RECORR ; MAKE AN ATOM (ISN'T THIS FUN?)
+ MOVE D,(B) ; GET GLOBAL BINDING
+ MOVEM B,2(D) ; STUFF IT IN ATOM
+ MOVE D,BSAPTR
+ PUSH D,(P)
+ PUSH D,B
+ MOVEM D,BSAPTR
+ ADJSP P,-1
+ POPJ P,
+
+BSLKP: HRROI D,BSATBL
+ MOVE C,1(B) ; POINT TO START OF PNAME
+BSLKPL: SKIPN E,(D)
+ JRST POPJ1
+ CAMN E,C
+ JRST BSLKP1
+ ADDI D,2
+ JRST BSLKPL
+BSLKP1: MOVE B,1(D)
+ MOVE A,[$TATOM,,10.] ; CHANGED (WAS 4)
+ POPJ P,
+
+; HERE TO READ SOME MCODE
+
+BSCOD: PUSH P,[0] ; CLEAR THE COUNTER
+BSCODL: MOVEI D,0
+ MOVEI E,4
+BSCDL: BIN
+ CAIG B,"A-1
+ JRST .-2
+ CAIN B,"|
+ JRST BSCODE
+ MOVEI C,-"A(B)
+ LSH C,5
+ BIN
+ CAIG B,"A-1
+ JRST .-2
+ SUBI B,"A
+ IOR C,B
+ LSH D,9.
+ IOR D,C
+ SOJG E,BSCDL
+
+ PUSH TP,$WFIX ; PUT IT ON THE STACK
+ PUSH TP,D ; P.S. - IT HAD BETTER BE A FIX
+ AOS (P)
+ JRST BSCODL ; AND LOOP
+BSCODE: CAIN E,4
+ JRST [IMULI E,9
+ LSH D,(E)
+ PUSH TP,$WFIX
+ PUSH TP,D
+ AOS (P)
+ JRST .+1]
+ MOVE O1,$WMCODE ; TYPE WORD SET
+ POP P,O2
+ PUSHJ P,UBLOKR ; MAKE THE UBLOCK (STRING)
+ POPJ P,
+
+; HERE TO READ A VECTOR
+
+BSVEC: PUSH P,[0]
+BSVECL: PUSHJ P,BSREAD
+ CAMN A,$WUNBOUND
+ CAIE B,"]
+ CAIA
+ JRST BSVECE
+ PUSH TP,A
+ PUSH TP,B
+ AOS (P)
+ JRST BSVECL
+BSVECE: MOVE O1,$WVECTOR
+ POP P,O2
+ PUSHJ P,UBLOKR
+ POPJ P,
+
+BSIMM: MOVE A,BSJFN
+ BIN
+ CAIE B,"< ; This is the only % frob we know how to read
+ HALTF
+ BIN
+ CAIE B,">
+ HALTF
+ MOVEI B,0
+ MOVE A,$WFALSE
+ POPJ P,
+
+; HERE TO READ A LIST
+
+BSLST: PUSH P,[0]
+BSLSTL: PUSHJ P,BSREAD
+ CAMN A,$WUNBOUND
+ CAIE B,")
+ CAIA
+ JRST BSLSTE
+ PUSH TP,A
+ PUSH TP,B
+ AOS (P)
+ JRST BSLSTL
+BSLSTE: POP P,O1
+ PUSHJ P,LIST
+ POPJ P,
+
+; HERE FOR BOOTSTRAP ERRORS
+
+BSNOB: HRROI A,[ASCIZ /No MSUBR named BOOT
+/]
+ PSOUT
+ PUSHJ P,HALTX
+
+BSNOF: HRROI A,[ASCIZ /Can't open BOOT.MSUBR
+/]
+ PSOUT
+ PUSHJ P,HALTX
+SUBTTL SMAP% CODE FOR MULTI SECTION HACKING
+
+SMAPIT: PUSH P,A
+ PUSH P,B
+ PUSH P,C
+; Create 1 or 2 stack sections, depending on FLIP
+ MOVEI A,0
+ MOVE B,[.FHSLF,,MIMSEC] ; create brand new section
+ MOVE C,[PM%CNT+PM%RD+PM%EX+PM%WR+1] ; bits for mapping
+ SMAP%
+IFN FLIP,[
+ MOVEI A,0
+ MOVE B,[.FHSLF,,MIMSEC+1] ; create brand new section
+ MOVE C,[PM%CNT+PM%RD+PM%EX+PM%WR+1] ; bits for mapping
+ SMAP%
+]
+ MOVSI C,(PM%RD+PM%EX+PM%CPY)
+ MOVSI A,.FHSLF
+ MOVE B,[.FHSLF,,<MIMSEC_9>]
+ PMAP
+IFN FLIP,[
+ MOVSI C,(PM%RD+PM%EX+PM%CPY)
+ MOVSI A,.FHSLF
+ MOVE B,[.FHSLF,,<<MIMSEC+1>_9>]
+ PMAP
+]
+ MOVE D,[.FHSLF,,1]
+MAPLP: MOVE A,D
+ MOVSI C,(PM%RD+PM%WR+PM%EX)
+ MOVE B,D
+ ADDI B,<MIMSEC_9.>
+ PMAP
+IFN FLIP,[
+ MOVSI C,(PM%RD+PM%WR+PM%EX)
+ MOVE A,D
+ MOVE B,D
+ ADDI B,<<MIMSEC+1>_9.>
+ PMAP
+]
+NXTMAP: ADDI D,1
+ CAME D,[.FHSLF,,1000]
+ JRST MAPLP
+
+; create stack section
+IFN <MIMSEC-TPSEC>,[
+ MOVEI A,0
+ MOVE B,[.FHSLF,,TPSEC]
+ MOVE C,[PM%CNT+PM%RD+PM%EX+PM%WR+1] ; bits for mapping
+ SMAP%
+]
+; create initial GC space section and section following (for MAPPUR)
+
+ MOVEI A,0
+ MOVE B,[.FHSLF,,INIGC]
+ MOVE C,[PM%CNT+PM%RD+PM%EX+PM%WR+2] ; bits for mapping
+ SMAP%
+
+; and map special page in from 0
+
+ MOVE A,[.FHSLF,,COMPAG+<MIMSEC_9>]
+ MOVE B,[.FHSLF,,<<INIGC_9.>+COMPAG>]
+ MOVE C,[PM%CNT+PM%RD+PM%EX+PM%WR+1] ; bits for mapping
+ PMAP
+IFN FLIP,MOVE A,[.FHSLF,,COMPAG+<<MIMSEC+1>_9>]
+IFE FLIP,MOVE A,[.FHSLF,,COMPAG+<MIMSEC_9>]
+ MOVE B,[.FHSLF,,<<<INIGC+1>_9.>+COMPAG>]
+ MOVE C,[PM%CNT+PM%RD+PM%EX+PM%WR+1]
+ PMAP
+
+; now all that is left to do is set up UUOs, fix ENTRY table and make stacks
+; happy
+
+ XJRST .+1
+ 0
+ MIMSEC,,.+1
+ MOVE A,[<ENTVEC+LOWOP-ENTMAX-1>,,ENTVEC+LOWOP]
+IFN FLIP, MOVEI B,MIMSEC+1
+IFE FLIP, MOVEI B,MIMSEC
+
+ HRRZ C,(A)
+ CAILE C,777
+ HRLM B,(A) ; MAKE POINT TO CORRECT SECTION
+ AOBJN A,.-3
+
+ MOVE A,[-FROBL,,FROBBS]
+ HRRZ C,(A)
+ CAILE C,777
+ HRLM B,(A)
+ AOBJN A,.-3
+
+IFN FLIP,[
+ XJRST .+1
+ 0
+ MIMSEC+1,,.+1
+ MOVE A,[<ENTVEC+LOWOP-ENTMAX-1>,,ENTVEC+LOWOP]
+ MOVEI B,MIMSEC
+
+ HRRZ C,(A)
+ CAILE C,777
+ HRLM B,(A) ; MAKE POINT TO CORRECT SECTION
+ AOBJN A,.-3
+]
+ MOVE A,[-FROBL,,FROBBS]
+ HRRZ C,(A)
+ CAILE C,777
+ HRLM B,(A)
+ AOBJN A,.-3
+
+ JRST @.+1
+ .+1
+ MOVEI A,.FHSLF
+ MOVEI B,2 ; CODE FOR SETUP OF UUO TABLE
+ MOVE C,[MIMSEC,,MLTUUP]
+ SWTRP%
+
+ MOVE TP,[TPSEC,,STRTTP] ; now have good TP
+ MOVE A,[INIGC,,1000] ; MAKE THIS START GC
+ MOVEM A,GCSMIN
+ MOVEM A,GCSBOT
+ MOVE A,[INIGC,,TOPMGC]
+ MOVEM A,GCSMAX
+ MOVE B,[MPAGM,,PAGTBL]
+ BLT B,PAGTBL+MPAGME-MPAGM
+ POP P,C
+ POP P,B
+ POP P,A
+ POP P,DUALPC+1
+ MOVEI 0,MIMSEC
+ HRLM DUALPC+1
+ MOVE P,[TPSEC,,STPDL] ; p-stack in MIM section
+ SETZM DUALPC
+ XJRST DUALPC ; poof we are outta here!
+
+MPAGM: ENDPG
+ 0
+ SETZ
+ 1000-ENDPG
+ ENDPG
+ -1
+ ENDPG
+ <MIMSEC_9.>
+ SETZ
+IFN <TPSEC-MIMSEC>,[
+ 1000-ENDPG
+ <MIMSEC_9.>+ENDPG
+ -1
+]
+ 1000-<STRTTP_<-9.>>
+ <STRTTP_<-9.>>+<TPSEC_9>
+ SETZ
+ ENDPG
+ <<MIMSEC+1>_9.>
+ SETZ
+IFN <TPSEC-MIMSEC>,[
+ 1000-ENDPG
+ <<MIMSEC+1>_9.>+ENDPG
+ -1
+]
+ 1000-<STRTTP_<-9.>>
+ <STRTTP_<-9.>>+<<TPSEC+1>_9>
+ SETZ
+ 1
+ <INIGC_9>
+ SETZ
+ <TOPMGC_<-9.>>+1
+ <INIGC_9>+1
+ INITZN
+ REPEAT <NUMSEC-1>,[1
+ <<INIGC+.RPCNT+1>_9.>
+ SETZ
+ 1000-1
+ <<INIGC+.RPCNT+1>_9.>+1
+ 0
+ ]
+
+MPAGME: 0
+
+
+CONSTANTS
+VARIABLES
+LOC ZZZ
+
+ END BOOTER
\ No newline at end of file
projects / pdp10-muddle.git / blobdiff