PDP-10.its/bin/librm3/madman.fbin

'<PCODE "MADMAN">

"(c) Copyright 1978 Massachusetts Institute of Technology.  All Rights Reserved." 

<PACKAGE "MADMAN"> 

<ENTRY PBLOCK CURSPACE ALLOC-TABLE AFIXCHOMP SPACE ARESERVE ARESTORE APGFIND 
APGGIVE PAGE-GIVE-TABLE AFIND ADD-ALLOC ARESET AGIVE ALENGTH APLENGTH PLENGTH 
APFREE AFREE UPAGES BOUNDS-CHECK ALEGAL? AGC ACOPY APRINT AREAD LFIXUP LHFIXUP 
LHPFIX LPFIXUP ASHARE ASHARE-RESET ASHARE-VECTOR ACONS ARELEASE ALSTRING ASTRING
ALISTRING AISTRING ALBYTES ABYTES ALIBYTES AIBYTES ALLIST ALIST ALILIST AILIST 
ALVECTOR AVECTOR ALIVECTOR AIVECTOR ALUVECTOR AUVECTOR ALIUVECTOR AIUVECTOR APUT
APUTC CURSPACE ASHARE-INIT UINDEX MADMAN-PAGE-FIND MADMAN-PAGE-GIVE ABIT-NOGROW 
ASPEC-BITS> 

<USE-DEFER "ASYLUM"> 

<DEFINE PUSHEM () #SPLICE (<PUSH P* O> <PUSH P* A> <PUSH P* B> <PUSH P* C> <PUSH
P* D> <PUSH P* E>)> 

<DEFINE POPPEM () #SPLICE (<POP P* E> <POP P* D> <POP P* C> <POP P* B> <POP P* A
> <POP P* O>)> 

<SETG AGCUV <IUVECTOR 2 #WORD *000000000000*>> 

<SETG ACOPY  %<RSUBR!- '[ %<PCODE!- "MADMAN" 0> ACOPY #DECL ("VALUE" ANY SPACE 
ANY) LHPFIX APUT PRINTP DATWRITE READP DATREAD CORE-BLOCK GET-LOC PUT-LOC 
MAP-PAGE AFIXCHOMP ILLEGAL-OBJECT!-ERRORS INTERNAL-ERROR!-ERRORS 
MUNGED-TEMPLATE!-ERRORS TEMPLATE-LOSSAGE!-ERRORS CURSPACE %<TYPE-W SPACE VECTOR>
 ARG-WRONG-TYPE!-ERRORS OUT-OF-BOUNDS!-ERRORS NEGATIVE-ARGUMENT!-ERRORS 
TYPES-DIFFER-IN-UNIFORM-VECTOR!-ERRORS NON-CHARACTER-INTO-STRING!-ERRORS 
NON-STRUCTURED-ARG-TO-PUT!-ERRORS CANT-PUT-NON-CHARACTER-INTO-STRING!-ERRORS 
TYPES-DIFFER-IN-UVECTOR!-ERRORS %<RGLOC CURSPACE T> 
CURSPACE-NOT-GASSIGNED!-ERRORS CANT-LOCK-SPACE RELEASE-OUT-OF-SPACE %<RGLOC 
TENEX T> T #FALSE ("ILLEGAL-ARGUMENT") #FALSE ("CANT-FILL-REQUEST") %<RGLOC 
AERRCHECK T> AERRFALSE OBJECT-POINTS-OUTSIDE-AREA!-ERRORS %<RGLOC BCFALSE T> 
NEGATIVE-LENGTH-VECTOR!-ERRORS #FALSE ("NEGATIVE-LENGTH-VECTOR") %<RGLOC 
AFIXCHOMP T> OUTCHAN "
        PGS        HIGH WORD             LAST WORD" %<TYPE-W PBLOCK VECTOR> 
