**********************************************************************
* Name: USE
* Stack: ( id --> list ) * Recursive *
* ( romp --> list ) * Recursive *
* ( dir --> list )
* ( ob --> list )
* Desc: Subroutine usage analyzer
**********************************************************************
ASSEMBLE
CON(1) 8
RPL
xNAME USE
::
CK1
::
DUPTYPEIDNT? case :: DUP@ TRUE ;
DUPTYPEROMP? NOTcaseFALSE
DUPROMPTR@ TRUE
;
( id ob TRUE TRUE / romp ob TRUE TRUE / ob FALSE )
NOTcase
::
GARBAGE ( * Make safe * )
CODE
USEstart GOSBVL =SAVPTR
USErestart GOSBVL =ROOM C[A] = room
LA(5) 200 Safety requirement
C=C-A A
GONC +
GOVLNG =GPMEMERR
+ ASRB.F A
C=C+A A Allocate atleast 100 nibbles
R1=C A R1[A] = free
GOSBVL =MAKE$N * Is safe now *
A=DAT1 A
AD0EX D0 = ->ob
D1=A D1 = ->output
* Dispatch based on object type
A=DAT0 A A[A] = obtype
LC(5) =DORRP
?A=C A
GOYES USErrp
LC(5) =DOLIB
?A#C A
GOYES +
GOTO USElib
* Scan a regular object
+ GOSUB USEscan
* Exit scanner
USEexit CD1EX Remove trailing extra space
RSTK=C
D0=C
GOSBVL =Shrink$
C=RSTK Remove leading 10 nibbles due to $
D0=C
C=0 A
LC(1) 10
A=DAT0 A
A=A-C A
DAT0=A A
A=R0
A=A+CON A,10
GOSBVL =MOVERSD * IS SAFE *
GOVLNG =GPOverWrR0Lp And push result
**********************************************************************
* Scan a directory object
**********************************************************************
USErrp GOSUB USEalloc{}
AD0EX A[A]=->rrp
GOSBVL =FNDLOPTR D0 = ->lastram-word offset
C=DAT0 A C[A] = offset
AD0EX
A=A+C A A[A] = ->lastram-word
?C=0 A
GOYES userrpdone Empty rrp - done
R4=A R4[A] = ->last variable
userrploop A=R4
D0=A D0 = ->variable
GOSBVL =TRAVERSE+ D0 = ->ob
A=R4
AD0EX D0 = ->variable
B=A A B[A] = ->ob
C=0 A
C=DAT0 B C[A] = chars in name
C=C+C A C[A] = nibbles in name
C=C+CON A,7 + 7 for DOIDNT and length
GOSUB USEallocC allocate name
LA(5) =DOIDNT Output prolog
DAT1=A A
D1=D1+ 5
C=C-CON A,5 And copy length & body
GOSBVL =MOVEDOWN
C=B A
D0=C D0 = ->ob
GOSUB USEscan Scan usage
GOSUB USEfix Change to NULL{} if got { }
A=R4
A=A-CON A,5 A[A] = ->variable offset
D0=A
C=DAT0 A C[A] = variable offset
A=A-C A
R4=A R4[A] = ->variable'
?C#0 A
GOYES userrploop Continue until no more variables
userrpdone GOSUB USEoutsemi
GOTO USEexit
* Check if had no usage at all - if so then output NULL{} instead
USEfix D1=D1- 10
A=DAT1 A
D1=D1+ 10
LC(5) =DOLIST
?C#A A
RTNYES
D1=D1- 10
LC(5) =NULL{}
DAT1=C A
D1=D1+ 5
C=R1
C=C+CON A,5 free = free + 5
R1=C
RTNCC
**********************************************************************
* Scan a library object - not implemented
**********************************************************************
USElib LC(5) =SYNTAXERR
GOVLNG =GETPTREVALC
**********************************************************************
* Allocate a list and output leading "{"
USEalloc{} P= 5+5
GOSUB USEallocP
LC(5) =DOLIST
DAT1=C A
D1=D1+ 5
RTN
* Output trailing "}"
USEoutsemi LC(5) =SEMI
DAT1=C A
D1=D1+ 5
RTN
**********************************************************************
* Scan a single _regular_ object for usage of ID's & ROMPTR's
*
* Input: D0 = ->ob R1[A] = free
* D1 = ->output
**********************************************************************
USEscan CD1EX
D1=C
R2=C R2[A] = ->output
GOSUB USEalloc{} Allocate list & output DOLIST
AD0EX
B=A A B[A] = ->ob
D0=A
GOSBVL =SKIPOB
A=B A
AD0EX D0 = ->ob
B=A A A[A] = ->obend
USEloop AD0EX Check current address first
D0=A
?A>=B A
GOYES USEoutsemi Reached end - output semi & exit
A=DAT0 A
LC(5) =DOCOL #02D9D
?C=A A
GOYES usecomp
LC(3) =DOLIST #02A74
?C=A A
GOYES usecomp
LC(2) =DOSYMB #02AB8
?C=A A
GOYES usecomp
LC(2) =DOEXT #02ADA
?C=A A
GOYES usecomp
LC(3) =DOIDNT #02E48
?C=A A
GOYES useidromp
LC(2) =DOROMP #02E92
?C=A A
GOYES useidromp
LC(4) =SEMI #0312B
?C=A A
GOYES usecomp
usecont GOSBVL =SKIPOB
GOTO USEloop
* Found composite - just skip into it & continue
usecomp D0=D0+ 5
GOTO USEloop
* Found idnt/romp - add it to usage list
useidromp C=R2.F A C[A] = ->usage
CD0EX D0 = ->usage
CD1EX D1 = ->ob
D=C A D[A] = ->output
D0=D0+ 5 Skip prolog
- CD0EX * Search a match from usage list
D0=C
?C>=D A
GOYES useadd Reached end - add new usage
GOSUB USEcompare
GOC + Match - no need to add
GOSBVL =SKIPOB
GOTO -
+ C=D A C[A] = ->output
CD1EX D1 = ->output
D0=C D0 = ->ob
GOTO usecont And continue
* Add object to usage list
useadd C=D A C[A] = ->output
CD1EX D1 = ->output
D0=C D0 = ->ob
RSTK=C RSTK = ->ob
GOSBVL =SKIPOB D0 = ->obend
C=RSTK C[A] = ->ob
AD0EX
D0=C D0 = ->ob
C=A-C A C[A] = obsize
GOSUB USEallocC Allocate it
GOSBVL =MOVEDOWN And append to the list
GOTO USEloop And continue until object is scanned
* Compare objects in D0 & D1
USEcompare A=DAT0 7 Quick exit if first 7 nibbles don't
C=A W match (7 = size of DOCHAR)
C=DAT1 7
?A=C W
GOYES + 7 nibbles match - compare the rest
RTNCC CC: No match
+ C=B A Save B[A] in RSTK
RSTK=C
CD0EX
B=C A B[A] = ->ob0
CD0EX
GOSBVL =SKIPOB D0 = ->ob0end
C=B A
RSTK=C Save ->ob0 in RSTK
CD0EX
C=C-B A C[A] = ob0 size
C=C-1 A
GOC usecmpno HUH!
P=C 0 P = nibbles to compare
CSR A
B=C A B[A] = words to compare
A=DAT0 WP
C=DAT1 WP
?C#A WP
GOYES usecmpno No match - recover & exit
CD0EX
C+P+1
CD0EX
CD1EX
C+P+1
CD1EX
P= 0
- B=B-1 A Compare words until end/match
GOC usecmpyes Match - recover & exit
A=DAT0 W
C=DAT1 W
D0=D0+ 16
D1=D1+ 16
?C=A W
GOYES -
usecmpno P= 1 Indicate failure
usecmpyes C=RSTK Recalculate ->ob0 and ->ob1
AD0EX
D0=C
A=A-C A
CD1EX
C=C-A A
D1=C
C=RSTK
B=C A
?P= 0
RTNYES CS: Match
P= 0
RTNCC CC: No match
* Memory allocation subroutines
USEallocP C=0 A
CPEX 0
USEallocC AR1EX.F A
A=A-C A
AR1EX.F A
RTNNC
GOVLNG =GPMEMERR
ENDCODE
;
( id ob TRUE / id FALSE / romp ob TRUE / romp FALSE )
NOTcase SETNONEXTERR ( * No contents! * )
* Scan the object
DUP GARBAGE
CODE
GOTO USEstart
ENDCODE ( id ob list )
* Avoid double recursion for lists
SWAP TYPERRP? case SWAPDROP ( --> list )
* Recurse deeper ( id list )
2DUP TWO{}N ROT ONE{}N ROT ( Luse Ldone Ltodo )
BEGIN
DUPNULLCOMP? NOT
WHILE
DUP TWO MINUSONE SUBCOMP
SWAP CARCOMP ( Luse Ldone Ltodo' name )
3PICKOVER EQUALPOSCOMP
#0<> caseDROP ( --> Luse Ldone Ltodo' )
ROTOVER >TCOMP UNROT ( Luse Ldone' Ltodo' name )
::
DUPTYPEIDNT? case DUP@
DUPTYPEROMP? NOTcaseFALSE
DUPROMPTR@
;
NOTcaseDROP ( --> Luse Ldone' Ltodo' )
GARBAGE
CODE
GOTO USEstart
ENDCODE ( Luse Ldone' Ltodo' name use )
ROTOVER &COMP UNROT ( Luse Ldone' Ltodo'' name use )
TWO{}N 4ROLLSWAP &COMP UNROT ( Luse' Ldone' Ltodo'' )
REPEAT
2DROP ( --> Luse )
;
**********************************************************************
