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==0 ; 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
100 0 ; DESTINATION STRING
104 IRDBRK ; FOR FUTURE EXPANSION
107 IRDBRK: 20000,,400 ; BREAK ON CONTROL-D
111 ARDBRK: BLOCK 4 ; ALTERNATE BREAK MASK FOR READ
115 CZONE: 0 ; current fs zone
122 PNTSTK: MIMSEC,,STKERR
125 ; JUMP 16,.+2 ;errors on sin/sout go to EXEC
132 ;Feature test switches:
133 FTKCN==0 ;ne 0 to include kernel testing code
139 DEFINE ENTRY ENTLOC,JSPQ
141 IFE FTKCN,{SETZ ENTLOC }
143 IFSE JSPQ,,1,,kercal ;;all dispatches through this address
146 loc kcltab+curop ;;hide real address in
147 xwd 1,entloc ;;other table (fake multi-sectioning)
151 IFG <%!ENTLOC+ENTVEC-ENTMAX>,ENTMAX==%!ENTLOC+1+ENTVEC
152 IFL <CUROP-LOWOP>,LOWOP==CUROP
158 ;;Some routines are JRST'd to, so we can't account them...
159 DEFINE OENTRY ENTLOC,JSPQ
162 IFG <%!ENTLOC-ENTMAX+ENTVEC>,ENTMAX==%!ENTLOC+1+ENTVEC
163 IFL <CUROP-LOWOP>,LOWOP==CUROP
169 DEFINE OENTRY ENTLOC,JSPQ
174 DEFINE TYPREC TBL,NAM\
175 $W!NAM=[$TYPCNT_6+$PRECORD,,0]
176 $T!NAM=$TYPCNT_6+$PRECORD
178 LOC RECTBL+<$TYPCNT*2>
185 DEFINE TYPMAK PT,NAM\
186 $W!NAM=[$TYPCNT_6+PT,,0]
194 SUBTTL OPCODE DEFINITIONS
282 SUBTTL Kernel stuff left in section 0 for max winnage
293 SBFRAM: MOVE O1,@3(M) ; get atom of current MSUBR
302 SUBI 0,SBRCLL-SBRFRM(TP)
309 SFRAME: PUSH TP,[$TSFRAM+$FRMDOPE,,0]
311 FRAME: PUSH TP,[$TFRAME+$FRMDOPE,,0]
316 BIND: PUSH TP,[$TBIND+$FRMDOPE,,0]
325 MOVE A,[$TBIND,,16.] ; LENGTH CHANGED (WAS 6)
331 FIXBLP: MOVE B,2(A) ; THE ATOM FOR THIS BINDING
332 CAMLE A,1(B) ; Survivored frob, we've already fixed this
334 MOVE O1,1(B) ; get section
335 CAMLE O1,TP ; skip if not top level binding
336 FIXBL1: CAILE 0,(A) ; ARE WE BEHIND THE CURRENT FRAME?
338 FIXBL2: MOVEM A,1(B) ; MAKE ATOM POINT TO THIS BINDING
339 SKIPE A,5(A) ; GET PREVIOUS BINDING AND LOOP
344 IFN FTKCN,< AOS @[MIMSEC,,KCNTAB+%CALL]> ;Count calls
350 ; PUSHJ P,@[MIMSEC,,TRACIN]
351 CALLRX: MOVE C,O2 ; SAVE # OF ARGUMENTS
352 SKIPN B,(O1) ; GET GLOBAL BINDING
353 JRST @[MIMSEC,,CALNGS] ; BARF, NOT GASSIGNED!
354 HLRZ A,(B) ; LOAD GVAL
355 CAIE A,$TMSUBR ; IS IT AN MSUBR?
356 JRST @[MIMSEC,,CALNGS] ; OH, FOO!
357 MOVE D,1(B) ; GET MSUBR
359 IFN FTKCN,{ SKIPE @[MIMSEC,,TRACNT] ;Trace count?
360 PUSHJ P,@[MIMSEC,,TRINCT] ; Yup
362 SKIPE B,@1(D) ; POINT TO GVAL OF ATOM OF IMSUBR
364 JRST COMPER ; If IMSUBR is not assigned...
365 SKIPL A,-1(F) ; GET PREVIOUS GLUED FRAME
366 SKIPA A,F ; OR ELSE CURRENT FRAME
368 HRRM SP,FR.SP(A) ; SAVE BINDING POINTER
369 MOVEM PC,FR.PC(A) ; SAVE PC (THIS IS WRONG)
371 SUBM TP,C ; POINT ABOVE FIRST ARG
372 MOVEM D,FR.MSA-1(C) ; STORE MSUBR IN FRAME
375 MOVEM F,FR.FRA-1(C) ; STORE PTR TO PREV FRAME
376 AOS F,FRAMID ; GET A UNIQUE ID
377 HRL F,O2 ; SAVE # ARGS IN LH
378 MOVEM F,FR.ARG-1(C) ; STORE ARGS,,ID
379 XMOVEI F,-1(C) ; POINT AT FRAME
380 SETZM (F) ; FOR WINNAGE
382 HLRZ A,(M) ; CHECK FOR FBIN TYPE KLUDGE
387 PUSHJ P,@[MIMSEC,,DMAPIN]
390 PUSHJ P,@[MIMSEC,,INTGOC]
392 ; JRST @[MIMSEC,,STKERR]
394 IFE FLIP&0,[ JRST @D ]
396 TLNN M,1 ; ODD/EVEN CHECK
403 EVNSEC: HRLI TP,ODDSEC
411 IUNBIN: MOVEI C,0 ; IN CASE NO BINDINGS FLUSHED
412 SETZB A,B ; IN CASE UNWINDER FOUND
414 IUNBNL: CAIL O1,(SP) ; IS BINDING POINTER ACCURATE?
415 JRST IUNBNQ ; YES, RETURN
416 SKIPN D,2(SP) ; THE ATOM BOUND
418 CAMN D,UWATM ; REALLY AN UNWIND?
419 JRST @[MIMSEC,,DOUNWI] ; AND LOOP UNTIL ALL DONE
420 UNJOIN: MOVE C,6(SP) ; THE OLD BINDING FOR THIS ATOM
421 MOVEM C,1(D) ; STUFF OLD BINDING INTO ATOM
422 NXTBND: MOVE C,SP ; SAVE LAST BINDING FLUSHED
423 MOVE SP,5(SP) ; POINT TO PREVIOUS BINDING
424 JRST IUNBNL ; YES, GO HANDLE IT
429 ; CAMGE C,TP ; NEED STACK TO FLUSH?
430 ; XMOVEI TP,-2(C) ; FLUSH BINDING DW AS WELL
434 IFN FTKCN,< AOS @[MIMSEC,,KCNTAB+%RETUR]>
435 ; SKIPE DIDCMP ; SEE IF MUST CHECK FOR OVFL PAGE HACK
436 ; JRST @[MIMSEC,,RET2]
437 RET3: SKIPL C,(F) ;NOTE THIS INSTRUCTION CAN BE MUNGED!!!
442 IFN SBRFY,[ TLZN C,SBRCAL ; SKIP IF SUBRIFY
444 MOVE M,-2(TP) ; CALLER'S M
446 HLRZ 0,(M) ; CHECK FOR PMAPPED
451 PUSHJ P,@[MIMSEC,,DMAPI1]
456 ; PUSHJ P,@[MIMSEC,,TRACOUT]
460 FRMFIX: MOVEI O1,-FR.LN(F)
461 CAIGE O1,(SP) ; DO WE NEED SOME UNBINDING?
462 JSP PC,IUNBNL ; YES. DO THEM
464 HRR F,FR.FRA(F) ; GET PREVIOUS FRAME
473 CHPCO: MOVE PC,FR.PC(C) ; RESTORE PC FROM FRAME
474 SKIPN M,FR.MSA(C) ; RESTORE MSUBR PTR FROM FRAME
476 MOVE M,@1(M) ; POINT TO GBIND THROUGH ATOM
477 MOVE M,1(M) ; GET IMSBUR INTO M
479 HLRZ O1,(M) ; CHECK FOR FBIN TYPE KLUDGE
484 PUSHJ P,@[MIMSEC,,DMAPI1]
487 IFE FLIP&0,[ JRST (E)]
488 IFN FLIP&0,[ JRST NOSBR]
489 HLRZS O2 ; FIND FRAME OF SUBRIFIED THING
490 ADD C,O2 ; THROUGH GROSS HAIR
491 DMOVE R,@(C) ; ONLY WORKS CAUSE R=M-1
494 IFE FLIP&0,[ JRST (E) ]
496 TLNN M,1 ; ODD/EVEN CHECK
503 EVNSE3: HRLI TP,ODDSEC
508 ; MAKTUP -- 0/ TOTAL ARGS PASSED, O1/ REQUIRED+OPT ARGS, O2/ #TEMPS
511 SUB 0,O1 ; SUBTRACT REQUIRED ARGUMENTS
512 LSH O2,1 ; O2 IS NUMBER OF TEMPS
513 ADJSP TP,(O2) ; BUMP TP TO REFLECT THIS
514 SKIPG A,0 ; A NOW HAS LENGTH OF TUPLE IN RH
515 JRST IMAKET ; ZERO LENGTH TUPLE
516 LSH O1,1 ; WORDS WORTH OF REQUIRED ARGS
517 MOVN C,0 ; # ARGS TO MOVE (NEG FOR XBLT)
518 ASH C,1 ; TO NUMBER OF WORDS
519 MOVEI D,2(O1) ; D/ # OF REQ ARGS+2
520 ADD D,F ; D POINT TO FIRST TUPLE WORD
521 SUB D,C ; NOW LAST TUPLE WORD+1
522 MOVE E,D ; COMPUTE DEST
523 ADD E,O2 ; ADD IN DELTA
531 XMOVEI B,1(TP) ; POINT AT DOPE WORD FOR EMPTY TUPLE
532 PUSHDW: LSH 0,1 ; MAKE IT BE # OF WORDS INSTEAD OF ELTS
533 HRLI 0,$TTUPLE+$FRMDOPE ; GENERATE A DOPE WORD
535 PUSH TP,[0] ; MUST PUT IN OTHER DOPE WORD
536 SKIPGE FR.TP(F) ; SKIP IF MUST MUNG FRAME
540 HRLM 0,FR.ARG(F) ; INDICATE IN FRAME
543 CONS: JSP OP,ICELL1 ; GET LIST CELL
544 JRST @[MIMSEC,,CONS1] ; REQS A GC
553 ICELL1: SKIPN B,CZONE
554 XMOVEI B,NOZONE-GCPOFF
561 ; TLNE 0,$GC%PB ; ONLY PAGES FROM ZONE?
563 ICELL2: MOVE A,GCSBOF(B)
567 JRST 1(OP) ; SKIP RET, ALL IS WELL
570 TUPLE: MOVE B,TP ; POINT TO STACK
571 MOVE A,O1 ; SAVE LENGTH
574 HRLI O1,$TTUPLE+$FRMDOP
577 HRLI A,$TTUPLE ; TYPE/LENGTH IN A
580 SUBTTL OPEN COMPILER UTILITIES
583 IFN FTKCN,<AOS @[MIMSEC,,KCNTAB+CUROP]>
584 MOVE 0,A ; POSSIBLE COUNT
585 LDB A,[220300,,A] ; ISOLATE PRIMTYPE
589 IFN FTKCN,<AOS @[MIMSEC,,KCNTAB+CUROP+1]>
590 MOVE 0,A ; POSSIBLE COUNT
591 LDB A,[220300,,A] ; GET PRIMTYPE
592 CIMON1: CAIN A,$PLIST
602 ; SKIPA ; THIS IS REALLY WRONG!!!
610 IFN FTKCN,<AOS @[MIMSEC,,KCNTAB+CUROP+2]>
620 JRST [MOVSI A,$TCHARACTER
627 DOILD1: MOVSI A,$TFIX
632 IFN FTKCN,<AOS @[MIMSEC,,KCNTAB+CUROP+3]>
647 AOJA B,[HRLI A,$TUVECTOR
651 ; CAMG B,[TPSEC+2,,] ; Win with tuples???
655 DOIBP1: HRLI A,$TSTRING
680 LENWRD==2200 ; LENGTH WORD
681 TYPWRD==222200 ; TYPE WORD
683 UPTBYT==220200 ; UBLOCK-PRIMTYPE PART OF TYPE WORD
684 PTPBYT==220300 ; PRIMTYPE PART OF TYPE WORD
685 TYPBYT==301200 ; TYPE PART OF TYPE WORD
686 RTYBYT==061200 ; FOR A TYPE IN THE RH
687 MONBYT==250200 ; MONITOR PART OF TYPE WORD
688 $FRMDOPE==40 ; LH BIT FOR DOPE WORD
690 $QSFRB==100000 ; BIT IN GLUED FRM PC IF SEG CALL
691 ; **** CAUTION SUSPECT IN FUTURE
692 ; VERSIONS OF THE 20 ****
693 SBRCAL==200000 ; BIT IF "SUBRIFY CALL"
694 ; Flags associated with gc spaces (see GCSFLGs) (LEFT HALF WORD)
696 $GC%DW==400000 ; don't create dope words
697 $GC%PB==200000 ; only on page boundaries
706 RECTBL: BLOCK 256.*2 ; Each entry is a type/val pair
712 ; UVECTOR of machine dependent information
714 MINF: 100 ; jfn for tty input
715 101 ; jfn for tty output
717 7. ; bits per character
718 512. ; words per page
719 5 ; characters per word
720 0 ; shift for address in word terms
722 377777777777 ; largest possible number (float)
723 400000000001 ; smallest possible number (float)
727 ; WHAT FOLLOWS IS THE INITIAL SET OF GC-PARAMS, USED UNTIL THE
728 ; FS SYSTEM IS STARTED.
732 ; RCLV IS A POINTER STRUCTURE OF FREE NON-LIST STORAGE.
733 ; IT IS CHAINED TOGETHER SUCH THAT MOVE AC,(AC) WILL GET THE
734 ; NEXT FREE BLOCK OF STORAGE. THE LENGTH OF A GIVEN BLOCK
735 ; POINTED AT BY AC IS TWO PLUS THE RIGHT HALF OF -1(AC).
736 ; THIS WORD, I.E. -1(AC) IS THE FIRST DOPE WORD OF THE BLOCK
737 ; WHICH WAS RECYCLED.
738 ; BELOW IS A SCHEMATIC REPRESENTATION OF RCLV
740 ; BITS,,LENGTH-2 BITS,,LENGTH-2
741 ; RCLV -> NEXT FREE BLOCK -> NEXT FREE BLOCK -> ... -> 0
743 ; 0 ; 'TYPE WORD' FOR RCLV (ALWAYS 0)
745 RCLV: 0 ; RECYCLE VECTOR
769 GCSBOT: 0 ; CURRENT GC POINTER
794 PAGTBL: REPEAT PAGTLN,0
797 PCLEV1: 0 ; two words per int pc for multi-sec
802 RUNINT: 0 ; IF NON-ZERO, RUN INTS IMMEDIATELY
803 MLTUUP: 0 ; HOLDS UUO (SWAPPED SORT OF)
806 MLTEA: 0 ; EFF ADDR OF UUO INSTRUCTION
807 MLTUUH: MIMSEC,,MLTUOP ; RUN IN MIMSEC
809 INITZN==1 ; for now...
825 ; Offsets associated with FRAMEs
827 FR.LN==6 ; Length of full frame
828 FR.OFF==4 ; Offset from F to real frame ptr
829 FR.ACT==1 ; Offset for PC for activation
830 FR.SP==0 ; Offset for saved binding (rh)
831 FR.TP==0 ; Offset for saved TP (lh)
832 FR.FRA==-1 ; Offset for previous frame
833 FR.ARG==-2 ; Offset for # of args to this guy (lh)
834 FR.ID==-2 ; Offset for frame id (rh)
835 FR.PC==-3 ; Offset for saved PC
836 FR.MSA==-4 ; Offset for save MSUBR pointer
837 FR.HDR==-5 ; Offset for FRAME header
841 ; In multi-section/extended addressing mode, MIMI20 lives in section 1.
842 ; it is mapped there at startup time. MIMI should be able to run in either
843 ; single or multi section mode. The TP stack lives in a section of its own
844 ; and everything else is GC space (for now).
846 MIMSEC==1 ; MIMI sections
847 TPSEC==1 ; STACK sections
848 IFE FLIP,[ INIGC==TPSEC+2 ; First GC section
850 IFN FLIP,[ INIGC==TPSEC+2
851 IFE TPSEC&1,[ ODDSEC==TPSEC+1
853 IFN TPSEC&1,[ ODDSEC==TPSEC
856 COMPAG==0 ; page mapped into all sections except
858 NUMSEC==12 ; total # of initial sections
859 ; (initial value of CURSIZ...)
860 STRTTP==200000 ; begin control stack to avoid paging
862 STPDL==777000 ; put P stack in a strange place also
863 PGPDL==<<TPSEC_9>\<<STPDL>_<-9>>> ; P STACK PAGE
864 TPENDP==PGPDL-1 ; illegal page to end TP
865 TPWARN==TPENDP-5 ; page to warn of end
869 SUBTTL TYPE DEFINITIONS
873 TYPMAK $PFIX,CHARACTER
880 TYPMAK $PSTRING,STRING
881 TYPMAK $PUVECTOR,MCODE
883 TYPMAK $PVECTOR,VECTOR
884 TYPMAK $PVECTOR,MSUBR
887 TYPREC BNDTBL,BINDING
894 ; TYPES STARTING HERE SHOULD BE HANDLED DIFFERENTLY AT SOME
900 TYPMAK $PLIST,SEGMENT
902 TYPMAK $PLIST,FUNCTION
905 TYPMAK $PVECTOR,CHANNEL
906 TYPMAK $PVECTOR,ENTRY
907 TYPMAK $PVECTOR,ADECL
908 TYPMAK $PVECTOR,OFFSET
914 TYPMAK $PVECTOR,TUPLE
915 TYPMAK $PUVECTOR,UVECTOR
916 TYPMAK $PVECTOR,IMSUBR
919 TYPMAK $PVECTOR,I$SDTABLE
920 TYPMAK $PVECTOR,I$DISKCHANNEL
921 TYPMAK $PVECTOR,MUDCHAN
923 TYPMAK $PUVECTOR,PCODE
925 TYPMAK $PUVECTOR,GCPARAMS
926 TYPMAK $PUVECTOR,AREA
936 DBVEC: 0 ; LOCATIONS WHERE PURE VEC STUFF IS STORED
940 PAGPTR: $TUVEC,,PAGTLN
945 BINDID: 0 ; USED IN BININING
946 TTBIND: 0 ; TOP LEV BIND
948 CURSIZ: NUMSEC ; Number of sections we have
953 RETPUR: MOVE A,PURVEC
956 MOVE A,[SAVAC+B,,B] ; Restore ACs
958 MOVE B,PURZON ; Pick up pure zone
959 MOVE C,ATMZON ; and atom zone
960 MOVEM A,INTSAV ; Make sure flag set
961 PUSHJ P,SAV1 ; Go do the save
965 ;storage for metering
966 ksava: block 1 ;save ac a
967 kcntab: block 400 ;count of calls
968 kcltab: block 400 ;addresses of routines to call
969 ;storage for trace counting
970 tracnt: block 1 ;0 means don't count calls
971 tranum==4000 ;number of different atoms we may see:
972 tratab: block tranum+1 ;tbluk table for atom names
973 trascr: block tranum*3 ;scratch space for atom names
974 traptr: block 1 ;pointer to first free word in scratch space
975 tranam: block 10 ;temp space for atom name before lookup
976 trsava: block 2 ;save a,b
977 trsavc: block 2 ;save c,d
978 trsav5: block 2 ;save 5,6
980 movei a,trascr ;address of scratch space
981 movem a,traptr ;is first free at startup
982 hrrzi a,tranum ;0,,num
983 movem a,tratab ;tbluk table header
985 popj p, ;and return init'd
986 ;print out the table (and zero it)
987 pritab: dmovem a,trsava
990 priget: hrroi a,[asciz/Output file for trace: /]
992 move a,[gj%sht+gj%fns]
993 move b,[.priin,,.priout]
996 move b,[070000,,300000] ;7-bit read/write
998 jrst priget ;clever error handling
999 prilup: hlrz 5,tratab ;number of entries in table
1001 jumpe 5,pridun ;done?
1002 hrlz 5,5 ;in left half
1003 setz 3, ;largest count so far....
1005 plup: hrrz 4,tratab+1(5) ;get a canditate count
1006 caml 4,3 ;bigger or equal?
1007 jrst [ hrrz 6,5 ;yes, store new index
1008 hrrz 3,tratab+1(6) ;and new count
1010 aobjn 5,plup ;iterate
1011 ;index of largest entry in ac 6 now
1016 hlro b,tratab+1(6) ;name
1018 hrrz b,tratab+1(6) ;count
1019 move c,[100010,,12] ;8 columns, leading filler, decimal
1022 hlrz 4,tratab ;table size
1023 move 3,tratab+1(4) ;top entry
1024 exch 3,tratab+1(6) ;flush out biggest entry
1025 sos 4 ;decrement used size
1026 hrlm 4,tratab ;save nwe count
1027 jrst prilup ;and iterate
1028 pridun: CLOSF ;close the file
1029 jfcl ;clever error handling
1033 popj p, ;and return to caller
1034 ;here to count a call
1035 trinct: dmovem a,trsava
1037 move b,3(d) ;get name of msubr
1038 move a,3(b) ;get string (count,,address)
1039 hrrz b,2(b) ;count into b
1040 move c,[440700,,tranam] ;temp space for name
1042 idpb d,c ;and put them
1043 sojg b,.-2 ;until there ain't no more (assumes 1 or more)
1044 setz d, ;null terminator
1046 movei a,tratab ;table address
1047 move b,[440700,,tranam] ;point to string
1049 tlne b,40000 ;set if exact match
1050 jrst [aos (a) ;bump count
1051 jrst trret] ;and return this call
1052 ;not in table, must add it
1053 move c,traptr ;get address of first free
1054 hrli c,440700 ;byte pointer
1055 move a,[440700,,tranam] ;
1057 idpb d,c ;and put them
1058 jumpn d,.-2 ;do til null
1059 movei a,tratab ;table address
1060 hrlz b,traptr ;address,,0
1061 aos b ;,,1 initial count
1063 aos c ;bump pointer to next word boundary
1064 hrrzm c,traptr ;and store it
1065 trret: dmove a,trsava
1069 ;Dispatch routine to use for metering calls into the kernel
1070 kerjsp: movem a,ksava ;called with JSP PC,
1071 hrrz a,-1(pc) ;get table offset
1072 aos kcntab-entvec(a) ;bump counter
1073 move a,kcltab-entvec(a) ;get real addr
1074 exch a,ksava ;restore a and setup to call
1076 kercal: movem a,ksava ;save a
1077 move a,(p) ;return address
1078 sos a ;caller's address
1079 hrrz a,(a) ;table offset used in call
1080 subi a,entvec ;table index relative to table start
1081 aos kcntab(a) ;count calls to this routine
1082 move a,kcltab(a) ;get address of routine being called
1083 exch a,ksava ;restore a and save routine address
1084 jrst @ksava ;do the real kernel call
1088 LOC <<.+777>&777000>
1090 SUBTTL STACK OPERATIONS & FLOW OF CONTROL
1092 ; LEGAL? TAKES ARGUMENT IN A & B
1094 LEGAL: HLRZ C,A ; GET TYPE OF FROBBIE
1100 TLZ C,770000 ; CLEAR OUT BYTE POINTER BITS
1101 CAML C,[INIGC,,0] ; SKIP IF IN STACK AREA
1105 CAMLE D,C ; SKIP IF ON STACK
1106 JRST LGLFLS ; NO, A LOSER
1107 LDB D,[220300,,A] ; GET SAT
1108 JRST @LGLTAB(D) ; DISPATCH
1109 LGLTRU: MOVSI A,$TFIX
1121 IBP A,B ; REST TO END OF STRING
1122 ADDI A,1 ; TO NEXT WORD
1124 TRNN B,$FRMDOPE ; DOPE WORD?
1125 JRST LGLFLS ; NO, LOSER
1137 LGLFRM: MOVSI D,<$TFRAME+$FRMDOPE>
1138 MOVSI E,<$TSFRAM+$FRMDOPE>
1152 LGLBND: CAML B,[INIGC,,0]
1154 MOVSI D,<$TBIND+$FRMDOPE>
1166 CAIE D,$TVECTOR+$FRMDOPE
1167 CAIN D,$TTUPLE+$FRMDOPE
1169 HLRZ D,-FR.LN-1(B) ; SEE IF ARGS OF A FRAME
1170 CAIE D,$TFRAME+$FRMDOPE
1171 CAIN D,$TSFRAM+$FRMDOPE
1174 ;here to check for rested args of a frame
1176 MOVE D,F ; start at current frame
1177 LGLTU3: SKIPL (D) ; glued frame
1179 HRRZ D,-1(D) ; get real frame
1181 LGLTU2: CAMG D,B ; skip if frame above tuple
1187 LGLTU1: HLRE C,FR.ARG(D) ; get arg count
1190 ADDI D,2(C) ; should be tuple end
1202 IPFRM1: MOVE A,$WFRAME
1215 MOVEM O1,@[MIMSEC,,UWATM]
1216 MOVEM O1,@[MIMSEC+1,,UWATM]
1218 IFE FLIP MOVEM O1,UWATM
1221 ARGS: HLRE A,FR.OFF+FR.ARG(O1) ; COUNT OF ARGUMENTS
1222 JUMPL A,IARG1 ; FUNNY, CASE
1223 HRLI A,$TTUPLE ; SET TYPE WORD
1224 MOVEI B,6(O1) ; POINT AT ARGUMENT BLOCK
1228 IARG1: SUBM O1,A ; POINT TO DW OF TUPLE
1229 HRRZ B,FR.OFF-1(A) ; GET LENGTH
1239 IFN FTKCN,< AOS KCNTAB+%INCAL> ;Count calls
1244 SKIPL A,-1(F) ; GET PREVIOUS GLUED FRAME
1245 MOVE A,F ; OR ELSE CURRENT FRAME
1249 MOVE 0,FR.MSA(A) ; SO RETURN WINS
1255 AOS F,@[MIMSEC,,FRAMID]
1256 MOVEM F,@[MIMSEC+1,,FRAMID]
1258 IFE FLIP AOS F,FRAMID
1261 MOVEM 0,FR.MSA(F) ; SO RETURN WINS
1263 ADDI B,1 ; NOTE: DONT CHANGE TO AOJA!!!
1267 IFN FTKCN,< AOS KCNTAB+%ACALL> ;Count calls
1270 JRST [ MOVE D,B ; GET ATOM
1280 CALNGS: SKIPN NCATM ; CALL'ED ATOM IS NOT GASSIGNED
1282 ADJSP TP,2 ; ROOM FOR EXTRA ARG
1284 SKIPN E,O2 ; # OF ARGS TO B
1289 SOJG E,.-3 ; MAKE ROOM
1291 CALNG5: JUMPE O1,CALNG2 ; JUMP IF NOT A CALL TO AN ATOM
1293 CALNG1: MOVE B,[$TATOM,,$LATOM]
1296 CALNG3: MOVE O1,NCATM
1299 CALNG2: DMOVEM A,-1(OP) ; MUNG IN WHATEVER IT IS
1303 CALNMS: PUSHJ P,HALTX ; VALUE OF CALL'ED ATOM ISN'T MSUBR
1306 IFN FTKCN,< AOS KCNTAB+%ACTIVA> ;Count calls
1311 SUBI A,(F) ; REL TP TO FRAME
1315 RETRY: XMOVEI F,FR.OFF(O1)
1316 HLRE B,FR.ARG(F) ; SEE IF TUPLE CASE
1318 SUBM F,B ; B POINTS TO DW
1319 HRRZ A,-1(B) ; A IS REAL # ARG
1321 HRLM A,FR.ARG(F) ; FIX UP # ARGS
1322 LSH A,1 ; TO # WORDS
1323 SUBI B,1(A) ; B IS SOURCE (I.E. 1ST ARG WORD)
1324 XMOVEI C,2(F) ; FIRS DEST
1326 BLTDON: PUSH P,FR.ARG(F) ; SAVE FOR NEW FRAME
1340 IFN FTKCN,< AOS KCNTAB+%AGAIN> ;Count
1342 SKIPGE (F) ; CHECK FOR GLUEDNESS
1343 HRR F,-1(F) ; GET THE REAL FRAME
1351 MOVE M,@1(M) ; GET ATOM OF IMSUBR
1352 MOVE M,1(M) ; AND FINALLY IMSUBR
1353 HLRZ A,(M) ; CHECK FOR FBIN TYPE KLUDGE
1356 JRST [ SKIPN R,PV%OFF(R) ; GET POINTER
1357 ; NOT THERE, MAP IT IN
1360 IAGN1: HRRZ PC,FR.ACT(F)
1364 IFE FLIP&0,[ ADD TP,F
1367 TLNN M,1 ; ODD/EVEN CHECK
1374 EVNSE1: HRLI F,ODDSEC
1379 ; HERE TO HANDLE AN UNWINDER
1381 DOUNWI: SKIPN O2,1(SP) ; GET UNWIND FRAME
1383 SKIPN M,FR.MSA+FR.OFF(O2) ; RESTORE MSUBR PTR FROM FRAME
1385 MOVE M,1(M) ; POINT TO ATOM
1386 MOVE M,(M) ; POINT TO GBIND
1387 MOVE M,1(M) ; GET IMSBUR INTO M
1388 HLRZ C,(M) ; CHECK FOR FBIN TYPE KLUDGE
1391 JRST [ SKIPE R,PV%OFF(R) ; GET POINTER
1393 PUSH TP,A ; NOT THERE, MAP IT IN
1403 HRRZ C,4(SP) ; GET PC OFFSET
1406 ADJSP TP,6(D) ; MUNG IT
1419 IFE FLIP&0,[ JRST (C) ]
1421 TLNN M,1 ; ODD/EVEN CHECK
1428 EVNSE2: HRLI TP,ODDSEC
1434 IFN FTKCN,< AOS KCNTAB+%UNWCN> ;Count calls
1442 MOVE D,2(SP) ; REALLY UNBIND IT IF SUCCESSFUL
1445 ; HERE TO HANDLE FIXUP AFTER STACK LOSSAGE FROM RETURN
1447 CAIL C,<<TPWARN>_9.> ; ARE WE BELOW
1460 MOVSI A,(SKIPL C,(F))
1461 MOVEM A,RET3 ; MUNG THAT INS!!!
1462 MOVEM A,@[MIMSEC+1,,RET3]
1466 ; RTUPLE WILL NOT RUN IN MIM MODE
1476 SKIPN O2 ; 0 ==> MRET FROM CURRENT FRAME
1477 XMOVEI O2,-FR.OFF(F) ; UPDATE FRAME
1478 MRET2: SKIPGE C,FR.OFF(O2) ; GLUED FRAME?
1480 JUMPN D,MRET3 ; JUMP IF RTUPLE
1481 HLRZ C,FR.HDR+FR.OFF(O2) ; SEE IF SEG FRAME
1482 CAIN C,$TSFRAM+$FRMDOP
1484 MOVE A,FR.FRA+FR.OFF(O2) ; Previous frame
1485 SKIPGE C,FR.OFF(A) ; Glued?
1486 JRST [HRR A,-1(A) ; Point to real frame
1488 MOVE C,FR.OFF+FR.PC(A) ; Get return PC if not glued
1489 MRETFO: MOVE M,FR.MSA+FR.OFF(A) ; MSUBR
1491 MOVE M,1(M) ; IMSUBR
1494 CAIE 0,$TPCODE ; skip if fbin
1496 SKIPN R,PV%OFF(R) ; skip if already mapped in
1497 PUSHJ P,@[MIMSEC,,DMAPI1] ; Map the guy in
1498 MOVE B,@C ; THIS KLUDGE SEES IF WE CAN STEP TO
1499 ; NEXT FRAME FOR THIS MRETURN
1500 CAMN B,[JRST @<RETOFF+ENTVEC>] ; IS IT A RETURN
1501 JRST [ MOVE O2,FR.OFF+FR.FRA(O2) ; YES, MRETURN FROM IT
1502 SKIPGE (O2) ; skip if not glued frame
1503 SUBI O2,FR.OFF ; fix up pointer
1504 JRST MRET2 ] ; try this all again
1509 PUSH TP,[$TFRAME,,$LFRAME]
1523 MRET3: XMOVEI F,FR.OFF(O2)
1524 PUSH P,O1 ; SAVE NUMBER OF ITEMS
1525 PUSH P,TP ; SAVE POINTER TO STACK
1528 JSP E,FRMFIX ; UNBIND, DO RETURN
1531 POP P,A ; GET BACK STACK
1532 MOVE C,(P) ; GET BACK TUPLE LENGTH
1533 LSH C,1 ; TWICE THAT FOR # OF WORDS
1534 SUB A,C ; POINT TO FIRST ELEMENT
1535 XMOVEI B,1(TP) ; SAVE POINTER TO TUPLE
1538 IRTPL2: JUMPE C,IRTPLE ; AN EMPTY TUPLE
1539 IRTPLP: PUSH TP,1(A) ; PUSH AN ELEMENT OF THE TUPLE
1541 ADDI A,2 ; MOVE THROUGH TUPLE
1542 SUBI C,2 ; DECREMENT COUNT
1543 JUMPN C,IRTPLP ; LOOP UNTIL DONE
1544 IRTPLE: JUMPE E,IRTPL3
1545 POP P,A ; RESTORE LENGTH
1554 GRTUPL: XMOVEI E,FR.OFF-2(O2) ; SAVE A COPY OF GLUED FRAME
1555 ; POP OF GLUED FRAME
1556 MOVE F,FR.OFF+1(O2) ; GET RESTORED
1557 MOVE A,O1 ; COPY # OF ELEMENTS
1558 LSH O1,1 ; TO NUMBER OF WORDS
1560 SUB O2,O1 ; POINT TO FIRST
1563 JUMPN D,IGRTP3 ; JUMP IF RTUPLE NOT MRETURN
1564 TLZE C,$QSFRB ; SEG CALL
1565 AOJA C,IGRTP3 ; YES, SKIP RETURN WITH STUFF ON STACK
1566 MOVE B,@C ; THIS KLUDGE SEES IF WE CAN STEP TO
1567 ; NEXT FRAME FOR THIS MRETURN
1568 CAMN B,[JRST @<RETOFF+ENTVEC>] ; IS IT A RETURN
1570 JUMPE O1,COMPER ; MUST HAVE AT LEAST ONE ARG
1571 DMOVE A,1(O2) ; RET 1ST ELEMENT
1575 IGRTP3: JUMPE O1,IGRTP1
1576 IGRTP2: PUSH E,1(O2)
1582 JUMPE D,IGRTP4 ; IF MRET, RET # OF ARGS
1590 SUBTTL CODE TO TRY TO MAP IN A FROB
1593 SBFPMP: MOVE R,1(M) ;pointer to pcode
1597 SBFPM1: PUSH TP,$TFIX
1607 DMAPIN: PUSH P,D ; NOT THERE, MAP IT IN
1609 IFE FLIP, PUSH P,NARGS
1611 PUSH P,@[MIMSEC,,NARGS]
1612 PUSH P,@[MIMSEC+1,,NARGS]
1615 IFE FLIP, POP P,NARGS
1617 POP P,@[MIMSEC+1,,NARGS]
1618 POP P,@[MIMSEC,,NARGS]
1624 DMAPI1: PUSH P,PC ; NOT THERE, MAP IT IN
1626 PUSH TP,A ; SAVE RET VAL
1635 MAPIN: SKIPN O1,MPATM ; HAVE WE BEEN SUPPLIED WITH ATOM?
1637 JSP PC,FRAME ; CREATE A FRAME
1638 PUSH TP,(M) ; CALL WITH THE PURVE PNTR OF INTEREST
1640 MOVEI O2,1 ; ONE ARG
1641 JSP PC,CALLZ ; GO FOR IT
1642 MOVE R,1(M) ; SET UP R NOW
1643 SKIPN R,PV%OFF(R) ; FROM THE VECTOR
1655 CIGVL: SKIPN B,@(TP)
1658 FOOADJ: ADJSP TP,-8.
1665 HRROI A,[ASCIZ /MIMI20 Not Running
1672 ; GET THE NEXT ELEMENT ON THE STACK. POINTER INTO THE STACK
1673 ; IS THE ARGUMENT (LOCAL). RETURNS AN OBJECT, OR A #UNBOUND -1
1674 ; IF THERE IS NOTHING ELSE ON THE STACK
1679 IRP %A,,[RCLOFF,RCLVOF,RCLV2O,RCLV3O,RCLV4O,RCLV7O,RCLV8O
1681 SETZM %A(B) ; THIS IS THE START OF A GC
1682 TERMIN ; SO RELEASE EVERYTHING
1685 ; SETOM INGC ; DONT PERMIT INTERRUPTS
1688 TRNE B,$FRMDOPE ; IS THIS A RECORD DOPE WORD?
1689 JRST [CAIN B,$TTUPLE+$FRMDOPE
1691 LDB A,[000300,,B] ; GET SAT
1692 CAIE A,$PRECORD ; RECORD?
1693 JRST INEXT6 ; NO, SKIP IT (STACK STRUCTURE)
1694 LDB B,[RTYBYT,,B] ; YES. GET RECORD TYPE
1696 MOVE B,@RECTBL+1(B) ; GET LENGTH FROM TABLE
1697 LSH B,-1 ; DIVIDE BY TWO FOR 36-BIT WORDS
1698 ADDI O1,1(B) ; ADD ONE FOR HEADER WORD
1699 JRST INEXT5] ; REENTER CODE
1700 INEXT3: ADDI O1,2 ; POINT TO NEXT ELEMENT
1701 INEXT5: XMOVEI B,(TP) ; ARE WE DONE YET?
1703 JRST [MOVEI B,0 ; YUP
1706 JUMPL B,[ADDI O1,3 ; SKIP PSEUDO-FRAME
1707 JRST INEXT5] ; TRY THAT
1710 JRST [ LDB A,[000300,,B]
1716 INEXT7: SKIPN 1(O1) ; DONT RETURN 0 POINTER
1717 JRST [ CAIE B,$TBIND+$FRMDOPE
1721 INEXT1: MOVE A,$WFIX
1725 JRST INEXT5 ; SKIP STRUCTURE, TRY AGAIN
1727 CONTEN: DMOVE A,(O1) ; GET THE PAIR FROM THE STACK
1728 TLZE A,$FRMDOPE ; IS THE TYPE-WORD A DOPE WORD?
1729 XMOVEI B,1(O1) ; POINT PAST THE DOPE WORD
1730 JRST (PC) ; RETURN RECORD POINTER
1733 SUBTTL TYPE MANIPULATION
1735 NEWTYP: LDB B,[300,,O1] ; GET PRIMTYPE BITS
1736 MOVE A,$WTCNT ; GET TYPE COUNT
1738 CAIL A,1024. ; MAX NUMBER
1739 PUSHJ P,COMPER ; DIE
1740 DPB A,[61300,,B] ; STUFF NEW TYPE CODE
1741 MOVE A,$WFIX ; AND RETURN IT
1744 ; TYPEW - build a type word O1/ type-code O2/ type-code of prim
1746 TYPEW: LDB B,[600,,O2]
1753 MOVE O2,RECTBL+1(O2) ; GET POINTER TO RECORD TABLE
1754 HRRZ B,(O2) ; GET LENGTH FROM TABLE
1758 ; Add user template information to internal record table"
1764 XRECOR: SUBM R,(P) ; RELATIVIZE PC IN CASE OF GC
1771 MOVE D,C ; CHANGED BY MARC (BAD DOPE WORD)
1772 ADD C,A ; POINT TO DW
1776 TLNN 0,$GC%DW ; SKIP IF NO DW
1783 ADD B,[657777,,-1] ; MAKE GLOBAL BP
1789 SUBTTL STRUCTURE CREATION
1792 SETZ B, ; INITIALIZE CDR
1793 LISTL: SOJL O1,LISTE ; LOOP UNTIL DONE
1797 PUSHJ P,ICELL ; GET A CELL IN 'A'
1800 POP TP,2(A) ; POP VALUE
1801 POP TP,1(A) ; AND TYPE/LENGTH INTO CELL
1803 MOVE B,A ; UPDATE CDR POINTER
1804 JRST LISTL ; AND LOOP
1806 LISTE: MOVE A,$WLIST ; TYPE-WORD LIST
1811 JRST COMPER ; either negative of too big
1819 HRR O1,O2 ; MAKE TYPE WORD (WRONG FOR STRING, BYTES)
1823 SUBM TP,D ; POINT D AT FIRST ELEMENT
1836 PUSH P,A ; PUT # WORDS WHERE EXPECTED
1846 ; COUNT IS IN O2; POINTER IN D. RETURN COUNT IN A; CAN CLOBBER D.
1852 STRCLP: LDB C,[220304,,1]
1853 JUMPN C,STRCST ; A CHARACTER
1856 ADD A,C ; LENGTH OF STRING/BYTES
1863 ; BYTE POINTER IN B, ARG POINTER IN D, ARG COUNT IN O2, A IS SACRED
1864 ; (BYTE POINTER IS (A)).
1865 STRMOV: LDB C,[220304,,1] ; SAT OF THING IN 1(D)
1868 IDPB C,B ; STUFF OUT A BYTE
1880 DOSTR: ADJSP P,3 ; SPACE FOR EXTRA STUFF
1881 PUSH P,A ; BYTES/WORD
1882 PUSH P,B ; FROB TO MAKE LOCAL BYTE POINTER
1883 PUSH P,C ; FROB TO MAKE GLOBAL BP WHEN DONE
1886 HRR O1,A ; FIX UP SAVED TYPE WORD
1888 SUBI A,1 ; ROUND UP TO NEXT FULL WORD
1890 MOVEM A,-6(P) ; # OF WORDS FOR FROB
1894 JSP PC,IBLOCK ; GET STORAGE
1899 MOVEM 0,-3(P) ; SAVE ADDRESS AND FLAGS
1900 MOVE B,-1(P) ; ARGUMENT FROM B
1901 TLO B,1 ; MAKE BP (A)
1902 JUMPE O2,STRMDN ; OBVIOUSLY EMPTY?
1906 STRMDN: MOVE 0,-3(P) ; FLAGS
1907 MOVE B,-4(P) ; ADDRESS
1908 MOVE C,-5(P) ; # WORDS
1909 ADD C,B ; POINT TO DOPE WORDS
1910 ADD B,(P) ; GLOBAL BP
1911 ADJSP P,-5 ; FLUSH ALL BUT # OF WORDS
1912 POP P,A ; VALUES IN A,B,C
1915 UBLR: POP P,B ; TP BECOMES PLACE OF FIRST ARG.
1916 MOVE C,(P) ; # OF WORDS IN THE UBLOCK
1918 UBLR1: POP P,D ; # OF WORDS
1919 TLNN 0,$GC%DW ; MAYBE STUFF INTO DOPE WORDS
1921 MOVE D,O1 ; OTHER HALF OF DOPE WORD
1933 UBLU: MOVE A,O2 ; GET # ARGUMENTS
1935 ADDI A,2 ; ADD DOPE WORDS
1939 JSP PC,IBLOCK ; GET CORE
1943 PUSH P,A ; SAVE LOCATION
1949 SOJN O2,UBLUL ; AND LOOP
1952 UBLV: MOVE A,O2 ; GET # ARGUMENTS
1953 LSH A,1 ; 2 36-BIT WORDS FOR EACH
1955 ADDI A,2 ; ADD DOPE WORDS
1959 JSP PC,IBLOCK ; GET CORE
1963 PUSH P,A ; SAVE LOCATION
1964 JUMPE O2,UBLR ; CHOMPING EMPTY VECTOR
1968 MOVEM B,1(A) ; STUFF
1971 SOJN O2,UBLVL ; AND LOOP
1974 ; RETURN UNINITIALIZED STORAGE. ARGS JUST LIKE UBLOCK (O1 TYPE, O2 # ELEMENTS),
1975 ; BUT NOTHING ON STACK.
1978 JRST COMPER ; either negative or too big!
1980 SUBM R,(P) ; IN CASE OF GC
1981 LDB A,[220200,,O1] ; GET TYPE
1982 JRST @UUBLTB(A) ; TYPE DISPATCH
1989 JRST UUBLS1 ; LIKE STRING, WITH 4 BYTES/WORD
1991 UUBLS1: MOVE B,O2 ; # OF ELEMENTS
1992 ADDI B,-1(A) ; ROUND UP
1993 IDIV B,A ; # OF WORDS NEEDED
1994 PUSHJ P,UIB ; BUILD THE STORAGE
1996 CAME O1,[$TSTRING,,0]
1998 ADD B,C ; MAKE A BYTE POINTER
2007 PUSHJ P,CLRVEC ; THIS HAS TO BE ZEROED
2009 ; TYPE IN O1, LENGTH IN O2, # WORDS (EXCLUSIVE OF DW) IN B. RETURN
2010 ; POINTER IN A, B (SOMEBODY ELSE MAKES BYTE POINTER FOR STRINGS, BYTES
2011 UIB: CAILE B,777000-2 ;length better be less than a section
2016 MOVEI A,2(B) ; # WORDS, WITH DW
2017 JSP PC,IBLOCK ; GET THE STORAGE
2022 ADD B,(P) ; POINT AT DOPE WORDS
2035 ; BUILD STACK STRUCTURES. O1 IS TYPE WORD, O2 IS # ELTS.
2036 SBLOCK: TLNE O2,-1 ; skip if not negative or too big
2041 SUBM TP,D ; POINT AT FIRST ARGUMENT (-1)
2042 LDB A,[220200,,O1] ; GET LOW BITS OF SAT
2049 SBVEC: EXCH O1,O2 ; THIS IS ALMOST LIKE TUPLE
2054 MOVE A,O1 ; TYPE WORD
2055 TLO O1,$FRMDOPE ; DOPE WORD
2056 MOVEM O1,1(D) ; STUFF OUT FIRST DOPE WORD
2058 MOVE B,C ; SAVE POINTER
2060 SBUVCL: MOVE E,2(D) ; PICK UP A FROB
2061 MOVEM E,(C) ; STUFF IT OUT
2062 ADDI D,2 ; UPDATE POINTER TO SOURCE
2063 ADDI C,1 ; AND TO DEST
2064 SOJG O2,SBUVCL ; JUMP IF NOT DONE
2065 SBUVCD: MOVEM O1,(C) ; OTHER DOPE WORD
2066 MOVE TP,C ; UPDATE STACK
2069 ; STACK BYTES AND STRINGS. D STILL HAS POINTER TO FIRST ARGUMENT
2088 PUSHJ P,STRCNT ; GET LENGTH OF NEW STRING INTO A
2092 IDIV A,-4(P) ; # WORDS FOR STRING
2093 HRR O1,A ; SAVE FOR DOPE WORDS
2094 ADDI A,2 ; PLUS DOPE
2095 TLO O1,$FRMDOPE ; MAKE IT A DOPE WORD
2097 LSH B,1 ; WORDS OF ARGUMENT
2098 MOVE C,-1(P) ; BEGINNING OF BLOCK, ALMOST
2099 ADDI C,1 ; REAL BEGINNING OF BLOCK
2100 PUSH P,C ; WHICH WILL BE LOC OF 1ST DOPE WORD
2102 CAML A,B ; ENSURE NO BACKWARDS BLT PROBLEMS
2106 SSBCNT: MOVEM D,-2(P) ; SAVE IT
2107 XBLT B, ; BLT THE ARGS DOWN THE STACK
2108 POP P,A ; GET POINTER TO STACK AREA WE'RE USING
2109 MOVEM O1,(A) ; DUMP OUT FIRST DW
2111 PUSH P,A ; SAVE ADDRESS OF RESULT
2112 MOVE B,-4(P) ; LOCAL BYTE POINTER
2113 TLO B,1 ; MAKE IT BE (A)
2117 SUBI D,1 ; SHOULD POINT BEFORE ARG BLOCK
2118 PUSHJ P,STRMOV ; COPY THE STUFF IN
2119 SSBNOM: MOVE B,(P) ; RESULT POINTER
2121 ADDI B,(C) ; POINT TO LAST DOPE WORD
2122 MOVEM O1,(B) ; STUFF OUT DOPE WORD
2132 ; RETURN UNINITIALIZED STORAGE ON STACK. O1 IS TYPE WORD, O2 IS # ELTS.
2133 ; SAVE ACS EXCEPT A AND B.
2136 JRST COMPER ; either negative or too big
2145 USBYT: MOVEI A,3(O2)
2146 IDIVI A,4 ; # WORDS, EXCLUDING DOPE WORDS
2159 USSTR: MOVEI A,4(O2)
2171 USUVC: MOVE C,O1 ; MAKE A DOPE WORD
2173 HRRI C,(O2) ; # ELTS + 2 FOR DOPE WORD
2174 PUSH TP,C ; PUSH HEADER DOPE WORD
2175 XMOVEI B,1(TP) ; SAVE POINTER
2176 ADJSP TP,(O2) ; CREATE SPACE
2177 PUSH TP,C ; PUSH TRAILER DOPE WORD
2201 HRRZ C,A ; GET LENGTH IN WORDS
2203 SUBI C,1 ; LESS FIRST WORD
2204 SETZM (B) ; CLEAR FIRST WORD
2205 MOVE D,B ; SOURCE BLOCK
2206 XMOVEI E,1(B) ; DEST BLOCK
2219 RECORR: LDB A,[301200,,O1]
2221 MOVE A,RECTBL+1(A) ; GET POINTER TO RECORD TABLE
2222 ADDI A,1 ; POINT TO FIRST ENTRY
2223 PUSH P,O1 ; SAVE TYPE WORD FOR RETURN
2224 PUSH P,A ; SAVE POINTER TO TABLE
2228 ; HRRZ A,-1(A) ; GET # 1/2 WORDS NEEDED FOR RECORD
2230 ; THE SEMI'ED LINES ABOVE ARE CHANGED TO THE TWO FOLLOWING
2231 ; SHOULD CHANGE THE LENGTH FIELD OF RECORDS TO BE 'RIGHT'
2232 ; I.E. THE NUMBER OF 1/2 WORDS IN THE RECORD
2238 PUSH P,A ; SAVE THIS FOR A MOMENT
2239 ADDI A,2 ; ADD FOR DOPE WORDS
2242 JSP PC,IBLOCK ; HERE THEY ARE
2245 MOVE C,A ; HOLD ON TO RECORD POINTER
2246 ADD A,(P) ; POINT TO THE DOPE WORD
2247 POP P,B ; HERE'S THE # WORDS AGAIN
2249 JRST [TLO O1,$DOPEBIT ; SET THE DOPEWORD BIT
2250 HLLM O1,(A) ; PUT TYPE WORD IN DOPES
2251 HRRM B,(A) ; STORE IT IN DOPE WORD
2254 POP P,A ; RESTORE TABLE POINTER
2255 PUSH P,C ; SAVE POINTER TO RECORD FOR RETURN
2257 MOVSI C,222200+D ; MAKE BP TO RECORD
2258 MOVE E,O2 ; GET COUNT OF ELEMENTS
2259 LSH E,1 ; 2 WORDS PER ELEMENT
2261 SUBM TP,E ; E POINTS TO FIRST ARG
2263 RECORL: HLRZ C,1(A) ; BYTE OFFSET
2264 ADJBP C,[222200+D,,0]
2265 HRRZ B,1(A) ; SIZE OF THIS ELEMENT IN RECORD
2266 PUSHJ P,@PUTRTB-1(B) ; DO A 'PUTR'
2267 ADDI A,2 ; ADVANCE POINTER IN TABLE
2268 ADDI E,2 ; ADVANCE POINTER TO ELEMENT
2269 SOJN O2,RECORL ; LOOP UNTIL DONE
2272 ADJSP TP,(D) ; RESTORE TP
2273 POP P,B ; RESTORE VALUE WORD (POINTER)
2274 POP P,A ; RESTORE TYPE/LENGTH WORD
2278 SUBTTL STRUCTURE MANIPULATION
2280 NTHU: LDB A,[UPTBYT,,A] ; TYPE IN A, PTR IN O1, NUM IN O2
2314 SKIPN A,RECTBL+1(A) ; AND POINTER TO TABLE
2316 LSH O2,1 ; 4 16-BIT WORDS / ENTRY
2317 ADDI A,-1(O2) ; POINT TO CORRECT ENTRY
2318 HRRZ B,1(A) ; GET SIZE OF ITEM TO EXTRACT
2319 HLRZ C,1(A) ; WORD OFFSET TO START FROM
2320 MOVE O2,O1 ; COPY IN CASE MULTI SECT
2321 ; HRLI O1,222240 ; MAKE WORK IN MULTI SECT
2323 ADJBP C,O1 ; MAKE BYTE POINTER TO ITEM
2324 ; IN MULTI SECT, C & D ARE BPTR
2325 JRST @NTHRTB-1(B) ; DISPATCH
2327 NTHRTB: SETZ NTHRBB ; BOOLEAN
2328 SETZ NTHRE ; ERROR - SHOULDN'T HAPPEN
2329 SETZ NTHRBB ; ENUMERATION
2330 SETZ NTHRBB ; SUB-RANGE
2331 SETZ NTHRBB ; SUB-RANGE (SBOOL)
2332 SETZ NTHRLF ; LIST OR FIX
2333 SETZ NTHRLF ; LIST OR FIX (SBOOL)
2334 SETZ NTHRS3 ; STRUC IN 3 HALF WORDS
2335 SETZ NTHRS3 ; SAME WITH SBOOL
2336 SETZ NTHRS2 ; STRUC WITH DEFINED LENGTH
2337 SETZ NTHRS2 ; SAME SBOOL
2339 SETZ NTHRHW ; SPECIAL TYPE-C CASE
2341 ; HERE TO EXTRACT A BOOLEAN
2343 NTHRBB: LDB B,C ; GET WORD OF BOOLEANS
2344 LSH B,18. ; SHIFT OVER
2345 ILDB C,C ; GET NEXT 16 BITS
2346 IOR B,C ; THEN OR THEM TOGETHER
2347 LDB C,[111100,,(A)] ; GET LEFT SHIFT
2348 LSH B,(C) ; SHIFT IT
2349 LDB C,[001100,,(A)] ; GET RIGHT SHIFT
2351 LSH B,(C) ; SHIFT RIGHT
2357 NTHRE: PUSHJ P,COMPER
2359 ; HERE TO EXTRACT LIST OR FIX
2361 NTHRLF: HLLZ A,(A) ; GET TYPE/LENGTH FROM TABLE
2362 LDB B,C ; GET VALUE BYTE
2363 LSH B,18. ; SHIFT OVER
2364 ILDB C,C ; GET NEXT 16 BITS
2365 IOR B,C ; THEN OR THEM TOGETHER
2368 ; HERE TO EXTRACT 2-WORD ITEM
2370 NTHRS3: HLLZ A,(A) ; GET TYPE/LENGTH FROM TABLE
2371 LDB 0,C ; LOAD FIRST 16 BITS
2372 ILDB B,C ; GET NEXT 16 BITS
2373 LSH B,18. ; SHIFT OVER
2374 ILDB C,C ; GET NEXT 16 BITS
2375 IOR B,C ; THEN OR THEM TOGETHER
2377 NTHRX: JUMPN B,CPOPJ
2381 ; HERE TO EXTRACT STRUC WITH KNOWN LENGTH ITEM
2383 NTHRS2: LDB B,C ; GET LENGTH WORD
2384 LSH B,18. ; SHIFT OVER
2385 ILDB C,C ; GET NEXT 16 BITS
2386 IOR B,C ; THEN OR THEM TOGETHER
2387 MOVE A,(A) ; GET TYPE WORD FROM TABLE
2388 ILDB C ; FIX POINTER (SHOULD BE IBP)
2391 ; HERE TO EXTRACT 4-WORD ITEM (ANY)
2393 NTHRA: LDB B,C ; GET TYPE WORD
2395 ILDB A,C ; GET LENGTH WORD
2396 IOR A,B ; PUT EM TOGETHER
2397 ILDB B,C ; LOAD FIRST 16 BITS
2398 LSH B,18. ; SHIFT OVER
2399 ILDB C,C ; GET NEXT 16 BITS
2400 IOR B,C ; THEN OR THEM TOGETHER
2403 NTHRHW: LDB B,C ; GET POSSIBLE TYPE CODE
2408 HLLZ A,(A) ; TYPE FROM TABLE
2411 PUTU: LDB A,[UPTBYT,,A]
2423 PUTUU: ADDI B,-1(O2)
2434 SKIPN A,RECTBL+1(A) ; AND POINTER TO TABLE
2436 PUSH TP,(D) ; SAVE VALUE
2438 LSH O2,1 ; 4 16-BIT WORDS / ENTRY
2439 ADDI A,-1(O2) ; POINT TO CORRECT ENTRY (REMEMBER TOP)
2440 HRRZ B,1(A) ; GET SIZE OF ITEM TO EXTRACT
2441 HLRZ C,1(A) ; WORD OFFSET TO START FROM
2443 XMOVEI E,-1(TP) ; SEND VALUE IN E
2446 ADJBP C,O1 ; MAKE BYTE POINTER TO ITEM
2447 PUSHJ P,@PUTRTB-1(B) ; DISPATCH
2451 PUTRTB: SETZ PUTRBB ; BOOLEAN
2452 SETZ PUTRE ; ERROR - SHOULDN'T HAPPEN
2453 SETZ PUTRBB ; ENUMERATION
2454 SETZ PUTRBB ; SUB-RANGE
2455 SETZ PUTRBB ; SUB-RANGE (SBOOL)
2456 SETZ PUTRLF ; LIST OR FIX
2457 SETZ PUTRLF ; LIST OR FIX (SBOOL)
2458 SETZ PUTRS3 ; STRUC IN 3 HALF WORDS
2459 SETZ PUTRS3 ; SAME WITH SBOOL
2460 SETZ PUTRS2 ; STRUC WITH DEFINED LENGTH
2461 SETZ PUTRS2 ; SAME SBOOL
2463 SETZ PUTRHW ; SPECIAL CASE FOR TYPE-C
2465 ; HERE TO SET A BOOLEAN
2467 PUTRBB: LDB 0,[111100,,(A)] ; GET LSHIFT
2468 LDB A,[001100,,(A)] ; GET RSHIFT
2471 LSH B,30. ; BUILD BYTE POINTER
2475 IOR 0,B ; HAVE LH OF BYTE POINTER
2480 HRRI 0,A ; POINT TO AC
2481 MOVE B,1(E) ; NEW VAL
2482 DPB B,0 ; SMASH REGISTER
2483 DPB A,C ; PUT IT BACK
2485 ADJBP B,C ; SMASH OTHER BYTE
2487 DPB A,B ; OTHER HALF BACK IN
2491 PUTRE: PUSHJ P,COMPER
2493 PUTRLF: LDB B,[LH,,1(E)] ; GET LH OF VALUE OF 3RD ARG
2495 LDB B,[RH,,1(E)] ; GET RH OF VALUE OF 3RD ARG
2496 IDPB B,C ; AND STUFF
2499 PUTRS2: HLRZ B,(E) ; TYPE OF ARG
2501 SETZM 1(E) ; MAKE SURE 0
2504 ; HERE FOR 3 WORD ITEM (IE LENGTH AND POINTER)
2506 PUTRS3: LDB B,[LENWRD,,(E)] ; GET LENGTH
2508 ILDB C ; FIX POINTER (SHOULD BE IBP)
2511 ; HERE TO SET 4-WORD ITEM (ANY)
2513 PUTRA: LDB B,[TYPWRD,,(E)] ; GET TYPE
2514 DPB B,C ; AND STUFF IT
2520 PUTRHW: LDB B,[TYPWRD,,(E)] ; TYPE OF ARG
2521 CAIE B,$TFALSE ; FALSE ==> ZERO SLOT
2522 SKIPA B,1(E) ; NOT FALSE USE TYPEC
2528 RESTU: LDB C,[UPTBYT,,A]
2558 ; HRLI A,$TTUPLE ; Win with tuples???
2578 TOPUS1: ADJBP C,B ; ADJUST TO THE END
2581 SUBI C,(D) ; # BYTES UNUSED IN LAST WORD
2582 TLZ B,770000 ; MAKE WORD POINTER
2583 HRRZ A,1(B) ; THIS IS TOTAL LENGTH (FROM DOPE)
2584 SUB B,A ; TO WORD ADDRESS OF STRING START
2587 TLO B,(D) ; MAKE CORRECT GLOBAL BP
2588 ADD A,C ; ADJUST LENGTH
2589 HLL A,0 ; MAKE A TYPE WORD
2592 TOPUU: ADD B,C ; POINT TO DOPE WORD
2593 HRRZ A,(B) ; GET TOTAL LENGTH
2594 SUB B,A ; BACK IT UP
2595 HRLI A,$TUVECTOR ; HERE'S THE TYPE WORD
2599 ADD B,C ; POINT TO DOPE WORD
2600 HRRZ A,(B) ; HERE IS TOTAL LENGTH
2601 SUB B,A ; POINTS TO TOP OF VECTOR
2602 LSH A,-1 ; GET LENGTH
2603 HRLI A,$TVECTOR ; AND FINISH TYPE WORD
2606 ; HERE FOR CONS NEEDING GC
2613 PUSH TP,E ; IN CASE A GC OCCURS
2625 SUBTTL INPUT / OUTPUT
2634 PUSHJ P,OPNAM ; MAKE FILE NAME STRING
2636 XCT GTJMOD(O1) ; PERFORM GTJFN BITS MAGIC
2641 XCT OPNMOD(O1) ; PERFORM OPENF BITS MAGIC
2644 MOVE B,$WFIX ; RETURN JFN NUMBER
2648 OPNAM: MOVE B,[440700,,FNBLK] ; BP TO FILE NAME BLOCK
2650 OPNAML: ILDB 0,E ; GET CHARACTER
2651 IDPB 0,B ; AND STUFF IT
2652 SOJN C,OPNAML ; LOOP UNTIL DONE
2654 IDPB 0,B ; MAKE IT ASCIZ
2657 GTJMOD: MOVSI A,(GJ%SHT+GJ%OLD)
2658 MOVSI A,(GJ%SHT+GJ%FOU)
2662 OPNMOD: HRRI B,OF%RD
2667 CLOSEX: CLOSF ; ATTEMPT TO CLOSE JFN
2669 MOVE A,$WFIX ; RETURNS 1 IF WINNING
2680 TDNN B,[770000,,003777]
2681 JRST ATIC ; TRY different char
2684 JUMPL O1,ATICDN ; If not a char, don't do ATI
2687 CAIN O1,7 ; store channel for ^G and ^A
2692 ATICDN: MOVE A,$WFIX
2696 RETERR: PUSH P,A ; SAVE ERROR CODE
2697 PUSHJ P,ICELL ; GET A LIST CELL
2698 MOVE B,$WFIX ; STUFF THE CELL WITH ERROR CODE
2703 MOVE A,$WFALSE ; AND RETURN AS FALSE
2707 MOVEI A,400000 ; GET ERROR
2710 PUSHJ P,RETERR ; CONS IT UP
2712 JRST CMPER2 ; GO GIVE IT TO USER
2714 ; Return run time of process, in seconds, as float
2730 MOVEM OP,.RDRTY+IRDBLK ; SET UP PROMPT
2732 PUSH TP,$WFALSE ; SAVE IF NO PROMPT
2735 READX1: MOVEI D,1 ; OTHERWISE, GET LENGTH, SAVE STRING
2739 READX2: HRLI D,$TSTRING
2741 PUSH TP,.RDRTY+IRDBLK
2742 READX4: MOVEI C,IRDBRK
2743 MOVEM C,.RDBRK+IRDBLK ; SETUP BREAK MASK
2749 MOVE C,[ARDBRK,,ARDBRK+1]
2752 MOVEM C,.RDBRK+IRDBLK
2753 SKIPA C,[4] ; Turn on ctrl-D
2762 READNM: MOVE C,-1(P)
2764 HRLM A,.RDIOJ+IRDBLK ; INPUT JFN
2765 MOVEM B,.RDBFP+IRDBLK ; DESTINATION BUFFER POINTER
2766 MOVEM B,.RDBKL+IRDBLK ; BACKUP LIMIT
2767 SUB C,D ; GET LENGTH OF STRING
2768 MOVEM C,.RDDBC+IRDBLK ; AND SUBTRACT CHRS ALREADY READ
2769 ADJBP D,B ; ADJUST STRING FOR CHRS ALREADY READ
2770 MOVEM D,.RDDBP+IRDBLK ; DESTINATION STRING
2774 HRRM C,.RDIOJ+IRDBLK
2776 PUSH TP,IRDBLK+.RDIOJ
2777 MOVE C,-1(P) ; STRING LENGTH
2780 PUSH TP,IRDBLK+.RDBFP
2781 MOVE C,IRDBLK+.RDBRK
2790 ADJSP P,-2 ; NOW NOTHING ON P STACK
2791 BRESTA: MOVEI A,IRDBLK
2794 ; This now has a giant kludge to make ctrl-D redisplay the buffer without
2795 ; clearing the screen.
2796 LDB B,.RDDBP+IRDBLK ; Look at last character read
2799 HRRZ A,.RDIOJ+IRDBLK ; Yes, pick up output jfn to use
2800 MOVEI B,^M ; do crlf
2804 SKIPN B,.RDRTY+IRDBLK
2807 SOUT ; Output prompt
2808 NOPRMP: MOVE B,.RDBFP+IRDBLK ; pick up pointer to buffer beginning
2809 HRRZ C,-11(TP) ; ORIGINAL LENGTH OF BUFFER
2810 AOS .RDDBC+IRDBLK ; ADD 1 TO CHARS AVAILABLE
2811 SUB C,.RDDBC+IRDBLK ; REAL NUMBER CHARS IN BUFFER
2812 MOVNS C ; - # CHARS IN BUFFER
2813 SKIPE C ; don't print if none there
2815 MOVEM B,.RDDBP+IRDBLK ; update dest string pointer
2817 JRST BRESTA ; try again
2819 DTEXTI: HRRZ B,-11(TP) ; GET ORIGINAL LENGTH
2820 SUB B,.RDDBC+IRDBLK ; FIXUP COUNT
2822 ADJSP TP,-20 ; EIGHT THINGS PUSHED ON STACK
2825 SOUTX: SKIPA O1,[SOUT]
2837 MOVEI O2,0 ; INDICATE FAILURE
2845 PUSH P,0 ; SAVE TYPE OF FROB
2851 JUMP 16,[ MOVEI O2,0
2855 LDB E,[360600,,B] ; GET BYTE PART
2856 LDB A,[360600,,-1(P)] ; OF BOTH
2858 MOVE C,B ; COPY POINTER
2859 TLZ C,770000 ; JUST WORD POINTER
2860 POP P,A ; GET ORIGINAL COUNT WORD
2861 POP P,D ; AND ORIG PNTR
2869 SUBI A,(C) ; AND FIX IT
2870 SINXXX: SKIPE O2 ; IF ERROR, SKIP
2875 MOVEI A,400000 ; GET ERROR
2877 MOVEI A,(B) ; ERROR TO A
2878 CAIN A,IOX4 ; IS THIS EOF
2879 JRST [ POP TP,B ; yes just return rested string
2882 PUSH TP,$WFIX ; save SIN/SOUT and JFN
2887 PUSH TP,0 ;relativized ret PC
2890 PUSHJ P,RETERR ; cons up error code
2893 PUSHJ P,ICELL ; include buffer in false
2899 SKIPN O1,ECATM ; call error-in compiled code handler
2906 MOVE PC,(TP) ; returned from error, try i/o again
2909 MOVE O1,-2(TP) ; unrelativized PC to stack
2910 DMOVE A,-5(TP) ; buffer back
2919 GTJFNX: TLNN A,(GJ%FNS) ; STRING ARG?
2921 PUSHJ P,OPNAM ; FORCE ASCIZ IN THIS SECTION
2930 JFNSX: CAIGE A,177 ; SKIP IF JFNSing to a string
2931 JUMPGE A,[ JFNS ; DO IT
2939 JUMP 16,JFSERR ; LOSE...
2942 MOVE C,[440700,,FNBLK]
2947 IDPB 0,E ; MOVE CHARS
2948 CAMN C,A ; ARE WE DONE
2952 MOVNS B ; RETURN NEGATIVE LENGTH
2953 JFNSM: MOVSI A,$TFIX
2956 JFSERR: MOVEI A,400000 ; GET ERROR
2958 MOVEI A,(B) ; ERROR TO A
2961 ERSTRX: CAIG A,177 ; SKIP IF TO STRING
2968 MOVE O2,A ; SAVE ORG STR PNTR
2973 LDB B,[360600,,A] ; GET BYTE PART
2988 ; do long form GTJFN
2990 GTJFNL: MOVNI A,(O1) ; FIND BASE OF ARGS
2992 MOVE O2,TP ; COPY STACK POINTER
2993 ADJSP O2,(A) ; POINT TO FIRS ARG
2994 MOVE B,[440700,,FNBLK] ; FOR COPIED STRINGS
2995 MOVEI A,GTJFBK ; POINT TO ARG BLOCK
2999 GTJFLP: HLRZ 0,1(O2)
3000 CAIE 0,$TSTRING ; STRING
3001 JRST [ MOVE 0,2(O2) ; NO GET FIX
3002 MOVEM 0,(A) ; INTO BLOCK
3005 HRRZ C,1(O2) ; STRING LENGTH
3008 MOVEM B,(A) ; STORE BYTE POINTER
3009 MOVE E,2(O2) ; STR PNTR
3010 PUSHJ P,OPNAML ; FORCE ASCIZ IN THIS SECTION
3011 GTJFNA: ADJSP O2,2 ; NEXT ARG
3018 GTJFN ; DO THE GTJFN
3019 JUMP 16,GTERR ; ERROR
3028 MOVE D,.GJCPP+.GJCPP+4(TP)
3029 HRRZ C,.GJCPP+.GJCPP+3(TP)
3040 ; MOVED TO PAGE ZERO SO EXCESSIBLE FROM ALL SECTIONS
3042 ; RD%BRK+RD%JFN ; JFNS COMING
3043 ; .PRIOU ; FOR EDITING
3044 ; 0 ; DESTINATION STRING
3048 ; IRDBRK ; FOR FUTURE EXPANSION
3065 SUBTTL LVAL MANIPULATION
3067 ;ILVAL RECEIVES ATOM IN IN O1
3069 ILVAL: SKIPN O2,1(O1) ;SEE IF BINDING
3071 MOVE 0,7(O2) ; GET BINDID
3072 CAME 0,BINDID ; SKIP IF OK
3074 DMOVE A,(O2) ; GET VALUE
3075 JUMPN A,(PC) ; RETURN IF BOUND
3077 JSP PC,FRAME ; Have binding with no value
3078 PUSH TP,[$TATOM,,$LATOM] ; So strictly error case of EICC
3081 MOVE O1,ECATM ; ERROR IN COMPILED CRUFT...
3085 ILVAL1: MOVE A,PC ; SAVE PC
3086 JSP PC,IASS ; SEE IF ASSIGNED AT ALL
3087 MOVEI O2,0 ; IF NOT , SO INDICATE
3089 JUMPE O2,ILVAL2 ; GENERATE ERROR
3093 ;IASS -- ASSIGNED? O1 IS ATOM, SKIP IF ASSIGNED?
3095 IASS: SKIPN O2,1(O1) ; BINDING PNTR?
3096 JRST (PC) ; NO, NO SKIP
3097 MOVE 0,7(O2) ; BIND ID?
3098 CAME 0,BINDID ; SKIP IF NO SEARCH
3100 IASS4: SKIPE (O2) ; BOUND?
3104 IASS1: MOVE O2,SP ; SEARCH
3105 IASS2: CAMN O1,2(O2) ; SKIP IF NOT IT
3106 JRST IASS4 ; CHECK VALUE OK
3107 SKIPE O2,5(O2) ; NEXT BINDING
3109 MOVE O2,TTBIND ; SAME THING FOR TOP BINDING
3110 IASS3: CAMN O1,2(O2)
3116 ;ISET -- RECEIVES ATOM IN O1 , NEW VAL IN A,B
3118 ISET: SKIPN O2,1(O1) ;SEE IF BINDING
3120 MOVE 0,7(O2) ; GET BINDID
3121 CAME 0,BINDID ; SKIP IF OK
3123 DMOVEM A,(O2) ; SET VALUE
3128 PUSH TP,[$TATOM,,$LATOM]
3133 MOVE O1,ECATM ; ERROR IN COMPILED CRUFT...
3137 ;MOVSTR - O1 FROM, O2 TO, O #CHARS
3139 MOVSTR: SKIPG C,0 ; make sure something to move
3140 JRST (PC) ; ret immediately
3141 MOVE A,O1 ; compute word addrs of strs
3144 ADJBP C,A ;C is end of from
3145 ADJBP E,D ;E is end of to
3146 TLZ O1,770000 ; clear byte pntr part, O1 start of from
3147 TLZ O2,770000 ; O2 start of to
3150 CAMG O1,E ; skip if start from is grtr than end to
3151 CAMLE O2,C ; dont skip if start of to is grt end from
3152 JRST NOOVER ; jump to use movestr instruction
3154 CAMN O1,O2 ; same word, check bp
3159 JRST MOVBAK ; must go backwards
3169 ADJBP O1,A ; point to last byte in both
3172 MOVBK1: LDB C,O1 ; move a byte
3174 ADJBP1: MOVNI A,1 ; now tediously backup the 2 bps
3176 TLNE A,770000 ; check for micro code bug
3183 TLNE A,770000 ; check for micro code bug
3191 ; here if strings dont overlap 0 & A & C are setup ok
3193 MOVSLJ==123000,,[016000,,]
3196 SETZB B,E ; superstition
3202 SUBTTL GARBAGE COLLECTION UTILITIES
3204 MARKR: CAMG B,[INIGC,,] ; DON'T MARK STACK OBJECTS
3208 ADD B,D ; MOVE TO DOPE WORD
3211 MARKU: LDB D,[UPTBYT,,A]
3231 MRKUX: MOVSI D,200000
3232 JUMPE C,[ANDCAM D,(B)
3235 MOVEM C,1(B) ; STORE RELOCATION
3245 ; HERE FOR MARK PREDICATE
3247 MKL: JUMPE B,[MOVEI B,1
3249 LDB B,[MARKBIT,,1(B)]
3250 JUMPE B,IMKL1 ; JUMP IF NOT MARKED
3251 MOVE B,(B) ; RETURN RELOCATION
3258 MKR: CAMG B,[INIGC,,] ; SAY IT'S MARKED IF ITS ON THE STACK
3262 ADD B,D ; MOVE TO DOPE WORD
3263 LDB B,[MARKBIT,,(B)] ; MUNG IT
3265 MOVE B,1(B) ; RELOCATED WITH OLD TYPE
3266 SUBI D,1(D) ; BACK TO TOP
3272 MKU: LDB C,[UPTBYT,,A]
3280 MKUS: ANDI A,-1 ; GET TO DW
3283 LDB B,[MARKBIT,,1(A)]
3297 LDB B,[MARKBIT,,(B)]
3305 ; SWEEP PHASE INSTRUCTIONS
3307 ; SWEEPNEXT - GIVEN IN O1 A POINTER TO GC SPACE, IN A A POINTER TO
3309 ; RETURNS A POINTER TO THE NEXT FROB IN GC SPACE
3321 MOVE A,-2(B) ; GET THE DOPE WORD
3322 TLZE A,$DOPEBIT ; IS THE DOPE BIT SET?
3323 JRST ISWVR ; YES. EITHER A UBLOCK OR RECORD
3324 SUBI B,3 ; NEXT FROB IS THREE BACK
3328 ISWVR: HRRZ D,A ; GET LENGTH
3329 SUBI B,2(D) ; FIND THE NEXT ONE
3330 LDB E,[PTPBYT,,A] ; GET THE TYPE WORD
3332 JRST [ADDI A,(A) ; RECORD DOPE WORD IS FULL WORDS (SIGH)
3334 CAIN E,$PVECTOR ; VECTOR DOPE WORD HAS TWICE LENGTH (SIGH)
3343 ; The byte pointers returned here are NOT standard--they are
3344 ; 440700,,x rather than 010700,,x-1. This works because everyone
3345 ; deals with them the adjbp and such; it avoids confusion in the
3346 ; sweep phase due to the x-1.
3347 ISWVRS: TLO B,610000 ; FIXUP STRING POINTER
3348 IMULI D,5 ; AND TYPE WORD
3349 HRR A,D ; SIGH. THIS SEEMS KLUDGY...
3351 ISWVRB: TLO B,540000
3357 XMOVEI C,-GCPOFF+IGCPR
3359 MOVE 0,RCLOFF(C) ; GET FREE LIST POINTER
3360 MOVEM 0,(B) ; CHAIN FREE LIST
3361 MOVEM B,RCLOFF(C) ; UPDATE FREE LIST POINTER
3373 RELU: LDB C,[UPTBYT,,A] ; GET THE PRIMTYPE
3374 JSP E,@RELUTB(C) ; POINT D AT THE DOPE WORDS
3375 JSP OP,RELB ; RECYCLE THE BLOCK OF STORAGE
3376 JRST (PC) ; DON'T WORK EITHER
3385 RELUS: HRRZ C,A ; GETLENGTH
3386 RELUSX: ADJBP C,B ; ADJUST TO THE END
3389 ADDI D,2 ; POINT TO SECOND DOPE WORD
3392 RELUU: HRRZ C,A ; GET LENGTH
3393 RELUX: MOVE D,B ; POINT TO UVECTOR
3394 ADDI D,1(C) ; POINT TO SECOND DOPE WORD
3397 RELUV: HRRZ C,A ; GET LENGTH
3398 LSH C,1 ; TIMES TWO FOR GOOD LUCK
3399 JRST RELUX ; REJOIN CODE
3402 ; set the current free storage zone (arg in A and B)
3403 ; if passed 0, return current, if current is zero, return gc params
3405 SETZON: JUMPN B,SETZN1 ; set it
3406 SKIPE B,CZONE ; get current if any
3407 JRST [MOVE A,[$TZONE,,7]
3411 MOVE A,[$TUVEC,,GCPL]
3415 ; SETZM INGC ; THIS TENDS TO HAPPEN AFTER A GC
3417 JRST [ HRROI A,[ASCIZ /OK int soon/]
3422 MOVEM B,@[MIMSEC,,CZONE]
3423 MOVEM B,@[MIMSEC+1,,CZONE]
3424 MOVE B,SECL(B) ; FIRST AREA
3425 MOVE B,@2(B) ; BOUND OF AREA
3426 TLNN B,1 ; ODD/EVEN CHECK
3433 STZSE2: HRLI TP,ODDSEC
3444 ; HERE IS THE BLOCK STORAGE RECYCLER
3445 ; D POINTS TO THE SECOND DOPE WORD OF THE FROB BEING RECYCLED
3447 ; RCL IS A LIST OF FREE CELLS
3454 RCLTB: PUSHJ P,COMPER ; ZERO LENGTH?
3455 PUSHJ P,COMPER ; ONE LENGTH?
3466 RELB: HRRZ E,-1(D) ; FIRST GET BLOCK LENGTH
3469 JRST RELB1 ; JUST DOPE WORDS
3471 SUBI B,-2(E) ; ZERO EVERYTHING EXCEPT DOPE WORDS
3476 RELB1: SKIPN B,CZONE
3477 XMOVEI B,-GCPOFF+IGCPR
3487 SKIPN A,(B) ; GET THE POINTER TO THE CHAIN
3492 MOVE A,B ; START FROM RCLV
3494 RECBL: MOVE B,(A) ; GET POINTER TO NEXT FREE BLOCK
3495 CAML B,D ; DOES IT GO HERE?
3496 JRST RECIN ; YES. INSERT IT
3498 MOVE A,B ; GO ON TO NEXT FREE BLOCK
3501 RECIN: TLZE OP,400000
3503 MOVE C,D ; GET POINTER TO OUR BLOCK
3504 SUB C,E ; BACK OFF TO THE TOP
3505 CAMN C,A ; DOES IT TOUCH PREVIOUS BLOCK?
3506 JFCL ; THIS GETS HAIRY. MORE CODE TO FOLLOW
3507 MOVE C,B ; GET CDR FOR THIS BLOCK
3508 HRRZ 0,-1(B) ; GET ITS LENGTH+2
3510 SUB C,0 ; SUBTRACT OFF THE BLOCK
3511 CAMN C,D ; DO WE TOUCH ON THE BOTTOM?
3512 JRST [ADDM E,-1(B) ; YES. SIMPLY UPDATE LENGTH
3514 RECIN1: MOVEM B,(D) ; CHAIN THE NEW BLOCK IN
3516 MOVEI B,$TUVECTOR+$DOPEBIT
3517 HRLM B,-1(D) ; MAKE SURE THIS IS A UV
3521 SUBTTL CORE ALLOCATION
3523 ICELL: JSP OP,ICELL1
3526 MOVEI A,3 ; # WORDS NEEDED
3530 ; HERE TO THE GARBAGE COLLECTOR FOR THE CURRENT ZONE
3535 SKIPN A,CZONE ; MUST HAVE A ZONE
3545 XMOVEI B,-GCPOFF+IGCPR
3547 XMOVEI B,RCLVOF(A) ; DEFAULT RCL CHAIN
3548 MOVE 0,GCFLGO(A) ; IF NO DWS, FUDGE HERE
3551 ; TLNE 0,$GC%PB ; ONLY EVEN # OF PAGES?
3556 XCT RCLTB(E) ; GET POINTER TO CORRECT RCL CHAIN
3557 SKIPN (B) ; DON'T BOTHER IF NOTHING'S ON THE CHAIN
3558 JRST IBLNEW ; OLD STYLE BLOCK ALLOCATOR
3561 JRST IBLFIX ; FIXED SIZE OBJECT
3562 MOVE D,B ; SETUP BACK POINTER
3563 MOVE B,(B) ; GET THE RECYCLE CHAIN ITSELF
3564 IBLCL: HRRZ C,-1(B) ; HOW MUCH STUFF HERE
3565 ADDI C,2 ; PLUS DOPE WORDS
3566 CAMN C,E ; IS THIS AN EXACT MATCH?
3567 JRST IBLC1 ; YES. DO THE RIGHT THING
3569 CAIL E,-2(C) ; CAN IT BE BROKEN UP
3570 JRST IBLC2 ; NO, KEEP LOOKING
3572 SUBI C,2(E) ; C ==> LENGTH OF REMAINDER
3573 HRRM C,-1(B) ; STORE IT
3574 CAILE C,10. ; SKIP IF MUST PUT IT ON OTHER CHAIN
3576 MOVE 0,(B) ; SPLICE IT OUT
3578 SETZM (B) ; FLUSH OLD POINTER
3585 JSP OP,RELB ; CALL BLOCK RECYCLER
3592 IBLC3: SUBI B,2(C) ; NEW DW
3594 HRRZM E,-1(B) ; DW LENGTH
3596 MOVE 0,GCFLGO(A) ; GET FLAGS
3597 MOVE A,B ; PNTR TO A
3598 SUBI A,1(E) ; POINT TO TOP
3599 IBLRET: TLNE 0,$GC%PB ; REQUIRE PAGE BOUNDARY?
3601 JRST (PC) ; NO RETURN
3604 IBLC2: MOVE D,B ; GET NEW BACK POINTER
3605 SKIPN B,(B) ; GET NEXT ENTRY
3606 JRST IBLNEW ; END OF CHAIN
3607 JRST IBLCL ; LOOP WITH NEW BLOCK
3609 IBLC1: MOVE (B) ; FOUND AN EXACT MATCH
3610 MOVEM (D) ; UPDATE CHAIN POINTER
3611 SETZM (B) ; CLEAR CHAIN POINTER
3612 MOVE 0,GCFLGO(A) ; FLAGS
3614 SUBI A,-1(C) ; SUBTRACT OFF TO GET TO TOP
3619 IBLNEW: MOVE 0,GCSBOF(A)
3628 MOVE A,E ; # WORDS NEEDED
3632 JRST IBLOCK ] ; WILL GC
3633 MOVE A,GCFLGO(A) ; RET FLAGS IN 0
3637 IBLFIX: MOVE 0,GCFLGO(A)
3649 SUBTTL KNOWN RECORD TYPE TABLES
3668 $TFIX,,<<0._9.>\18.>
3670 $TFIX,,<<18._9.>\18.>
3674 $TFIX,,<<0._9.>\18.>
3676 $TBIND,,<<18._9.>\18.>
3703 QFTBL==. ; will build tabel later
3711 SUBTTL ERROR ROUTINES & UTILITIES
3714 CMPER2: SKIPE O1,ECATM
3716 CMPERX: HRROI A,[ASCIZ /Error in Compiled Code
3726 CMPER3: MOVEI A,.FHSLF ; in case turned off by ill mem
3727 MOVSI B,(<<SETZ>_<-PREAD>>+<<SETZ>_<-PWRIT>>)
3735 SUBTTL DEBUGGING UTILITIES
3737 ; CALL TO SAVE FROM THE INTERPRETER
3739 ; B/ 0 or pointer-to-pure-zone
3740 ; C/ 0 or pointer-to-frozen-atom-zone
3742 SAVEX: MOVEM A,INTSAV'
3744 MOVEM C,ATMZON ; SAVE ZONES IN CASE NEED TO RE-SAVE
3746 CLOSF ; LIKE RESTORE, FILE SHOULDN'T BE OPEN...
3748 MOVE E,(P) ; GET RETURN PC
3762 SKIPE INTSAV ; DIFFERENT STARTING ADDRESS FOR .SAVE
3771 HRROI A,[ASCIZ /Output name: /]
3773 MOVE A,[GJ%FOU+GJ%SHT+GJ%NEW+GJ%FNS]
3777 SAV2: ; Special save for multi sect
3778 ; Here to write out multi-sect file
3781 ; FORMAT of extended page map for file
3783 ; even words: -count,,flags
3784 ; odd words: starting job page number
3786 MOVEI 0,SVMAP+6 ; SET UP MAP
3788 SKIPE O1,CZONE ; zones set up?
3789 JRST ZND1 ; yes, do it for them
3791 MOVE O1,GCSBOT ; get bounds
3797 ZND1: MOVE B,SAVAC+2 ; restore possible pure zone
3798 MOVE C,SAVAC+3 ; and atom zone
3799 SKIPN INTSAV ; skip if from user
3800 SETZB B,C ; otherwise, no pure or atom zones
3803 ZND6: PUSH P,SECL(O1) ; list of section bounds
3808 ZND2: SKIPE E,-2(P) ; any more bounds
3811 SKIPN O1,-3(P) ; atom zone?
3813 SETZM -3(P) ; dont look again
3814 ADJSP P,-3 ; remove old zone
3817 ZND5: SKIPN O1,-4(P)
3823 ZND4: MOVE O1,2(E) ; pointer to UVEC
3824 MOVE 0,3(O1) ; areas flags
3825 MOVE O2,1(O1) ; bounds of gcspace
3826 CAMN O2,(P) ; current zone?
3827 JRST [ MOVE O2,-1(P)
3833 PUSHJ P,PMSEC ; write it out
3839 ; SUBI B,777 ; dividing neg number by shift, so
3842 HRRI B,SS%RD+SS%CPY+SS%EXE+SS%EPN
3843 TRNE 0,2 ; skip if not read-only
3844 HRRI B,SS%RD+SS%EXE+SS%EPN
3855 ZND3A: MOVEI B,STRTTP-777 ; compute pages of stack
3858 HRRI B,SS%RD+SS%CPY+SS%EXE+SS%EPN
3861 MOVEI B,<TPSEC_9.>+<STRTTP_-9.> ; add in core page for stack
3865 ; now write out the actual cruft
3873 JRST [ HALTF ; give chance to save symbols
3878 SAVLOS: SKIPN INTSAV
3879 JRST [HRROI A,[ASCIZ /?/]
3891 PUSHJ P,RETERR ; return a false with error code
3896 IFN <MIMSEC-TPSEC>,[
3898 MOVE B,[.FHSLF,,MIMSEC] ; create brand new section
3899 MOVE C,[PM%CNT+PM%RD+PM%EX+PM%WR+1] ; bits for mapping
3907 MOVSI C,(PM%RD+PM%WR+PM%EX)
3913 MOVSI C,(PM%RD+PM%WR+PM%EX)
3916 ADDI B,<<MIMSEC+1>_9.>
3920 CAME D,[.FHSLF,,1000]
3923 MOVE A,[.FHSLF,,<<TPSEC_9>+<STRTTP_<-9>>>]
3926 MOVSI C,(PM%RD+PM%WR+PM%EX+PM%CNT)
3927 HRRI C,1000-<STRTTP_<-9>>
3930 RSTTPD: MOVE 0,CURSIZ
3932 ; MOVEI 0,<<NUMSEC+INIGC>_<-1>>
3933 MOVE A,[.FHSLF,,1000]
3934 IFN FLIP,MOVE B,[.FHSLF,,3000]
3935 IFE FLIP,MOVE B,[.FHSLF,,2000]
3936 MOVSI C,(PM%RD+PM%WR+PM%EX)
3959 MOVEI B,2 ; CODE FOR SETUP OF UUO TABLE
3960 MOVE C,[MIMSEC,,MLTUUP]
3965 MOVES <<TPENDP-TPWARN>_9>(A)
3968 MOVES <<TPENDP-TPWARN>_9>(A)
3997 ; RESTORE CALLED FROM MUM
3998 ; TAKES JFN IN ACCUMULATOR A
4002 MOVE B,[.FHSLF,,TPWARN]
4003 MOVE C,[PM%CNT\<<TPENDP-TPWARN>+1>] ; unmap end-of-stack warning
4006 MOVE B,[.FHSLF,,<TPWARN+1000>]
4007 MOVE C,[PM%CNT\<<TPENDP-TPWARN>+1>]
4011 MOVE B,[SETZ INIGC] ; FLUSH MANY SECTIONS
4013 SMAP% ; FLUSH LOTS OF STUFF
4014 MOVE A,D ; RESTORE CHANNEL
4015 SETOM INTSAV ; CALLED FROM MUM
4016 TLO A,400000 ; KEEP THE JFN
4017 CLOSF ; FOR REASONS KNOWN ONLY TO GOD, AND
4018 HALTF ; I EVEN DOUBT THAT, THE FILE CAN'T
4019 HRLI A,.FHSLF ; BE OPEN WHEN A GET IS DONE. SIGH.
4021 MOVE D,[MOVEI A,.FHSLF]
4026 ; Take fix or false in A/B. If false, return first GC sec,,# GC secs;
4032 SETSZD: MOVSI A,$TFIX
4037 SETSZ1: MOVEM B,CURSIZ
4043 HRROI A,[ASCIZ /Fatal error--/]
4066 HRROI A,[ASCIZ / (/]
4077 HRROI A,[ASCIZ /.) [/]
4079 MOVE C,O2 ; # OF ARGUMENTS
4082 SUBM TP,C ; POINT THERE
4135 SVMAP: -ENDPG,,SS%CPY+SS%RD+SS%EXE+SS%EPN
4137 -1,,SS%CPY+SS%RD+SS%EXE+SS%EPN
4139 -1,,SS%CPY+SS%RD+SS%EXE+SS%EPN
4145 SUBTTL INTERRUPT HANDLER
4151 CHNTAB: REPEAT 36.,[ 2,,CHNS+<.RPCNT*2>
4154 CHNS: REPEAT 36.,[ PUSH P,[.RPCNT]
4162 CAIN A,PWRIT ; have we touched "magic" page
4168 MOVE C,@[MIMSEC,,INTFLG]
4170 IORM B,@[MIMSEC,,INTFLG]
4171 IORM B,@[MIMSEC+1,,INTFLG]
4173 IFE FLIP, IORM B,INTFLG
4185 HRROI A,[ASCIZ /GCing--please wait../]
4189 AOS C,CTLGS ; how many successive ^G or ^As
4190 CAIGE C,3 ; if more than 5, int anyway
4193 HRROI A,[ASCIZ /Forced interrupt, here's hoping...
4206 SKIPGE PCLEV2 ; REALLY DEBRK?
4207 JRST [ EXCH A,PCLEV2
4213 ; Come here when interrupts enabled
4215 TLNN A,10000 ; Test for user mode
4219 CHNS4: EXCH A,@LEVTAB+1
4220 CHNS41: PUSHJ P,SAVALL
4223 DEBRK ; Leave int level, go to rest of handler
4224 CHNS5: PUSHJ P,RINTGO ; Process interrupts
4225 CHNS52: SUBM R,-1(TP) ; Get real PC back
4226 SOS A,-1(TP) ; Back it up
4228 LDB B,[331100,,(A)] ; Get opcode
4229 SKIPN -12.(TP) ; skip if from JSYS
4231 CAIE B,104 ; Not JSYS; assume XCT 0
4238 MOVEI B,IOX4 ; Return with error code
4241 MOVE A,(A) ; Get ERJMP instruction
4244 XMOVEI A,@A ; Get address of error routine
4246 RSTALL: MOVE 0,-15(TP) ; saved CZONE
4247 CAME 0,CZONE ; no, change -- no GC
4249 CAIA ; here if either no GC, or doesn't matter
4250 JRST [ HRROI A,[ASCIZ /GC has occurred, you may lose..
4266 SETOM RUNINT ; Re-enable interrupts
4268 POPJ P, ; Back into code
4270 CHNS1: MOVEI B,CHNS2
4271 HRRM B,PCLEV2 ; Go back to section originally in
4274 SAVALL: PUSH TP,[$TUVEC+$FRMDO,,16.]
4283 PUSH TP,D ; Save ACs for system call
4291 PUSH TP,[$TUVEC+$FRMDO,,16.]
4292 SUBM R,-1(TP) ; Save rel PC
4295 ; come here when interrupt out of TEXTI. Everything needed for TEXTI
4296 ; except .rddbp and .rddbc is on tp; those two can be computed.
4297 CHNS2: PUSH TP,$WFIX
4298 PUSH TP,IRDBLK+.RDDBC ; SAVE BYTE COUNT
4299 PUSHJ P,RINTGO ; HACK INTERRUPTS
4300 MOVE A,-20(TP) ; PROMPT
4301 MOVEM A,IRDBLK+.RDRTY
4312 MOVEM B,3(A) ; GET BREAKS SET UP
4313 MOVEM A,IRDBLK+.RDBRK ; Restore right word
4314 MOVE A,-14(TP) ; JFN WORD
4315 MOVEM A,IRDBLK+.RDIOJ
4316 MOVE A,-12(TP) ; ORIGINAL STRING
4317 MOVEM A,IRDBLK+.RDBFP
4318 MOVEM A,IRDBLK+.RDBKL
4320 SUB B,(TP) ; # CHARS USED
4321 ADJBP B,A ; POINT TO EMPTY PAART
4322 MOVEM B,IRDBLK+.RDDBP
4324 MOVEM B,IRDBLK+.RDDBC ; SPACE REMAINING
4326 JRST BRESTA ; FALL BACKK INTO TEXTI
4330 INTGOC: SKIPE INGC ; DONT INTERRUPT POOR GC
4341 PUSH TP,@[MIMSEC,,NARGS]
4343 PUSH TP,@[MIMSEC+1,,NARGS]
4351 POP TP,@[MIMSEC+1,,NARGS]
4353 POP TP,@[MIMSEC,,NARGS]
4368 RINTGO: PUSH TP,$WFIX
4383 ANDCAM C,@[MIMSEC,,INTFLG]
4384 ANDCAM C,@[MIMSEC+1,,INTFLG]
4386 IFE FLIP, ANDCAM C,INTFLG ; AND CLEAR IT
4395 INTINI: MOVE A,[-36.,,CHNTAB]
4397 LSH 0,12. ; move level over
4398 IORI 0,MIMSEC ; cause it to run int MIM
4403 HRLM 0,LEVTAB ; also mung LEVTAB
4416 PWRIT==17. ; Bit for page write int
4418 INFINT==19. ; bit for inferior interrupt
4420 MOVSI B,(<<SETZ>_<-PREAD>>+<<SETZ>_<-PWRIT>>)
4421 TRO B,<SETZ>_<-INFINT>
4422 AIC ; Activate the int
4425 ;Here to see if illegal page access is really stack overflow
4427 STKCHK: XMOVEI B,1(TP) ; lets see which page
4428 LSH B,-9 ; to page number
4430 CAIN B,TPWARN ; warning page?
4431 JRST [MOVSI A,(SETZ)
4433 MOVSI B,(PA%RD+PA%EX+PA%WT)
4437 MOVE A,[JRST @PNTSTK]
4439 MOVEM A,@[MIMSEC+1,,STKMNG]
4442 HRROI A,[ASCIZ /Fatal error: stack overflow
4462 ; XGTPW% ; get info about lossage
4463 ; MOVE C,(P) ; get address
4464 ; TLNE C,MONBIT ; monitored?
4465 ; JRST DOMON ; yes, handle it, else lose
4466 PUSH P,D ; need more regs
4469 DMOVE A,@LEVTAB+1 ; get instruction
4471 LDB D,[331100,,A] ; and opcode
4472 TLZE E,MONBIT ; is it monitored
4474 CAIL D,134 ; see if a bp ins
4476 JRST REALER ; this is a real lossage
4478 SKIPG A,(E) ; get byte pointer (skip if
4480 CAMG A,[450000,,0] ; skip if global
4482 PUSHJ P,EFFADR ; treat like ins
4484 MOVE B,E ; point to where BP is
4486 GBPTR1: TLZN E,MONBIT
4489 JRST MONIT ; not int GC, cause monitor
4490 MOVE A,@PCLEV2+1 ; get ins
4491 TLON A,1000 ; skip if no incr
4495 NOTBP1: TLZ A,37 ; kill index etc.
4499 MOVEM A,INSDO ; set up to do ins
4500 AOS A,PCLEV2 ; get pc
4511 REALER: MOVSI B,(<<SETZ>_<-PREAD>>+<<SETZ>_<-PWRIT>>)
4513 DIC ; turn of interrupt
4514 GCNT: POP P,OP ; need more regs
4526 POP P,-16(TP) ; save monitored address
4531 XMOVEI A,MONIT1 ; here to trigger monitor
4532 MOVEM A,PCLEV2 ; set to disable ints
4533 DMOVE A,-17(TP) ; leave funny in A
4536 MONIT1: JSP PC,FRAME
4555 TLO A,400000 ; SO WE DONT DEBRK
4563 ; Compute effective address
4567 EFFADR: MOVE A,(B) ; get ins
4569 LDB D,[220400,,A] ; get index
4570 MOVEI OP,0 ; indirect?
4575 HRRES E ; make negative offsets work
4577 EFF1: JUMPE D,EFF2 ; jump if no index field
4579 CAIG D,OP ; reg on stack?
4581 SKIPN D,(D) ; get its contents
4582 JRST EFF2 ; zero in index, ignore
4584 TLNE D,-1 ; skip if rh only (local index)
4585 JUMPG D,EFF3 ; jump if global index
4587 ADD E,D ; do local indexing
4588 ANDI E,-1 ; but prevent overflowing
4591 EFF3: ADD E,D ; add global index
4593 EFF2: CAIGE E,17 ; AC?
4595 TLNN E,400000 ; negative addr also get current section
4596 TLNN E,-1 ; skip if section already here
4597 HLL E,B ; use PC section
4599 EFF6: JUMPE OP,EFF5 ; no indirection, leave
4601 PUSHJ P,GETVAL ; get indirect word
4603 JUMPGE A,EFF7 ; jump if global ind
4605 LDB D,[220400,,A] ; get index field
4606 TLNN A,20 ; skip if indirect
4607 MOVEI OP,0 ; turn it on
4608 HRRE E,A ; keep original section with new address
4609 JRST EFF1 ; loop back
4611 EFF7: LDB D,[360400,,A]
4612 TLNN A,200000 ; global indirect bit?
4614 TLZ A,770000 ; kill index and indirect
4621 ; here to extract value
4623 GETVAL: TLZ E,MONBIT
4624 CAIG E,OP ; skip if register
4627 MOVE A,(E) ; get word
4633 IFE FLIP&0,[ MOVE 0,[JRST @D]]
4634 IFN FLIP&0,[ MOVE 0,[TLNN M,1]]
4636 MOVEM 0,@[MIMSEC+1,,STKMNG]
4637 MOVE 0,[JRST @PNTRET] ; CHANGE INS IN RETURN
4639 MOVEM 0,@[MIMSEC+1,,RET3]
4646 SUBTTL DEBUGGING UUOS
4656 IRPS X,,[FRM DP DC TON TOFF EX GVERR MADJBP]
4663 MLTUOP: PUSH P,MLTUUP
4669 ; Here if in multi-section mode but running a section 0 uuo
4671 EXCH 0,(P) ;GET PC AND SAVE 0
4688 MOVEM UUOD' ; CONTENTS OF EFF ADR
4689 MOVE B,UUOE ; EFF ADR
4690 LDB A,[050400,,MLTUUP] ; GET UUO AC,
4691 LDB C,[110400,,MLTUUP] ; AND OPCODE
4694 UUODS1: LDB A,[270400,,40] ; GET UUO AC,
4695 LDB C,[330600,,40] ; OP CODE
4696 UUODSP: CAIL C,UUOMAX
4697 MOVEI C,0 ; GRT=>ILLEGAL
4698 JRST @UUOTAB(C) ; GO TO PROPER ROUT
4703 POP P,A ; RESTORE AC'S
4711 ; KLUDGE TO DO ADJBP GIVEN MICROCODE BUG
4713 CAILE A,D ; CHECK AC ARG
4714 JRST ADJB2 ; Not pushed, so continue
4715 SUBI A,D ; Make A point to stack slot
4717 ADJB2: MOVE C,(A) ; PICK UP AC
4718 IBP C,UUOD ; Do the IBP
4719 TLNE C,770000 ; Skip if lost
4722 JRST ADJB2 ; And try again
4723 ADJBO: MOVEM C,(A) ; Won, stuff bp out
4724 JRST UUORET ; And return
4726 UGVERR: SUBM R,-5(P) ; RELATIVE RETURN PC
4731 CAIGE B,20 ; IF EA IS REGISTER, HACK IT
4732 JRST [ PUSH TP,[$TGVAL,,$LATOM]
4739 MOVE 0,-1(B) ; CHANGE ATOM TO GVAL
4740 CAME 0,[$TGBIND,,$LGBIND]
4741 MOVE 0,[$TGVAL,,$LATOM]
4742 PUSH TP,0 ; PUSH GBIND POINTER OR ATOM POINTER
4745 JSP PC,CALLZ ; CALL EICC
4747 ADJSP P,-4 ; PRESERVE NEW CONT. OF A AND B
4749 AOS -1(P) ; SKIP RETURN
4766 JRST [HRROI A,[ASCIZ /< TUPLE >/]
4774 ADJSP TP,-2 ; SUB TP,[2,,2]
4775 UFRMLX: HRROI A,[ASCIZ /
4778 SKIPGE C,3(C) ; GET NEXT FRAME
4779 JRST [HRROI A,[ASCIZ / <GLUED FRAME(S)>
4782 HRRZ C,-1(C) ; GET REAL FRAME
4787 JRST [HRROI A,[ASCIZ / <GLUED FRAME(S)>
4801 UDP: MOVE A,(B) ; TYPE WORD
4807 TLZE C,200000 ; IS IT MARKED?
4842 HRROI A,[ASCIZ /??/]
4846 UDPUNB: HRROI A,[ASCIZ /#UNBOUND /]
4850 UDPMCD: HRROI A,[ASCIZ /#MCODE |??|/]
4853 UDPFLS: HRROI A,[ASCIZ /#FALSE ()/]
4857 UDPMSB: HRROI A,[ASCIZ /#MSUBR ??/]
4861 UDPCHR: HRROI A,[ASCIZ /!\/]
4867 UDPFIX: MOVEI A,.PRIOU
4873 UDPFLT: MOVEI A,.PRIOU
4889 UDPOBL: HRROI A,[ASCIZ /#OBLIST /]
4900 HRROI A,[ASCIZ /#TUPLE /]
4920 UDPVCE: HRROI A,[ASCIZ /]/]
4922 ADJSP P,-2 ; SUB P,[2,,2]
4925 UDPFRM: HRROI A,[ASCIZ /#FORM /]
4927 UDPLST: HRROI A,[ASCIZ /(/]
4940 UPLSTE: HRROI A,[ASCIZ /)/]
4945 HRROI A,[ASCIZ /#CHANNEL [/]
4975 XCT @MLTEA ; get ins to execute
4978 SUBTTL END OF THE ROAD
4981 NOISY: 1 ; non-zero, say if int in GC
4982 ONOISY: 0 ; non-zero, say ok after GC
4983 BUGS: 0 ; count bad ADJBP
4984 CTLGS: 0 ; count ^Gs and ^As
4985 CTLGCH: 0 ; int channel for ^G
4986 CTLACH: 0 ; int channel for ^A
4992 IFN MON,.INSRT M20:INSINT.MID
4995 LOC <<.+777>&777000> ; GO TO PAGE BOUNDARY
4996 ENDPG==<.+777>_<-9.>
5001 LOC <<.+777>&777000>
5006 SUBTTL BOOTSTRAP MSUBR READER
5013 BSAPTR: -256.,,BSATBL-1
5015 BOOTER: MOVE A,GCSMIN
5020 MOVE A,[MIMSEC,,PAGTBL]
5022 MOVE A,[MIMSEC,,MINF]
5026 HRROI A,[ASCIZ /MIMI20 Initialization
5031 HRRO A,[[ASCIZ /Using msubrs
5035 [ASCIZ /Using big mbins
5039 BNIN: HRROI A,[ASCIZ /Enter type (1 big mbins, 0 mbins, -1 msubrs): /]
5047 BNIN1: MOVE P,[-PDLLEN,,PDL-1]
5048 MOVE TP,[-STACKLEN,,STACK-1]
5050 PUSHJ P,SMAPIT ; setup multi sections
5055 MOVE B,[$TVECTOR,,237.]
5064 MOVE B,[$DOPEBIT+$TVECT,,<237.*2>]
5068 MOVSI A,(GJ%SHT+GJ%OLD)
5069 HRROI B,[ASCIZ /<MIM.BOOT>BOOT.MSUBR/]
5072 MOVE B,[070000,,OF%RD]
5084 MOVE C,[.BYTE 7 ? "B ? "O ? "O ? "T]
5085 PUSHJ P,BSLKPL ; GET ATOM BOOT IN A/B
5091 MOVE A,[STACK,,STACK+1]
5093 JSP PC,FRAME ; MAKE A FRAME
5096 HRROI A,[ASCIZ /Bootstrap Loaded
5101 MOVEI O2,1 ; Actually call with 1 arg
5102 MOVEI SP,0 ; START SP IN RIGHT SECT
5103 JSP PC,CALLZ ; CALL BOOTSTRAP WITH NO ARGS
5104 JRST SAV ; AND ATTEMPT TO SAVE OURSELVES
5127 BSREAD: SKIPE BSENDF
5147 JRST [MOVE A,$WUNBOUND
5158 ; HERE TO READ # FORMAT
5160 BSTYP: PUSHJ P,BSREAD ; GET TYPE NAME
5161 MOVE B,3(B) ; GET PNAME
5165 CAMN C,[.BYTE 7 ? "M ? "S ? "U ? "B]
5167 CAMN C,[.BYTE 7 ? "I ? "M ? "S ? "U]
5169 CAMN C,[.BYTE 7 ? "D ? "E ? "C ? "L]
5171 CAMN C,[.BYTE 7 ? "U ? "N ? "B ? "O]
5173 CAMN C,[.BYTE 7 ? "F ? "A ? "L ? "S]
5175 PUSHJ P,BSREAD ; GET PRIMITIVE STRUCTURE
5176 HLL A,(P) ; GET NEW TYPE WORD
5187 REPEAT 4,PUSH TP,[0]
5190 PUSHJ P,RECORR ; MAKE A BINDING
5193 POP TP,A ; RESTORE THE MSUBR
5194 MOVE C,3(B) ; THE ATOM
5198 MOVEM A,(C) ; STUFF BINDING IN ATOM
5199 MOVEM C,2(A) ; STUFF ATOM IN BINDING
5203 ; HERE TO READ A FIX
5208 MOVEI C,-"0(B) ; C WILL HOLD FIX
5209 SETZ D, ; D IS FRACTION / E IS # OF DIGITS
5211 BSFIXL: BIN ; GET NEXT CHARACTER
5212 PUSHJ P,BSSEP ; IS IT A SEPARATOR
5213 JRST BSFIXE ; YES, FINISH
5215 JRST [IMULI D,10. ; UPDATE INFO
5219 CAIN B,". ; DECIMAL?
5222 IMULI C,10. ; SHIFT OVER SOME
5223 ADDI C,-"0(B) ; ADD IN THE NEXT DIGIT
5224 JRST BSFIXL ; AND LOOP
5226 BSFIXE: MOVEM B,BSBRK'
5239 ; HERE TO READ A CHARACTER
5248 ; HERE TO READ A STRING
5250 BSSTR: PUSH P,[0] ; CLEAR COUNT (PREPARE TO MAKE STRING)
5259 BSSTR1: PUSH TP,$WCHARACTER ; PUT CHARACTER ON STACK
5262 JRST BSSTRL ; AND LOOP
5263 BSSTR2: MOVE O1,$WSTRING
5265 PUSHJ P,UBLOKR ; MAKE THE STRING
5268 ; HERE TO READ AN ATOM
5270 BSATM: PUSH P,[0] ; CLEAR COUNT (PREPARE TO MAKE STRING)
5275 BSATM1: PUSH TP,$WCHARACTER ; PUT CHARACTER ON STACK
5278 JRST BSATML ; AND LOOP
5279 BSATM2: MOVEM B,BSBRK
5282 PUSHJ P,UBLOKR ; MAKE THE STRING
5286 BSGBND: TLO B,660000
5300 PUSH TP,A ; PUSH GLOBAL BINDING
5302 PUSH TP,$WFIX ; PUSH LOCAL BINDING
5304 PUSH TP,C ; PUSH PNAME
5310 PUSHJ P,RECORR ; MAKE AN ATOM (ISN'T THIS FUN?)
5311 MOVE D,(B) ; GET GLOBAL BINDING
5312 MOVEM B,2(D) ; STUFF IT IN ATOM
5320 BSLKP: HRROI D,BSATBL
5321 MOVE C,1(B) ; POINT TO START OF PNAME
5329 MOVE A,[$TATOM,,10.] ; CHANGED (WAS 4)
5332 ; HERE TO READ SOME MCODE
5334 BSCOD: PUSH P,[0] ; CLEAR THE COUNTER
5353 PUSH TP,$WFIX ; PUT IT ON THE STACK
5354 PUSH TP,D ; P.S. - IT HAD BETTER BE A FIX
5356 JRST BSCODL ; AND LOOP
5364 MOVE O1,$WMCODE ; TYPE WORD SET
5366 PUSHJ P,UBLOKR ; MAKE THE UBLOCK (STRING)
5369 ; HERE TO READ A VECTOR
5372 BSVECL: PUSHJ P,BSREAD
5381 BSVECE: MOVE O1,$WVECTOR
5388 CAIE B,"< ; This is the only % frob we know how to read
5397 ; HERE TO READ A LIST
5400 BSLSTL: PUSHJ P,BSREAD
5413 ; HERE FOR BOOTSTRAP ERRORS
5415 BSNOB: HRROI A,[ASCIZ /No MSUBR named BOOT
5420 BSNOF: HRROI A,[ASCIZ /Can't open BOOT.MSUBR
5424 SUBTTL SMAP% CODE FOR MULTI SECTION HACKING
5429 ; Create 1 or 2 stack sections, depending on FLIP
5431 MOVE B,[.FHSLF,,MIMSEC] ; create brand new section
5432 MOVE C,[PM%CNT+PM%RD+PM%EX+PM%WR+1] ; bits for mapping
5436 MOVE B,[.FHSLF,,MIMSEC+1] ; create brand new section
5437 MOVE C,[PM%CNT+PM%RD+PM%EX+PM%WR+1] ; bits for mapping
5440 MOVSI C,(PM%RD+PM%EX+PM%CPY)
5442 MOVE B,[.FHSLF,,<MIMSEC_9>]
5445 MOVSI C,(PM%RD+PM%EX+PM%CPY)
5447 MOVE B,[.FHSLF,,<<MIMSEC+1>_9>]
5452 MOVSI C,(PM%RD+PM%WR+PM%EX)
5457 MOVSI C,(PM%RD+PM%WR+PM%EX)
5460 ADDI B,<<MIMSEC+1>_9.>
5464 CAME D,[.FHSLF,,1000]
5467 ; create stack section
5468 IFN <MIMSEC-TPSEC>,[
5470 MOVE B,[.FHSLF,,TPSEC]
5471 MOVE C,[PM%CNT+PM%RD+PM%EX+PM%WR+1] ; bits for mapping
5474 ; create initial GC space section and section following (for MAPPUR)
5477 MOVE B,[.FHSLF,,INIGC]
5478 MOVE C,[PM%CNT+PM%RD+PM%EX+PM%WR+2] ; bits for mapping
5481 ; and map special page in from 0
5483 MOVE A,[.FHSLF,,COMPAG+<MIMSEC_9>]
5484 MOVE B,[.FHSLF,,<<INIGC_9.>+COMPAG>]
5485 MOVE C,[PM%CNT+PM%RD+PM%EX+PM%WR+1] ; bits for mapping
5487 IFN FLIP,MOVE A,[.FHSLF,,COMPAG+<<MIMSEC+1>_9>]
5488 IFE FLIP,MOVE A,[.FHSLF,,COMPAG+<MIMSEC_9>]
5489 MOVE B,[.FHSLF,,<<<INIGC+1>_9.>+COMPAG>]
5490 MOVE C,[PM%CNT+PM%RD+PM%EX+PM%WR+1]
5493 ; now all that is left to do is set up UUOs, fix ENTRY table and make stacks
5499 MOVE A,[<ENTVEC+LOWOP-ENTMAX-1>,,ENTVEC+LOWOP]
5500 IFN FLIP, MOVEI B,MIMSEC+1
5501 IFE FLIP, MOVEI B,MIMSEC
5505 HRLM B,(A) ; MAKE POINT TO CORRECT SECTION
5508 MOVE A,[-FROBL,,FROBBS]
5518 MOVE A,[<ENTVEC+LOWOP-ENTMAX-1>,,ENTVEC+LOWOP]
5523 HRLM B,(A) ; MAKE POINT TO CORRECT SECTION
5526 MOVE A,[-FROBL,,FROBBS]
5535 MOVEI B,2 ; CODE FOR SETUP OF UUO TABLE
5536 MOVE C,[MIMSEC,,MLTUUP]
5539 MOVE TP,[TPSEC,,STRTTP] ; now have good TP
5540 MOVE A,[INIGC,,1000] ; MAKE THIS START GC
5543 MOVE A,[INIGC,,TOPMGC]
5545 MOVE B,[MPAGM,,PAGTBL]
5546 BLT B,PAGTBL+MPAGME-MPAGM
5553 MOVE P,[TPSEC,,STPDL] ; p-stack in MIM section
5555 XJRST DUALPC ; poof we are outta here!
5566 IFN <TPSEC-MIMSEC>,[
5572 <STRTTP_<-9.>>+<TPSEC_9>
5577 IFN <TPSEC-MIMSEC>,[
5579 <<MIMSEC+1>_9.>+ENDPG
5583 <STRTTP_<-9.>>+<<TPSEC+1>_9>
5591 REPEAT <NUMSEC-1>,[1
5592 <<INIGC+.RPCNT+1>_9.>
5595 <<INIGC+.RPCNT+1>_9.>+1