--- /dev/null
+
+TITLE MODIFIED AFREE FOR MUDDLE
+
+RELOCATABLE
+
+.INSRT MUDDLE >
+
+.GLOBAL CAFREE,CAFRET,PARNEW,AGC,PARBOT,CODTOP,CAFRE1
+.GLOBAL STOGC,STOSTR,CAFRE,ISTOST,STOLST,SAT,ICONS,BYTDOP
+.GLOBAL FLIST,STORIC,GPURFL,GCDANG,PVSTOR,SPSTOR
+.GLOBAL %CLNCO
+
+MFUNCTION FREEZE,SUBR
+
+ ENTRY 1
+
+ GETYP A,(AB) ; get type of it
+ PUSH TP,(AB) ; save a copy
+ PUSH TP,1(AB)
+ PUSH P,[0] ; flag for tupel freeze
+ PUSHJ P,SAT ; to SAT
+ MOVEI B,0 ; final type
+ CAIN A,SNWORD ; check valid types
+ MOVSI B,TUVEC ; use UVECTOR
+ CAIN A,S2NWOR
+ MOVSI B,TVEC
+ CAIN A,SARGS
+ MOVSI B,TVEC
+ CAIN A,SCHSTR
+ MOVSI B,TCHSTR
+ CAIN A,SBYTE
+ MOVEI B,TBYTE
+ JUMPE B,WTYP1
+ PUSH P,B ; save final type
+ CAMN B,$TBYTE
+ JRST .+3
+ CAME B,$TCHSTR ; special chars hack
+ JRST OK.FR
+ HRR B,(AB) ; fixup count
+ MOVEM B,(P)
+
+ MOVEI C,(TB) ; point to it
+ PUSHJ P,BYTDOP ; A==> points to dope word
+ HRRO B,1(TB)
+ SUBI A,1(B) ; A==> length of block
+ TLC B,-1(A)
+ MOVEM B,1(TB) ; and save
+ MOVSI 0,TUVEC
+ MOVEM 0,(TB)
+
+OK.FR: HLRE A,1(TB) ; get length
+ MOVNS A
+ PUSH P,A
+ ADDI A,2
+ PUSHJ P,CAFREE ; get storage
+ HRLZ B,1(TB) ; set up to BLT
+ HRRI B,(A)
+ POP P,C
+ ADDI C,(A) ; compute end
+ BLT B,(C)
+ HLLOS 1(C) ; INDICATION IN RELOCATION FIELD THAT ITS NOT GARBAGE
+ MOVEI B,(A)
+ HLL B,1(AB)
+ POP P,A
+ JRST FINIS
+
+
+CAFRE: PUSH P,A
+ HRRZ E,STOLST+1
+ SETZB C,D
+ PUSHJ P,ICONS ; get list element
+ PUSH TP,$TLIST ; and save
+ PUSH TP,B
+ MOVE A,(P) ; restore length
+ ADDI A,2 ; 2 more for dope words
+ PUSHJ P,CAFREE ; get the core and dope words
+ POP P,B ; restore count
+ MOVNS B ; build AOBJN pointer
+ MOVSI B,(B)
+ HRRI B,(A)
+ MOVE C,(TP)
+ MOVEM B,1(C) ; save on list
+ MOVSI 0,TSTORA ; and type
+ HLLM 0,(C)
+ HRRZM C,STOLST+1 ; and save as new list
+ SUB TP,[2,,2]
+ POPJ P,
+
+CAFRE1: PUSH P,A
+ ADDI A,2
+ PUSHJ P,CAFREE
+ HRROI B,(A) ; pointer to B
+ POP P,A ; length back
+ TLC B,-1(A)
+ POPJ P,
+
+CAFREE: IRP AC,,[B,C,D,E]
+ PUSH P,AC
+ TERMIN
+ SKIPG A ; make sure arg is a winner
+ FATAL BAD CALL TO CAFREE
+ MOVSI A,(A) ; count to left half for search
+ MOVEI B,FLIST ; get first pointer
+ HRRZ C,(B) ; c points to next block
+CLOOP: CAMG A,(C) ; skip if not big enough
+ JRST CONLIS ; found one
+ MOVEI D,(B) ; save in case fall out
+ MOVEI B,(C) ; point to new previous
+ HRRZ C,(C) ; next block
+ JUMPN C,CLOOP ; go on through loop
+ HLRZ E,A ; count to E
+ CAMGE E,STORIC ; skip if a area or more
+ MOVE E,STORIC ; else use a whole area
+ MOVE C,PARBOT ; found out if any funny space
+ SUB C,CODTOP ; amount around to C
+ EXCH B,D
+ CAMLE C,E ; skip if must GC
+ JRST CHAVIT ; already have it
+ SUBI E,-1(C) ; get needed from agc
+ MOVEM E,PARNEW ; funny arg to AGC
+ PUSH P,A
+ MOVE C,[7,,6] ; SET UP AGC INDICATORS
+ SKIPE GPURFL ; DONT GC IF IN DUMPER
+ JRST PURGC
+ PUSHJ P,AGC ; collect that garbage
+ SETZM PARNEW ; dont do it again
+ POP P,A
+
+; Make sure pointers still good after GC
+
+ MOVEI B,FLIST
+ HRRZ D,(B)
+
+ HRRZ E,(D) ; next pointer
+ JUMPE E,.+4 ; end of list ok
+ MOVEI B,(D)
+ MOVEI D,(E)
+ JRST .-4 ; look at next
+
+CHAVIT: MOVE C,CODTOP
+ MOVE E,PARBOT
+ PUSHJ P,%CLNCO ; flush extra pages
+ MOVE E,PARBOT ; find amount obtained
+ SUBI E,1 ; dont use a real pair
+ MOVEI C,(E) ; for reset of CODTOP
+ SUB E,CODTOP
+ EXCH C,CODTOP ; store it back
+ CAIE B,(C) ; did we simply grow the last block?
+ JRST CSPLIC ; no, splice it in
+ HLRZ C,(B) ; length of old guy
+ ADDI C,(E) ; total length
+ ADDI B,(E) ; point to new last dope word
+ HRLZM C,(B) ; clobber final length in
+ HRRM B,(D) ; and splice into free list
+ MOVEI C,(B) ; reset acs for reentry into loop
+ MOVEI B,(D)
+ JRST CLOOP
+
+; Here to splice new core onto end of list.
+
+CSPLIC: MOVE C,CODTOP ; point to end of new block
+ HRLZM E,(C) ; store length of new block in dope words
+ HRRM C,(D) ; D is old previous, link it up
+ MOVEI B,(D) ; and reset B for reentry into loop
+ JRST CLOOP
+
+; here if an appropriate block is on the list
+
+CONLIS: HLRZS A ; count back to a rh
+ HLRZ D,(C) ; length of proposed block to D
+ CAIN A,(D) ; skip if they are different
+ JRST CEASY ; just splice it out
+ MOVEI B,(C) ; point to block to be chopped up
+ SUBI B,-1(D) ; point to beginning of same
+ SUBI D,(A) ; amount of block to be left to D
+ HRLM D,(C) ; and fix up dope words
+ ADDI B,-1(A) ; point to end of same
+ HRLZM A,(B)
+ HRRM B,(B) ; for GC benefit
+
+CFREET: CAIE A,1 ; if more than 1
+ SETZM -1(B) ; make tasteful dope worda
+ SUBI B,-1(A)
+ MOVEI A,(B)
+ACRST: IRP AC,,[E,D,C,B]
+ POP P,AC
+ TERMIN
+ POPJ P,
+
+PURGC: SUB P,[1,,1] ; CLEAN OFF STACK
+ SETOM GCDANG ; INDICATE GC SHOULD HAVE OCCURED
+ JRST ACRST
+
+CEASY: MOVEI D,(C) ; point to block to return
+ HRRZ C,(C) ; point to next of same
+ HRRM C,(B) ; smash its previous
+ MOVEI B,(D) ; point to block with B
+ HRRM B,(B) ; for GC benefit
+ JRST CFREET
+
+CAFRET: HRROI B,(B) ; prepare to search list
+ TLC B,-1(A) ; by making an AOBJN pointer
+ HRRZ C,STOLST+1 ; start of list
+ MOVEI D,STOLST+1
+
+CAFRTL: JUMPE C,CPOPJ ; not founc
+ CAME B,1(C) ; this it?
+ JRST CAFRT1
+ HRRZ C,(C) ; yes splice it out
+ HRRM C,(D) ; smash it
+CPOPJ: POPJ P, ; dont do anything now
+
+CAFRT1: MOVEI D,(C)
+ HRRZ C,(C)
+ JRST CAFRTL
+
+; Here from GC to collect all unused blocks into free list
+
+STOGC: SETZB C,E ; zero current length and pointer
+ MOVE A,CODTOP ; get high end of free space
+
+STOGCL: CAIG A,STOSTR ; end?
+ JRST STOGCE ; yes, cleanup and leave
+
+ HLRZ 0,(A) ; get length
+ ANDI 0,377777
+ SKIPGE (A) ; skip if a not used block
+ JRST STOGC1 ; jump if marked
+
+; HERE TO SEE WHETHER AN UNMARKED ITEM IS AN ATOM. IF IT IS IT IS NOT GARBAGE
+; AND IT IS PRESERVED WITH ITS VALUE CELLS FLUSHED
+
+ HLRZ 0,-1(A) ; GET TYPE OF FIRST D.W.
+ ANDI 0,TYPMSK ; FLUSH MONITORS
+ CAIE 0,SATOM
+ JRST STOGC5 ; NOT AN ATOM COLLECT THE GARBAGE
+ PUSH P,A ; SAVE PTR TO D.W.
+ HLRZ 0,(A)
+ SUB A,0 ; POINT TO JUST BEFORE ATOM
+ SETZM 1(A) ; ZERO VALUE CELLS
+ SETZM 2(A)
+ POP P,A ; RESTORE A
+ JRST STOGC1
+
+STOGC5: HLRZ 0,(A)
+ JUMPE C,STOGC3 ; jump if no block under construction
+ ADD C,0 ; else add this length to current
+ JRST STOGC4
+
+STOGC3: MOVEI B,(A) ; save pointer
+ MOVE C,0 ; init length
+
+STOGC4: SUB A,0 ; point to next block
+ JRST STOGCL
+
+STOGC1: HLLOS (A) ; -1 IS INDICATOR OF FREE SLOT
+ ANDCAM D,(A) ; kill mark bit
+ JUMPE C,STOGC4 ; if no block under cons, dont fix
+ HRLM C,(B) ; store total block length
+ HRRM E,(B) ; next pointer hooked in
+ MOVEI E,(B) ; new next pointer
+ MOVEI C,0
+ JRST STOGC4
+
+STOGCE: JUMPE C,STGCE1 ; jump if no current block
+ HRLM C,(B) ; smash in count
+ HRRM E,(B) ; smash in next pointer
+ MOVEI E,(B) ; and setup E
+
+STGCE1: HRRZM E,FLIST+1 ; final link up
+ POPJ P,
+
+IMPURE
+
+FLIST: .+1
+ ISTOST
+
+PURE
+
+END
+\f
\ No newline at end of file
projects / pdp10-muddle.git / blobdiff