"
CURRENT LOCATION = " "
LOWEST LOCATION  = " "
FVC LOCATION     = " "
FREE LIST LENGTH = " "
SPEC = " %<RGLOC ALLOC-TABLE T> #FALSE ("PAGE-FIND-FAILED") "READB" 
"MADMAN;ASHARE PAGE" "PRINTB" CANT-GET-SHARE-PAGE!-ERRORS SCRATCH-PAGE %<RGLOC 
SCRATCH-PAGE T> %<RGLOC AUV3 T> %<RGLOC AUV2 T> TENEX CANT-GET-PAGES!-ERRORS #
FALSE ("APGFIND-FAILED") %<RGLOC SPARE-PBLOCKS T> %<RGLOC SPARE-SPACE T> %<RGLOC
SPARE-LIST T> GROWING-UNGROWABLE-SPACE #FALSE ("ARESERVE FAILED") %<RGLOC AUV6 T
> %<TYPE-C ASYLUM VECTOR> %<TYPE-C CHANP VECTOR> %<RGLOC ARVL T> %<RGLOC 
AREAD-VECTOR T> #FALSE ("SPACE NOT LARGE ENOUGH FOR READ?") %<RGLOC AUV4 T> (
ACTIVATION) WORD LIST [STRING BYTES]]>> 
<AND <ASSIGNED? GLUE> .GLUE <PUT ,ACOPY PGLUE ![715827967 -1 -1 -1 -1048576 0!]>
> 


<SETG AGC %<RSUBR-ENTRY '[ACOPY AGC #DECL ("VALUE" ANY SPACE ANY)] 9>> 

<BLOCK (<ROOT>)> 

TABLOCK 

<ENDBLOCK> 

<SETG ACONS %<RSUBR-ENTRY '[ACOPY ACONS #DECL ("VALUE" <OR LIST FALSE> SPACE ANY
LIST)] 468>> 

<SETG TABLOCK %<RSUBR-ENTRY '[ACOPY TABLOCK #DECL ("VALUE" UVECTOR FIX)] 1486>> 

<SETG APUT %<RSUBR-ENTRY '[ACOPY APUT #DECL ("VALUE" ANY SPACE STRUCTURED FIX 
ANY)] 1353>> 

<SETG ALSTRING %<RSUBR-ENTRY '[ACOPY ALSTRING #DECL ("VALUE" <OR STRING FALSE> 
"TUPLE" TUPLE)] 1266>> 

<SETG ASTRING %<RSUBR-ENTRY '[ACOPY ASTRING #DECL ("VALUE" <OR STRING FALSE> 
SPACE "TUPLE" TUPLE)] 1246>> 

<SETG ALUVECTOR %<RSUBR-ENTRY '[ACOPY ALUVECTOR #DECL ("VALUE" <OR UVECTOR FALSE
> "TUPLE" TUPLE)] 1199>> 

<SETG AUVECTOR %<RSUBR-ENTRY '[ACOPY AUVECTOR #DECL ("VALUE" <OR UVECTOR FALSE> 
SPACE "TUPLE" TUPLE)] 1179>> 

<SETG ALVECTOR %<RSUBR-ENTRY '[ACOPY ALVECTOR #DECL ("VALUE" <OR VECTOR FALSE> 
"TUPLE" TUPLE)] 1137>> 

<SETG AVECTOR %<RSUBR-ENTRY '[ACOPY AVECTOR #DECL ("VALUE" <OR VECTOR FALSE> 
SPACE "TUPLE" TUPLE)] 1117>> 

<SETG ALISTRING %<RSUBR-ENTRY '[ACOPY ALISTRING #DECL ("VALUE" <OR STRING FALSE>
FIX "OPTIONAL" CHARACTER)] 1089>> 

<SETG AISTRING %<RSUBR-ENTRY '[ACOPY AISTRING #DECL ("VALUE" <OR STRING FALSE> 
SPACE FIX "OPTIONAL" CHARACTER)] 1067>> 

<SETG ALIBYTES %<RSUBR-ENTRY '[ACOPY ALIBYTES #DECL ("VALUE" <OR BYTES FALSE> 
FIX FIX "OPTIONAL" <PRIMTYPE WORD>)] 995>> 

