1 ;Set FTKCN non-zero to include debugging count code
3 TITLE TOPS-20 MIM INTERPRETER (MIMI)
9 XJRST==JRST 5, ; DOESN'T SEEM TO EXIST??
10 SS%EPN==10000 ; MAGIC BIT
11 IFNDEF SWTRP%,SWTRP%==JSYS 573
12 IFNDEF XSIR%,XSIR%==JSYS 602
13 IFNDEF SMAP%,SMAP%==JSYS 767
19 FLIP==1 ; FLAG TO DO SECTION FLIPPING
21 SBRFY==1 ; ENABLE "SUBRIFY" STUFF
23 XBLT==123000,,[020000,,]
46 PV%OFF==3 ; OFFSET FOR CODE IN PURVEC
55 LOC 136 ; POINTERS TO INTERESTING THING
57 MIMSEC,,BINDID ; VARIABLE BINDING ID
58 MIMSEC,,MPATM ; ATOM TO CALL FOR MAPPING
59 MIMSEC,,PURVEC ; PURE VECTOR
60 MIMSEC,,DBVEC ; OTHER PURE INFO
61 MIMSEC,,MINFO ; POINTER TO INFO VEC
62 MIMSEC,,TOPOBL ; OBLIST TABLE
63 MIMSEC,,PAGPTR ; POINTER TO PAGE TABLE
64 MIMSEC,,UWATM ; UNWIND ATOM
65 MIMSEC,,ICATM ; INTERRUPT ATOM
66 MIMSEC,,ECATM ; ERROR ATOM
67 MIMSEC,,NCATM ; UNDEFINED CALL ATOM
79 JRST @[MIMSEC,,CMPERR]
95 NOZONE: MIMSEC,,RCL ; POINTER TO NON-ZONE GC-PARAMS
97 BLOCK 21 ; SPACE USED FOR IRDBLK BEFORE?
101 CZONE: 0 ; current fs zone
108 PNTSTK: MIMSEC,,STKERR
111 ; JUMP 16,.+2 ;errors on sin/sout go to EXEC
118 ;Feature test switches:
119 FTKCN==0 ;ne 0 to include kernel testing code
125 DEFINE ENTRY ENTLOC,JSPQ
127 IFE FTKCN,{SETZ ENTLOC }
129 IFSE JSPQ,,1,,kercal ;;all dispatches through this address
132 loc kcltab+curop ;;hide real address in
133 xwd 1,entloc ;;other table (fake multi-sectioning)
137 IFG <%!ENTLOC+ENTVEC-ENTMAX>,ENTMAX==%!ENTLOC+1+ENTVEC
138 IFL <CUROP-LOWOP>,LOWOP==CUROP
144 ;;Some routines are JRST'd to, so we can't account them...
145 DEFINE OENTRY ENTLOC,JSPQ
148 IFG <%!ENTLOC-ENTMAX+ENTVEC>,ENTMAX==%!ENTLOC+1+ENTVEC
149 IFL <CUROP-LOWOP>,LOWOP==CUROP
155 DEFINE OENTRY ENTLOC,JSPQ
160 DEFINE TYPREC TBL,NAM\
161 $W!NAM=[$TYPCNT_6+$PRECORD,,0]
162 $T!NAM=$TYPCNT_6+$PRECORD
164 LOC RECTBL+<$TYPCNT*2>
171 DEFINE TYPMAK PT,NAM\
172 $W!NAM=[$TYPCNT_6+PT,,0]
180 SUBTTL OPCODE DEFINITIONS
269 SUBTTL Kernel stuff left in section 0 for max winnage
280 SBFRAM: MOVE O1,@3(M) ; get atom of current MSUBR
289 SUBI 0,SBRCLL-SBRFRM(TP)
296 SFRAME: PUSH TP,[$TSFRAM+$FRMDOPE,,0]
298 FRAME: PUSH TP,[$TFRAME+$FRMDOPE,,0]
303 BIND: PUSH TP,[$TBIND+$FRMDOPE,,0]
312 MOVE A,[$TBIND,,16.] ; LENGTH CHANGED (WAS 6)
318 FIXBLP: MOVE B,2(A) ; THE ATOM FOR THIS BINDING
319 CAMLE A,1(B) ; Survivored frob, we've already fixed this
321 MOVE O1,1(B) ; get section
322 CAMLE O1,TP ; skip if not top level binding
323 FIXBL1: CAILE 0,(A) ; ARE WE BEHIND THE CURRENT FRAME?
325 FIXBL2: MOVEM A,1(B) ; MAKE ATOM POINT TO THIS BINDING
326 SKIPE A,5(A) ; GET PREVIOUS BINDING AND LOOP
331 IFN FTKCN,< AOS @[MIMSEC,,KCNTAB+%CALL]> ;Count calls
337 ; PUSHJ P,@[MIMSEC,,TRACIN]
338 CALLRX: MOVE C,O2 ; SAVE # OF ARGUMENTS
339 SKIPN B,(O1) ; GET GLOBAL BINDING
340 JRST @[MIMSEC,,CALNGS] ; BARF, NOT GASSIGNED!
341 HLRZ A,(B) ; LOAD GVAL
342 CAIE A,$TMSUBR ; IS IT AN MSUBR?
343 JRST @[MIMSEC,,CALNGS] ; OH, FOO!
344 MOVE D,1(B) ; GET MSUBR
346 IFN FTKCN,{ SKIPE @[MIMSEC,,TRACNT] ;Trace count?
347 PUSHJ P,@[MIMSEC,,TRINCT] ; Yup
349 SKIPE B,@1(D) ; POINT TO GVAL OF ATOM OF IMSUBR
351 JRST COMPER ; If IMSUBR is not assigned...
352 SKIPL A,-1(F) ; GET PREVIOUS GLUED FRAME
353 SKIPA A,F ; OR ELSE CURRENT FRAME
355 HRRM SP,FR.SP(A) ; SAVE BINDING POINTER
356 MOVEM PC,FR.PC(A) ; SAVE PC (THIS IS WRONG)
358 SUBM TP,C ; POINT ABOVE FIRST ARG
359 MOVEM D,FR.MSA-1(C) ; STORE MSUBR IN FRAME
362 MOVEM F,FR.FRA-1(C) ; STORE PTR TO PREV FRAME
363 AOS F,FRAMID ; GET A UNIQUE ID
364 HRL F,O2 ; SAVE # ARGS IN LH
365 MOVEM F,FR.ARG-1(C) ; STORE ARGS,,ID
366 XMOVEI F,-1(C) ; POINT AT FRAME
367 SETZM (F) ; FOR WINNAGE
369 HLRZ A,(M) ; CHECK FOR FBIN TYPE KLUDGE
374 PUSHJ P,@[MIMSEC,,DMAPIN]
377 PUSHJ P,@[MIMSEC,,INTGOC]
379 ; JRST @[MIMSEC,,STKERR]
381 IFE FLIP&0,[ JRST @D ]
383 TLNN M,1 ; ODD/EVEN CHECK
390 EVNSEC: HRLI TP,ODDSEC
398 IUNBIN: MOVEI C,0 ; IN CASE NO BINDINGS FLUSHED
399 SETZB A,B ; IN CASE UNWINDER FOUND
401 IUNBNL: CAIL O1,(SP) ; IS BINDING POINTER ACCURATE?
402 JRST IUNBNQ ; YES, RETURN
403 SKIPN D,2(SP) ; THE ATOM BOUND
405 CAMN D,UWATM ; REALLY AN UNWIND?
406 JRST @[MIMSEC,,DOUNWI] ; AND LOOP UNTIL ALL DONE
407 UNJOIN: MOVE C,6(SP) ; THE OLD BINDING FOR THIS ATOM
408 MOVEM C,1(D) ; STUFF OLD BINDING INTO ATOM
409 NXTBND: MOVE C,SP ; SAVE LAST BINDING FLUSHED
410 MOVE SP,5(SP) ; POINT TO PREVIOUS BINDING
411 JRST IUNBNL ; YES, GO HANDLE IT
416 ; CAMGE C,TP ; NEED STACK TO FLUSH?
417 ; XMOVEI TP,-2(C) ; FLUSH BINDING DW AS WELL
421 IFN FTKCN,< AOS @[MIMSEC,,KCNTAB+%RETUR]>
422 ; SKIPE DIDCMP ; SEE IF MUST CHECK FOR OVFL PAGE HACK
423 ; JRST @[MIMSEC,,RET2]
424 RET3: SKIPL C,(F) ;NOTE THIS INSTRUCTION CAN BE MUNGED!!!
429 IFN SBRFY,[ TLZN C,SBRCAL ; SKIP IF SUBRIFY
431 MOVE M,-2(TP) ; CALLER'S M
433 HLRZ 0,(M) ; CHECK FOR PMAPPED
438 PUSHJ P,@[MIMSEC,,DMAPI1]
443 ; PUSHJ P,@[MIMSEC,,TRACOUT]
447 FRMFIX: MOVEI O1,-FR.LN(F)
448 CAIGE O1,(SP) ; DO WE NEED SOME UNBINDING?
449 JSP PC,IUNBNL ; YES. DO THEM
451 HRR F,FR.FRA(F) ; GET PREVIOUS FRAME
460 CHPCO: MOVE PC,FR.PC(C) ; RESTORE PC FROM FRAME
461 SKIPN M,FR.MSA(C) ; RESTORE MSUBR PTR FROM FRAME
463 MOVE M,@1(M) ; POINT TO GBIND THROUGH ATOM
464 MOVE M,1(M) ; GET IMSBUR INTO M
466 HLRZ O1,(M) ; CHECK FOR FBIN TYPE KLUDGE
471 PUSHJ P,@[MIMSEC,,DMAPI1]
474 IFE FLIP&0,[ JRST (E)]
475 IFN FLIP&0,[ JRST NOSBR]
476 HLRZS O2 ; FIND FRAME OF SUBRIFIED THING
477 ADD C,O2 ; THROUGH GROSS HAIR
478 DMOVE R,@(C) ; ONLY WORKS CAUSE R=M-1
481 IFE FLIP&0,[ JRST (E) ]
483 TLNN M,1 ; ODD/EVEN CHECK
490 EVNSE3: HRLI TP,ODDSEC
495 ; MAKTUP -- 0/ TOTAL ARGS PASSED, O1/ REQUIRED+OPT ARGS, O2/ #TEMPS
498 SUB 0,O1 ; SUBTRACT REQUIRED ARGUMENTS
499 LSH O2,1 ; O2 IS NUMBER OF TEMPS
500 ADJSP TP,(O2) ; BUMP TP TO REFLECT THIS
501 SKIPG A,0 ; A NOW HAS LENGTH OF TUPLE IN RH
502 JRST IMAKET ; ZERO LENGTH TUPLE
503 LSH O1,1 ; WORDS WORTH OF REQUIRED ARGS
504 MOVN C,0 ; # ARGS TO MOVE (NEG FOR XBLT)
505 ASH C,1 ; TO NUMBER OF WORDS
506 MOVEI D,2(O1) ; D/ # OF REQ ARGS+2
507 ADD D,F ; D POINT TO FIRST TUPLE WORD
508 SUB D,C ; NOW LAST TUPLE WORD+1
509 MOVE E,D ; COMPUTE DEST
510 ADD E,O2 ; ADD IN DELTA
518 XMOVEI B,1(TP) ; POINT AT DOPE WORD FOR EMPTY TUPLE
519 PUSHDW: LSH 0,1 ; MAKE IT BE # OF WORDS INSTEAD OF ELTS
520 HRLI 0,$TTUPLE+$FRMDOPE ; GENERATE A DOPE WORD
522 PUSH TP,[0] ; MUST PUT IN OTHER DOPE WORD
523 SKIPGE FR.TP(F) ; SKIP IF MUST MUNG FRAME
527 HRLM 0,FR.ARG(F) ; INDICATE IN FRAME
530 CONS: JSP OP,ICELL1 ; GET LIST CELL
531 JRST @[MIMSEC,,CONS1] ; REQS A GC
540 ICELL1: SKIPN B,CZONE
541 XMOVEI B,NOZONE-GCPOFF
542 MOVE B,GCPOFF(B) ; GC params
543 SKIPE A,RCLOFF(B) ; Recycled list cells?
544 JRST [MOVE 0,(A) ; Yes, use one
548 ; TLNE 0,$GC%PB ; ONLY PAGES FROM ZONE?
550 ICELL2: MOVE A,GCSBOF(B) ; Get GCSBOT
551 MOVEI 0,3 ; # words to allocate
552 ADDB 0,GCSBOF(B) ; Update GCSBOT?
553 CAMG 0,GCSMXO(B) ; Need GC?
554 JRST 1(OP) ; No, skip return
556 ADDM 0,GCSBOF(B) ; Fix up GCSBOT
557 JRST (OP) ; Lose, lose
559 TUPLE: MOVE B,TP ; POINT TO STACK
560 MOVE A,O1 ; SAVE LENGTH
563 HRLI O1,$TTUPLE+$FRMDOP
566 HRLI A,$TTUPLE ; TYPE/LENGTH IN A
569 SUBTTL OPEN COMPILER UTILITIES
572 IFN FTKCN,<AOS @[MIMSEC,,KCNTAB+CUROP]>
573 MOVE 0,A ; POSSIBLE COUNT
574 LDB A,[220300,,A] ; ISOLATE PRIMTYPE
578 IFN FTKCN,<AOS @[MIMSEC,,KCNTAB+CUROP+1]>
579 MOVE 0,A ; POSSIBLE COUNT
580 LDB A,[220300,,A] ; GET PRIMTYPE
581 CIMON1: CAIN A,$PLIST
591 ; SKIPA ; THIS IS REALLY WRONG!!!
599 IFN FTKCN,<AOS @[MIMSEC,,KCNTAB+CUROP+2]>
609 JRST [MOVSI A,$TCHARACTER
616 DOILD1: MOVSI A,$TFIX
621 IFN FTKCN,<AOS @[MIMSEC,,KCNTAB+CUROP+3]>
636 AOJA B,[HRLI A,$TUVECTOR
640 ; CAMG B,[TPSEC+2,,] ; Win with tuples???
644 DOIBP1: HRLI A,$TSTRING
655 INSRE1: MIMSEC,,INSRET
656 INSRE2: MIMSEC,,INSRET+1
669 LENWRD==2200 ; LENGTH WORD
670 TYPWRD==222200 ; TYPE WORD
672 UPTBYT==220200 ; UBLOCK-PRIMTYPE PART OF TYPE WORD
673 PTPBYT==220300 ; PRIMTYPE PART OF TYPE WORD
674 TYPBYT==301200 ; TYPE PART OF TYPE WORD
675 RTYBYT==061200 ; FOR A TYPE IN THE RH
676 MONBYT==250200 ; MONITOR PART OF TYPE WORD
677 $FRMDOPE==40 ; LH BIT FOR DOPE WORD
679 $QSFRB==100000 ; BIT IN GLUED FRM PC IF SEG CALL
680 ; **** CAUTION SUSPECT IN FUTURE
681 ; VERSIONS OF THE 20 ****
682 SBRCAL==200000 ; BIT IF "SUBRIFY CALL"
683 ; Flags associated with gc spaces (see GCSFLGs) (LEFT HALF WORD)
685 $GC%DW==400000 ; don't create dope words
686 $GC%PB==200000 ; only on page boundaries
695 RECTBL: BLOCK 256.*2 ; Each entry is a type/val pair
701 ; UVECTOR of machine dependent information
703 MINF: 100 ; jfn for tty input
704 101 ; jfn for tty output
706 7. ; bits per character
707 512. ; words per page
708 5 ; characters per word
709 0 ; shift for address in word terms
711 377777777777 ; largest possible number (float)
712 400000000001 ; smallest possible number (float)
716 ; WHAT FOLLOWS IS THE INITIAL SET OF GC-PARAMS, USED UNTIL THE
717 ; FS SYSTEM IS STARTED.
721 ; RCLV IS A POINTER STRUCTURE OF FREE NON-LIST STORAGE.
722 ; IT IS CHAINED TOGETHER SUCH THAT MOVE AC,(AC) WILL GET THE
723 ; NEXT FREE BLOCK OF STORAGE. THE LENGTH OF A GIVEN BLOCK
724 ; POINTED AT BY AC IS TWO PLUS THE RIGHT HALF OF -1(AC).
725 ; THIS WORD, I.E. -1(AC) IS THE FIRST DOPE WORD OF THE BLOCK
726 ; WHICH WAS RECYCLED.
727 ; BELOW IS A SCHEMATIC REPRESENTATION OF RCLV
729 ; BITS,,LENGTH-2 BITS,,LENGTH-2
730 ; RCLV -> NEXT FREE BLOCK -> NEXT FREE BLOCK -> ... -> 0
732 ; 0 ; 'TYPE WORD' FOR RCLV (ALWAYS 0)
734 RCLV: 0 ; RECYCLE VECTOR
758 GCSBOT: 0 ; CURRENT GC POINTER
783 PAGTBL: REPEAT PAGTLN,0
786 PCLEV1: 0 ; two words per int pc for multi-sec
791 RUNINT: 0 ; IF NON-ZERO, RUN INTS IMMEDIATELY
792 MLTUUP: 0 ; HOLDS UUO (SWAPPED SORT OF)
795 MLTEA: 0 ; EFF ADDR OF UUO INSTRUCTION
796 MLTUUH: MIMSEC,,MLTUOP ; RUN IN MIMSEC
798 INITZN==1 ; for now...
814 ; Offsets associated with FRAMEs
816 FR.LN==6 ; Length of full frame
817 FR.OFF==4 ; Offset from F to real frame ptr
818 FR.ACT==1 ; Offset for PC for activation
819 FR.SP==0 ; Offset for saved binding (rh)
820 FR.TP==0 ; Offset for saved TP (lh)
821 FR.FRA==-1 ; Offset for previous frame
822 FR.ARG==-2 ; Offset for # of args to this guy (lh)
823 FR.ID==-2 ; Offset for frame id (rh)
824 FR.PC==-3 ; Offset for saved PC
825 FR.MSA==-4 ; Offset for save MSUBR pointer
826 FR.HDR==-5 ; Offset for FRAME header
830 ; In multi-section/extended addressing mode, MIMI20 lives in section 1.
831 ; it is mapped there at startup time. MIMI should be able to run in either
832 ; single or multi section mode. The TP stack lives in a section of its own
833 ; and everything else is GC space (for now).
835 MIMSEC==1 ; MIMI sections
836 TPSEC==1 ; STACK sections
837 IFE FLIP,[ INIGC==TPSEC+2 ; First GC section
839 IFN FLIP,[ INIGC==TPSEC+2
840 IFE TPSEC&1,[ ODDSEC==TPSEC+1
842 IFN TPSEC&1,[ ODDSEC==TPSEC
845 COMPAG==0 ; page mapped into all sections except
847 NUMSEC==12 ; total # of initial sections
848 ; (initial value of CURSIZ...)
849 STRTTP==200000 ; begin control stack to avoid paging
851 STPDL==777000 ; put P stack in a strange place also
852 PGPDL==<<TPSEC_9>\<<STPDL>_<-9>>> ; P STACK PAGE
853 TPENDP==PGPDL-1 ; illegal page to end TP
854 TPWARN==TPENDP-5 ; page to warn of end
858 SUBTTL TYPE DEFINITIONS
862 TYPMAK $PFIX,CHARACTER
869 TYPMAK $PSTRING,STRING
870 TYPMAK $PUVECTOR,MCODE
872 TYPMAK $PVECTOR,VECTOR
873 TYPMAK $PVECTOR,MSUBR
876 TYPREC BNDTBL,BINDING
883 ; TYPES STARTING HERE SHOULD BE HANDLED DIFFERENTLY AT SOME
889 TYPMAK $PLIST,SEGMENT
891 TYPMAK $PLIST,FUNCTION
894 TYPMAK $PVECTOR,CHANNEL
895 TYPMAK $PVECTOR,ENTRY
896 TYPMAK $PVECTOR,ADECL
897 TYPMAK $PVECTOR,OFFSET
903 TYPMAK $PVECTOR,TUPLE
904 TYPMAK $PUVECTOR,UVECTOR
905 TYPMAK $PVECTOR,IMSUBR
908 TYPMAK $PVECTOR,I$SDTABLE
909 TYPMAK $PVECTOR,I$DISKCHANNEL
910 TYPMAK $PVECTOR,MUDCHAN
912 TYPMAK $PUVECTOR,PCODE
914 TYPMAK $PUVECTOR,GCPARAMS
915 TYPMAK $PUVECTOR,AREA
921 TYPMAK $PVECTOR,KENTRY
927 DBVEC: 0 ; LOCATIONS WHERE PURE VEC STUFF IS STORED
931 PAGPTR: $TUVEC,,PAGTLN
936 BINDID: 0 ; USED IN BININING
937 TTBIND: 0 ; TOP LEV BIND
939 CURSIZ: NUMSEC ; Number of sections we have
944 RETPUR: MOVE A,PURVEC
947 MOVE A,[SAVAC+B,,B] ; Restore ACs
949 MOVE B,PURZON ; Pick up pure zone
950 MOVE C,ATMZON ; and atom zone
951 MOVEM A,INTSAV ; Make sure flag set
952 PUSHJ P,SAV1 ; Go do the save
956 ;storage for metering
957 ksava: block 1 ;save ac a
958 kcntab: block 400 ;count of calls
959 kcltab: block 400 ;addresses of routines to call
960 ;storage for trace counting
961 tracnt: block 1 ;0 means don't count calls
962 tranum==4000 ;number of different atoms we may see:
963 tratab: block tranum+1 ;tbluk table for atom names
964 trascr: block tranum*3 ;scratch space for atom names
965 traptr: block 1 ;pointer to first free word in scratch space
966 tranam: block 10 ;temp space for atom name before lookup
967 trsava: block 2 ;save a,b
968 trsavc: block 2 ;save c,d
969 trsav5: block 2 ;save 5,6
971 movei a,trascr ;address of scratch space
972 movem a,traptr ;is first free at startup
973 hrrzi a,tranum ;0,,num
974 movem a,tratab ;tbluk table header
976 popj p, ;and return init'd
977 ;print out the table (and zero it)
978 pritab: dmovem a,trsava
981 priget: hrroi a,[asciz/Output file for trace: /]
983 move a,[gj%sht+gj%fns]
984 move b,[.priin,,.priout]
987 move b,[070000,,300000] ;7-bit read/write
989 jrst priget ;clever error handling
990 prilup: hlrz 5,tratab ;number of entries in table
992 jumpe 5,pridun ;done?
993 hrlz 5,5 ;in left half
994 setz 3, ;largest count so far....
996 plup: hrrz 4,tratab+1(5) ;get a canditate count
997 caml 4,3 ;bigger or equal?
998 jrst [ hrrz 6,5 ;yes, store new index
999 hrrz 3,tratab+1(6) ;and new count
1001 aobjn 5,plup ;iterate
1002 ;index of largest entry in ac 6 now
1007 hlro b,tratab+1(6) ;name
1009 hrrz b,tratab+1(6) ;count
1010 move c,[100010,,12] ;8 columns, leading filler, decimal
1013 hlrz 4,tratab ;table size
1014 move 3,tratab+1(4) ;top entry
1015 exch 3,tratab+1(6) ;flush out biggest entry
1016 sos 4 ;decrement used size
1017 hrlm 4,tratab ;save nwe count
1018 jrst prilup ;and iterate
1019 pridun: CLOSF ;close the file
1020 jfcl ;clever error handling
1024 popj p, ;and return to caller
1025 ;here to count a call
1026 trinct: dmovem a,trsava
1028 move b,3(d) ;get name of msubr
1029 move a,3(b) ;get string (count,,address)
1030 hrrz b,2(b) ;count into b
1031 move c,[440700,,tranam] ;temp space for name
1033 idpb d,c ;and put them
1034 sojg b,.-2 ;until there ain't no more (assumes 1 or more)
1035 setz d, ;null terminator
1037 movei a,tratab ;table address
1038 move b,[440700,,tranam] ;point to string
1040 tlne b,40000 ;set if exact match
1041 jrst [aos (a) ;bump count
1042 jrst trret] ;and return this call
1043 ;not in table, must add it
1044 move c,traptr ;get address of first free
1045 hrli c,440700 ;byte pointer
1046 move a,[440700,,tranam] ;
1048 idpb d,c ;and put them
1049 jumpn d,.-2 ;do til null
1050 movei a,tratab ;table address
1051 hrlz b,traptr ;address,,0
1052 aos b ;,,1 initial count
1054 aos c ;bump pointer to next word boundary
1055 hrrzm c,traptr ;and store it
1056 trret: dmove a,trsava
1060 ;Dispatch routine to use for metering calls into the kernel
1061 kerjsp: movem a,ksava ;called with JSP PC,
1062 hrrz a,-1(pc) ;get table offset
1063 aos kcntab-entvec(a) ;bump counter
1064 move a,kcltab-entvec(a) ;get real addr
1065 exch a,ksava ;restore a and setup to call
1067 kercal: movem a,ksava ;save a
1068 move a,(p) ;return address
1069 sos a ;caller's address
1070 hrrz a,(a) ;table offset used in call
1071 subi a,entvec ;table index relative to table start
1072 aos kcntab(a) ;count calls to this routine
1073 move a,kcltab(a) ;get address of routine being called
1074 exch a,ksava ;restore a and save routine address
1075 jrst @ksava ;do the real kernel call
1079 LOC <<.+777>&777000>
1081 SUBTTL STACK OPERATIONS & FLOW OF CONTROL
1083 ; LEGAL? TAKES ARGUMENT IN A & B
1085 LEGAL: HLRZ C,A ; GET TYPE OF FROBBIE
1091 TLZ C,770000 ; CLEAR OUT BYTE POINTER BITS
1092 CAML C,[INIGC,,0] ; SKIP IF IN STACK AREA
1096 CAMLE D,C ; SKIP IF ON STACK
1097 JRST LGLFLS ; NO, A LOSER
1098 LDB D,[220300,,A] ; GET SAT
1099 JRST @LGLTAB(D) ; DISPATCH
1100 LGLTRU: MOVSI A,$TFIX
1112 IBP A,B ; REST TO END OF STRING
1113 ADDI A,1 ; TO NEXT WORD
1115 TRNN B,$FRMDOPE ; DOPE WORD?
1116 JRST LGLFLS ; NO, LOSER
1128 LGLFRM: MOVSI D,<$TFRAME+$FRMDOPE>
1129 MOVSI E,<$TSFRAM+$FRMDOPE>
1143 LGLBND: CAML B,[INIGC,,0]
1145 MOVSI D,<$TBIND+$FRMDOPE>
1157 CAIE D,$TVECTOR+$FRMDOPE
1158 CAIN D,$TTUPLE+$FRMDOPE
1160 HLRZ D,-FR.LN-1(B) ; SEE IF ARGS OF A FRAME
1161 CAIE D,$TFRAME+$FRMDOPE
1162 CAIN D,$TSFRAM+$FRMDOPE
1165 ;here to check for rested args of a frame
1167 MOVE D,F ; start at current frame
1168 LGLTU3: SKIPL (D) ; glued frame
1170 HRRZ D,-1(D) ; get real frame
1172 LGLTU2: CAMG D,B ; skip if frame above tuple
1178 LGLTU1: HLRE C,FR.ARG(D) ; get arg count
1181 ADDI D,2(C) ; should be tuple end
1193 IPFRM1: MOVE A,$WFRAME
1206 MOVEM O1,@[MIMSEC,,UWATM]
1207 MOVEM O1,@[MIMSEC+1,,UWATM]
1209 IFE FLIP MOVEM O1,UWATM
1212 ARGS: HLRE A,FR.OFF+FR.ARG(O1) ; COUNT OF ARGUMENTS
1213 JUMPL A,IARG1 ; FUNNY, CASE
1214 HRLI A,$TTUPLE ; SET TYPE WORD
1215 MOVEI B,6(O1) ; POINT AT ARGUMENT BLOCK
1219 IARG1: SUBM O1,A ; POINT TO DW OF TUPLE
1220 HRRZ B,FR.OFF-1(A) ; GET LENGTH
1230 IFN FTKCN,< AOS KCNTAB+%INCAL> ;Count calls
1235 SKIPL A,-1(F) ; GET PREVIOUS GLUED FRAME
1236 MOVE A,F ; OR ELSE CURRENT FRAME
1240 MOVE 0,FR.MSA(A) ; SO RETURN WINS
1246 AOS F,@[MIMSEC,,FRAMID]
1247 MOVEM F,@[MIMSEC+1,,FRAMID]
1249 IFE FLIP AOS F,FRAMID
1252 MOVEM 0,FR.MSA(F) ; SO RETURN WINS
1254 ADDI B,1 ; NOTE: DONT CHANGE TO AOJA!!!
1258 IFN FTKCN,< AOS KCNTAB+%ACALL> ;Count calls
1261 JRST [ MOVE D,B ; GET ATOM
1271 CALNGS: SKIPN NCATM ; CALL'ED ATOM IS NOT GASSIGNED
1273 ADJSP TP,2 ; ROOM FOR EXTRA ARG
1275 SKIPN E,O2 ; # OF ARGS TO B
1280 SOJG E,.-3 ; MAKE ROOM
1282 CALNG5: JUMPE O1,CALNG2 ; JUMP IF NOT A CALL TO AN ATOM
1284 CALNG1: MOVE B,[$TATOM,,$LATOM]
1287 CALNG3: MOVE O1,NCATM
1288 SKIPN B,(O1) ; See if global binding for this guy
1291 CAIE A,$TMSUBR ; Better be an msubr, or
1292 PUSHJ P,HALTX ; we'd go into an infinite loop
1295 CALNG2: DMOVEM A,-1(OP) ; MUNG IN WHATEVER IT IS
1299 CALNMS: PUSHJ P,HALTX ; VALUE OF CALL'ED ATOM ISN'T MSUBR
1302 IFN FTKCN,< AOS KCNTAB+%ACTIVA> ;Count calls
1307 SUBI A,(F) ; REL TP TO FRAME
1311 RETRY: XMOVEI F,FR.OFF(O1)
1312 HLRE B,FR.ARG(F) ; SEE IF TUPLE CASE
1314 SUBM F,B ; B POINTS TO DW
1315 HRRZ A,-1(B) ; A IS REAL # ARG
1317 HRLM A,FR.ARG(F) ; FIX UP # ARGS
1318 LSH A,1 ; TO # WORDS
1319 SUBI B,1(A) ; B IS SOURCE (I.E. 1ST ARG WORD)
1320 XMOVEI C,2(F) ; FIRS DEST
1322 BLTDON: PUSH P,FR.ARG(F) ; SAVE FOR NEW FRAME
1336 IFN FTKCN,< AOS KCNTAB+%AGAIN> ;Count
1338 SKIPGE (F) ; CHECK FOR GLUEDNESS
1339 HRR F,-1(F) ; GET THE REAL FRAME
1347 MOVE M,@1(M) ; GET ATOM OF IMSUBR
1348 MOVE M,1(M) ; AND FINALLY IMSUBR
1349 HLRZ A,(M) ; CHECK FOR FBIN TYPE KLUDGE
1352 JRST [ SKIPN R,PV%OFF(R) ; GET POINTER
1353 ; NOT THERE, MAP IT IN
1356 IAGN1: HRRZ PC,FR.ACT(F)
1360 IFE FLIP&0,[ ADD TP,F
1363 TLNN M,1 ; ODD/EVEN CHECK
1370 EVNSE1: HRLI F,ODDSEC
1375 ; HERE TO HANDLE AN UNWINDER
1377 DOUNWI: SKIPN O2,1(SP) ; GET UNWIND FRAME
1379 SKIPN M,FR.MSA+FR.OFF(O2) ; RESTORE MSUBR PTR FROM FRAME
1381 MOVE M,1(M) ; POINT TO ATOM
1382 MOVE M,(M) ; POINT TO GBIND
1383 MOVE M,1(M) ; GET IMSBUR INTO M
1384 HLRZ C,(M) ; CHECK FOR FBIN TYPE KLUDGE
1387 JRST [ SKIPE R,PV%OFF(R) ; GET POINTER
1389 PUSH TP,A ; NOT THERE, MAP IT IN
1399 HRRZ C,4(SP) ; GET PC OFFSET
1402 ADJSP TP,6(D) ; MUNG IT
1415 IFE FLIP&0,[ JRST (C) ]
1417 TLNN M,1 ; ODD/EVEN CHECK
1424 EVNSE2: HRLI TP,ODDSEC
1430 IFN FTKCN,< AOS KCNTAB+%UNWCN> ;Count calls
1438 MOVE D,2(SP) ; REALLY UNBIND IT IF SUCCESSFUL
1441 ; HERE TO HANDLE FIXUP AFTER STACK LOSSAGE FROM RETURN
1443 CAIL C,<<TPWARN>_9.> ; ARE WE BELOW
1456 MOVSI A,(SKIPL C,(F))
1457 MOVEM A,RET3 ; MUNG THAT INS!!!
1458 MOVEM A,@[MIMSEC+1,,RET3]
1462 ; RTUPLE WILL NOT RUN IN MIM MODE
1472 SKIPN O2 ; 0 ==> MRET FROM CURRENT FRAME
1473 XMOVEI O2,-FR.OFF(F) ; UPDATE FRAME
1474 MRET2: SKIPGE C,FR.OFF(O2) ; GLUED FRAME?
1476 JUMPN D,MRET3 ; JUMP IF RTUPLE
1477 HLRZ C,FR.HDR+FR.OFF(O2) ; SEE IF SEG FRAME
1478 CAIN C,$TSFRAM+$FRMDOP
1480 MOVE A,FR.FRA+FR.OFF(O2) ; Previous frame
1481 SKIPGE C,FR.OFF(A) ; Glued?
1482 JRST [HRR A,-1(A) ; Point to real frame
1484 MOVE C,FR.OFF+FR.PC(A) ; Get return PC if not glued
1485 MRETFO: MOVE M,FR.MSA+FR.OFF(A) ; MSUBR
1487 MOVE M,1(M) ; IMSUBR
1490 CAIE 0,$TPCODE ; skip if fbin
1492 SKIPN R,PV%OFF(R) ; skip if already mapped in
1493 PUSHJ P,@[MIMSEC,,DMAPI1] ; Map the guy in
1494 MOVE B,@C ; THIS KLUDGE SEES IF WE CAN STEP TO
1495 ; NEXT FRAME FOR THIS MRETURN
1496 CAMN B,[JRST @<RETOFF+ENTVEC>] ; IS IT A RETURN
1497 JRST [ MOVE O2,FR.OFF+FR.FRA(O2) ; YES, MRETURN FROM IT
1498 SKIPGE (O2) ; skip if not glued frame
1499 SUBI O2,FR.OFF ; fix up pointer
1500 JRST MRET2 ] ; try this all again
1505 PUSH TP,[$TFRAME,,$LFRAME]
1519 MRET3: XMOVEI F,FR.OFF(O2)
1520 PUSH P,O1 ; SAVE NUMBER OF ITEMS
1521 PUSH P,TP ; SAVE POINTER TO STACK
1524 JSP E,FRMFIX ; UNBIND, DO RETURN
1527 POP P,A ; GET BACK STACK
1528 MOVE C,(P) ; GET BACK TUPLE LENGTH
1529 LSH C,1 ; TWICE THAT FOR # OF WORDS
1530 SUB A,C ; POINT TO FIRST ELEMENT
1531 XMOVEI B,1(TP) ; SAVE POINTER TO TUPLE
1534 IRTPL2: JUMPE C,IRTPLE ; AN EMPTY TUPLE
1535 IRTPLP: PUSH TP,1(A) ; PUSH AN ELEMENT OF THE TUPLE
1537 ADDI A,2 ; MOVE THROUGH TUPLE
1538 SUBI C,2 ; DECREMENT COUNT
1539 JUMPN C,IRTPLP ; LOOP UNTIL DONE
1540 IRTPLE: JUMPE E,IRTPL3
1541 POP P,A ; RESTORE LENGTH
1550 GRTUPL: XMOVEI E,FR.OFF-2(O2) ; SAVE A COPY OF GLUED FRAME
1551 ; POP OF GLUED FRAME
1552 MOVE F,FR.OFF+1(O2) ; GET RESTORED
1553 MOVE A,O1 ; COPY # OF ELEMENTS
1554 LSH O1,1 ; TO NUMBER OF WORDS
1556 SUB O2,O1 ; POINT TO FIRST
1559 JUMPN D,IGRTP3 ; JUMP IF RTUPLE NOT MRETURN
1560 TLZE C,$QSFRB ; SEG CALL
1561 AOJA C,IGRTP3 ; YES, SKIP RETURN WITH STUFF ON STACK
1562 MOVE B,@C ; THIS KLUDGE SEES IF WE CAN STEP TO
1563 ; NEXT FRAME FOR THIS MRETURN
1564 CAMN B,[JRST @<RETOFF+ENTVEC>] ; IS IT A RETURN
1566 JUMPE O1,COMPER ; MUST HAVE AT LEAST ONE ARG
1567 DMOVE A,1(O2) ; RET 1ST ELEMENT
1571 IGRTP3: JUMPE O1,IGRTP1
1572 IGRTP2: PUSH E,1(O2)
1578 JUMPE D,IGRTP4 ; IF MRET, RET # OF ARGS
1586 SUBTTL CODE TO TRY TO MAP IN A FROB
1589 SBFPMP: MOVE R,1(M) ;pointer to pcode
1593 SBFPM1: PUSH TP,$TFIX
1603 DMAPIN: PUSH P,D ; NOT THERE, MAP IT IN
1605 IFE FLIP, PUSH P,NARGS
1607 PUSH P,@[MIMSEC,,NARGS]
1608 PUSH P,@[MIMSEC+1,,NARGS]
1611 IFE FLIP, POP P,NARGS
1613 POP P,@[MIMSEC+1,,NARGS]
1614 POP P,@[MIMSEC,,NARGS]
1620 DMAPI1: PUSH P,PC ; NOT THERE, MAP IT IN
1622 PUSH TP,A ; SAVE RET VAL
1631 MAPIN: SKIPN O1,MPATM ; HAVE WE BEEN SUPPLIED WITH ATOM?
1633 JSP PC,FRAME ; CREATE A FRAME
1634 PUSH TP,(M) ; CALL WITH THE PURVE PNTR OF INTEREST
1636 MOVEI O2,1 ; ONE ARG
1637 JSP PC,CALLZ ; GO FOR IT
1638 MOVE R,1(M) ; SET UP R NOW
1639 SKIPN R,PV%OFF(R) ; FROM THE VECTOR
1651 CIGVL: SKIPN B,@(TP)
1654 FOOADJ: ADJSP TP,-8.
1661 HRROI A,[ASCIZ /MIMI20 Not Running
1668 ; GET THE NEXT ELEMENT ON THE STACK. POINTER INTO THE STACK
1669 ; IS THE ARGUMENT (LOCAL). RETURNS AN OBJECT, OR A #UNBOUND -1
1670 ; IF THERE IS NOTHING ELSE ON THE STACK
1675 IRP %A,,[RCLOFF,RCLVOF,RCLV2O,RCLV3O,RCLV4O,RCLV7O,RCLV8O
1677 SETZM %A(B) ; THIS IS THE START OF A GC
1678 TERMIN ; SO RELEASE EVERYTHING
1681 ; SETOM INGC ; DONT PERMIT INTERRUPTS
1684 TRNE B,$FRMDOPE ; IS THIS A RECORD DOPE WORD?
1685 JRST [CAIN B,$TTUPLE+$FRMDOPE
1687 LDB A,[000300,,B] ; GET SAT
1688 CAIE A,$PRECORD ; RECORD?
1689 JRST INEXT6 ; NO, SKIP IT (STACK STRUCTURE)
1690 LDB B,[RTYBYT,,B] ; YES. GET RECORD TYPE
1692 MOVE B,@RECTBL+1(B) ; GET LENGTH FROM TABLE
1693 LSH B,-1 ; DIVIDE BY TWO FOR 36-BIT WORDS
1694 ADDI O1,1(B) ; ADD ONE FOR HEADER WORD
1695 JRST INEXT5] ; REENTER CODE
1696 INEXT3: ADDI O1,2 ; POINT TO NEXT ELEMENT
1697 INEXT5: XMOVEI B,(TP) ; ARE WE DONE YET?
1699 JRST [MOVEI B,0 ; YUP
1702 JUMPL B,[ADDI O1,3 ; SKIP PSEUDO-FRAME
1703 JRST INEXT5] ; TRY THAT
1706 JRST [ LDB A,[000300,,B]
1712 INEXT7: SKIPN 1(O1) ; DONT RETURN 0 POINTER
1713 JRST [ CAIE B,$TBIND+$FRMDOPE
1717 INEXT1: MOVE A,$WFIX
1721 JRST INEXT5 ; SKIP STRUCTURE, TRY AGAIN
1723 CONTEN: DMOVE A,(O1) ; GET THE PAIR FROM THE STACK
1724 TLZE A,$FRMDOPE ; IS THE TYPE-WORD A DOPE WORD?
1725 XMOVEI B,1(O1) ; POINT PAST THE DOPE WORD
1726 JRST (PC) ; RETURN RECORD POINTER
1729 SUBTTL TYPE MANIPULATION
1731 NEWTYP: LDB B,[300,,O1] ; GET PRIMTYPE BITS
1732 MOVE A,$WTCNT ; GET TYPE COUNT
1734 CAIL A,1024. ; MAX NUMBER
1735 PUSHJ P,COMPER ; DIE
1736 DPB A,[61300,,B] ; STUFF NEW TYPE CODE
1737 MOVE A,$WFIX ; AND RETURN IT
1740 ; TYPEW - build a type word O1/ type-code O2/ type-code of prim
1742 TYPEW: LDB B,[600,,O2]
1749 MOVE O2,RECTBL+1(O2) ; GET POINTER TO RECORD TABLE
1750 HRRZ B,(O2) ; GET LENGTH FROM TABLE
1754 ; Add user template information to internal record table"
1760 XRECOR: SUBM R,(P) ; RELATIVIZE PC IN CASE OF GC
1767 MOVE D,C ; CHANGED BY MARC (BAD DOPE WORD)
1768 ADD C,A ; POINT TO DW
1772 TLNN 0,$GC%DW ; SKIP IF NO DW
1779 ADD B,[657777,,-1] ; MAKE GLOBAL BP
1785 SUBTTL STRUCTURE CREATION
1788 SETZ B, ; INITIALIZE CDR
1789 LISTL: SOJL O1,LISTE ; LOOP UNTIL DONE
1793 PUSHJ P,ICELL ; GET A CELL IN 'A'
1796 POP TP,2(A) ; POP VALUE
1797 POP TP,1(A) ; AND TYPE/LENGTH INTO CELL
1799 MOVE B,A ; UPDATE CDR POINTER
1800 JRST LISTL ; AND LOOP
1802 LISTE: MOVE A,$WLIST ; TYPE-WORD LIST
1807 JRST COMPER ; either negative of too big
1815 HRR O1,O2 ; MAKE TYPE WORD (WRONG FOR STRING, BYTES)
1819 SUBM TP,D ; POINT D AT FIRST ELEMENT
1832 PUSH P,A ; PUT # WORDS WHERE EXPECTED
1842 ; COUNT IS IN O2; POINTER IN D. RETURN COUNT IN A; CAN CLOBBER D.
1848 STRCLP: LDB C,[220304,,1]
1849 JUMPN C,STRCST ; A CHARACTER
1852 ADD A,C ; LENGTH OF STRING/BYTES
1859 ; BYTE POINTER IN B, ARG POINTER IN D, ARG COUNT IN O2, A IS SACRED
1860 ; (BYTE POINTER IS (A)).
1861 STRMOV: LDB C,[220304,,1] ; SAT OF THING IN 1(D)
1864 IDPB C,B ; STUFF OUT A BYTE
1876 DOSTR: ADJSP P,3 ; SPACE FOR EXTRA STUFF
1877 PUSH P,A ; BYTES/WORD
1878 PUSH P,B ; FROB TO MAKE LOCAL BYTE POINTER
1879 PUSH P,C ; FROB TO MAKE GLOBAL BP WHEN DONE
1882 HRR O1,A ; FIX UP SAVED TYPE WORD
1884 SUBI A,1 ; ROUND UP TO NEXT FULL WORD
1886 MOVEM A,-6(P) ; # OF WORDS FOR FROB
1890 JSP PC,IBLOCK ; GET STORAGE
1895 MOVEM 0,-3(P) ; SAVE ADDRESS AND FLAGS
1896 MOVE B,-1(P) ; ARGUMENT FROM B
1897 TLO B,1 ; MAKE BP (A)
1898 JUMPE O2,STRMDN ; OBVIOUSLY EMPTY?
1902 STRMDN: MOVE 0,-3(P) ; FLAGS
1903 MOVE B,-4(P) ; ADDRESS
1904 MOVE C,-5(P) ; # WORDS
1905 ADD C,B ; POINT TO DOPE WORDS
1906 ADD B,(P) ; GLOBAL BP
1907 ADJSP P,-5 ; FLUSH ALL BUT # OF WORDS
1908 POP P,A ; VALUES IN A,B,C
1911 UBLR: POP P,B ; TP BECOMES PLACE OF FIRST ARG.
1912 MOVE C,(P) ; # OF WORDS IN THE UBLOCK
1914 UBLR1: POP P,D ; # OF WORDS
1915 TLNN 0,$GC%DW ; MAYBE STUFF INTO DOPE WORDS
1917 MOVE D,O1 ; OTHER HALF OF DOPE WORD
1929 UBLU: MOVE A,O2 ; GET # ARGUMENTS
1931 ADDI A,2 ; ADD DOPE WORDS
1935 JSP PC,IBLOCK ; GET CORE
1939 PUSH P,A ; SAVE LOCATION
1945 SOJN O2,UBLUL ; AND LOOP
1948 UBLV: MOVE A,O2 ; GET # ARGUMENTS
1949 LSH A,1 ; 2 36-BIT WORDS FOR EACH
1951 ADDI A,2 ; ADD DOPE WORDS
1955 JSP PC,IBLOCK ; GET CORE
1959 PUSH P,A ; SAVE LOCATION
1960 JUMPE O2,UBLR ; CHOMPING EMPTY VECTOR
1964 MOVEM B,1(A) ; STUFF
1967 SOJN O2,UBLVL ; AND LOOP
1970 ; RETURN UNINITIALIZED STORAGE. ARGS JUST LIKE UBLOCK (O1 TYPE, O2 # ELEMENTS),
1971 ; BUT NOTHING ON STACK.
1974 JRST COMPER ; either negative or too big!
1976 SUBM R,(P) ; IN CASE OF GC
1977 LDB A,[220200,,O1] ; GET TYPE
1978 JRST @UUBLTB(A) ; TYPE DISPATCH
1985 JRST UUBLS1 ; LIKE STRING, WITH 4 BYTES/WORD
1987 UUBLS1: MOVE B,O2 ; # OF ELEMENTS
1988 ADDI B,-1(A) ; ROUND UP
1989 IDIV B,A ; # OF WORDS NEEDED
1990 PUSHJ P,UIB ; BUILD THE STORAGE
1992 CAME O1,[$TSTRING,,0]
1994 ADD B,C ; MAKE A BYTE POINTER
2003 PUSHJ P,CLRVEC ; THIS HAS TO BE ZEROED
2005 ; TYPE IN O1, LENGTH IN O2, # WORDS (EXCLUSIVE OF DW) IN B. RETURN
2006 ; POINTER IN A, B (SOMEBODY ELSE MAKES BYTE POINTER FOR STRINGS, BYTES
2007 UIB: CAILE B,777000-2 ;length better be less than a section
2012 MOVEI A,2(B) ; # WORDS, WITH DW
2013 JSP PC,IBLOCK ; GET THE STORAGE
2018 ADD B,(P) ; POINT AT DOPE WORDS
2031 ; BUILD STACK STRUCTURES. O1 IS TYPE WORD, O2 IS # ELTS.
2032 SBLOCK: TLNE O2,-1 ; skip if not negative or too big
2037 SUBM TP,D ; POINT AT FIRST ARGUMENT (-1)
2038 LDB A,[220200,,O1] ; GET LOW BITS OF SAT
2045 SBVEC: EXCH O1,O2 ; THIS IS ALMOST LIKE TUPLE
2050 MOVE A,O1 ; TYPE WORD
2051 TLO O1,$FRMDOPE ; DOPE WORD
2052 MOVEM O1,1(D) ; STUFF OUT FIRST DOPE WORD
2054 MOVE B,C ; SAVE POINTER
2056 SBUVCL: MOVE E,2(D) ; PICK UP A FROB
2057 MOVEM E,(C) ; STUFF IT OUT
2058 ADDI D,2 ; UPDATE POINTER TO SOURCE
2059 ADDI C,1 ; AND TO DEST
2060 SOJG O2,SBUVCL ; JUMP IF NOT DONE
2061 SBUVCD: MOVEM O1,(C) ; OTHER DOPE WORD
2062 MOVE TP,C ; UPDATE STACK
2065 ; STACK BYTES AND STRINGS. D STILL HAS POINTER TO FIRST ARGUMENT
2084 PUSHJ P,STRCNT ; GET LENGTH OF NEW STRING INTO A
2088 IDIV A,-4(P) ; # WORDS FOR STRING
2089 HRR O1,A ; SAVE FOR DOPE WORDS
2090 ADDI A,2 ; PLUS DOPE
2091 TLO O1,$FRMDOPE ; MAKE IT A DOPE WORD
2093 LSH B,1 ; WORDS OF ARGUMENT
2094 MOVE C,-1(P) ; BEGINNING OF BLOCK, ALMOST
2095 ADDI C,1 ; REAL BEGINNING OF BLOCK
2096 PUSH P,C ; WHICH WILL BE LOC OF 1ST DOPE WORD
2098 CAML A,B ; ENSURE NO BACKWARDS BLT PROBLEMS
2102 SSBCNT: MOVEM D,-2(P) ; SAVE IT
2103 XBLT B, ; BLT THE ARGS DOWN THE STACK
2104 POP P,A ; GET POINTER TO STACK AREA WE'RE USING
2105 MOVEM O1,(A) ; DUMP OUT FIRST DW
2107 PUSH P,A ; SAVE ADDRESS OF RESULT
2108 MOVE B,-4(P) ; LOCAL BYTE POINTER
2109 TLO B,1 ; MAKE IT BE (A)
2113 SUBI D,1 ; SHOULD POINT BEFORE ARG BLOCK
2114 PUSHJ P,STRMOV ; COPY THE STUFF IN
2115 SSBNOM: MOVE B,(P) ; RESULT POINTER
2117 ADDI B,(C) ; POINT TO LAST DOPE WORD
2118 MOVEM O1,(B) ; STUFF OUT DOPE WORD
2128 ; RETURN UNINITIALIZED STORAGE ON STACK. O1 IS TYPE WORD, O2 IS # ELTS.
2129 ; SAVE ACS EXCEPT A AND B.
2132 JRST COMPER ; either negative or too big
2141 USBYT: MOVEI A,3(O2)
2142 IDIVI A,4 ; # WORDS, EXCLUDING DOPE WORDS
2155 USSTR: MOVEI A,4(O2)
2167 USUVC: MOVE C,O1 ; MAKE A DOPE WORD
2169 HRRI C,(O2) ; # ELTS + 2 FOR DOPE WORD
2170 PUSH TP,C ; PUSH HEADER DOPE WORD
2171 XMOVEI B,1(TP) ; SAVE POINTER
2172 ADJSP TP,(O2) ; CREATE SPACE
2173 PUSH TP,C ; PUSH TRAILER DOPE WORD
2178 HRLI C,$FRMDOPE+$TTUPLE
2196 HRRZ C,A ; GET LENGTH IN WORDS
2198 SUBI C,1 ; LESS FIRST WORD
2199 SETZM (B) ; CLEAR FIRST WORD
2200 MOVE D,B ; SOURCE BLOCK
2201 XMOVEI E,1(B) ; DEST BLOCK
2214 RECORR: LDB A,[301200,,O1]
2216 MOVE A,RECTBL+1(A) ; GET POINTER TO RECORD TABLE
2217 ADDI A,1 ; POINT TO FIRST ENTRY
2218 PUSH P,O1 ; SAVE TYPE WORD FOR RETURN
2219 PUSH P,A ; SAVE POINTER TO TABLE
2223 ; HRRZ A,-1(A) ; GET # 1/2 WORDS NEEDED FOR RECORD
2225 ; THE SEMI'ED LINES ABOVE ARE CHANGED TO THE TWO FOLLOWING
2226 ; SHOULD CHANGE THE LENGTH FIELD OF RECORDS TO BE 'RIGHT'
2227 ; I.E. THE NUMBER OF 1/2 WORDS IN THE RECORD
2233 PUSH P,A ; SAVE THIS FOR A MOMENT
2234 ADDI A,2 ; ADD FOR DOPE WORDS
2237 JSP PC,IBLOCK ; HERE THEY ARE
2240 MOVE C,A ; HOLD ON TO RECORD POINTER
2241 ADD A,(P) ; POINT TO THE DOPE WORD
2242 POP P,B ; HERE'S THE # WORDS AGAIN
2244 JRST [TLO O1,$DOPEBIT ; SET THE DOPEWORD BIT
2245 HLLM O1,(A) ; PUT TYPE WORD IN DOPES
2246 HRRM B,(A) ; STORE IT IN DOPE WORD
2249 POP P,A ; RESTORE TABLE POINTER
2250 PUSH P,C ; SAVE POINTER TO RECORD FOR RETURN
2252 MOVSI C,222200+D ; MAKE BP TO RECORD
2253 MOVE E,O2 ; GET COUNT OF ELEMENTS
2254 LSH E,1 ; 2 WORDS PER ELEMENT
2256 SUBM TP,E ; E POINTS TO FIRST ARG
2258 RECORL: HLRZ C,1(A) ; BYTE OFFSET
2259 ADJBP C,[222200+D,,0]
2260 HRRZ B,1(A) ; SIZE OF THIS ELEMENT IN RECORD
2261 PUSHJ P,@PUTRTB-1(B) ; DO A 'PUTR'
2262 ADDI A,2 ; ADVANCE POINTER IN TABLE
2263 ADDI E,2 ; ADVANCE POINTER TO ELEMENT
2264 SOJN O2,RECORL ; LOOP UNTIL DONE
2267 ADJSP TP,(D) ; RESTORE TP
2268 POP P,B ; RESTORE VALUE WORD (POINTER)
2269 POP P,A ; RESTORE TYPE/LENGTH WORD
2273 SUBTTL STRUCTURE MANIPULATION
2275 NTHU: LDB A,[UPTBYT,,A] ; TYPE IN A, PTR IN O1, NUM IN O2
2309 SKIPN A,RECTBL+1(A) ; AND POINTER TO TABLE
2311 LSH O2,1 ; 4 16-BIT WORDS / ENTRY
2312 ADDI A,-1(O2) ; POINT TO CORRECT ENTRY
2313 HRRZ B,1(A) ; GET SIZE OF ITEM TO EXTRACT
2314 HLRZ C,1(A) ; WORD OFFSET TO START FROM
2315 MOVE O2,O1 ; COPY IN CASE MULTI SECT
2316 ; HRLI O1,222240 ; MAKE WORK IN MULTI SECT
2318 ADJBP C,O1 ; MAKE BYTE POINTER TO ITEM
2319 ; IN MULTI SECT, C & D ARE BPTR
2320 JRST @NTHRTB-1(B) ; DISPATCH
2322 NTHRTB: SETZ NTHRBB ; BOOLEAN
2323 SETZ NTHRE ; ERROR - SHOULDN'T HAPPEN
2324 SETZ NTHRBB ; ENUMERATION
2325 SETZ NTHRBB ; SUB-RANGE
2326 SETZ NTHRBB ; SUB-RANGE (SBOOL)
2327 SETZ NTHRLF ; LIST OR FIX
2328 SETZ NTHRLF ; LIST OR FIX (SBOOL)
2329 SETZ NTHRS3 ; STRUC IN 3 HALF WORDS
2330 SETZ NTHRS3 ; SAME WITH SBOOL
2331 SETZ NTHRS2 ; STRUC WITH DEFINED LENGTH
2332 SETZ NTHRS2 ; SAME SBOOL
2334 SETZ NTHRHW ; SPECIAL TYPE-C CASE
2336 ; HERE TO EXTRACT A BOOLEAN
2338 NTHRBB: LDB B,C ; GET WORD OF BOOLEANS
2339 LSH B,18. ; SHIFT OVER
2340 ILDB C,C ; GET NEXT 16 BITS
2341 IOR B,C ; THEN OR THEM TOGETHER
2342 LDB C,[111100,,(A)] ; GET LEFT SHIFT
2343 LSH B,(C) ; SHIFT IT
2344 LDB C,[001100,,(A)] ; GET RIGHT SHIFT
2346 LSH B,(C) ; SHIFT RIGHT
2352 NTHRE: PUSHJ P,COMPER
2354 ; HERE TO EXTRACT LIST OR FIX
2356 NTHRLF: HLLZ A,(A) ; GET TYPE/LENGTH FROM TABLE
2357 LDB B,C ; GET VALUE BYTE
2358 LSH B,18. ; SHIFT OVER
2359 ILDB C,C ; GET NEXT 16 BITS
2360 IOR B,C ; THEN OR THEM TOGETHER
2363 ; HERE TO EXTRACT 2-WORD ITEM
2365 NTHRS3: HLLZ A,(A) ; GET TYPE/LENGTH FROM TABLE
2366 LDB 0,C ; LOAD FIRST 16 BITS
2367 ILDB B,C ; GET NEXT 16 BITS
2368 LSH B,18. ; SHIFT OVER
2369 ILDB C,C ; GET NEXT 16 BITS
2370 IOR B,C ; THEN OR THEM TOGETHER
2372 NTHRX: JUMPN B,CPOPJ
2376 ; HERE TO EXTRACT STRUC WITH KNOWN LENGTH ITEM
2378 NTHRS2: LDB B,C ; GET LENGTH WORD
2379 LSH B,18. ; SHIFT OVER
2380 ILDB C,C ; GET NEXT 16 BITS
2381 IOR B,C ; THEN OR THEM TOGETHER
2382 MOVE A,(A) ; GET TYPE WORD FROM TABLE
2383 ILDB C ; FIX POINTER (SHOULD BE IBP)
2386 ; HERE TO EXTRACT 4-WORD ITEM (ANY)
2388 NTHRA: LDB B,C ; GET TYPE WORD
2390 ILDB A,C ; GET LENGTH WORD
2391 IOR A,B ; PUT EM TOGETHER
2392 ILDB B,C ; LOAD FIRST 16 BITS
2393 LSH B,18. ; SHIFT OVER
2394 ILDB C,C ; GET NEXT 16 BITS
2395 IOR B,C ; THEN OR THEM TOGETHER
2398 NTHRHW: LDB B,C ; GET POSSIBLE TYPE CODE
2403 HLLZ A,(A) ; TYPE FROM TABLE
2406 PUTU: LDB A,[UPTBYT,,A]
2418 PUTUU: ADDI B,-1(O2)
2429 SKIPN A,RECTBL+1(A) ; AND POINTER TO TABLE
2431 PUSH TP,(D) ; SAVE VALUE
2433 LSH O2,1 ; 4 16-BIT WORDS / ENTRY
2434 ADDI A,-1(O2) ; POINT TO CORRECT ENTRY (REMEMBER TOP)
2435 HRRZ B,1(A) ; GET SIZE OF ITEM TO EXTRACT
2436 HLRZ C,1(A) ; WORD OFFSET TO START FROM
2438 XMOVEI E,-1(TP) ; SEND VALUE IN E
2441 ADJBP C,O1 ; MAKE BYTE POINTER TO ITEM
2442 PUSHJ P,@PUTRTB-1(B) ; DISPATCH
2446 PUTRTB: SETZ PUTRBB ; BOOLEAN
2447 SETZ PUTRE ; ERROR - SHOULDN'T HAPPEN
2448 SETZ PUTRBB ; ENUMERATION
2449 SETZ PUTRBB ; SUB-RANGE
2450 SETZ PUTRBB ; SUB-RANGE (SBOOL)
2451 SETZ PUTRLF ; LIST OR FIX
2452 SETZ PUTRLF ; LIST OR FIX (SBOOL)
2453 SETZ PUTRS3 ; STRUC IN 3 HALF WORDS
2454 SETZ PUTRS3 ; SAME WITH SBOOL
2455 SETZ PUTRS2 ; STRUC WITH DEFINED LENGTH
2456 SETZ PUTRS2 ; SAME SBOOL
2458 SETZ PUTRHW ; SPECIAL CASE FOR TYPE-C
2460 ; HERE TO SET A BOOLEAN
2462 PUTRBB: LDB 0,[111100,,(A)] ; GET LSHIFT
2463 LDB A,[001100,,(A)] ; GET RSHIFT
2466 LSH B,30. ; BUILD BYTE POINTER
2470 IOR 0,B ; HAVE LH OF BYTE POINTER
2475 HRRI 0,A ; POINT TO AC
2476 MOVE B,1(E) ; NEW VAL
2477 DPB B,0 ; SMASH REGISTER
2478 DPB A,C ; PUT IT BACK
2480 ADJBP B,C ; SMASH OTHER BYTE
2482 DPB A,B ; OTHER HALF BACK IN
2486 PUTRE: PUSHJ P,COMPER
2488 PUTRLF: LDB B,[LH,,1(E)] ; GET LH OF VALUE OF 3RD ARG
2490 LDB B,[RH,,1(E)] ; GET RH OF VALUE OF 3RD ARG
2491 IDPB B,C ; AND STUFF
2494 PUTRS2: HLRZ B,(E) ; TYPE OF ARG
2496 SETZM 1(E) ; MAKE SURE 0
2499 ; HERE FOR 3 WORD ITEM (IE LENGTH AND POINTER)
2501 PUTRS3: LDB B,[LENWRD,,(E)] ; GET LENGTH
2503 ILDB C ; FIX POINTER (SHOULD BE IBP)
2506 ; HERE TO SET 4-WORD ITEM (ANY)
2508 PUTRA: LDB B,[TYPWRD,,(E)] ; GET TYPE
2509 DPB B,C ; AND STUFF IT
2515 PUTRHW: LDB B,[TYPWRD,,(E)] ; TYPE OF ARG
2516 CAIE B,$TFALSE ; FALSE ==> ZERO SLOT
2517 SKIPA B,1(E) ; NOT FALSE USE TYPEC
2523 RESTU: LDB C,[UPTBYT,,A]
2553 ; HRLI A,$TTUPLE ; Win with tuples???
2573 TOPUS1: ADJBP C,B ; ADJUST TO THE END
2576 SUBI C,(D) ; # BYTES UNUSED IN LAST WORD
2577 TLZ B,770000 ; MAKE WORD POINTER
2578 HRRZ A,1(B) ; THIS IS TOTAL LENGTH (FROM DOPE)
2579 SUB B,A ; TO WORD ADDRESS OF STRING START
2582 TLO B,(D) ; MAKE CORRECT GLOBAL BP
2583 ADD A,C ; ADJUST LENGTH
2584 HLL A,0 ; MAKE A TYPE WORD
2587 TOPUU: ADD B,C ; POINT TO DOPE WORD
2588 HRRZ A,(B) ; GET TOTAL LENGTH
2589 SUB B,A ; BACK IT UP
2590 HRLI A,$TUVECTOR ; HERE'S THE TYPE WORD
2594 ADD B,C ; POINT TO DOPE WORD
2595 HRRZ A,(B) ; HERE IS TOTAL LENGTH
2596 SUB B,A ; POINTS TO TOP OF VECTOR
2597 LSH A,-1 ; GET LENGTH
2598 HRLI A,$TVECTOR ; AND FINISH TYPE WORD
2601 ; HERE FOR CONS NEEDING GC
2608 PUSH TP,E ; IN CASE A GC OCCURS
2620 SUBTTL INPUT / OUTPUT
2629 PUSHJ P,OPNAM ; MAKE FILE NAME STRING
2631 XCT GTJMOD(O1) ; PERFORM GTJFN BITS MAGIC
2636 XCT OPNMOD(O1) ; PERFORM OPENF BITS MAGIC
2639 MOVE B,$WFIX ; RETURN JFN NUMBER
2643 OPNAM: MOVE B,[440700,,FNBLK] ; BP TO FILE NAME BLOCK
2645 OPNAML: ILDB 0,E ; GET CHARACTER
2646 IDPB 0,B ; AND STUFF IT
2647 SOJN C,OPNAML ; LOOP UNTIL DONE
2649 IDPB 0,B ; MAKE IT ASCIZ
2652 GTJMOD: MOVSI A,(GJ%SHT+GJ%OLD)
2653 MOVSI A,(GJ%SHT+GJ%FOU)
2657 OPNMOD: HRRI B,OF%RD
2662 CLOSEX: CLOSF ; ATTEMPT TO CLOSE JFN
2664 MOVE A,$WFIX ; RETURNS 1 IF WINNING
2675 TDNN B,[770000,,003777]
2676 JRST ATIC ; TRY different char
2679 JUMPL O1,ATICDN ; If not a char, don't do ATI
2682 CAIN O1,7 ; store channel for ^G and ^A
2687 ATICDN: MOVE A,$WFIX
2691 RETERR: PUSH P,A ; SAVE ERROR CODE
2692 PUSHJ P,ICELL ; GET A LIST CELL
2693 MOVE B,$WFIX ; STUFF THE CELL WITH ERROR CODE
2698 MOVE A,$WFALSE ; AND RETURN AS FALSE
2702 MOVEI A,400000 ; GET ERROR
2705 PUSHJ P,RETERR ; CONS IT UP
2707 JRST CMPER2 ; GO GIVE IT TO USER
2709 ; Return run time of process, in seconds, as float
2725 MOVEM OP,.RDRTY+IRDBLK ; SET UP PROMPT
2727 PUSH TP,$WFALSE ; SAVE IF NO PROMPT
2730 READX1: MOVEI D,1 ; OTHERWISE, GET LENGTH, SAVE STRING
2734 READX2: HRLI D,$TSTRING
2736 PUSH TP,.RDRTY+IRDBLK
2737 READX4: MOVEI C,IRDBRK
2738 MOVEM C,.RDBRK+IRDBLK ; SETUP BREAK MASK
2744 MOVE C,[ARDBRK,,ARDBRK+1]
2747 MOVEM C,.RDBRK+IRDBLK
2748 SKIPA C,[4] ; Turn on ctrl-D
2757 READNM: MOVE C,-1(P)
2759 HRLM A,.RDIOJ+IRDBLK ; INPUT JFN
2760 MOVEM B,.RDBFP+IRDBLK ; DESTINATION BUFFER POINTER
2761 MOVEM B,.RDBKL+IRDBLK ; BACKUP LIMIT
2762 SUB C,D ; GET LENGTH OF STRING
2763 MOVEM C,.RDDBC+IRDBLK ; AND SUBTRACT CHRS ALREADY READ
2764 ADJBP D,B ; ADJUST STRING FOR CHRS ALREADY READ
2765 MOVEM D,.RDDBP+IRDBLK ; DESTINATION STRING
2769 HRRM C,.RDIOJ+IRDBLK
2771 PUSH TP,IRDBLK+.RDIOJ
2772 MOVE C,-1(P) ; STRING LENGTH
2775 PUSH TP,IRDBLK+.RDBFP
2776 MOVE C,IRDBLK+.RDBRK
2785 ADJSP P,-2 ; NOW NOTHING ON P STACK
2786 BRESTA: MOVEI A,IRDBLK
2789 ; This now has a giant kludge to make ctrl-D redisplay the buffer without
2790 ; clearing the screen.
2791 LDB B,.RDDBP+IRDBLK ; Look at last character read
2794 HRRZ A,.RDIOJ+IRDBLK ; Yes, pick up output jfn to use
2795 MOVEI B,^M ; do crlf
2799 SKIPN B,.RDRTY+IRDBLK
2802 SOUT ; Output prompt
2803 NOPRMP: MOVE B,.RDBFP+IRDBLK ; pick up pointer to buffer beginning
2804 HRRZ C,-11(TP) ; ORIGINAL LENGTH OF BUFFER
2805 AOS .RDDBC+IRDBLK ; ADD 1 TO CHARS AVAILABLE
2806 SUB C,.RDDBC+IRDBLK ; REAL NUMBER CHARS IN BUFFER
2807 MOVNS C ; - # CHARS IN BUFFER
2808 SKIPE C ; don't print if none there
2810 MOVEM B,.RDDBP+IRDBLK ; update dest string pointer
2812 JRST BRESTA ; try again
2814 DTEXTI: CAIE B,^M ; FUNNINESS IF ^M AS TERMINAL
2816 HLRZ A,.RDIOJ+IRDBLK ; PICK UP INPUT JFN
2820 DTEXT1: BIN ; READ & DUMP THE CHARACTER
2821 DTEXT2: HRRZ B,-11(TP) ; GET ORIGINAL LENGTH
2822 SUB B,.RDDBC+IRDBLK ; FIXUP COUNT
2824 ADJSP TP,-20 ; EIGHT THINGS PUSHED ON STACK
2827 ; JFN IN A, TABLE IN B, LENGTH IN C
2828 RFTADX: PUSH TP,$WFIX
2832 HLRZ D,P ; Make sure it's really the same
2839 ERJMP RFTADF ; Return false
2848 RFTADF: MOVSI A,$TFALSE
2854 SOUTX: SKIPA O1,[SOUT]
2859 PUSH P,D ; Save these guys in case of retry
2860 PUSH P,B ; Byte pointer
2868 MOVEI O2,0 ; INDICATE FAILURE (never happens)
2876 PUSH P,0 ; SAVE TYPE OF FROB
2882 JUMP 16,[ MOVEI O2,0 ; Error case
2886 LDB E,[360600,,B] ; GET BYTE PART
2887 LDB A,[360600,,-1(P)] ; OF BOTH
2889 MOVE C,B ; COPY POINTER
2890 TLZ C,770000 ; JUST WORD POINTER
2891 POP P,A ; GET ORIGINAL COUNT WORD
2892 POP P,D ; AND ORIG PNTR
2899 SINXX1: ADD C,E ; C has actual # of characters xfered
2900 SUBI A,(C) ; AND FIX IT
2901 SINXXX: SKIPN O2 ; skip if not error
2902 JRST SINLSR ; go handle error
2903 ADJSP P,-2 ; flush saved c and d
2906 SINLSR: PUSH TP,A ; save rested string
2908 MOVEI A,400000 ; GET ERROR
2910 MOVEI A,(B) ; ERROR TO A
2911 CAIN A,IOX4 ; IS THIS EOF
2912 JRST [ POP TP,B ; yes just return rested string
2914 ADJSP P,-2 ; flush saved args
2916 CAIE A,IOX11 ; Quota exceeded
2917 CAIN A,IOX34 ; Disk full
2918 JRST SINFUL ; Handle this case
2919 PUSH TP,$WFIX ; save SIN/SOUT and JFN
2924 PUSH TP,0 ;relativized ret PC
2927 PUSHJ P,RETERR ; cons up error code
2930 PUSHJ P,ICELL ; include buffer in false
2936 SKIPN O1,ECATM ; call error-in compiled code handler
2943 MOVE PC,(TP) ; returned from error, try i/o again
2946 MOVE O1,-2(TP) ; unrelativized PC to stack
2947 DMOVE A,-5(TP) ; buffer back
2956 SINFUL: MOVEI A,.FHSLF
2957 MOVE B,[<SETZ_<0-.ICQTA>>]
2958 IIC ; Cause fatal interrupt
2959 POP P,D ; Restore terminating char
2961 POP P,C ; # chars to transfer
2962 SKIPL C ; Set up for update
2964 ADD C,B ; Actual # to transfer
2966 POP TP,0 ; Count word
2967 HLRZ A,O1 ; restore JFN
2968 JRST SOUTX ; Try again
2970 GTJFNX: TLNN A,(GJ%FNS) ; STRING ARG?
2972 PUSHJ P,OPNAM ; FORCE ASCIZ IN THIS SECTION
2981 JFNSX: CAIGE A,177 ; SKIP IF JFNSing to a string
2982 JUMPGE A,[ JFNS ; DO IT
2990 JUMP 16,JFSERR ; LOSE...
2993 MOVE C,[440700,,FNBLK]
2998 IDPB 0,E ; MOVE CHARS
2999 CAMN C,A ; ARE WE DONE
3003 MOVNS B ; RETURN NEGATIVE LENGTH
3004 JFNSM: MOVSI A,$TFIX
3007 JFSERR: MOVEI A,400000 ; GET ERROR
3009 MOVEI A,(B) ; ERROR TO A
3012 ERSTRX: CAIG A,177 ; SKIP IF TO STRING
3019 MOVE O2,A ; SAVE ORG STR PNTR
3024 LDB B,[360600,,A] ; GET BYTE PART
3039 ; do long form GTJFN
3041 GTJFNL: MOVNI A,(O1) ; FIND BASE OF ARGS
3043 MOVE O2,TP ; COPY STACK POINTER
3044 ADJSP O2,(A) ; POINT TO FIRS ARG
3045 MOVE B,[440700,,FNBLK] ; FOR COPIED STRINGS
3046 MOVEI A,GTJFBK ; POINT TO ARG BLOCK
3050 GTJFLP: HLRZ 0,1(O2)
3051 CAIE 0,$TSTRING ; STRING
3052 JRST [ MOVE 0,2(O2) ; NO GET FIX
3053 MOVEM 0,(A) ; INTO BLOCK
3056 HRRZ C,1(O2) ; STRING LENGTH
3059 MOVEM B,(A) ; STORE BYTE POINTER
3060 MOVE E,2(O2) ; STR PNTR
3061 PUSHJ P,OPNAML ; FORCE ASCIZ IN THIS SECTION
3062 GTJFNA: ADJSP O2,2 ; NEXT ARG
3069 GTJFN ; DO THE GTJFN
3070 JUMP 16,GTERR ; ERROR
3079 MOVE D,.GJCPP+.GJCPP+4(TP)
3080 HRRZ C,.GJCPP+.GJCPP+3(TP)
3092 RD%JFN ; JFNS COMING
3093 .PRIOU ; FOR EDITING
3094 0 ; DESTINATION STRING
3098 IRDBRK ; FOR FUTURE EXPANSION
3101 IRDBRK: 20000,,400 ; BREAK ON CONTROL-D
3105 ARDBRK: BLOCK 4 ; ALTERNATE BREAK MASK FOR READ
3116 SUBTTL LVAL MANIPULATION
3118 ;ILVAL RECEIVES ATOM IN IN O1
3120 ILVAL: SKIPN O2,1(O1) ;SEE IF BINDING
3122 MOVE 0,7(O2) ; GET BINDID
3123 CAME 0,BINDID ; SKIP IF OK
3125 DMOVE A,(O2) ; GET VALUE
3126 JUMPN A,(PC) ; RETURN IF BOUND
3128 JSP PC,FRAME ; Have binding with no value
3129 PUSH TP,[$TATOM,,$LATOM] ; So strictly error case of EICC
3132 MOVE O1,ECATM ; ERROR IN COMPILED CRUFT...
3136 ILVAL1: MOVE A,PC ; SAVE PC
3137 JSP PC,IASS ; SEE IF ASSIGNED AT ALL
3138 MOVEI O2,0 ; IF NOT , SO INDICATE
3140 JUMPE O2,ILVAL2 ; GENERATE ERROR
3144 ;IASS -- ASSIGNED? O1 IS ATOM, SKIP IF ASSIGNED?
3146 IASS: SKIPN O2,1(O1) ; BINDING PNTR?
3147 JRST (PC) ; NO, NO SKIP
3148 MOVE 0,7(O2) ; BIND ID?
3149 CAME 0,BINDID ; SKIP IF NO SEARCH
3151 IASS4: SKIPE (O2) ; BOUND?
3155 IASS1: MOVE O2,SP ; SEARCH
3156 IASS2: CAMN O1,2(O2) ; SKIP IF NOT IT
3157 JRST IASS4 ; CHECK VALUE OK
3158 SKIPE O2,5(O2) ; NEXT BINDING
3160 MOVE O2,TTBIND ; SAME THING FOR TOP BINDING
3161 IASS3: CAMN O1,2(O2)
3167 ;ISET -- RECEIVES ATOM IN O1 , NEW VAL IN A,B
3169 ISET: SKIPN O2,1(O1) ;SEE IF BINDING
3171 MOVE 0,7(O2) ; GET BINDID
3172 CAME 0,BINDID ; SKIP IF OK
3174 DMOVEM A,(O2) ; SET VALUE
3179 PUSH TP,[$TATOM,,$LATOM]
3184 MOVE O1,ECATM ; ERROR IN COMPILED CRUFT...
3188 ;MOVSTR - O1 FROM, O2 TO, O #CHARS
3190 MOVSTR: SKIPG C,0 ; make sure something to move
3191 JRST (PC) ; ret immediately
3192 MOVE A,O1 ; compute word addrs of strs
3195 ADJBP C,A ;C is end of from
3196 ADJBP E,D ;E is end of to
3197 TLZ O1,770000 ; clear byte pntr part, O1 start of from
3198 TLZ O2,770000 ; O2 start of to
3201 CAMG O1,E ; skip if start from is grtr than end to
3202 CAMLE O2,C ; dont skip if start of to is grt end from
3203 JRST NOOVER ; jump to use movestr instruction
3205 CAMN O1,O2 ; same word, check bp
3210 JRST MOVBAK ; must go backwards
3220 ADJBP O1,A ; point to last byte in both
3223 MOVBK1: LDB C,O1 ; move a byte
3225 ADJBP1: MOVNI A,1 ; now tediously backup the 2 bps
3227 TLNE A,770000 ; check for micro code bug
3234 TLNE A,770000 ; check for micro code bug
3242 ; here if strings dont overlap 0 & A & C are setup ok
3244 MOVSLJ==123000,,[016000,,]
3247 SETZB B,E ; superstition
3253 SUBTTL GARBAGE COLLECTION UTILITIES
3255 MARKR: CAMG B,[INIGC,,] ; DON'T MARK STACK OBJECTS
3259 ADD B,D ; MOVE TO DOPE WORD
3262 MARKU: LDB D,[UPTBYT,,A]
3282 MRKUX: MOVSI D,200000
3283 JUMPE C,[ANDCAM D,(B)
3286 MOVEM C,1(B) ; STORE RELOCATION
3296 ; HERE FOR MARK PREDICATE
3298 MKL: JUMPE B,[MOVEI B,1
3300 LDB B,[MARKBIT,,1(B)]
3301 JUMPE B,IMKL1 ; JUMP IF NOT MARKED
3302 MOVE B,(B) ; RETURN RELOCATION
3309 MKR: CAMG B,[INIGC,,] ; SAY IT'S MARKED IF ITS ON THE STACK
3313 ADD B,D ; MOVE TO DOPE WORD
3314 LDB B,[MARKBIT,,(B)] ; MUNG IT
3316 MOVE B,1(B) ; RELOCATED WITH OLD TYPE
3317 SUBI D,1(D) ; BACK TO TOP
3323 MKU: LDB C,[UPTBYT,,A]
3331 MKUS: ANDI A,-1 ; GET TO DW
3334 LDB B,[MARKBIT,,1(A)]
3348 LDB B,[MARKBIT,,(B)]
3356 ; SWEEP PHASE INSTRUCTIONS
3358 ; SWEEPNEXT - GIVEN IN O1 A POINTER TO GC SPACE, IN A A POINTER TO
3360 ; RETURNS A POINTER TO THE NEXT FROB IN GC SPACE
3372 MOVE A,-2(B) ; GET THE DOPE WORD
3373 TLZE A,$DOPEBIT ; IS THE DOPE BIT SET?
3374 JRST ISWVR ; YES. EITHER A UBLOCK OR RECORD
3375 SUBI B,3 ; NEXT FROB IS THREE BACK
3379 ISWVR: HRRZ D,A ; GET LENGTH
3380 SUBI B,2(D) ; FIND THE NEXT ONE
3381 LDB E,[PTPBYT,,A] ; GET THE TYPE WORD
3383 JRST [ADDI A,(A) ; RECORD DOPE WORD IS FULL WORDS (SIGH)
3385 CAIN E,$PVECTOR ; VECTOR DOPE WORD HAS TWICE LENGTH (SIGH)
3394 ; The byte pointers returned here are NOT standard--they are
3395 ; 440700,,x rather than 010700,,x-1. This works because everyone
3396 ; deals with them the adjbp and such; it avoids confusion in the
3397 ; sweep phase due to the x-1.
3398 ISWVRS: TLO B,610000 ; FIXUP STRING POINTER
3399 IMULI D,5 ; AND TYPE WORD
3400 HRR A,D ; SIGH. THIS SEEMS KLUDGY...
3402 ISWVRB: TLO B,540000
3408 XMOVEI C,-GCPOFF+IGCPR
3410 MOVE 0,RCLOFF(C) ; GET FREE LIST POINTER
3411 MOVEM 0,(B) ; CHAIN FREE LIST
3412 MOVEM B,RCLOFF(C) ; UPDATE FREE LIST POINTER
3424 RELU: LDB C,[UPTBYT,,A] ; GET THE PRIMTYPE
3425 JSP E,@RELUTB(C) ; POINT D AT THE DOPE WORDS
3426 JSP OP,RELB ; RECYCLE THE BLOCK OF STORAGE
3427 JRST (PC) ; DON'T WORK EITHER
3436 RELUS: HRRZ C,A ; GETLENGTH
3437 RELUSX: ADJBP C,B ; ADJUST TO THE END
3440 ADDI D,2 ; POINT TO SECOND DOPE WORD
3443 RELUU: HRRZ C,A ; GET LENGTH
3444 RELUX: MOVE D,B ; POINT TO UVECTOR
3445 ADDI D,1(C) ; POINT TO SECOND DOPE WORD
3448 RELUV: HRRZ C,A ; GET LENGTH
3449 LSH C,1 ; TIMES TWO FOR GOOD LUCK
3450 JRST RELUX ; REJOIN CODE
3453 ; set the current free storage zone (arg in A and B)
3454 ; if passed 0, return current, if current is zero, return gc params
3456 SETZON: JUMPN B,SETZN1 ; set it
3457 SKIPE B,CZONE ; get current if any
3458 JRST [MOVE A,[$TZONE,,7]
3462 MOVE A,[$TUVEC,,GCPL]
3466 ; SETZM INGC ; THIS TENDS TO HAPPEN AFTER A GC
3468 JRST [ HRROI A,[ASCIZ /OK int soon/]
3473 MOVEM B,@[MIMSEC,,CZONE]
3474 MOVEM B,@[MIMSEC+1,,CZONE]
3475 MOVE B,SECL(B) ; FIRST AREA
3476 MOVE B,@2(B) ; BOUND OF AREA
3477 TLNN B,1 ; ODD/EVEN CHECK
3484 STZSE2: HRLI TP,ODDSEC
3495 ; HERE IS THE BLOCK STORAGE RECYCLER
3496 ; D POINTS TO THE SECOND DOPE WORD OF THE FROB BEING RECYCLED
3498 ; RCL IS A LIST OF FREE CELLS
3505 RCLTB: PUSHJ P,COMPER ; ZERO LENGTH?
3506 PUSHJ P,COMPER ; ONE LENGTH?
3517 RELB: HRRZ E,-1(D) ; FIRST GET BLOCK LENGTH
3520 JRST RELB1 ; JUST DOPE WORDS
3522 SUBI B,-2(E) ; ZERO EVERYTHING EXCEPT DOPE WORDS
3527 RELB1: SKIPN B,CZONE
3528 XMOVEI B,-GCPOFF+IGCPR
3538 SKIPN A,(B) ; GET THE POINTER TO THE CHAIN
3543 MOVE A,B ; START FROM RCLV
3545 RECBL: MOVE B,(A) ; GET POINTER TO NEXT FREE BLOCK
3546 CAML B,D ; DOES IT GO HERE?
3547 JRST RECIN ; YES. INSERT IT
3549 MOVE A,B ; GO ON TO NEXT FREE BLOCK
3552 RECIN: CAMN B,D ; Don't skip if block already there
3554 HRROI A,[ASCIZ /Recycled block already on chain
3559 JRST (OP)] ; Can be continued...
3562 MOVE C,D ; GET POINTER TO OUR BLOCK
3563 SUB C,E ; BACK OFF TO THE TOP
3564 CAMN C,A ; DOES IT TOUCH PREVIOUS BLOCK?
3565 JFCL ; THIS GETS HAIRY. MORE CODE TO FOLLOW
3566 SKIPN C,B ; GET CDR FOR THIS BLOCK
3568 HRRZ 0,-1(B) ; GET ITS LENGTH+2
3570 SUB C,0 ; SUBTRACT OFF THE BLOCK
3571 CAMN C,D ; DO WE TOUCH ON THE BOTTOM?
3572 JRST [ADDM E,-1(B) ; YES. SIMPLY UPDATE LENGTH
3574 RECIN1: MOVEM B,(D) ; CHAIN THE NEW BLOCK IN
3576 MOVEI B,$TUVECTOR+$DOPEBIT
3577 HRLM B,-1(D) ; MAKE SURE THIS IS A UV
3581 SUBTTL CORE ALLOCATION
3583 ICELL: JSP OP,ICELL1 ; Get a cell
3586 MOVEI A,3 ; Need 3 words
3587 JSP PC,IBLOCK ; IBLOCK looks at other chains, then GCs
3590 ; HERE TO THE GARBAGE COLLECTOR FOR THE CURRENT ZONE
3595 SKIPN A,CZONE ; MUST HAVE A ZONE
3605 XMOVEI B,-GCPOFF+IGCPR
3607 XMOVEI B,RCLVOF(A) ; DEFAULT RCL CHAIN
3608 MOVE 0,GCFLGO(A) ; IF NO DWS, FUDGE HERE
3611 ; TLNE 0,$GC%PB ; ONLY EVEN # OF PAGES?
3616 XCT RCLTB(E) ; GET POINTER TO CORRECT RCL CHAIN
3617 SKIPE (B) ; DON'T BOTHER IF NOTHING'S ON THE CHAIN
3618 JRST IBLOLD ; Got something there
3619 XMOVEI B,RCLVOF(A) ; Check general chain
3620 SKIPN (B) ; Skip if something there
3621 JRST IBLNEW ; OLD STYLE BLOCK ALLOCATOR
3623 CAIE 0,RCLVOF(A) ; Skip if allocating from general chain
3624 JRST IBLFIX ; FIXED SIZE OBJECT
3625 MOVE D,B ; SETUP BACK POINTER
3626 MOVE B,(B) ; GET THE RECYCLE CHAIN ITSELF
3627 IBLCL: HRRZ C,-1(B) ; HOW MUCH STUFF HERE
3628 ADDI C,2 ; PLUS DOPE WORDS
3629 CAMN C,E ; IS THIS AN EXACT MATCH?
3630 JRST IBLC1 ; YES. DO THE RIGHT THING
3632 CAIL E,-2(C) ; CAN IT BE BROKEN UP
3633 JRST IBLC2 ; NO, KEEP LOOKING
3635 SUBI C,2(E) ; C ==> LENGTH OF REMAINDER
3636 HRRM C,-1(B) ; STORE IT
3637 CAILE C,10. ; SKIP IF MUST PUT IT ON OTHER CHAIN
3639 MOVE 0,(B) ; SPLICE IT OUT
3641 SETZM (B) ; FLUSH OLD POINTER
3648 JSP OP,RELB ; CALL BLOCK RECYCLER
3655 IBLC3: SUBI B,2(C) ; NEW DW
3657 HRRZM E,-1(B) ; DW LENGTH
3659 MOVE 0,GCFLGO(A) ; GET FLAGS
3660 MOVE A,B ; PNTR TO A
3661 SUBI A,1(E) ; POINT TO TOP
3662 IBLRET: TLNE 0,$GC%PB ; REQUIRE PAGE BOUNDARY?
3664 JRST (PC) ; NO RETURN
3667 IBLC2: MOVE D,B ; GET NEW BACK POINTER
3668 SKIPN B,(B) ; GET NEXT ENTRY
3669 JRST IBLNEW ; END OF CHAIN
3670 JRST IBLCL ; LOOP WITH NEW BLOCK
3672 IBLC1: MOVE (B) ; FOUND AN EXACT MATCH
3673 MOVEM (D) ; UPDATE CHAIN POINTER
3674 SETZM (B) ; CLEAR CHAIN POINTER
3675 MOVE 0,GCFLGO(A) ; FLAGS
3677 SUBI A,-1(C) ; SUBTRACT OFF TO GET TO TOP
3682 IBLNEW: MOVE 0,GCSBOF(A)
3691 MOVE A,E ; # WORDS NEEDED
3695 JRST IBLOCK ] ; WILL GC
3696 MOVE A,GCFLGO(A) ; RET FLAGS IN 0
3700 IBLFIX: MOVE 0,GCFLGO(A)
3712 SUBTTL KNOWN RECORD TYPE TABLES
3731 $TFIX,,<<0._9.>\18.>
3733 $TFIX,,<<18._9.>\18.>
3737 $TFIX,,<<0._9.>\18.>
3739 $TBIND,,<<18._9.>\18.>
3766 QFTBL==. ; will build tabel later
3774 SUBTTL ERROR ROUTINES & UTILITIES
3777 CMPER2: SKIPE O1,ECATM
3779 CMPERX: HRROI A,[ASCIZ /Error in Compiled Code
3789 CMPER3: JSP PC,CALLZ
3795 SUBTTL DEBUGGING UTILITIES
3797 ; CALL TO SAVE FROM THE INTERPRETER
3799 ; B/ 0 or pointer-to-pure-zone
3800 ; C/ 0 or pointer-to-frozen-atom-zone
3802 SAVEX: MOVEM A,INTSAV'
3804 MOVEM C,ATMZON ; SAVE ZONES IN CASE NEED TO RE-SAVE
3806 CLOSF ; LIKE RESTORE, FILE SHOULDN'T BE OPEN...
3808 MOVE E,(P) ; GET RETURN PC
3822 SKIPE INTSAV ; DIFFERENT STARTING ADDRESS FOR .SAVE
3831 HRROI A,[ASCIZ /Output name: /]
3833 MOVE A,[GJ%FOU+GJ%SHT+GJ%NEW+GJ%FNS]
3837 SAV2: ; Special save for multi sect
3838 ; Here to write out multi-sect file
3841 ; FORMAT of extended page map for file
3843 ; even words: -count,,flags
3844 ; odd words: starting job page number
3846 MOVEI 0,SVMAP+6 ; SET UP MAP
3848 SKIPE O1,CZONE ; zones set up?
3849 JRST ZND1 ; yes, do it for them
3851 MOVE O1,GCSBOT ; get bounds
3857 ZND1: MOVE B,SAVAC+2 ; restore possible pure zone
3858 MOVE C,SAVAC+3 ; and atom zone
3859 SKIPN INTSAV ; skip if from user
3860 SETZB B,C ; otherwise, no pure or atom zones
3863 ZND6: PUSH P,SECL(O1) ; list of section bounds
3868 ZND2: SKIPE E,-2(P) ; any more bounds
3871 SKIPN O1,-3(P) ; atom zone?
3873 SETZM -3(P) ; dont look again
3874 ADJSP P,-3 ; remove old zone
3877 ZND5: SKIPN O1,-4(P)
3883 ZND4: MOVE O1,2(E) ; pointer to UVEC
3884 MOVE 0,3(O1) ; areas flags
3885 MOVE O2,1(O1) ; bounds of gcspace
3886 CAMN O2,(P) ; current zone?
3887 JRST [ MOVE O2,-1(P)
3893 PUSHJ P,PMSEC ; write it out
3899 ; SUBI B,777 ; dividing neg number by shift, so
3902 HRRI B,SS%RD+SS%CPY+SS%EXE+SS%EPN
3903 TRNE 0,2 ; skip if not read-only
3904 HRRI B,SS%RD+SS%EXE+SS%EPN
3915 ZND3A: MOVEI B,STRTTP-777 ; compute pages of stack
3918 HRRI B,SS%RD+SS%CPY+SS%EXE+SS%EPN
3921 MOVEI B,<TPSEC_9.>+<STRTTP_-9.> ; add in core page for stack
3925 ; now write out the actual cruft
3933 JRST [ HALTF ; give chance to save symbols
3938 SAVLOS: SKIPN INTSAV
3939 JRST [HRROI A,[ASCIZ /?/]
3951 PUSHJ P,RETERR ; return a false with error code
3956 IFN <MIMSEC-TPSEC>,[
3958 MOVE B,[.FHSLF,,MIMSEC] ; create brand new section
3959 MOVE C,[PM%CNT+PM%RD+PM%EX+PM%WR+1] ; bits for mapping
3967 MOVSI C,(PM%RD+PM%WR+PM%EX)
3973 MOVSI C,(PM%RD+PM%WR+PM%EX)
3976 ADDI B,<<MIMSEC+1>_9.>
3980 CAME D,[.FHSLF,,1000]
3983 MOVE A,[.FHSLF,,<<TPSEC_9>+<STRTTP_<-9>>>]
3986 MOVSI C,(PM%RD+PM%WR+PM%EX+PM%CNT)
3987 HRRI C,1000-<STRTTP_<-9>>
3990 RSTTPD: MOVE 0,CURSIZ
3992 ; MOVEI 0,<<NUMSEC+INIGC>_<-1>>
3993 MOVE A,[.FHSLF,,1000]
3994 IFN FLIP,MOVE B,[.FHSLF,,3000]
3995 IFE FLIP,MOVE B,[.FHSLF,,2000]
3996 MOVSI C,(PM%RD+PM%WR+PM%EX)
4019 MOVEI B,2 ; CODE FOR SETUP OF UUO TABLE
4020 MOVE C,[MIMSEC,,MLTUUP]
4025 MOVES <<TPENDP-TPWARN>_9>(A)
4028 MOVES <<TPENDP-TPWARN>_9>(A)
4057 ; RESTORE CALLED FROM MUM
4058 ; TAKES JFN IN ACCUMULATOR A
4062 MOVE B,[.FHSLF,,TPWARN]
4063 MOVE C,[PM%CNT\<<TPENDP-TPWARN>+1>] ; unmap end-of-stack warning
4066 MOVE B,[.FHSLF,,<TPWARN+1000>]
4067 MOVE C,[PM%CNT\<<TPENDP-TPWARN>+1>]
4071 MOVE B,[SETZ INIGC] ; FLUSH MANY SECTIONS
4073 SMAP% ; FLUSH LOTS OF STUFF
4074 MOVE A,D ; RESTORE CHANNEL
4075 SETOM INTSAV ; CALLED FROM MUM
4076 TLO A,400000 ; KEEP THE JFN
4077 CLOSF ; FOR REASONS KNOWN ONLY TO GOD, AND
4078 HALTF ; I EVEN DOUBT THAT, THE FILE CAN'T
4079 HRLI A,.FHSLF ; BE OPEN WHEN A GET IS DONE. SIGH.
4081 MOVE D,[MOVEI A,.FHSLF]
4086 ; Take fix or false in A/B. If false, return first GC sec,,# GC secs;
4092 SETSZD: MOVSI A,$TFIX
4097 SETSZ1: MOVEM B,CURSIZ
4103 HRROI A,[ASCIZ /Fatal error--/]
4126 HRROI A,[ASCIZ / (/]
4137 HRROI A,[ASCIZ /.) [/]
4139 MOVE C,O2 ; # OF ARGUMENTS
4142 SUBM TP,C ; POINT THERE
4195 SVMAP: -ENDPG,,SS%CPY+SS%RD+SS%EXE+SS%EPN
4197 -1,,SS%CPY+SS%RD+SS%EXE+SS%EPN
4199 -1,,SS%CPY+SS%RD+SS%EXE+SS%EPN
4205 SUBTTL INTERRUPT HANDLER
4211 CHNTAB: REPEAT 36.,[ 2,,CHNS+<.RPCNT*2>
4214 CHNS: REPEAT 36.,[ PUSH P,[.RPCNT]
4221 CAIN A,PWRIT ; have we touched "magic" page
4227 MOVE C,@[MIMSEC,,INTFLG]
4229 IORM B,@[MIMSEC,,INTFLG]
4230 IORM B,@[MIMSEC+1,,INTFLG]
4232 IFE FLIP, IORM B,INTFLG
4244 HRROI A,[ASCIZ /GCing--please wait../]
4248 AOS C,CTLGS ; how many successive ^G or ^As
4249 CAIGE C,3 ; if more than 5, int anyway
4252 HRROI A,[ASCIZ /Forced interrupt, here's hoping...
4267 ; Come here when interrupts enabled
4269 TLNN A,10000 ; Test for user mode
4273 CHNS4: EXCH A,@LEVTAB+1
4274 CHNS41: PUSH TP,[$TUVEC+$FRMDO,,13.]
4282 PUSH TP,D ; Save ACs for system call
4290 PUSH TP,[$TUVEC+$FRMDO,,13.]
4291 SUBM R,-1(TP) ; Save rel PC
4294 DEBRK ; Leave int level, go to rest of handler
4295 CHNS5: PUSHJ P,RINTGO ; Process interrupts
4296 SUBM R,-1(TP) ; Get real PC back
4297 SOS A,-1(TP) ; Back it up
4299 LDB B,[331100,,(A)] ; Get opcode
4300 SKIPN -12.(TP) ; skip if from JSYS
4302 CAIE B,104 ; Not JSYS; assume XCT 0
4309 MOVEI B,IOX4 ; Return with error code
4312 MOVE A,(A) ; Get ERJMP instruction
4315 XMOVEI A,@A ; Get address of error routine
4317 MOVE 0,-15(TP) ; saved CZONE
4318 CAME 0,CZONE ; no, change -- no GC
4320 CAIA ; here if either no GC, or doesn't matter
4321 JRST [ HRROI A,[ASCIZ /GC has occurred, you may lose..
4337 SETOM RUNINT ; Re-enable interrupts
4339 POPJ P, ; Back into code
4341 CHNS1: MOVEI B,CHNS2
4342 HRRM B,PCLEV2 ; Go back to section originally in
4345 ; come here when interrupt out of TEXTI. Everything needed for TEXTI
4346 ; except .rddbp and .rddbc is on tp; those two can be computed.
4347 CHNS2: PUSH TP,$WFIX
4348 PUSH TP,IRDBLK+.RDDBC ; SAVE BYTE COUNT
4349 PUSHJ P,RINTGO ; HACK INTERRUPTS
4350 MOVE A,-20(TP) ; PROMPT
4351 MOVEM A,IRDBLK+.RDRTY
4362 MOVEM B,3(A) ; GET BREAKS SET UP
4363 MOVEM A,IRDBLK+.RDBRK ; Restore right word
4364 MOVE A,-14(TP) ; JFN WORD
4365 MOVEM A,IRDBLK+.RDIOJ
4366 MOVE A,-12(TP) ; ORIGINAL STRING
4367 MOVEM A,IRDBLK+.RDBFP
4368 MOVEM A,IRDBLK+.RDBKL
4370 SUB B,(TP) ; # CHARS USED
4371 ADJBP B,A ; POINT TO EMPTY PAART
4372 MOVEM B,IRDBLK+.RDDBP
4374 MOVEM B,IRDBLK+.RDDBC ; SPACE REMAINING
4376 JRST BRESTA ; FALL BACKK INTO TEXTI
4380 INTGOC: SKIPE INGC ; DONT INTERRUPT POOR GC
4391 PUSH TP,@[MIMSEC,,NARGS]
4393 PUSH TP,@[MIMSEC+1,,NARGS]
4401 POP TP,@[MIMSEC+1,,NARGS]
4403 POP TP,@[MIMSEC,,NARGS]
4418 RINTGO: PUSH TP,$WFIX
4432 ANDCAM C,@[MIMSEC,,INTFLG]
4433 ANDCAM C,@[MIMSEC+1,,INTFLG]
4435 IFE FLIP, ANDCAM C,INTFLG ; AND CLEAR IT
4444 INTINI: MOVE A,[-36.,,CHNTAB]
4446 LSH 0,12. ; move level over
4447 IORI 0,MIMSEC ; cause it to run int MIM
4452 HRLM 0,LEVTAB ; also mung LEVTAB
4465 PWRIT==17. ; Bit for page write int
4466 INFINT==19. ; bit for inferior interrupt
4468 MOVSI B,(<SETZ>_<-PWRIT>)
4469 TRO B,<SETZ>_<-INFINT>
4470 AIC ; Activate the int
4473 ;Here to see if illegal page access is really stack overflow
4475 STKCHK: XMOVEI B,1(TP) ; lets see which page
4476 LSH B,-9 ; to page number
4478 CAIN B,TPWARN ; warning page?
4479 JRST [MOVSI A,(SETZ)
4481 MOVSI B,(PA%RD+PA%EX+PA%WT)
4485 MOVE A,[JRST @PNTSTK]
4487 MOVEM A,@[MIMSEC+1,,STKMNG]
4490 HRROI A,[ASCIZ /Fatal error: stack overflow
4495 STKLOS: HRROI A,[ASCIZ /Fatal error: illegal memory access
4499 XMOVEI B,HALTX ; Fall into HALTX when leave handler
4500 MOVE A,PCLEV2 ; PC where lossage happened
4501 MOVEM B,PCLEV2 ; Store new return PC
4502 EXCH A,-1(P) ; Leave losing PC on stack
4504 DEBRK ; Return from interrupt, so loser who
4505 ; reenters has interrupts
4508 IFE FLIP&0,[ MOVE 0,[JRST @D]]
4509 IFN FLIP&0,[ MOVE 0,[TLNN M,1]]
4511 MOVEM 0,@[MIMSEC+1,,STKMNG]
4512 MOVE 0,[JRST @PNTRET] ; CHANGE INS IN RETURN
4514 MOVEM 0,@[MIMSEC+1,,RET3]
4520 SUBTTL DEBUGGING UUOS
4530 IRPS X,,[FRM DP DC TON TOFF EX GVERR MADJBP]
4537 MLTUOP: PUSH P,MLTUUP
4543 ; Here if in multi-section mode but running a section 0 uuo
4545 EXCH 0,(P) ;GET PC AND SAVE 0
4562 MOVEM UUOD' ; CONTENTS OF EFF ADR
4563 MOVE B,UUOE ; EFF ADR
4564 LDB A,[050400,,MLTUUP] ; GET UUO AC,
4565 LDB C,[110400,,MLTUUP] ; AND OPCODE
4568 UUODS1: LDB A,[270400,,40] ; GET UUO AC,
4569 LDB C,[330600,,40] ; OP CODE
4570 UUODSP: CAIL C,UUOMAX
4571 MOVEI C,0 ; GRT=>ILLEGAL
4572 JRST @UUOTAB(C) ; GO TO PROPER ROUT
4577 POP P,A ; RESTORE AC'S
4585 ; KLUDGE TO DO ADJBP GIVEN MICROCODE BUG
4587 CAILE A,D ; CHECK AC ARG
4588 JRST ADJB2 ; Not pushed, so continue
4589 SUBI A,D ; Make A point to stack slot
4591 ADJB2: MOVE C,(A) ; PICK UP AC
4592 IBP C,UUOD ; Do the IBP
4593 TLNE C,770000 ; Skip if lost
4596 JRST ADJB2 ; And try again
4597 ADJBO: MOVEM C,(A) ; Won, stuff bp out
4598 JRST UUORET ; And return
4600 UGVERR: SUBM R,-5(P) ; RELATIVE RETURN PC
4605 CAIGE B,20 ; IF EA IS REGISTER, HACK IT
4606 JRST [ PUSH TP,[$TGVAL,,$LATOM]
4613 MOVE 0,-1(B) ; CHANGE ATOM TO GVAL
4614 CAME 0,[$TGBIND,,$LGBIND]
4615 MOVE 0,[$TGVAL,,$LATOM]
4616 PUSH TP,0 ; PUSH GBIND POINTER OR ATOM POINTER
4619 JSP PC,CALLZ ; CALL EICC
4621 ADJSP P,-4 ; PRESERVE NEW CONT. OF A AND B
4623 AOS -1(P) ; SKIP RETURN
4640 JRST [HRROI A,[ASCIZ /< TUPLE >/]
4648 ADJSP TP,-2 ; SUB TP,[2,,2]
4649 UFRMLX: HRROI A,[ASCIZ /
4652 SKIPGE C,3(C) ; GET NEXT FRAME
4653 JRST [HRROI A,[ASCIZ / <GLUED FRAME(S)>
4656 HRRZ C,-1(C) ; GET REAL FRAME
4661 JRST [HRROI A,[ASCIZ / <GLUED FRAME(S)>
4675 UDP: MOVE A,(B) ; TYPE WORD
4681 TLZE C,200000 ; IS IT MARKED?
4716 HRROI A,[ASCIZ /??/]
4720 UDPUNB: HRROI A,[ASCIZ /#UNBOUND /]
4724 UDPMCD: HRROI A,[ASCIZ /#MCODE |??|/]
4727 UDPFLS: HRROI A,[ASCIZ /#FALSE ()/]
4731 UDPMSB: HRROI A,[ASCIZ /#MSUBR ??/]
4735 UDPCHR: HRROI A,[ASCIZ /!\/]
4741 UDPFIX: MOVEI A,.PRIOU
4747 UDPFLT: MOVEI A,.PRIOU
4763 UDPOBL: HRROI A,[ASCIZ /#OBLIST /]
4774 HRROI A,[ASCIZ /#TUPLE /]
4794 UDPVCE: HRROI A,[ASCIZ /]/]
4796 ADJSP P,-2 ; SUB P,[2,,2]
4799 UDPFRM: HRROI A,[ASCIZ /</]
4804 UDPLST: HRROI A,[ASCIZ /(/]
4824 HRROI A,[ASCIZ /#CHANNEL [/]
4854 XCT @MLTEA ; get ins to execute
4857 SUBTTL END OF THE ROAD
4860 NOISY: 1 ; non-zero, say if int in GC
4861 ONOISY: 0 ; non-zero, say ok after GC
4862 BUGS: 0 ; count bad ADJBP
4863 CTLGS: 0 ; count ^Gs and ^As
4864 CTLGCH: 0 ; int channel for ^G
4865 CTLACH: 0 ; int channel for ^A
4871 IFN MON,.INSRT M20:INSINT.MID
4874 LOC <<.+777>&777000> ; GO TO PAGE BOUNDARY
4875 ENDPG==<.+777>_<-9.>
4880 LOC <<.+777>&777000>
4885 SUBTTL BOOTSTRAP MSUBR READER
4892 BSAPTR: -256.,,BSATBL-1
4894 BOOTER: MOVE A,GCSMIN
4899 MOVE A,[MIMSEC,,PAGTBL]
4901 MOVE A,[MIMSEC,,MINF]
4905 HRROI A,[ASCIZ /MIMI20 Initialization
4910 HRRO A,[[ASCIZ /Using msubrs
4914 [ASCIZ /Using big mbins
4918 BNIN: HRROI A,[ASCIZ /Enter type (1 big mbins, 0 mbins, -1 msubrs): /]
4926 BNIN1: MOVE P,[-PDLLEN,,PDL-1]
4927 MOVE TP,[-STACKLEN,,STACK-1]
4929 PUSHJ P,SMAPIT ; setup multi sections
4934 MOVE B,[$TVECTOR,,237.]
4943 MOVE B,[$DOPEBIT+$TVECT,,<237.*2>]
4947 MOVSI A,(GJ%SHT+GJ%OLD)
4948 HRROI B,[ASCIZ /<MIM.BOOT>BOOT.MSUBR/]
4951 MOVE B,[070000,,OF%RD]
4963 MOVE C,[.BYTE 7 ? "B ? "O ? "O ? "T]
4964 PUSHJ P,BSLKPL ; GET ATOM BOOT IN A/B
4970 MOVE A,[STACK,,STACK+1]
4972 JSP PC,FRAME ; MAKE A FRAME
4975 HRROI A,[ASCIZ /Bootstrap Loaded
4980 MOVEI O2,1 ; Actually call with 1 arg
4981 MOVEI SP,0 ; START SP IN RIGHT SECT
4982 JSP PC,CALLZ ; CALL BOOTSTRAP WITH NO ARGS
4983 JRST SAV ; AND ATTEMPT TO SAVE OURSELVES
5006 BSREAD: SKIPE BSENDF
5026 JRST [MOVE A,$WUNBOUND
5037 ; HERE TO READ # FORMAT
5039 BSTYP: PUSHJ P,BSREAD ; GET TYPE NAME
5040 MOVE B,3(B) ; GET PNAME
5044 CAMN C,[.BYTE 7 ? "M ? "S ? "U ? "B]
5046 CAMN C,[.BYTE 7 ? "I ? "M ? "S ? "U]
5048 CAMN C,[.BYTE 7 ? "D ? "E ? "C ? "L]
5050 CAMN C,[.BYTE 7 ? "U ? "N ? "B ? "O]
5052 CAMN C,[.BYTE 7 ? "F ? "A ? "L ? "S]
5054 PUSHJ P,BSREAD ; GET PRIMITIVE STRUCTURE
5055 HLL A,(P) ; GET NEW TYPE WORD
5066 REPEAT 4,PUSH TP,[0]
5069 PUSHJ P,RECORR ; MAKE A BINDING
5072 POP TP,A ; RESTORE THE MSUBR
5073 MOVE C,3(B) ; THE ATOM
5077 MOVEM A,(C) ; STUFF BINDING IN ATOM
5078 MOVEM C,2(A) ; STUFF ATOM IN BINDING
5082 ; HERE TO READ A FIX
5087 MOVEI C,-"0(B) ; C WILL HOLD FIX
5088 SETZ D, ; D IS FRACTION / E IS # OF DIGITS
5090 BSFIXL: BIN ; GET NEXT CHARACTER
5091 PUSHJ P,BSSEP ; IS IT A SEPARATOR
5092 JRST BSFIXE ; YES, FINISH
5094 JRST [IMULI D,10. ; UPDATE INFO
5098 CAIN B,". ; DECIMAL?
5101 IMULI C,10. ; SHIFT OVER SOME
5102 ADDI C,-"0(B) ; ADD IN THE NEXT DIGIT
5103 JRST BSFIXL ; AND LOOP
5105 BSFIXE: MOVEM B,BSBRK'
5118 ; HERE TO READ A CHARACTER
5127 ; HERE TO READ A STRING
5129 BSSTR: PUSH P,[0] ; CLEAR COUNT (PREPARE TO MAKE STRING)
5138 BSSTR1: PUSH TP,$WCHARACTER ; PUT CHARACTER ON STACK
5141 JRST BSSTRL ; AND LOOP
5142 BSSTR2: MOVE O1,$WSTRING
5144 PUSHJ P,UBLOKR ; MAKE THE STRING
5147 ; HERE TO READ AN ATOM
5149 BSATM: PUSH P,[0] ; CLEAR COUNT (PREPARE TO MAKE STRING)
5154 BSATM1: PUSH TP,$WCHARACTER ; PUT CHARACTER ON STACK
5157 JRST BSATML ; AND LOOP
5158 BSATM2: MOVEM B,BSBRK
5161 PUSHJ P,UBLOKR ; MAKE THE STRING
5165 BSGBND: TLO B,660000
5179 PUSH TP,A ; PUSH GLOBAL BINDING
5181 PUSH TP,$WFIX ; PUSH LOCAL BINDING
5183 PUSH TP,C ; PUSH PNAME
5189 PUSHJ P,RECORR ; MAKE AN ATOM (ISN'T THIS FUN?)
5190 MOVE D,(B) ; GET GLOBAL BINDING
5191 MOVEM B,2(D) ; STUFF IT IN ATOM
5199 BSLKP: HRROI D,BSATBL
5200 MOVE C,1(B) ; POINT TO START OF PNAME
5208 MOVE A,[$TATOM,,10.] ; CHANGED (WAS 4)
5211 ; HERE TO READ SOME MCODE
5213 BSCOD: PUSH P,[0] ; CLEAR THE COUNTER
5232 PUSH TP,$WFIX ; PUT IT ON THE STACK
5233 PUSH TP,D ; P.S. - IT HAD BETTER BE A FIX
5235 JRST BSCODL ; AND LOOP
5243 MOVE O1,$WMCODE ; TYPE WORD SET
5245 PUSHJ P,UBLOKR ; MAKE THE UBLOCK (STRING)
5248 ; HERE TO READ A VECTOR
5251 BSVECL: PUSHJ P,BSREAD
5260 BSVECE: MOVE O1,$WVECTOR
5267 CAIE B,"< ; This is the only % frob we know how to read
5276 ; HERE TO READ A LIST
5279 BSLSTL: PUSHJ P,BSREAD
5292 ; HERE FOR BOOTSTRAP ERRORS
5294 BSNOB: HRROI A,[ASCIZ /No MSUBR named BOOT
5299 BSNOF: HRROI A,[ASCIZ /Can't open BOOT.MSUBR
5303 SUBTTL SMAP% CODE FOR MULTI SECTION HACKING
5308 ; Create 1 or 2 stack sections, depending on FLIP
5310 MOVE B,[.FHSLF,,MIMSEC] ; create brand new section
5311 MOVE C,[PM%CNT+PM%RD+PM%EX+PM%WR+1] ; bits for mapping
5315 MOVE B,[.FHSLF,,MIMSEC+1] ; create brand new section
5316 MOVE C,[PM%CNT+PM%RD+PM%EX+PM%WR+1] ; bits for mapping
5319 MOVSI C,(PM%RD+PM%EX+PM%CPY)
5321 MOVE B,[.FHSLF,,<MIMSEC_9>]
5324 MOVSI C,(PM%RD+PM%EX+PM%CPY)
5326 MOVE B,[.FHSLF,,<<MIMSEC+1>_9>]
5331 MOVSI C,(PM%RD+PM%WR+PM%EX)
5336 MOVSI C,(PM%RD+PM%WR+PM%EX)
5339 ADDI B,<<MIMSEC+1>_9.>
5343 CAME D,[.FHSLF,,1000]
5346 ; create stack section
5347 IFN <MIMSEC-TPSEC>,[
5349 MOVE B,[.FHSLF,,TPSEC]
5350 MOVE C,[PM%CNT+PM%RD+PM%EX+PM%WR+1] ; bits for mapping
5353 ; create initial GC space section and section following (for MAPPUR)
5356 MOVE B,[.FHSLF,,INIGC]
5357 MOVE C,[PM%CNT+PM%RD+PM%EX+PM%WR+2] ; bits for mapping
5360 ; and map special page in from 0
5362 MOVE A,[.FHSLF,,COMPAG+<MIMSEC_9>]
5363 MOVE B,[.FHSLF,,<<INIGC_9.>+COMPAG>]
5364 MOVE C,[PM%CNT+PM%RD+PM%EX+PM%WR+1] ; bits for mapping
5366 IFN FLIP,MOVE A,[.FHSLF,,COMPAG+<<MIMSEC+1>_9>]
5367 IFE FLIP,MOVE A,[.FHSLF,,COMPAG+<MIMSEC_9>]
5368 MOVE B,[.FHSLF,,<<<INIGC+1>_9.>+COMPAG>]
5369 MOVE C,[PM%CNT+PM%RD+PM%EX+PM%WR+1]
5372 ; now all that is left to do is set up UUOs, fix ENTRY table and make stacks
5378 MOVE A,[<ENTVEC+LOWOP-ENTMAX-1>,,ENTVEC+LOWOP]
5379 IFN FLIP, MOVEI B,MIMSEC+1
5380 IFE FLIP, MOVEI B,MIMSEC
5384 HRLM B,(A) ; MAKE POINT TO CORRECT SECTION
5387 MOVE A,[-FROBL,,FROBBS]
5397 MOVE A,[<ENTVEC+LOWOP-ENTMAX-1>,,ENTVEC+LOWOP]
5402 HRLM B,(A) ; MAKE POINT TO CORRECT SECTION
5405 MOVE A,[-FROBL,,FROBBS]
5414 MOVEI B,2 ; CODE FOR SETUP OF UUO TABLE
5415 MOVE C,[MIMSEC,,MLTUUP]
5418 MOVE TP,[TPSEC,,STRTTP] ; now have good TP
5419 MOVE A,[INIGC,,1000] ; MAKE THIS START GC
5422 MOVE A,[INIGC,,TOPMGC]
5424 MOVE B,[MPAGM,,PAGTBL]
5425 BLT B,PAGTBL+MPAGME-MPAGM
5432 MOVE P,[TPSEC,,STPDL] ; p-stack in MIM section
5434 XJRST DUALPC ; poof we are outta here!
5445 IFN <TPSEC-MIMSEC>,[
5451 <STRTTP_<-9.>>+<TPSEC_9>
5456 IFN <TPSEC-MIMSEC>,[
5458 <<MIMSEC+1>_9.>+ENDPG
5462 <STRTTP_<-9.>>+<<TPSEC+1>_9>
5470 REPEAT <NUMSEC-1>,[1
5471 <<INIGC+.RPCNT+1>_9.>
5474 <<INIGC+.RPCNT+1>_9.>+1