diff --git a/Makefile b/Makefile index 39619a32..b68026fd 100644 --- a/Makefile +++ b/Makefile @@ -29,14 +29,14 @@ SRC = syseng sysen1 sysen2 sysen3 sysnet kshack dragon channa \ moon teach ken lmio1 llogo a2deh chsgtv clib sys3 lmio turnip \ mits_s rab stan_k bs cstacy kp dcp2 -pics- victor imlac rjl mb bh \ lars drnil radia gjd maint bolio cent shrdlu vis cbf digest prs jsf \ - decus bsg muds54 hello + decus bsg muds54 hello rrs DOC = info _info_ sysdoc sysnet syshst kshack _teco_ emacs emacs1 c kcc \ chprog sail draw wl pc tj6 share _glpr_ _xgpr_ inquir mudman system \ xfont maxout ucode moon acount alan channa fonts games graphs humor \ kldcp libdoc lisp _mail_ midas quux scheme manual wp chess ms macdoc \ aplogo _temp_ pdp11 chsncp cbf rug bawden llogo eak clib teach pcnet \ combat pdl minits mits_s chaos hal -pics- imlac maint cent ksc klh \ - digest prs decus bsg madman hur lmdoc + digest prs decus bsg madman hur lmdoc rrs BIN = sys sys1 sys2 emacs _teco_ lisp liblsp alan inquir sail comlap \ c decsys graphs draw datdrw fonts fonts1 fonts2 games macsym \ maint _www_ gt40 llogo bawden sysbin -pics- lmman r shrdlu imlac \ diff --git a/build/timestamps.txt b/build/timestamps.txt index fc6e52cb..7d2bb060 100644 --- a/build/timestamps.txt +++ b/build/timestamps.txt @@ -1662,6 +1662,13 @@ rlb/faslre.116 198012060049.06 rms/lisp11.265 198012171044.51 rms/macros.18 197511040224.09 rms/palx.143 197204150602.24 +rrs/jsys.order 197810181754.50 +rrs/jsys.rsubr 197810162112.06 +rrs/pdump.12 197810192328.16 +rrs/subsys.mud 197811072327.30 +rrs/subsys.order 1978080144.12 +rrs/uvbyte.order 198112032117.39 +rrs/uvbyte.rsubr 198112010022.40 r/ts.r42 198605302320.40 rug/rug.doc2 197601150012.10 rwg/life.demo 197407260854.31 diff --git a/doc/rrs/jsys.order b/doc/rrs/jsys.order new file mode 100644 index 00000000..83890925 --- /dev/null +++ b/doc/rrs/jsys.order @@ -0,0 +1,50 @@ + JSYS PACKAGE + .... ....... + + THIS PACKAGE IS A JSYS HANDLER FOR TENEX AND TWINEX MUDDLE. +THERE ARE TWO RSUBRS, JSYS AND ADR. ALSO THERE IS AN OBLIST CALL J THAT +HAS THE ATOMS WHO'S PNAMES ARE THE NAMES OF THE 10X JSYS'S. THE GVALS +OF THESE ATOMS ARE THE RIGHT HALFS OF THE JSYS'S. + + THE RSUBR ADR TAKES ONE ARGUMENT. THIS IS EITHER A STRING OR +AN UVECTOR. ADR RETURNS A BYTE POINTER TO A STRING OR THE ADDRESS OF +THE FIRST WORD IN THE UVECTOR. + + THE RSUBR JSYS IS USED TO EXECUTE THE JSYS OF YOUR CHOICE. IT +HAS FIVE REQUIRED ARGUMENTS (PRIMTYPE WORD) AND AN OPTIONAL SIXTH ONE, +WHICH IS OF TYPE VECTOR (]>). THE FIRST ARG +IS THE THE RIGHT HALF OF THE JSYS TO PREFORM. ARGS 2 - 4 ARE THE ACS +1 - 3. THE 5TH ARG IS THE ADDRESS OF THE AC TO RETURN. THE SIXTH ARG +IS AN OPTIONAL TWO VECTOR FOR THE RESALTS TO RETURNED IN. IF THIS +ARG IS MISSING THEN JSYS PUTS ITS RESALTS INTO THE GVAL OF THE ATOM +JSYSVECTOR!-IJSYS!-JSYS!-PACKAGE. + JSYS RETURNS A TWO ELEMENT VECTOR (). THE +FIRST ELEMENT IS THE VALUE OF THE AC POINTED TO BY ARG 5, AND THE +SECOND ELEMENT IS THE SKIP COUNT OF THE JSYS THAT WAS EXECUTED. + + EXAMPLE 1 + + > + <- > + 2> ;"OUTPUT THE STRING .S ON OUTCHAN"$ + + EXAMPLE 2 + + 0 + 10 + 2>> + FIX>> ;"READ THE NEXT FIXED NUMBER TYPED ON INCHAN + IN BASE TEN AND SET THE LVAL OF FOO TO THE + NUMBER."$ + + + --- NOTE --- +THIS PACKAGE OFFERS THE 10X MDL HACKERS HUNDREDS OF WAYS TO SCREW THERE +CORE IMAGE OF MUDDLE UP, DELETE THERE FILES, OR LOG OUT THERE JOB. +BECAUSE OF THIS I TAKE NO RESPONSIBILITY FOR THE USE OF THIS PACKAGE. + RRS + +   \ No newline at end of file diff --git a/doc/rrs/subsys.order b/doc/rrs/subsys.order new file mode 100644 index 00000000..18fe4c3b --- /dev/null +++ b/doc/rrs/subsys.order @@ -0,0 +1,60 @@ + + SUBSYS PACKAGE + ------ ------- + + THIS PACKAGE WILL LET THE TOPS-20 MUDDLE USER EXECUTE ANY 'EXE' FILE +AS AN INFERIOR TO MUDDLE. AT THE MINUTE SUBSYS IS THE ONLY RSUBR IN THE +PACKAGE. THIS PACKAGE USES THE JSYS PACKAGE. + + SUBSYS TAKES ONE OPTIONAL ARGUMENT OF TYPE STRING. THE STRING IS THE +NAME OF THE NAME OF THE FILE TO RUN AS AN INFERIOR TO MUDDLE. THIS ARGUMENT +WILL DEFAULT TO "EXEC.EXE", THUS $ WILL RUN THE EXEC. +SUBSYS RETURNS THE FORK HANDLE OF THE LOWER FORK WHEN IT QUITS. THE +FORK HANDLE IS OF TYPE WORD AND WILL BE USED BE OTHER RSURS ADDED TO +THIS PACKAGE. + + EX. 1.1 + --- --- + ;"THIS WILL RUN AN EXEC"$ + + EX. 1.2 + ___ ___ +MDL104.EXE"> ;"RUN AN INFERIOR MUDDLE"$ + + + +THE RSUBR "CONTINUE" LETS THE CONTINUE A FORK THAT HE QUIT. IT ACTS +LIKE A $P FROM DDT. CONTINUE TAKES ONE ARGUMENT OF PRIMTYPE WORD. +THIS ARGUMENTS IS THE FORK HANDLE OF THE FORK TO RESUME. IT SHOULD +BE A VALID INFERIOR FORK HANDLE. CONTINUE RETURNS THE FORK HANDLE +WHEN THE LOWER FORK QUITS. + + EX. 2.1 + --- --- +> ;"RUN AN EXEC AS A LOWER FORK"$ +@;DO SOMETHING +@POP +#WORD *400XXX* ;"THIS IS THE FORK HANDLE .FH" +;"PLAY WITH MDL" + ;"CONTINUE THE EXEC"$ +@DIR *.* ;DIR OF FOO'S DIRECTORY +........... + + + +KILLFORK IS THE RSUBR TO KILL A LOWER FORK, SINCE WHEN YOU QUIT A +LOWER FORK IT DOESNT DIE. KILLFORK TAKES ONE ARGUMENT OF PRIMTYE +WORD, THIS IS THE VALID FORK HANDLE OF THE PROCESS TO KILL. KILLFORK +CAN'T BE UNDONE, ALSO ALL THE INFERIORS OF THE KILLED FORK ARE +KILLED. + + EX. 3.1 + --- --- + +@; LETS KILL THE EXEC FROM EXAMPLE 2! +@POP +#WORD *400XXX* + ;"THE EXEC IS KILLED"$ +#WORD *400XXX* ;"FREE FORK HANDLE. NOT GOOD FOR ANYTHING" + +  \ No newline at end of file diff --git a/doc/rrs/uvbyte.order b/doc/rrs/uvbyte.order new file mode 100644 index 00000000..a6c0c8b1 --- /dev/null +++ b/doc/rrs/uvbyte.order @@ -0,0 +1,16 @@ + The UVBYTES package has now been released to the world, it will work on +both XXs and ITS. There is one function in this package, UV-BYTES. The +purpose of UV-BYTES is to corrupt UVECTORs into BYTES of any bytesize. +It does this by consing up a bytpointer of the requested byte size to +the UVECTOR. Note, the BYTES created UV-BYTES will shear the same +storage as the UVECTOR. The contents UVECTOR must be of primtype WORD. +The main use of UV-BYTES is to create multiple windows of different +bytesize to the same UVECTOR. The call to UV-BYTES follows. + + +;"UV-BYTES RETURNS BYTES FOR ANY GIVEN BYTE SIZE TO A UVECTOR + OF PRIMTYPE WORD. THE CALL TO THIS ROUTINE IS . + UV-BYTES RETURNS AN OBJECT OF TYPE BYTES. ARGS ARE: + .UV ........ A UVECTOR OF PRIMTYPE WORDS + .BSIZE ..... THE BYTE SIZE OF THE DESIRED BYTES, MUST BE LEES THAN 36." + \ No newline at end of file diff --git a/src/rrs/jsys.rsubr b/src/rrs/jsys.rsubr new file mode 100644 index 00000000..5444db29 --- /dev/null +++ b/src/rrs/jsys.rsubr @@ -0,0 +1,392 @@ + + + + + ;"USE BY JSYS IF THE 6 ARG ISNT PASSED" + + FOO JSYSS + ;"JSYS DEFINITIONS ARE SETG'ED ON THE J OBLIST." + !.OBLIST)> + + + + )> + <1 .FOO>> + >> + + + + + + ;"SECOND TRY AT A JSYS HANDLER FOR MDL" + ;"" + ;"RJSYS <- RIGHT HALF OF JSYS" + ;"AC1,AC2,AC3 <- JSYS ACS" + ;"RAC <- ADR OF AC TO RETURN" + ;"JSYSVECT <- OPTIONAL VECTOR TO HOLD RETURN AC AND SKIP COUNT + IF USER DOESNT SUPPLY IT JSYS WILL" + ;"ARGS 1-5 ARE PRIMTYPE WORD AND THE VALUE AND JSYSVECT ARE + ]>" + + <DECLARE ("VALUE" <VECTOR [2 <PRIMTYPE WORD>]> + <PRIMTYPE WORD> <PRIMTYPE WORD> + <PRIMTYPE WORD> <PRIMTYPE WORD> <PRIMTYPE WORD> + "OPTIONAL" <VECTOR [2 <PRIMTYPE WORD>]>)> + <MOVE A* AB > ;"SAVE ARG PNTR" +TAG3!-TMP ;1 + <PUSH TP* (AB) > + <PUSH TP* (AB) 1> ;"PICK UP ARGS" + <ADD AB* [<2 (2)>]> + <JUMPL AB* TAG3!-TMP> + <HLRES A > + <ASH A* -1> ;"A NOW HAS - THE # ARGS" + <ADDI A* TAG4!-TMP> + <PUSHJ P* @ (A) 5> + <JRST FINIS > + <JSYS0!-TMP> +TAG4!-TMP ;11 + <JSYS1!-TMP> + <INTERNAL-ENTRY JSYS1!-TMP 5> + <MOVE A* <MQUOTE '%<RGLOC JSYSVECTOR T>>> + <ADD A* GLOTOP 1> + <PUSH TP* (A)> + <PUSH TP* (A) 1> ;"PUSH GVAL OF JSYSVECTOR" + <INTERNAL-ENTRY JSYS0!-TMP 6> + <SUBM M* (P) > + <INTGO> + <PUSH TP* (TP) -11> + <PUSH TP* (TP) -11> ;"RIGHT HALF OF JSYS. (TP)-10" + <PUSH TP* (TP) -11> + <PUSH TP* (TP) -11> ;"AC1. (TP)-8" + <PUSH TP* (TP) -11> + <PUSH TP* (TP) -11> ;"AC2. (TP)-6" + <PUSH TP* (TP) -11> + <PUSH TP* (TP) -11> ;"AC3. (TP)-4" + <PUSH TP* (TP) -11> + <PUSH TP* (TP) -11> ;"# OF AC TO RETURN. (TP)-2" + <PUSH TP* (TP) -11> + <PUSH TP* (TP) -11> ;"VECTOR TO RETURN. (TP)" + <MOVE E* [*104000000000*]> ;"LEFT HALF OF JSYS" + <ADD E* (TP) -10> ;"E NOW HAS THE JSYS IN IT" + <MOVE A* (TP) -8> ;"LOAD AC1" + <MOVE B* (TP) -6> ;"LOAD AC2" + <MOVE C* (TP) -4> ;"LOAD AC3" + <MOVEI O* 0> ;"0 SKIP COUNT" + <XCT E> ;"EXECUTE JSYS" + <SUBI O* 1> ;"NO SKIP" + <SUBI O* 1> ;"1 SKIP" + <SUBI O* 1> ;"2 SKIP" + <ADDI O* 3> ;"SKIP COUNT IN AC0" + <MOVE E* (TP) -2> ;"GET # OF AC TO RETURN" + <MOVE E* (E)> ;"E* NOW HAS VALUE TO RETURN" + <MOVE B* (TP)> ;"B* POINTS TO RETURN VECTOR" + <MOVE C* <TYPE-WORD WORD>> + <MOVEM C* (B)> + <MOVEM E* (B) 1> ;"PUT RETURN AC IN <1 .VECTOR>" + <MOVE C* <TYPE-WORD FIX>> + <MOVEM C* (B) 2> + <MOVEM O* (B) 3> ;"PUT SKIP COUNT IN <2 .VECTOR>" + <MOVE A* (TP) -1> + <MOVE B* (TP)> ;"RETURN THE VECTOR" + <SUB TP* [<(12) 12>]> ;"CLEAN UP STACK" + <JRST MPOPJ> ;"RETURN" + + + +;"ADR RETURNS THE ADDRESS OF A UVECTOR, OR THE BYTE POINTER TO + THE START OF A STRING. THIS IS USEFULL FOR JSYS'S THAT DEAL WITH + STRINGS OR A BLOCK OF MEMORY." + <TITLE ADR> + <DECLARE ("VALUE" <PRIMTYPE WORD> + <OR <UVECTOR [REST <PRIMTYPE WORD>]> + STRING> )> + <PUSH TP* (AB)> ;"PUSH TYPE" + <PUSH TP* (AB) 1> ;"PUSH VALUE" + <PUSHJ P* ADR0> ;"GOTO INTERNAL-ENTRY" + <JRST FINIS> ;"ALL DONE" + <INTERNAL-ENTRY ADR0 1> + <SUBM M* (P)> ;"MAKE RETURN ADDRESS M* RELATIVE" + <INTGO> + <HLRZ O* (TP) -1> ;"GET TYPECODE OF ARG" + <CAIE O* <TYPE-CODE STRING>> ;"STRING OR UVECTOR?" + <JRST ADR-UV> ;"ITS A UVECTOR" +ADR-STR <MOVE B* (TP)> ;"STRING...RETURN BYTEPOINTER" + <SKIPA O* 0> +ADR-UV <HRRZ B* (TP)> ;"UVECTOR...RETURN ADDRESS" + <MOVE A* <TYPE-WORD WORD>> + <JRST MPOPJ> ;"RETURN" + + + <END> + +<ENDPACKAGE> + \ No newline at end of file diff --git a/src/rrs/pdump.12 b/src/rrs/pdump.12 new file mode 100644 index 00000000..3aa1fc50 --- /dev/null +++ b/src/rrs/pdump.12 @@ -0,0 +1,356 @@ + +<PACKAGE "PDUMP"> + +<ENTRY PDUMP> + +<BLOCK (<ROOT>)> + +<SET GLUE T> + +PGLUE + +TMP + +IMPURE + +<ENDBLOCK> + +<COND (<L? ,MUDDLE!- 100> <FLOAD "CLR;NBYTER NBIN">) + (T <FLOAD "<BROOS>NBYTER.NBIN">)> + +<MANIFEST R HW INDEX-FIELD> + +<COND (<==? ,MUDDLE 104> <SETG TEMPDIR "MDLLIB">) + (<SETG TEMPDIR "MUDTMP">)> + +<SETG R 14> + +<SETG HW <BITS 18>> + +<SETG INDEX-FIELD <BITS 4 18>> + +<SET TMPOB <MOBLIST TMP 7>> + +<DEFINE FIXUP-MUNG (GOODS OFFSET + "AUX" TMP TYP IT FOO (POS 0) + (FIXUPS <CHUTYPE .GOODS WORD>)) + #DECL ((FIXUPS) <<PRIMTYPE UVECTOR> [REST WORD]> + (OFFSET TMP FOO EXTRA-COUNT) FIX (GOODS) <PRIMTYPE UVECTOR> + (EXTRA-SLOT-POS) LIST (IT FOO) <PRIMTYPE WORD>) + <SET GOODS <REST .GOODS>> + <SET FIXUPS <REST .FIXUPS>> + <REPEAT () + <COND (<EMPTY? .FIXUPS> <RETURN .GOODS>)> + <SET FIXUPS <REST .FIXUPS>> + <SET POS 0> + <REPEAT () + <SET IT <1 .FIXUPS>> + <COND (<0? <SET FOO + <CHTYPE <GETBITS .IT <BITS 18 .POS>> FIX>>> + <SET FIXUPS <REST .FIXUPS>> + <RETURN>)> + <SET IT <PUTBITS .IT <BITS 18 .POS> <+ .FOO .OFFSET>>> + <PUT .FIXUPS 1 .IT> + <COND (<0? .POS> <SET FIXUPS <REST .FIXUPS>> <SET POS 18>) + (<SET POS 0>)>>>> + +<DEFINE RSUB-DMP (RSUB NAM BINCHN FIXCHN + "AUX" OFF FIXES (EXTRA-SLOTS (1)) + (EXTRA-SLOT-POS .EXTRA-SLOTS) + (EXTRA-COUNT <+ <* <LENGTH .RSUB> 2> 1>) + (COD <CHTYPE <1 .RSUB> UVECTOR>) GB RNAM) + #DECL ((RSUB) RSUBR (NAM) STRING + (COD) <SPECIAL <<PRIMTYPE UVECTOR> [REST <PRIMTYPE WORD>]>> + (EXTRA-COUNT) <SPECIAL <PRIMTYPE WORD>> (OFF) <PRIMTYPE WORD> + (GB FIXES) <OR FALSE <UVECTOR [REST <PRIMTYPE WORD>]>> + (EXTRA-SLOTS) LIST (EXTRA-SLOT-POS) <SPECIAL LIST>) + <SET OFF <17 .BINCHN>> + <SET FIXES + <SET FIXES + <GET .RSUB RSUBR '<ERROR "NO FIXUPS AVAILABLE">>>> + <COND (<NOT <TYPE? .FIXES UVECTOR>> + <ERROR "RSUBRS NOT IN MAGIC FORMAT">)> + <SET FIXES <FIXUP-MUNG <SUBSTRUC .FIXES> .OFF>> + <PRINTB .FIXES .FIXCHN> + <PRINTB .COD .BINCHN> + <PRINC " %<RSUBR!- '[ %<PCODE!- "> + <PRIN1 .NAM> + <PRINC " "> + <PRINC .OFF> + <PRINC ">"> + <REPEAT ((GOODS <LIST !<REST .RSUB> !<REST .EXTRA-SLOTS>>)) + <COND (<EMPTY? .GOODS> <RETURN>)> + <PRINC " "> + <COND (<NOT <TYPE? <1 .GOODS> RSUBR RSUBR-ENTRY>> <PRIN1 <1 .GOODS>>) + (<OR <GASSIGNED? <SET RNAM <2 <1 .GOODS>>>> + <TYPE? <1 .GOODS> RSUBR-ENTRY>> + <PRIN1 <2 <1 .GOODS>>>) + (T + <PUT <1 .GOODS> + 2 + <OR <LOOKUP <SET RNAM <PNAME .RNAM>> .TMPOB> + <INSERT .RNAM .TMPOB>>> + <RSUB-DMP <1 .GOODS> .NAM .BINCHN .FIXCHN>)> + <SET GOODS <REST .GOODS>>> + <PRINC "]>"> + <COND (<SET GB <GET .RSUB GLUE>> + <PROG (XG (COD <1 .RSUB>) + IL + (LN <- <LENGTH .COD> + <CHTYPE <GETBITS <NTH .COD <SET IL <LENGTH .COD>>> + <BITS 18>> + FIX> + <CHTYPE <GETBITS <NTH .COD .IL> <BITS 18 18>> FIX> + 1>) + (NG + <BYTER <SET XG <IUVECTOR <+ 1 </ <LENGTH .RSUB> 16>> 0>>>) + (OG <BYTER .GB>) WD (CT 0)) + #DECL ((LN CT) FIX (WD) <PRIMTYPE WORD> (OG NG) <BYTES 2 0> + (XG) <UVECTOR [REST <PRIMTYPE WORD>]> (COD) CODE) + <REPEAT () + <AND <G? <SET CT <+ .CT 1>> .LN> <RETURN>> + <SET WD <NTH .COD .CT>> + <AND <NOT <0? <1 .OG>>> + <==? <CHTYPE <GETBITS .WD ,INDEX-FIELD> FIX> ,R> + <PUT .NG + <+ </ <CHTYPE <GETBITS .WD ,HW> FIX> 2> 1> + <1 .OG>>> + <SET OG <REST .OG>>> + <PUT .RSUB PGLUE .XG>>)>> + +<DEFINE PDUMP ("TUPLE" NAMS + "AUX" (MUDDLE ,MUDDLE)RSUB NAM TMP DIR + (PNAM <COND (<==? .MUDDLE 104> + <UNIQUE-FILE-20 <SPNAME <1 .NAMS>>>) + (<UNIQUE-FILE <SPNAME <1 .NAMS>>>)>) + BINCHN FIXCHN + (OBL <COND (<EMPTY? .OBLIST> FULL-OBL) (BLOCK)>) + (OOBLIST .OBLIST) GOODS THIS-FORM FIXUPS POS OBLIST ITEM) + #DECL ((PNAM MUDNUM) STRING (POS) FIX (FIXUPS) <UVECTOR <PRIMTYPE WORD>> + (THIS-FORM) FORM (OBLIST) <SPECIAL ANY> (GOODS) LIST + (BINCHN FIXCHN) <OR FALSE CHANNEL> (MUDDLE) FIX) + <PROG () + <COND + (<NOT <SET BINCHN + <OPEN "PRINTB" + .PNAM + <STRING "SAV" <UNPARSE .MUDDLE>> + "DSK" + ,TEMPDIR>>> + <RETURN .BINCHN>) + (<NOT <SET FIXCHN + <OPEN "PRINTB" + .PNAM + <COND (<==? .MUDDLE 104> "FIXUP") + (<STRING "FIX" <UNPARSE ,MUDDLE>>)> + "DSK" + ,TEMPDIR>>> + <CLOSE .BINCHN> + <RETURN .FIXCHN>) + (ELSE + <PRINTB '![0 0!] .FIXCHN> + <REPEAT (OUTCHAN) + #DECL ((OUTCHAN) <SPECIAL <OR FALSE CHANNEL>>) + <COND (<EMPTY? .NAMS> <RETURN>)> + <SET NAM <1 .NAMS>> + <PROG () + <COND + (<SET OUTCHAN <OPEN "PRINT" + <COND (<G? .MUDDLE 100> "PDMP") + (T "_PDMP_")> + <COND (<G? .MUDDLE 100> "TMP") + (T ">")> + "DSK" <SNAME>>>) + (ELSE + <ERROR OUTPUT-OPEN-FAILED-ERRET-ANYTHING-TO-RETRY-ERRORS + PDUMP + .OUTCHAN> + <AGAIN>)>> + <PROG () + <COND (<NOT <ASSIGNED? .NAM>> + <RETURN '#FALSE ("OBJECT NOT GROUP NAME")>)> + <SET GOODS ..NAM> + <SET OBLIST <GET .NAM .OBL '.OOBLIST>> + <PRINC "'<PCODE "> + <PRIN1 .PNAM> + <PRINC ">"> + <CRLF> + <REPEAT (MCR) + <COND (<EMPTY? .GOODS> <RETURN>)> + <COND (<AND <TYPE? <1 .GOODS> FORM> + <SET THIS-FORM <1 .GOODS>> + <==? 3 <LENGTH .THIS-FORM>> + <OR <AND <SET MCR <TYPE? <3 .THIS-FORM> MACRO>> + <TYPE? <SET RSUB <1 <3 .THIS-FORM>>> + RSUBR>> + <TYPE? <SET RSUB <3 .THIS-FORM>> RSUBR>> + <COND (<TYPE? <1 .RSUB> CODE>) + (ELSE + <PRINC "PURE-RSUBR-IN-GROUP " ,OUTCHAN> + <PRIN1 <2 .THIS-FORM> ,OUTCHAN> + <TERPRI ,OUTCHAN>)> + <NOT <GET .RSUB IMPURE>>> + <TERPRI> + <PRINC "<"> + <PRIN1 <1 .THIS-FORM>> + <PRINC " "> + <PRIN1 <2 .THIS-FORM>> + <PRINC " "> + <COND (.MCR <PRINC "#MACRO (">)> + <RSUB-DMP .RSUB .PNAM .BINCHN .FIXCHN> + <PRINC <COND (.MCR ")> ") (ELSE "> ")>> + <AND <GET .RSUB PGLUE> + <PRINT <FORM AND + '<ASSIGNED? GLUE> + '.GLUE + <FORM PUT + <FORM GVAL <2 .RSUB>> + PGLUE + <GET .RSUB PGLUE>>>>>) + (<NOT <AND <TYPE? <SET ITEM <1 .GOODS>> FORM> + <==? <LENGTH .ITEM> 4> + <==? <1 .ITEM> AND> + <=? <2 .ITEM> '<ASSIGNED? GLUE>> + <=? <3 .ITEM> '.GLUE> + <TYPE? <SET ITEM <4 .ITEM>> FORM> + <==? <LENGTH .ITEM> 4> + <==? <1 .ITEM> PUT> + <==? <3 .ITEM> GLUE> + <TYPE? <2 .ITEM> FORM> + <==? <LENGTH <2 .ITEM>> 2> + <==? <1 <2 .ITEM>> GVAL>>> + <PRINT <1 .GOODS>>)> + <TERPRI> + <SET OBLIST <GETPROP .GOODS .OBL '.OBLIST>> + <SET GOODS <REST .GOODS>>>> + <COND + (<G? .MUDDLE 100> + <CLOSE .OUTCHAN> + <RENAME <STRING <9 .OUTCHAN> ":<" <10 .OUTCHAN> !\> + <7 .OUTCHAN> !\. <8 .OUTCHAN>> + TO + <STRING <9 .OUTCHAN> ":<" <10 .OUTCHAN> !\> + <SPNAME .NAM> !\. "FBIN">>) + (T + <COND (<RENAME .OUTCHAN <PNAME .NAM> "FBIN">) + (ELSE + <ERROR + RENAME-OF-TEMP-FAILED-ERRET-ANYTHING-TO-CONTINUE + PDUMP + .NAM>)> + <CLOSE .OUTCHAN>)> + <SET NAMS <REST .NAMS>>> + <SET POS <17 .FIXCHN>> + <ACCESS .FIXCHN 0> + <PRINTB <UVECTOR .POS ,MUDDLE> .FIXCHN> + <CLOSE .BINCHN> + <CLOSE .FIXCHN> + "DUMPED")>>> + +<SETG LOW-BITS <BITS 6>> + +;"LOW ORDER SIX BITS OF A WORD" + +<COND (<N==? ,MUDDLE 104> <SETG DIRBUF <IUVECTOR 1024 0>>)> + +;"BUFFER TO HOLD DIRECTORY" + +<SETG RCL ![0!]> + +;"SINGLE WORD BUFFER. USED TO READ LENGTHS AND SO FORTH" + +<COND (<G? ,MUDDLE 100> <SETG SAV-FILE "<MUDSAV>SAV.FILE">) + (<SETG SAV-FILE "MUDSAV;SAV FILE">)> + +<SETG TSTRING <ISTRING 6>> +<GDECL (TSTRING) STRING> +<DEFINE UNIQUE-FILE-20 (PNAM "AUX" CH) + #DECL ((PNAM) STRING (CH) <OR FALSE CHANNEL>) + <REPEAT ((CNT 0) (TST ,TSTRING) NP (MST <STRING "SAV" <UNPARSE ,MUDDLE>>)) + #DECL ((CNT) FIX (TST) STRING) + <COND (<0? .CNT> + <SET NP .PNAM>) + (<SET NP <STRING <UNPARSE .CNT> .PNAM>>)> + <COND (<G? <LENGTH .NP> 6> + <SUBSTRUC .NP 0 6 .TST> + <SET NP .TST>)> + <COND (<SET CH <OPEN "READB" .NP .MST "DSK" "MDLLIB">> + <CLOSE .CH>) + (<RETURN .NP>)> + <SET CNT <+ .CNT 1>>>> + +;"MAIN FILE DIRECTORY" + +<DEFINE UNIQUE-FILE (PNAM "AUX" (CH <OPEN "READB" ,SAV-FILE>)) + #DECL ((PNAM) STRING (CH) <OR FALSE CHANNEL>) + <COND (<NOT .CH> <ERROR CAN 'T-OPEN-MAIN-FILE!-ERRORS>)> + <REPEAT ((CNT 0) (MAXD 1) CCH TNUM TSTRING) + #DECL ((CNT MAXD) FIX (TNUM) <PRIMTYPE WORD> (CCH) <OR FALSE CHANNEL> + (TSTRING) STRING) + <COND + (<==? .CNT 0> + <LOAD-DIRECTORY .CH + <SET TNUM <SIXBIT <SET TSTRING .PNAM>>>>) + (<==? .CNT .MAXD> + <LOAD-DIRECTORY + .CH <SET TNUM + <SIXBIT <SET TSTRING <STRING <UNPARSE .CNT> .PNAM>>>>> + <SET MAXD <* .MAXD 10>>) + (<SET TNUM + <SIXBIT <SET TSTRING <STRING <UNPARSE .CNT> .PNAM>>>>)> + <COND (<NOT <BINSRCH .TNUM <REST ,DIRBUF> <CHTYPE <1 ,DIRBUF> FIX>>> + <SET CCH + <OPEN-NR "READB" + <STRING ,TEMPDIR + ";" + <STRING .TSTRING " SAV" <UNPARSE ,MUDDLE>>>>> + <COND (.CCH <CLOSE .CCH>) (<CLOSE .CH> <RETURN .TSTRING>)>)> + <SET CNT <+ .CNT 1>>>> + +<DEFINE SIXBIT (STR "AUX" (WORD 0) (POS 30) (CHR 0)) + #DECL ((STR) STRING (WORD POS CHR) FIX) + <REPEAT () + <COND (<OR <EMPTY? .STR> <L? .POS 0>> + <RETURN <CHTYPE .WORD FIX>>) + (<OR <L? <SET CHR <CHTYPE <1 .STR> FIX>> 32> + <G? .CHR 122>> + <ERROR "BAD CHAR IN SIXBIT" <1 .STR>> + <RETURN 0>) + (<G=? .CHR 96> <SET CHR <- .CHR 64>>) + (<SET CHR <- .CHR 32>>)> + <SET WORD <PUTBITS .WORD <BITS 6 .POS> .CHR>> + <SET STR <REST .STR>> + <SET POS <- .POS 6>>>> + +<DEFINE BINSRCH (NM1 DIR LNT "AUX" (EXIT .LNT)) + #DECL ((NM1) FIX (LNT) FIX (DIR) <UVECTOR [REST <PRIMTYPE WORD>]>) + <REPEAT UP () + <COND (<0? <SET LNT <CHTYPE <ANDB </ .LNT 2> -2> FIX>>> + <REPEAT () + <COND (<L=? .EXIT 0> <RETURN <> .UP>) + (<SET EXIT <- .EXIT 2>> + <AND <==? .NM1 <1 .DIR>> + <RETURN .DIR .UP>> + <SET DIR <REST .DIR 2>>)>>) + (<==? .NM1 <1 .DIR>> <RETURN .DIR>) + (<G=? .NM1 <NTH .DIR <+ .LNT 1>>> + <SET DIR <REST .DIR .LNT>>)> + <SET EXIT <- .EXIT .LNT>>>> + +<DEFINE LOAD-DIRECTORY (CHN NAME) + #DECL ((CHN) CHANNEL (NAME) FIX) + <REPEAT (CH) + #DECL ((CH) FIX) + <SET CH <CHTYPE <GETBITS .NAME ,LOW-BITS> FIX>> + <COND (<NOT <0? .CH>> <SET NAME .CH> <RETURN>) + (<SET NAME </ .NAME 64>>)>> + <ACCESS .CHN 0> + <READB ,RCL .CHN> + <ACCESS .CHN <+ 1 <MOD .NAME <1 ,RCL>>>> + <READB ,RCL .CHN> + <ACCESS .CHN <* <1 ,RCL> 1024>> + <READB ,DIRBUF .CHN> + ,DIRBUF> + +<ENDPACKAGE> +  \ No newline at end of file diff --git a/src/rrs/subsys.mud b/src/rrs/subsys.mud new file mode 100644 index 00000000..086c5a10 --- /dev/null +++ b/src/rrs/subsys.mud @@ -0,0 +1,57 @@ + +<PACKAGE "SUBSYS"> + +<ENTRY SUBSYS CONTINUE KILLFORK> + +<USE "JSYS"> + +<BLOCK (!.OBLIST <GET J OBLIST>)> + +<DEFINE SUBSYS ( + "OPTIONAL" (FILENAME "<SYSTEM>EXEC.EXE") + "AUX" JFN CHN A B C D FH) + #DECL ((FILENAME) STRING (CHN) <OR CHANNEL FALSE> + (A) <VECTOR [2 <PRIMTYPE WORD>]> + (VALUE B C D JFN FH) <PRIMTYPE WORD>) + <SET B 262144> ;"DO A SHORT GET JFN" + <COND (<N=? <2 <SET A <JSYS ,GTJFN .B <ADR .FILENAME> 0 1>>> 0> + <SET JFN <ANDB <1 .A> 262143>>) + (T <ERROR SUBSYS GTJFN-FAILED!-ERRORS <1 .A>>)> + <COND (<N=? <2 <SET A <JSYS ,CFORK 0 0 0 1>>> 0> <SET FH <1 .A>>) + (T <ERROR SUBSYS CFORK-FAILED!-ERRORS <1 .A>>)> + <SET C <PUTBITS #WORD *000000000000* <BITS 18 18> .FH>> + <SET C <PUTBITS .C <BITS 18 0> .JFN>> + <JSYS ,GET-JSYS .C 0 0 1> + <JSYS ,EPCAP .FH -1 -1 3> + <JSYS ,SFRKV .FH 0 0 1> + <JSYS ,WFORK .FH 0 0 1> + .FH> + +<DEFINE CONTINUE (FKH "AUX" FSW FPC T1 T2) + #DECL ((FKH FSW FPC T1 T2) <PRIMTYPE WORD> + (VALUE) <OR <PRIMTYPE WORD> FALSE>) + <SET FSW <1 <JSYS ,RFSTS .FKH 0 0 1>>> + <SET T1 <GETBITS .FSW <BITS 18 18>>> + <COND (<==? .T1 #WORD *000000777777*> + <CHTYPE ("FORK DOES'NT EXIST" .FKH) FALSE>) + (T + <SET FPC <1 <JSYS ,RFSTS .FKH 0 0 2>>> + <COND (<==? <ANDB .T1 #WORD *000000000007*> #WORD *000000000000*> + <CHTYPE ("FORK IS RUNNING" .FKH) FALSE>) + (T + <JSYS ,SFORK .FKH .FPC 0 1> + <JSYS ,WFORK .FKH 0 0 1> + .FKH)>)>> + +<DEFINE KILLFORK (FKH "AUX" FSW T1) + #DECL ((VALUE) <OR <PRIMTYPE WORD> FALSE> (FKH FSW T1) <PRIMTYPE WORD>) + <SET FSW <1 <JSYS ,RFSTS .FKH 0 0 1>>> + <SET T1 <GETBITS .FSW <BITS 18 18>>> + <COND (<==? .T1 #WORD *000000777777*> + <CHTYPE ("INVALID FORK HANDLE" .FKH) FALSE>) + (T <JSYS ,KFORK .FKH 0 0 1> .FKH)>> + +<ENDBLOCK> + +<ENDPACKAGE> + \ No newline at end of file diff --git a/src/rrs/uvbyte.rsubr b/src/rrs/uvbyte.rsubr new file mode 100644 index 00000000..f7197a65 --- /dev/null +++ b/src/rrs/uvbyte.rsubr @@ -0,0 +1,52 @@ +<PACKAGE "UVBYTES"> +<ENTRY UV-BYTES> + +;"UV-BYTES RETURNS BYTES FOR ANY GIVEN BYTE SIZE TO A UVECTOR + OF PRIMTYPE WORD. THE CALL TO THIS ROUTINE IS <UV-BYTES .UV .BSIZE>. + UV-BYTES RETURNS AN OBJECT OF TYPE BYTES. ARGS ARE: + .UV ........ A UVECTOR OF PRIMTYPE WORDS + .BSIZE ..... THE BYTE SIZE OF THE DESIRED BYTES, MUST BE LEES THAN 36." + <TITLE UV-BYTES> + <DECLARE ("VALUE" BYTES + <UVECTOR [REST <PRIMTYPE WORD>]> + FIX )> + <PUSH TP* (AB)> + <PUSH TP* (AB)1> ;"PUSH UVECTOR" + <PUSH TP* (AB)2> + <PUSH TP* (AB)3> ;"PUSH BYTE BIZE" + <PUSHJ P* UVBT0> ;"CONVERT UVECTOR TO BYTES" + <JRST FINIS> ;"RETURN THE BYTES" + <INTERNAL-ENTRY UVBT0 2> ;"2 ARGS" + <SUBM M* (P)> ;"MAKE RETURN ADR M* RELATIVE" + <INTGO> ;"CHECK FOR INTERRUPTS" + <HRRZ E* (TP)-2> ;"UV ADR TO E*" + <HLRE O* (TP)-2> + <MOVM O* O> ;"UV LENGTH TO O*" + <MOVE C* (TP)> ;"GET BYTE SIZE, THEN CHECK VALIDITY" + <CAIG C* 0> ;"BSIZE < 1 ?" + <JRST ERR:> ;"YES, BYTES SIZE ERROR" + <CAILE C* 36> ;"BSIZE > 36 ??" + <JRST ERR:> ;"YES, BYTE SIZE ERROR" + <HRRZI A* 36> + <IDIV A* (TP)> ;"CALC. BYTES/WORD IN A*" + <IMUL A* O> ;"CALC. LENGTH OF BYTES" + <HRLI A* <TYPE-CODE BYTES>> ;"MAKE THE TYPE WORD FOR THE BYTES" + <HRRZ B* (TP)> ;"GET BYTE SIZE WANTED" + <LSH B* 6> + <IORI B* *440000*> + <HRLZ B* B> ;"MAKE LEFT 1/2 OF BYTEPOINTER" + <HRR B* E> ;"BYTEPOINTER IS VALUE CELL" + <JRST MPOPJ> ;"ALL DONE" +ERR: <PUSH TP* <MQUOTE UV-BYTES> -1> ;"BYTE SIZE ERROR HANDLER" + <PUSH TP* <MQUOTE UV-BYTES>> + <PUSH TP* (TP) -3> + <PUSH TP* (TP) -3> ;"GET BAD BSIZE" + <PUSH TP* <MQUOTE INVALID.BYTE.SIZE> -1> + <PUSH TP* <MQUOTE INVALID.BYTE.SIZE>> + <MCALL 3 ERROR> + <JRST MPOPJ> + <END> + +<ENDPACKAGE> + + \ No newline at end of file