<SETG AIBYTES %<RSUBR-ENTRY '[ACOPY AIBYTES #DECL ("VALUE" <OR BYTES FALSE> 
SPACE FIX FIX "OPTIONAL" <PRIMTYPE WORD>)] 971>> 

<SETG ALBYTES %<RSUBR-ENTRY '[ACOPY ALBYTES #DECL ("VALUE" <OR BYTES FALSE> FIX 
"TUPLE" TUPLE)] 859>> 

<SETG ABYTES %<RSUBR-ENTRY '[ACOPY ABYTES #DECL ("VALUE" <OR BYTES FALSE> SPACE 
FIX "TUPLE" TUPLE)] 836>> 

<SETG ALIUVECTOR %<RSUBR-ENTRY '[ACOPY ALIUVECTOR #DECL ("VALUE" <OR UVECTOR 
FALSE> FIX "OPTIONAL" ANY)] 781>> 

<SETG AIUVECTOR %<RSUBR-ENTRY '[ACOPY AIUVECTOR #DECL ("VALUE" <OR UVECTOR FALSE
> SPACE FIX "OPTIONAL" ANY)] 759>> 

<SETG ALIVECTOR %<RSUBR-ENTRY '[ACOPY ALIVECTOR #DECL ("VALUE" <OR VECTOR FALSE>
FIX "OPTIONAL" ANY)] 703>> 

<SETG AIVECTOR %<RSUBR-ENTRY '[ACOPY AIVECTOR #DECL ("VALUE" <OR VECTOR FALSE> 
SPACE FIX "OPTIONAL" ANY)] 681>> 

<SETG ALLIST %<RSUBR-ENTRY '[ACOPY ALLIST #DECL ("VALUE" <OR LIST FALSE> "TUPLE"
TUPLE)] 620>> 

<SETG ALIST %<RSUBR-ENTRY '[ACOPY ALIST #DECL ("VALUE" <OR LIST FALSE> SPACE 
"TUPLE" TUPLE)] 600>> 

<SETG ALILIST %<RSUBR-ENTRY '[ACOPY ALILIST #DECL ("VALUE" <OR LIST FALSE> FIX 
"OPTIONAL" ANY)] 547>> 

<SETG AILIST %<RSUBR-ENTRY '[ACOPY AILIST #DECL ("VALUE" <OR LIST FALSE> SPACE 
FIX "OPTIONAL" ANY)] 525>> 

<SETG ALCONS %<RSUBR-ENTRY '[ACOPY ALCONS #DECL ("VALUE" <OR LIST FALSE> ANY 
LIST)] 476>> 

<SETG ARELEASE %<RSUBR-ENTRY '[ACOPY ARELEASE #DECL ("VALUE" ANY SPACE ANY 
"OPTIONAL" FIX)] 1665>> 

<SETG PRINTA %<RSUBR-ENTRY '[ACOPY PRINTA #DECL ("VALUE" ANY CHANNEL <OR UVECTOR
<PRIMTYPE WORD>> FIX)] 1866>> 

<SETG READA %<RSUBR-ENTRY '[ACOPY READA #DECL ("VALUE" ANY CHANNEL <OR UVECTOR <
PRIMTYPE WORD>> FIX)] 1873>> 

<SETG PAGE-CLEAR %<RSUBR-ENTRY '[ACOPY PAGE-CLEAR #DECL ("VALUE" 'T FIX FIX)] 
1908>> 

<SETG CLEAR-UV %<RSUBR-ENTRY '[ACOPY CLEAR-UV #DECL ("VALUE" UVECTOR UVECTOR)] 
1931>> 

<SETG CLEAR-VEC %<RSUBR-ENTRY '[ACOPY CLEAR-VEC #DECL ("VALUE" VECTOR VECTOR)] 
1950>> 

