;;; -*-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| ) GETS THE ARRAY PROPERTY OF , ;;; 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 )) PUSHJ P,NCONS ; WHERE 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, ;CROCK FOR BINARY SEARCH REPEAT <1_LOG2LL5>-LLSYMS, 377777,,777777 LAP5P: BLOCK /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_>(R) ADDI R,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]