github.com/PDP-10.its
1
0
Fork 0
mirror of https://github.com/PDP-10/its.git synced 2026-01-21 10:13:35 +00:00
Code Issues Releases Wiki Activity
PDP-10.its/src/l/ulap.145

662 lines
14 KiB
Plaintext
Raw Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

;;; -*-MIDAS-*-
;;; **************************************************************
;;; ***** MACLISP ****** UTAPE, LAP, AND AGGLOMERATED SUBRS ******
;;; **************************************************************
;;; ** (C) COPYRIGHT 1980 MASSACHUSETTS INSTITUTE OF TECHNOLOGY **
;;; ****** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) *******
;;; **************************************************************
PGBOT [UIO]
SUBTTL OLD I/O FUNCTIONS IN TERMS OF NEW I/O PRIMITIVES
;;; (DEFUN UREAD FEXPR (FILENAME)
;;; (UCLOSE)
;;; ((LAMBDA (FILE)
;;; (EOFFN UREAD
;;; (FUNCTION
;;; (LAMBDA (EOFFILE EOFVAL)
;;; (UCLOSE)
;;; EOFVAL)))
;;; (INPUSH (SETQ UREAD FILE))
;;; (DEFAULTF FILE))
;;; (OPEN (*UGREAT FILENAME) 'IN)))
UREAD: PUSH P,A ;FEXPR
PUSHJ P,UCLOSE
POP P,A
PUSHJ P,UGREAT
PUSH P,[UREAD2]
PUSH P,A
MOVNI T,1
JRST $EOPEN
UREAD2: MOVEM A,VUREAD
PUSH P,[UREAD1]
PUSH P,A
PUSH P,[QUREOF]
MOVNI T,2
JRST EOFFN
UREAD1: HRRZ A,VUREAD
PUSHJ P,INPUSH
PUSHJ P,DEFAULTF
HRRZ A,VUREAD
JRST TRUENAME ;RETURN TRUENAME OF FILE TO USER
UREOF: PUSH P,B ;+INTERNAL-UREAD-EOFFN - SUBR 2
PUSHJ P,UCLOSE
JRST POPAJ
;;; (DEFUN UCLOSE FEXPR (X)
;;; (COND (UREAD
;;; ((LAMBDA (OUREAD)
;;; (AND (EQ OUREAD INFILE) (INPUSH -1))
;;; (SETQ UREAD NIL)
;;; (CLOSE OUREAD))
;;; UREAD))
;;; (T NIL)))
UCLOSE: SKIPN A,VUREAD ;FEXPR
POPJ P,
CAMN A,VINFILE
PUSHJ P,INPOP ;SAVES A
SETZM VUREAD
JRST $CLOSE
;;; (DEFUN UWRITE FEXPR (DEVDIR)
;;; (OR DEVDIR (SETQ DEVDIR (CAR (DEFAULTF NIL))))
;;; (*UWRITE (CONS DEVDIR
;;; (COND ((STATUS FEATURE DEC10)
;;; (CONS (STATUS JNAME) '(OUT)))
;;; ((STATUS FEATURE DEC20)
;;; '(MACLISP OUTPUT))
;;; ((STATUS FEATURE ITS)
;;; '(.LISP. OUTPUT))))
;;; 'OUT
;;; (LIST DEVDIR)))
;;;
;;; (DEFUN UAPPEND FEXPR (FILENAME)
;;; (SETQ FILENAME (*UGREAT FILENAME))
;;; (*UWRITE FILENAME 'APPEND FILENAME))
;;;
;;; (DEFUN *UWRITE (NAME MODE NEWDEFAULT) ;INTERNAL ROUTINE
;;; (COND (UWRITE
;;; (SETQ OUTFILES (DELQ UWRITE OUTFILES))
;;; (CLOSE UWRITE)
;;; (SETQ UWRITE NIL)))
;;; ((LAMBDA (FILE)
;;; (SETQ OUTFILES
;;; (CONS (SETQ UWRITE FILE)
;;; OUTFILES))
;;; (CAR (DEFAULTF NEWDEFAULT)))
;;; (OPEN NAME MODE)))
UAPPEND: PUSHJ P,UGREAT ;FEXPR
MOVEI C,(A)
MOVEI B,QAPPEND
JRST UWRT1
UWRITE: JUMPN A,UWRT0 ;FEXPR
PUSHJ P,DEFAULTF
HLRZ A,(A)
UWRT0: PUSHJ P,NCONS
IFN ITS+D20,[
MOVEI C,(A)
HLRZ A,(C)
MOVEI B,QLSPOUT
PUSHJ P,CONS
] ;END OF IFN ITS+D20
IFN D10,[
PUSH P,A
PUSHJ P,SJNAME
MOVEI B,Q$OUT
PUSHJ P,CONS
POP P,C
HLRZ B,(C)
PUSHJ P,XCONS
] ;END OF IFN D10
MOVEI B,Q$OUT
UWRT1: PUSH P,C ;*UWRITE BEGINS HERE
PUSH P,[UWRT2]
PUSH P,A
PUSH P,B
SKIPE VUWRITE
PUSHJ P,UFILE5
MOVNI T,2
JRST $OPEN
UWRT2: MOVEM A,VUWRITE
HRRZ B,VOUTFILES
PUSHJ P,CONS
MOVEM A,VOUTFILES
POP P,A
PUSHJ P,DEFAULTF
JRST $CAR
;;; (DEFUN UFILE FEXPR (SHORTNAME)
;;; (COND ((NULL UWRITE)
;;; (ERROR 'NO/ UWRITE/ FILE
;;; (CONS 'UFILE SHORTNAME)
;;; 'IO-LOSSAGE))
;;; (T (PROG2 NIL
;;; (DEFAULTF (RENAMEF UWRITE (*UGREAT SHORTNAME)))
;;; (SETQ OUTFILES (DELQ UWRITE OUTFILES))
;;; (SETQ UWRITE NIL)
;;; (OR OUTFILES (SETQ ^R NIL))))))
UFILE0: MOVEI B,QUFILE
PUSHJ P,XCONS
IOL [NO UWRITE FILE!]
UFILE: SKIPN VUWRITE ;FEXPR
JRST UFILE0
PUSHJ P,UGREAT
MOVEI B,(A)
SETZ A,
EXCH A,VUWRITE
PUSH P,A
PUSH P,B
HRRZ B,VOUTFILES
PUSHJ P,.DELQ
MOVEM A,VOUTFILES
SKIPN VOUTFILES
SETZM TAPWRT
POP P,B
POP P,A
PUSHJ P,$RENAME ;CLOSES THE FILE AS WELL AS RENAMES IT
PUSHJ P,DEFAULTF
POPJ P,
UFILE5: HRRZ A,VUWRITE
HRRZ B,VOUTFILES
PUSHJ P,.DELQ
MOVEM A,VOUTFILES
HRRZ A,VUWRITE
PUSHJ P,$CLOSE
SETZM VUWRITE
SKIPN VOUTFILES
SETZM TAPWRT
POPJ P,
;;; (DEFUN CRUNIT FEXPR (DEVDIR)
;;; (CAR (DEFAULTF (AND DEVDIR (LIST DEVDIR)))))
SCRUNIT: SETZ A,
CRUNIT: SKIPE A ;FEXPR
PUSHJ P,NCONS
PUSHJ P,DEFAULTF
JRST $CAR
;;; (DEFUN *UGREAT (NAME) ;INTERNAL ROUTINE
;;; (MERGEF NAME
;;; (COND ((STATUS FEATURE ITS) '(* . >))
;;; ('(* . LSP)))))
UGREAT: PUSH P,[6BTNML]
UGRT1: PUSHJ P,FIL6BT
IFN ITS+D10,[
REPEAT 3, PUSH FXP,[SIXBIT \*\]
IT$ PUSH FXP,[SIXBIT \>\]
SA$ PUSH FXP,[SIXBIT \___\]
SA% 10$ PUSH FXP,[SIXBIT \LSP\]
10$ SETOM -2(FXP) ;FOR D10 DEFAULT PPN IS -1
] ;END OF IFN ITS+D10
IFN D20,[
PUSHN FXP,L.F6BT
MOVE T,[ASCII \LSP\]
MOVEM T,-L.6EXT-L.6VRS+1(FXP)
] ;END OF IFN D20
JRST IMRGF
;;; (DEFUN UPROBE FEXPR (FILENAME)
;;; (SETQ FILENAME (MERGEF (*UGREAT FILENAME) NIL))
;;; (PROBEF FILENAME))
UPROBE: PUSHJ P,UGRT1 ;FEXPR
JRST PROBF0
;;; (DEFUN UKILL FEXPR (FILENAME)
;;; (DEFAULTF (DELETEF FILENAME))))
UKILL: PUSHJ P,$DELETEF
JRST DEFAULTF
SUBTTL SYMBOL MANIPULATION AND SQUOZE FUNCTIONS
;;; (TTSR| <SYMBOL>) GETS THE ARRAY PROPERTY OF <SYMBOL>,
;;; OR GIVES IT AN ARRAY PROPERTY WITH A DEAD SAR;
;;; IT MARKS THE SAR AS BEING NEEDED BY COMPILED CODE,
;;; AND THEN RETURNS THE ADDRESS OF THE TTSAR AS A FIXNUM.
;;; THIS IS USED PRIMARILY BY LAP.
TTSR: PUSH P,CFIX1 ;SUBR 1 - NCALLABLE (TTSR|)
MOVEI C,(A) ;SAVES AR1,R,F - SEE FASLOAD
PUSHJ P,ARGET
JUMPN A,TTSR1
JSP T,SACONS
MOVEI T,ADEAD
MOVEM T,ASAR(A)
MOVE T,[TTDEAD]
MOVEM T,TTSAR(A)
MOVEI B,(A)
MOVEI A,(C)
MOVEI C,QARRAY
PUSHJ P,PUTPROP
TTSR1: MOVSI T,TTS.CN
IORM T,TTSAR(A)
MOVEI TT,1(A)
POPJ P,
;;; BOTH ROUTINES ALWAYS RETURN THE LEFT-JUSTIFIED SQUOZE IN T
;;; AND THE SIXBIT IN R
;;; RSQUEEZE MAY LEAVE RIGHT-JUSTIFIED SQUOZE IN TT
RSQUEEZE: ;CANONICAL SQUOZE CONVERSION
IT% HRROS (P) ;FOR DEC-10, GIVES DEC-10 SQUOZE
SQUEEZE: ;THIS ALWAYS GIVES LEFT-JUSTIFIED SQUOZE
MOVEI AR1,6 ;CONVERT PNAME-ATOM TO SQUOZE AND SIXBIT
MOVE AR2A,[440600,,SQ6BIT] ;RETURNS SQUOZE IN TT, SIXBIT IN R
SETZM SQ6BIT ;CLEAR LOCS USED TO ACCUMULATE
SETZM SQSQOZ ; SIXBIT AND SQUOZE
HRROI R,SQZCHR
PUSHJ P,PRINTA ;"PRINT" OUT CHARS OR PNAME
IT% MOVE TT,SQSQOZ
SKIPA T,SQSQOZ
IMULI T,50
SOJGE AR1,.-1 ; MULTIPLY ITS SQUOZE UP TO SIZE
IT% MOVE R,(P)
IT% TLNN R,1
MOVE TT,T
MOVE R,SQ6BIT
POPJ P,
SQZCHR: TLNN AR2A,770000 ;IGNORE MORE THAN 6 CHARS
POPJ P,
SUBI A,40 ;CONVERT TO SIXBIT
CAIL A,1 ;LOSSAGE IF NOT SIXBIT CHAR
CAILE A,77 ; - ALSO, SPACE IS A LOSS
MOVEI A,'. ;LOSING NON-SQUOZE CHAR
IDPB A,AR2A ;DEPOSIT SIXBIT CHAR
CAIL A,'A ;CHECK FOR LETTER
CAILE A,'Z
JRST SQNOTL
SUBI A,'A-13 ;CONVERT TO SQUOZE VALUE
SQOK: EXCH T,SQSQOZ
IMULI T,50
ADDI T,(A)
EXCH T,SQSQOZ
SOJA AR1,CPOPJ ;DECR COUNT AND RETURN TO PRINTA
SQNOTL: CAIL A,'0 ;CHECK FOR DIGIT
CAILE A,'9
JRST SQNOTD
SUBI A,'0-1 ;CONVERT TO SQUOZE VALUE
JRST SQOK
SQNOTD: CAIE A,'$ ;CHECK FOR $ OR %
CAIN A,'%
JRST SQ%$
MOVEI A,'. ;ANY CHAR OTHER THAN A-Z, 0-9, $, OR %
DPB A,AR2A ; DEFAULTS TO . (E.G. *FOOBAR -> .FOOBA)
MOVEI A,45-42
SQ%$: ADDI A,42 ;SQUOZE VALUE FOR $,%,.
JRST SQOK
UNSQOZ: LDB T,[004000,,D] ;HAIRY MESS TO CONVERT
SETZM LD6BIT ; SQUOZE TO SIXBIT
UNSQZ1: IDIVI T,50 ;(THIS IS SEPARATE ROUTINE SO
JUMPE TT,UNSQZ2 ; LAP LOSERS CAN USE IT)
CAIL TT,45 ;<1SQUOZE .>
JRST UNSQZ3
CAIL TT,13 ;<1SQUOZ A> IS 13
ADDI TT,'A-13 ;CONVERT RANGE A - Z ,
CAIGE TT,13 ;<1SQUOZ 1> IS 1
ADDI TT,'0-1 ;CONVERT RANGE 0 - 9
UNSQZ2: IOR TT,LD6BIT
ROT TT,-6
MOVEM TT,LD6BIT
JUMPN T,UNSQZ1
MOVE A,[440600,,LD6BIT] ;MAKE SIXBIT INTO AN ATOM
JRST READ6C
UNSQZ3: SUBI TT,46-'$ ;[1SQUOZ $] IS 46, [1SQOZ .] IS 45
CAIN TT,45-<46-'$> ;CONVERT RANGE $ - %
MOVEI TT,'* ;BUT . IS EXCEPTIONAL
JRST UNSQZ2
PUTDDTSYM:
MOVEI R,0 ;PUTDDTSYM| IS FOR LAP - OFFSETS VALUE BY LOAD OFFSET
PUTDD0:
IT$ JSP T,SIDDTP ;LOSE IF NO DDT TO GIVE SYMBOL TO
IT% 20% SKIPN .JBSYM"
JRST FALSE
PUSH FXP,R
PUSH P,B
10$ SKIPL R ;SEE LDPUT1
PUSHJ P,RSQUEEZE ;SQUEEZE ATOM'S PNAME DOWN TO SQUOZ CODE
POP P,B
PUSHJ P,GETDDG ;L-JUST SQUOZ IN T, CANONICAL-JUST IN TT
JRST PUTDX ;DONT REDEFINE GLOBALSYMS
IFE ITS,[
PUSHJ P,GETDDJ
JRST PUTDD4
MOVEI F,(D)
] ;END OF IFE ITS
PUTDD2: JSP T,FXNV2 ;GET VALUE OF SECOND ARG
POP FXP,R
ADDI D,(R) ;ADD IN OFFSET
IT$ .BREAK 12,[..SSYM,,TT]
10$ MOVEM D,(F) ;NON-ITS LEAVES IN F A PTR TO SYMTAB
JRST TRUE ; SLOT WHERE ENTRY IS TO BE MADE
IFE ITS,[
PUTDD4: SOSGE SYMLO
JRST FALSE
MOVE F,R70+2
SUBB F,.JBSYM"
TLO TT,100000 ;LOCAL SYMBOL
MOVEM TT,(F)
AOJA F,PUTDD2
] ;END OF IFE ITS
PUTDX: POPI FXP,1
JRST FALSE
SUBTTL LAPSETUP AND FASLAPSETUP
LAPSETUP:
JUMPN A,LAPSMH ;ARG = NIL => SETUP SOME SYM PROPERTIES
MOVEI T,LAPST2
LAP5HAK:
PUSH P,T ;APPLIES THE ROUTINE FOUND IN T
; TO ALL THE GLOBALSYMS
PUSH P,[441100,,LAP5P] ;ATOMIC SYMBOL PLACED IN A,
; GLOBALSYM INDEX IN TT
MOVSI F,-LLSYMS
L5H1: ILDB TT,(P) ;HAFTA GET THE GLOBALSYM INDEX FROM
; PERMUTATION TABLE
CAIL TT,LGSYMS ;IF NOT A GLOBALSYM [BUT AN XTRASYM], SKIP IT
JRST L5XIT
CAIN TT,3 ;****NEVER CHANGE THE GLOBALSYM INDICES FOR:
JRST L5SPBND ; SPECBIND 3
CAIN TT,25 ; ERSETUP 25
JRST L5ERSTP ; MAKUNBOUND 34
CAIN TT,34 ; INHIBIT 47
JRST L5MKUNBD ; 0*0PUSH 53
CAIN TT,47 ; NILPROPS 54
JRST L5INHIBI ;THOSE HAVE MORE THAN 6 CHARS IN THEIR PNAME
CAIN TT,53 ;AND CANT BE RECONSTRUCTED BY UNSQOZ'ING FROM
JRST L50.0P ;FROM THE LAPFIV TABLE
CAIN TT,54
JRST L5NILP
MOVE D,LAPFIV(F)
PUSHJ P,UNSQOZ
L5H2: LDB TT,(P)
PUSHJ P,@-1(P)
L5XIT: AOBJN F,L5H1
JRST POP2J
L5ERSTP:
MOVEI A,[SIXBIT \ERSETUP \]
JRST L5H3
L5SPBND:
MOVEI A,[SIXBIT \SPECBIND \]
L5H3: HRLI A,440600
PUSHJ P,READ6C
JRST L5H2
L5MKUNBD:
MOVEI A,[SIXBIT \MAKUNBOUND \]
JRST L5H3
L5INHIBIT:
MOVEI A,[SIXBIT \INHIBIT \]
JRST L5H3
L50.0P: MOVEI A,[SIXBIT \0*0PUSH \]
JRST L5H3
L5NILP: MOVEI A,[SIXBIT \NILPROPS\]
JRST L5H3
LAPSMH: CAIE A,TRUTH ;(LAPSETUP| T 2) MEANS
JRST LAPSM1 ; SET UP THE XCT HACK AREAS
10$ JSP T,FXNV2 ; WITH 2 XCT PAGES
10$ MOVE TT,D
10$ JRST LDXHAK
10% POPJ P, ;FOR NON TOPS-10, NO NEED TO DO ANY SETUP
LAPSM1: MOVEI T,(B) ;OTHERWISE, FIRST ARG IS ADDRESS
MOVEI R,(A) ; TO HACK, SECOND NON-NIL =>
MOVE TT,(R) ; TRY THE XCT-PAGE HAK
PUSHJ P,PRCHAK ;TRY TO SMASH (SKIP ON FAILURE)
JRST TRUE
MOVEI A,(AR2A)
MOVE B,VPURCLOBRL
PUSHJ P,CONS
MOVEM A,VPURCLOBRL
JRST TRUE
LAPST2: MOVE TT,LSYMS(TT) ;GET ACTUAL VALUE FROM GLOBALSYM INDEX
MOVEI C,QSYM
LSYMPUT: ;EXPECTS SYMBOL IN A, "SYM" OR "GLOBALSYM"
MOVEI B,(A) ; IN C, AND VALUE IN TT
JSP T,FXCONS
EXCH A,B
JRST PUTPROP
FSLSTP:
MOVEI T,FSLST2
PUSHJ P,LAP5HAK
MOVE TT,LDFNM2
JRST FIX1
FSLST2: MOVEI C,(A) ;MAKE UP ATOMIC SYMBOLS AND GIVE THEM SYM PROPERTIES
JSP T,FXCONS ; OF THE FORM (0 (NIL <N>))
PUSHJ P,NCONS ; WHERE <N> IS THE INDEX OF THE SYMBOL
SETZ B, ; (THESE ARE THE "GLOBALSYMS")
PUSHJ P,XCONS
PUSHJ P,NCONS
MOVE B,CIN0
PUSHJ P,XCONS
MOVEI B,(A)
MOVEI A,(C)
MOVEI C,Q%GLOBALSYM
JRST PUTPROP
R70 ;GLOBALSYM NUMBER -1
LSYMS: GLBSYM A
LGSYMS==.-LSYMS ;END OF GLOBALSYMS HACKED BY FASLAP
XTRSYM A
LLSYMS==.-LSYMS ;END OF ALL GLOBAL SYMBOLS
;;; SIXBIT FOR LAP SYMBOL NAMES; MUST MATCH IRP LIST OF GLBSYM
ZZ==0
LAPSIX: .BYTE 6
SIXSYM [
IRPC Q,,[A]
'Q
TERMIN
0
ZZ==ZZ+1
] ;END OF SIXSYM ARGUMENT
.BYTE
IFN ZZ-LGSYMS, WARN [LAPSIX OUT OF PHASE]
EXPUNGE ZZ
LAPFIV:
GLBSYM [SQUOZE 0,A]
XTRSYM [SQUOZE 0,A]
HAOLNG LOG2LL5,<LLSYMS-1> ;CROCK FOR BINARY SEARCH
REPEAT <1_LOG2LL5>-LLSYMS, 377777,,777777
LAP5P: BLOCK <LLSYMS+3>/4 ;PERMUTATION, STORED 4/WD, TO GET GLOBALSYMINDEX FROM LAPFIV INDEX
GETDDTSYM:
PUSHJ P,RSQUEEZE
PUSHJ P,GETDDG ;GET GLOBALSYM INDEX, AND NO-SKIP IF WIN
JRST FIX1
IFN ITS,[
MOVE D,TT ;SAVE SQUOZE OVER CALL TO SIDDTP
JSP T,SIDDTP ;LOSE IF NO DDT FROM WHICH TO GET SYMBOL
JRST FALSE
MOVE TT,D
.BREAK 12,[..RSYM,,TT]
JUMPE TT,FALSE
MOVE TT,TT+1
JRST FIX1
] ;END OF IFN ITS
IFE ITS,[
PUSHJ P,GETDDJ
JRST FALSE
JRST FIX1
GETDDJ: SKIPA D,.JBSYM" ;SQUOZ IN TT - FIND SYMBOL IN JOB SYMBOL TABLE
GETDD1: ADD D,R70+2 ; SKIP IF FOUND
JUMPGE D,CPOPJ
MOVE T,(D)
TLZ T,540000
TLZN T,200000 ;SYMBOL MUSTN'T BE KILLED
CAME T,TT ;MUST BE THE ONE WE WANT
JRST GETDD1
MOVE TT,1(D)
AOJA D,POPJ1
] ;END OF IFE ITS
GETDDG: MOVEI R,0 ;SQUOZ IN T, SEARCH "GLOBALSYM" TABLE,
TLZ T,740000 ; SKIP IF LOSE, LEAVE VALUE IN TT IF WIN
REPEAT LOG2LL5,[
CAML T,LAPFIV+<1_<LOG2LL5-.RPCNT-1>>(R)
ADDI R,1_<LOG2LL5-.RPCNT-1>
] ;END OF REPEAT LOG2LL5
CAME T,LAPFIV(R) ;IF DDTSYM REQUEST IS FOR A GLOBAL SYM
JRST POPJ1 ;THEN FIND IT IN THE LAPFIV TABLE, AND GET ITS
LSHC R,-2 ;GLOBALSYM INDEX FROM THE PERMUTATION TABLE
LSH F,-42
LDB TT,LDGET6(F) ;USE TABLE FROM FASLOAD
MOVE TT,LSYMS(TT)
POPJ P,
LGTSPC: MOVEM TT,GAMNT
ADD TT,@VBPORG ;INSURE THAT BPEND-BPORG > (TT)
SUB TT,@VBPEND
JUMPGE TT,GTSPC1 ;MUST RELOCATE, OR GET MORE CORE.
MOVE A,VBPEND ;ALREADY OK
MOVE TT,(A)
POPJ P,
PAGEBPORG: MOVE A,VBPORG ;MAKE SURE BPORG IS ON PAGE BOUNDRY
MOVE TT,(A) ;NUMERIC VALUE OF BPORG
TRNN TT,PAGKSM
POPJ P,
ADDI TT,PAGSIZ-1
ANDCMI TT,PAGKSM
CAMGE TT,@VBPEND
JRST PGBP4
PUSH FXP,TT ;NEW VALUE FOR BPORG
JSP T,SPECBIND
0 VNORET
AOS VNORET
PUSH P,CUNBIND
SUB TT,(A)
PUSHJ P,LGTSPC
JUMPE TT,[LERR [SIXBIT \NO CORE - PAGEBPORG!\]]
POP FXP,TT
PGBP4: JSP T,FIX1A
MOVEM A,VBPORG ;GIVE BPORG NEW PAGIFIED VALUE
POPJ P,
SUBTTL MAKUNBOUND AND PURIFY
;NEVER FLUSHES VALUE CELL
MAKUBE: %WTA [SIXBIT \UNCHANGEABLE VALUE - MAKUNBOUND!\]
MAKUNBOUND: ;SUBR 1 - FLUSH VALUE OF ATOMIC SYMBOL
BAKPRO
JSP D,SETCK ;MAKE SURE IT'S A SYMBOL
JUMPE A,MAKUBE
CAIN A,TRUTH
JRST MAKUBE
HLRZ T,(A)
MOVE B,(T)
IFE 0, NOPRO
IFN 0,[
TLNE B,300 ;CAN'T RECLAIM VALUE CELL IF PURE
JRST MAKUN1 ; OR IF COMPILED CODE NEEDS IT
TLZ B,-1
CAIN B,SUNBOUND ;CAN'T RECLAIM SUNBOUND!!!
POPJ P,
CAIL B,BXVCSG+NXVCSG*SEGSIZ
JRST MAKUN1 ;CAN'T RECLAIM CELL NOT IN VALUE CELL AREA
EXCH B,FFVC ;SO RECLAIM THE VALUE CELL ALREADY
XCTPRO
MOVEM B,@FFVC
MOVEI B,SUNBOUND ;USE SUNBOUND FOR A VALUE CELL
HRRM B,(T)
NOPRO
POPJ P, ;THAT'S ALL
] ;END IFN 0
MAKUN1: PUSH P,A ;MAKE SURE WE RETURN THE ARGUMENT
PUSH P,CPOPAJ
MOVEI B,QUNBOUND ;FALL INTO SET WITH "UNBOUND" VALUE
JRST SET+1
;;;; PURIFY
IFN USELESS,[
$PURIFY:
IFN D10, POPJ P,
IFN ITS+D20,[
LOCKTOPOPJ
SETZ AR1,
JSP T,FXNV1 ;GET TWO MACHINE NUMBERS
JSP T,FXNV2
ANDCMI TT,1777 ;PAGIFY FIRST DOWNWARD
IORI D,1777 ;PAGIFY SECOND UPWARD
CAMLE TT,D
LERR [SIXBIT \ARG 2 < ARG 1 - PURIFY!\]
JUMPE C,FPURF3 ;NULL THIRD ARG MEANS DEPURE
MOVE T,LDXLPL
HRRZ T,LDXPSP(T) ;GET ADR OF POSSIBLY PURE PAGE
CAIG TT,(T)
CAIGE D,(T)
SKIPA
SETZM LDXLPC ;FOR PURE PAGE JUST FORCE FREE COUNT TO ZERO
FPURF0: CAIE C,QBPORG
JRST FPURF3
PUSHJ P,FPURF7
JRST FPURF2
FPURF3: JSP R,IP0
POPJ P,
] ;END OF IFN ITS+D20
] ;END OF IFN USELESS
PGTOP UIO,[UTAPE, LAP, AND AGGLOMERATED SUBRS]
Reference in New Issue View Git Blame Copy Permalink