<SETG AOBJECT %<RSUBR-ENTRY '[ACOPY AOBJECT #DECL ("VALUE" UVECTOR ANY UVECTOR)]
1965>> 

<SETG GET-VECTOR %<RSUBR-ENTRY '[ACOPY GET-VECTOR #DECL ("VALUE" <OR FALSE 
VECTOR> <PRIMTYPE WORD>)] 1981>> 

<SETG MOVE-M %<RSUBR-ENTRY '[ACOPY MOVE-M #DECL ("VALUE" 'T <PRIMTYPE WORD> <
PRIMTYPE WORD>)] 1992>> 

<SETG GETLOC %<RSUBR-ENTRY '[ACOPY GETLOC #DECL ("VALUE" WORD <PRIMTYPE WORD>)] 
2004>> 

<SETG APGFIND %<RSUBR-ENTRY '[ACOPY APGFIND #DECL ("VALUE" <OR FALSE FIX> FIX 
FIX <UVECTOR [REST WORD]>)] 2014>> 

<SETG APGGIVE %<RSUBR-ENTRY '[ACOPY APGGIVE #DECL ("VALUE" FIX FIX FIX <UVECTOR 
[REST WORD]>)] 2118>> 

<SETG PAGE-GIVE-TABLE %<RSUBR-ENTRY '[ACOPY PAGE-GIVE-TABLE #DECL ("VALUE" <OR 
ATOM FALSE> <UVECTOR [8 WORD]>)] 2148>> 

<SETG MADMAN-PAGE-FIND %<RSUBR-ENTRY '[ACOPY MADMAN-PAGE-FIND #DECL ("VALUE" <OR
FIX FALSE> "OPTIONAL" FIX)] 2184>> 

<SETG MADMAN-PAGE-GIVE %<RSUBR-ENTRY '[ACOPY MADMAN-PAGE-GIVE #DECL ("VALUE" FIX
FIX "OPTIONAL" FIX)] 2208>> 

<AND <GET ESYASS!-PACKAGE OBLIST> <SETG <OR <LOOKUP "F*" <GET OP!-PACKAGE OBLIST
>> <INSERT "F*" <GET OP!-PACKAGE OBLIST>>> <CHTYPE 50331648 <LOOKUP "OPCODE" <
GET OP!-PACKAGE OBLIST>>>> <SETG <OR <LOOKUP "G*" <GET OP!-PACKAGE OBLIST>> <
INSERT "G*" <GET OP!-PACKAGE OBLIST>>> <CHTYPE 58720256 <LOOKUP "OPCODE" <GET 
OP!-PACKAGE OBLIST>>>>> 

<SETG BCFALSE #FALSE ("OBJECT-POINTS-OUTSIDE-SPACE" 1)> 

<SETG LHFIXUP %<RSUBR-ENTRY '[ACOPY LHFIXUP #DECL ("VALUE" ANY WORD WORD VECTOR)
] 2238>> 

<SETG LFIXUP %<RSUBR-ENTRY '[ACOPY LFIXUP #DECL ("VALUE" ANY WORD WORD WORD WORD
WORD)] 2401>> 

<SETG LPFIXUP %<RSUBR-ENTRY '[ACOPY LPFIXUP #DECL ("VALUE" ANY ANY UVECTOR 
VECTOR)] 2313>> 

<SETG LHPFIX %<RSUBR-ENTRY '[ACOPY LHPFIX #DECL ("VALUE" WORD WORD <VECTOR [REST
WORD]>)] 2276>> 

<SETG GET-LIST %<RSUBR-ENTRY '[ACOPY GET-LIST #DECL ("VALUE" LIST WORD)] 2671>> 

<SETG GET-FRESH-PAGE %<RSUBR-ENTRY '[ACOPY GET-FRESH-PAGE #DECL ("VALUE" <OR FIX
FALSE> FIX)] 2681>> 

<SETG INDEX %<RSUBR-ENTRY '[ACOPY INDEX #DECL ("VALUE" FIX)] 2721>> 

<SETG ARVL 60> 

<SETG AREAD-VECTOR <IVECTOR ,ARVL #WORD *000000000000*>> 

<NEWTYPE PBLOCK VECTOR '<VECTOR FIX WORD>> 

<NEWTYPE SPACE VECTOR '<VECTOR <LIST [REST PBLOCK]> WORD WORD WORD LIST VECTOR 
FIX FIX>> 

<SETG FREE-VECTOR-CHAIN 4> 

<SETG FREE-LIST 5> 

<SETG ASHARE-VECTOR 6> 

<SETG ASHARE-LOCK 7> 

<SETG ASPEC-BITS 8> 

"ERROR IF ATTEMPT TO GROW SPACE" 

<SETG ABIT-NOGROW *400000000000*> 

"ERROR IF ATTEMPT TO RELEASE SOMETHING OUTSIDE SPACE" 

<SETG ABIT-RELERR 17179869184> 

<MANIFEST FREE-VECTOR-CHAIN FREE-LIST ASHARE-VECTOR ASHARE-LOCK ASPEC-BITS 
ABIT-NOGROW ABIT-RELERR> 

<SETG SPARE-SPACE <CHTYPE [() #WORD *000000000000* #WORD *000000000000* #WORD 
*000000000000* () [] -1 0] SPACE>> 

<SETG SPARE-LIST '(T)> 

<SETG SPARE-PBLOCKS '()> 

<SETG ALLOC-TABLE <IUVECTOR 8 #WORD *000000000000*>> 

<SETG AUV1 <IUVECTOR 1 #WORD *000000000000*>> 

<SETG AUV2 <IUVECTOR 2 #WORD *000000000000*>> 

<SETG AUV3 <IUVECTOR 3 #WORD *000000000000*>> 

<SETG AUV4 <IUVECTOR 4 #WORD *000000000000*>> 

<SETG AUV6 <IUVECTOR 6 #WORD *000000000000*>> 

<GDECL (SPARE-PBLOCKS) LIST (AUV1 AUV2 AUV3 AUV4 AUV6) UVECTOR (SCRATCH-PAGE) 
SPACE (AREAD-VECTOR) VECTOR> 

<SETG SPACETYPE %<RSUBR-ENTRY '[ACOPY SPACETYPE #DECL ("VALUE" <OR FALSE FIX> 
SPACE)] 2728>> 

<AND <APPLICABLE? ,SPACETYPE> <PRINTTYPE SPACE ,SPACETYPE>> 

<SETG ARESERVE %<RSUBR-ENTRY '[ACOPY ARESERVE #DECL ("VALUE" <OR FALSE FIX> FIX 
"OPTIONAL" <UVECTOR [REST WORD]> <OR 'T FALSE>)] 2848>> 

<SETG GET-SHARE-PAGE %<RSUBR-ENTRY '[ACOPY GET-SHARE-PAGE #DECL ("VALUE" ANY)] 
2921>> 

<SETG ASHARE %<RSUBR-ENTRY '[ACOPY ASHARE #DECL ("VALUE" <OR FALSE SPACE> FIX 
"OPTIONAL" FIX FIX <OR FIX FALSE>)] 2978>> 

<SETG ASHARE-RESET %<RSUBR-ENTRY '[ACOPY ASHARE-RESET #DECL ("VALUE" SPACE SPACE
"OPTIONAL" <OR 'T FALSE> <OR 'T FALSE>)] 3236>> 

<SETG PGFIXUP %<RSUBR-ENTRY '[ACOPY PGFIXUP #DECL ("VALUE" <OR ATOM FALSE> FIX 
FIX "OPTIONAL" <OR 'T FALSE> FIX)] 3298>> 

<SETG ARESTORE %<RSUBR-ENTRY '[ACOPY ARESTORE #DECL ("VALUE" <OR FALSE FIX> 
SPACE "OPTIONAL" <OR ATOM FALSE>)] 3402>> 

<SETG AFIND %<RSUBR-ENTRY '[ACOPY AFIND #DECL ("VALUE" <OR FALSE SPACE> FIX 
"OPTIONAL" <OR FALSE SPACE> FIX)] 3464>> 

<SETG AGIVE %<RSUBR-ENTRY '[ACOPY AGIVE #DECL ("VALUE" SPACE SPACE)] 3553>> 

<SETG ARESET %<RSUBR-ENTRY '[ACOPY ARESET #DECL ("VALUE" SPACE SPACE "OPTIONAL" 
<OR FALSE 'T> <OR FALSE 'T>)] 3619>> 

<SETG PAGE-FIXUP %<RSUBR-ENTRY '[ACOPY PAGE-FIXUP #DECL ("VALUE" SPACE FIX FIX 
SPACE "OPTIONAL" <OR 'T FALSE>)] 3796>> 

<SETG GET-PBLOCK %<RSUBR-ENTRY '[ACOPY GET-PBLOCK #DECL ("VALUE" PBLOCK FIX WORD
WORD)] 3919>> 

<SETG ADD-ALLOC %<RSUBR-ENTRY '[ACOPY ADD-ALLOC #DECL ("VALUE" <OR ATOM FALSE 
SPACE> SPACE FIX "OPTIONAL" <OR FIX FALSE>)] 3975>> 

<SETG BORDER? %<RSUBR-ENTRY '[ACOPY BORDER? #DECL ("VALUE" <OR FALSE PBLOCK> 
PBLOCK <LIST [REST PBLOCK]>)] 4359>> 

<SETG UPAGES %<RSUBR-ENTRY '[ACOPY UPAGES #DECL ("VALUE" WORD SPACE)] 4395>> 

<SETG AFREE %<RSUBR-ENTRY '[ACOPY AFREE #DECL ("VALUE" <OR ATOM FALSE> SPACE 
PBLOCK)] 4448>> 

<SETG APLENGTH %<RSUBR-ENTRY '[ACOPY APLENGTH #DECL ("VALUE" WORD SPACE)] 4493>> 

<SETG ALENGTH %<RSUBR-ENTRY '[ACOPY ALENGTH #DECL ("VALUE" WORD SPACE "OPTIONAL"
FIX FIX)] 4536>> 

<SETG PLENGTH %<RSUBR-ENTRY '[ACOPY PLENGTH #DECL ("VALUE" FIX SPACE PBLOCK FIX)
] 4623>> 

<SETG PFREE %<RSUBR-ENTRY '[ACOPY PFREE #DECL ("VALUE" FIX SPACE PBLOCK)] 4671>> 

<SETG AREAD %<RSUBR-ENTRY '[ACOPY AREAD #DECL ("VALUE" ANY SPACE <OR CHANNEL 
CHANP ASYLUM> "OPTIONAL" FIX FIX <OR 'T FALSE>)] 4701>> 

<SETG APRINT %<RSUBR-ENTRY '[ACOPY APRINT #DECL ("VALUE" <OR ASYLUM CHANNEL 
CHANP> SPACE ANY <OR CHANNEL CHANP ASYLUM> "OPTIONAL" FIX <OR 'T FALSE>)] 5227>> 

<SETG BOUNDS-CHECK %<RSUBR-ENTRY '[ACOPY BOUNDS-CHECK #DECL ("VALUE" ANY SPACE)]
5909>> 

<SETG ALEGAL? %<RSUBR-ENTRY '[ACOPY ALEGAL? #DECL ("VALUE" <OR ATOM FALSE> SPACE
ANY)] 6069>> 

<SETG APUTC %<RSUBR-ENTRY '[ACOPY APUTC #DECL ("VALUE" ANY SPACE STRUCTURED FIX 
ANY)] 6179>> 

<SETG ASHARE-INIT %<RSUBR-ENTRY '[ACOPY ASHARE-INIT #DECL ("VALUE" <OR ATOM 
FALSE SPACE>)] 6224>> 

<ENDPACKAGE>