From 1d81350714f0e61c5d3c8e542ddcfe71b9394ae6 Mon Sep 17 00:00:00 2001
From: Larry Masinter <LMM@acm.org>
Date: Wed, 17 Mar 2021 12:22:40 -0700
Subject: [PATCH] guard didn't include #endif

---
 sources/LLSUBRS      |   2 +-
 sources/LLSUBRS.LCOM | Bin 13996 -> 14483 bytes
 sources/subrs.h      |   3 ++-
 3 files changed, 3 insertions(+), 2 deletions(-)

diff --git a/sources/LLSUBRS b/sources/LLSUBRS
index 9a8013c4..09ce3db2 100644
--- a/sources/LLSUBRS
+++ b/sources/LLSUBRS
@@ -1 +1 @@
-(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "16-Mar-2021 23:00:15" {DSK}<home>larry>ilisp>medley>sources>LLSUBRS.;3 22484  

      changes to%:  (VARS \INITSUBRS)
                    (FNS WRITECALLSUBRS)

      previous date%: "21-Feb-2021 21:20:11" {DSK}<home>larry>ilisp>medley>sources>LLSUBRS.;1)


(* ; "
Copyright (c) 1983-1986, 1988-1992, 2021 by Venue & Xerox Corporation.
")

(PRETTYCOMPRINT LLSUBRSCOMS)

(RPAQQ LLSUBRSCOMS
       ((DECLARE%: EVAL@COMPILE DONTCOPY (ADDVARS (DONTCOMPILEFNS SUBRCALL MISCN FIX-SUBR-NAME 
                                                         WRITECALLSUBRS)))
        

(* ;;; "MISCN  Vars & Functions")

        (EXPORT (VARS \MISCN-TABLE-LIST))
        (FUNCTIONS MISCN)
        (OPTIMIZERS MISCN)
        (FNS MISCN-NUMBER \MISCN.UFN \UNDEFINED-MISCN-UFN MISCN-COLLECT \GET-MY-BF \INIT-MISCN-TABLE)
        (PROP ARGNAMES MISCN)
        (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS MISCN-UFN-SPEC MISCN-UFN-ENTRY))
        

(* ;;; " USER-SUBR Vars & Functions")

        (EXPORT (VARS \USER-SUBR-LIST))
        (FUNCTIONS USER-SUBR ADD-USER-SUBR)
        (FNS \USER-SUBR-UFN \INIT-USER-SUBR-TABLE \UNDEFINED-USER-SUBR-UFN USER-SUBR-NUMBER EQ-TO-CAR
             EQ-TO-CADR)
        (PROP ARGNAMES USER-SUBR)
        

(* ;;; "SUBRCALL Vars & Functions")

        (EXPORT (VARS \INITSUBRS))
        (FUNCTIONS SUBRCALL)
        (OPTIMIZERS SUBRCALL)
        (FNS SUBRNUMBER)
        
        (* ;; "use this to make a subrs.h file for Maiko ")

        (FNS WRITECALLSUBRS FIX-SUBR-NAME)
        (PROP ARGNAMES SUBRCALL)
        (DECLARE%: DONTCOPY (RESOURCES UNIXSTRING))
        (INITRESOURCES UNIXSTRING)
        (FNS \MOREVMEMFILE \WRITEMAP \COPYSYS0SUBR \PUPLEVEL1STATE SHOWDISPLAY SETSCREENCOLOR 
             \WRITERAWPBI \READRAWPBI RAID \LISPFINISH \GETPACKETBUFFER \GATHERSTATS \DSPRATE DSPBOUT
             DISKPARTITION \CHECKBCPLPASSWORD SUSPEND-LISP UNIX-USERNAME UNIX-FULLNAME UNIX-GETENV 
             UNIX-GETPARM)
        (IFPROP ARGNAMES SHOWDISPLAY SETSCREENCOLOR \WRITERAWPBI \READRAWPBI RAID \LISPFINISH 
               \GETPACKETBUFFER \GATHERSTATS \DSPRATE DSPBOUT DISKPARTITION \CHECKBCPLPASSWORD)
        (PROPS (LLSUBRS FILETYPE))))
(DECLARE%: EVAL@COMPILE DONTCOPY 

(ADDTOVAR DONTCOMPILEFNS SUBRCALL MISCN FIX-SUBR-NAME WRITECALLSUBRS)
)



(* ;;; "MISCN  Vars & Functions")

(* "FOLLOWING DEFINITIONS EXPORTED")
(RPAQQ \MISCN-TABLE-LIST
       ((USER-SUBR 0 \USER-SUBR-UFN T)
        (CL:VALUES 1 CL::VALUES-UFN NIL)
        (CL:SXHASH 2 CL::SXHASH-UFN NIL)
        (CL::EQLHASHBITSFN 3 CL::EQLHASHBITSFN-UFN NIL)
        (STRINGHASHBITS 4 \STRINGHASHBITS-UFN NIL)
        (STRING-EQUAL-HASHBITS 5 \STRING-EQUAL-HASHBITS-UFN NIL)
        (CL:VALUES-LIST 6 CL::VALUES-LIST-UFN NIL)
        (LCFetchMethod 7 LCFetchMethod NIL)
        (LCFetchMethodOrHelp 8 NIL NIL)
        (LCFindVarIndex 9 NIL NIL)
        (LCGetIVValue 10 NIL NIL)
        (LCPutIVValue 11 NIL NIL)))

(* "END EXPORTED DEFINITIONS")


(DEFMACRO MISCN (NAME &REST ARGS)
   [LET [(ARGNAMES (MAPCAR ARGS #'(LAMBDA (X)
                                    (GENSYM]
        `(CL:FUNCALL [CL:COMPILE NIL '(LAMBDA ,ARGNAMES
                                        ((OPCODES MISCN ,(MISCN-NUMBER NAME)
                                                ,(LENGTH ARGS))
                                         ,@ARGNAMES]
                ,@ARGS])

(DEFOPTIMIZER MISCN (NAME &REST ARGS)
                        `((OPCODES MISCN ,(MISCN-NUMBER NAME)
                                 ,(LENGTH ARGS))
                          ,@ARGS))
(DEFINEQ

(MISCN-NUMBER
(LAMBDA (NAME) (* ; "Edited  7-Nov-88 15:21 by krivacic") (CADR (OR (ASSOC NAME \MISCN-TABLE-LIST) (ERROR NAME " not a MISCN index"))))
)

(\MISCN.UFN
(LAMBDA (ALPHA-BETA) (* ; "Edited  8-Jun-89 16:57 by jds") (* ;; "The UFN for the MISCN opcode.") (DECLARE (GLOBALVARS \MISCN-TABLE)) (* ;; "Get the misc index & number of args from the code stream") (LET ((INDEX (LRSH ALPHA-BETA 8)) (ARG-COUNT (LOGAND ALPHA-BETA 255))) (* ;; "compute the position of the real IVARS on the stack.  Create a pointer to these args and pass it to the Handler routine.") (COND ((NOT (AND (BOUNDP (QUOTE \MISCN-TABLE)) \MISCN-TABLE)) (\INIT-MISCN-TABLE))) (LET* ((CALLER (\MYALINK)) (MY-BF (\GET-MY-BF)) (MY-IVAR (fetch (BF IVAR) of MY-BF)) (RESULT-IVAR (- MY-IVAR (LLSH ARG-COUNT 1))) (MY-PARMS-PTR (\VAG2 1 RESULT-IVAR)) (UFN-ENTRY (\ADDBASE \MISCN-TABLE (LLSH INDEX 1)))) (COND ((fetch (MISCN-UFN-ENTRY MISCN-MVS) OF UFN-ENTRY) (* ;; "This UFN can return Multiple values, so we need to preserve them.") (CL:UNWIND-PROTECT (APPLY* (\GETBASEPTR UFN-ENTRY 0) INDEX ARG-COUNT MY-PARMS-PTR) (replace (BF IVAR) of MY-BF with RESULT-IVAR) (REPLACE (FX NEXTBLOCK) OF CALLER WITH RESULT-IVAR))) (T (* ;; "He said no MVs are possible, so don't even TRY to preserve them.  This is an expanded and cleaned up version of CL:UNWIND-PROTECT, so watch it!") (PROG1 (.UNWIND.PROTECT. (FUNCTION (LAMBDA NIL (replace (BF IVAR) of MY-BF with RESULT-IVAR))) (APPLY* (\GETBASEPTR UFN-ENTRY 0) INDEX ARG-COUNT MY-PARMS-PTR)) (replace (BF IVAR) of MY-BF with RESULT-IVAR) (REPLACE (FX NEXTBLOCK) OF CALLER WITH RESULT-IVAR)))))))
)

(\UNDEFINED-MISCN-UFN
(LAMBDA (INDEX ARG-COUNT ARG-PTR) (* ; "Edited  3-Nov-88 15:56 by krivacic") (PRINTOUT T "index " INDEX ", arg count " ARG-COUNT T) (ERROR (CL:FORMAT T "Undefined MISCN[~d] with ~d args." INDEX ARG-COUNT) (MISCN-COLLECT ARG-COUNT ARG-PTR)))
)

(MISCN-COLLECT
(LAMBDA (ARG-COUNT ARG-PTR) (* ; "Edited  3-Nov-88 11:52 by krivacic") (FOR I FROM 0 TO (- ARG-COUNT 1) COLLECT (\GETBASEPTR ARG-PTR (LLSH I 1))))
)

(\GET-MY-BF
(LAMBDA NIL (* ; "Edited  3-Nov-88 11:08 by krivacic") (* ;; "Returns the stack index of the caller's BF.") (- (\MYALINK) 2))
)

(\INIT-MISCN-TABLE
(LAMBDA NIL (DECLARE (GLOBALVARS \MISCN-TABLE-LIST \MISCN-TABLE)) (* ; "Edited  7-Mar-89 09:43 by jds") (LET ((OP-NUMBER 36) (OP-LENGTH 3) BASE) (SETQ \MISCN-TABLE (ARRAY 256 (QUOTE POINTER) (QUOTE \UNDEFINED-MISCN-UFN) 0)) (SETQ BASE (FETCH (ARRAYP BASE) OF \MISCN-TABLE)) (for MISCN-ENTRY in \MISCN-TABLE-LIST do (SETA \MISCN-TABLE (CADR MISCN-ENTRY) (CADDR MISCN-ENTRY)) (REPLACE (MISCN-UFN-ENTRY MISCN-MVS) OF (\ADDBASE2 BASE (FETCH (MISCN-UFN-SPEC INDEX) OF MISCN-ENTRY)) WITH (FETCH (MISCN-UFN-SPEC MVS) OF MISCN-ENTRY))) (SETQ \MISCN-TABLE BASE)))
)
)

(PUTPROPS MISCN ARGNAMES (NAME &REST ARGS))
(DECLARE%: EVAL@COMPILE DONTCOPY 
(DECLARE%: EVAL@COMPILE

(RECORD MISCN-UFN-SPEC (
                            (* ;; 
                "This is the description for a MISCN opcode's UFN, as placed in \MISCN-TABLE-LIST.")

                            NAME                             (* ; 
                                                    "Name of the MISCN, for the MISCN macro's use.")
                            INDEX                            (* ; "Sub-opcode index.")
                            UFN-NAME                         (* ; "Name of the UFN")
                            MVS                              (* ; 
              "T if the UFN can returnmultiple values.  If this is NIL, MVs WILL NOT BE PRESERVED.")
                            ))

(BLOCKRECORD MISCN-UFN-ENTRY ((MISCN-MVS FLAG)
                                  (NIL BITS 3)
                                  (MISCN-UFN POINTER)))
)
)



(* ;;; " USER-SUBR Vars & Functions")

(* "FOLLOWING DEFINITIONS EXPORTED")
(RPAQQ \USER-SUBR-LIST ((DUMMY 10 DUMMY-UFN)
                            (SAMPLE-USER-SUBR 0 SAMPLE-USER-SUBR-UFN)))

(* "END EXPORTED DEFINITIONS")


(DEFMACRO USER-SUBR (USER-SUBR-NAME &REST ARGS)
   `(MISCN USER-SUBR ,(USER-SUBR-NUMBER USER-SUBR-NAME)
           ,@ARGS))

(CL:DEFUN ADD-USER-SUBR (USER-SUBR-NAME USER-SUBR-INDEX USER-SUBR-UFN)
   (DECLARE (GLOBALVARS \USER-SUBR-TABLE \USER-SUBR-LIST))

   (* ;; "Make Sure \USER-SUBR-TABLE is made")

   (IF (NOT (AND (BOUNDP '\USER-SUBR-TABLE)
                     \USER-SUBR-TABLE))
       THEN (\INIT-USER-SUBR-TABLE))

   (* ;; "See if the Name is already defined")

   [AND (FASSOC USER-SUBR-NAME \USER-SUBR-LIST)
        (CL:CERROR "Delete old User-subr" "User-subr ~S already defined" USER-SUBR-NAME)
        (SETA \USER-SUBR-TABLE (CADR (FASSOC USER-SUBR-NAME \USER-SUBR-LIST))
              '\UNDEFINED-USER-SUBR-UFN)
        (SETQ \USER-SUBR-LIST (CL:REMOVE USER-SUBR-NAME \USER-SUBR-LIST :TEST 'EQ-TO-CAR]

   (* ;; "See if the UFN is already defined")

   [AND (OR (NEQ (ELT \USER-SUBR-TABLE USER-SUBR-INDEX)
                 '\UNDEFINED-USER-SUBR-UFN)
            (CL:FIND USER-SUBR-INDEX \USER-SUBR-LIST :KEY #'CL:SECOND))
        (CL:CERROR "Delete old User-subr" " User-subr index ~d already defined" USER-SUBR-INDEX)
        (SETQ \USER-SUBR-LIST (CL:REMOVE USER-SUBR-INDEX \USER-SUBR-LIST :TEST 'EQ-TO-CADR]
   (CL:PUSH (LIST USER-SUBR-NAME USER-SUBR-INDEX (OR USER-SUBR-UFN '\UNDEFINED-USER-SUBR-UFN))
          \USER-SUBR-LIST)
   (\INIT-USER-SUBR-TABLE))
(DEFINEQ

(\USER-SUBR-UFN
(LAMBDA (INDEX ARG-COUNT ARG-PTR) (DECLARE (GLOBALVARS \USER-SUBR-TABLE)) (* ; "Edited  4-Nov-88 18:43 by krivacic") (IF (NOT (AND (BOUNDP (QUOTE \USER-SUBR-TABLE)) \USER-SUBR-TABLE)) THEN (\INIT-USER-SUBR-TABLE)) (LET ((USER-SUBR-INDEX (\GETBASE ARG-PTR 1))) (* ;; "User SUBR ufn.  Index on the User subr indexes") (APPLY* (ELT \USER-SUBR-TABLE USER-SUBR-INDEX) USER-SUBR-INDEX (- ARG-COUNT 1) (\ADDBASE ARG-PTR 2))))
)

(\INIT-USER-SUBR-TABLE
(LAMBDA NIL (DECLARE (GLOBALVARS \USER-SUBR-TABLE \USER-SUBR-LIST)) (* ; "Edited  4-Nov-88 18:58 by krivacic") (SETQ \USER-SUBR-TABLE (ARRAY 256 (QUOTE POINTER) (QUOTE \UNDEFINED-USER-SUBR-UFN) 0)) (for SUBR-ENTRY in \USER-SUBR-LIST do (SETA \USER-SUBR-TABLE (CADR SUBR-ENTRY) (CADDR SUBR-ENTRY))))
)

(\UNDEFINED-USER-SUBR-UFN
(LAMBDA (USER-SUBR-INDEX ARG-COUNT ARG-PTR) (* ; "Edited  7-Nov-88 14:33 by krivacic") (* ;; "User SUBR ufn.  Index on the User subr indexes") (ERROR (CL:FORMAT NIL "Undefined USER-SUBR[~d] with ~d args." USER-SUBR-INDEX ARG-COUNT) (MISCN-COLLECT ARG-COUNT ARG-PTR)))
)

(USER-SUBR-NUMBER
(LAMBDA (NAME) (* ; "Edited  4-Nov-88 18:42 by krivacic") (CADR (OR (ASSOC NAME \USER-SUBR-LIST) (ERROR NAME " not a USER-SUBR index"))))
)

(EQ-TO-CAR
(LAMBDA (ITEM LIST) (EQ ITEM (CAR LIST))))

(EQ-TO-CADR
(LAMBDA (ITEM LIST) (EQ ITEM (CADR LIST))))
)

(PUTPROPS USER-SUBR ARGNAMES (USER-SUBR-NAME &REST ARGS))



(* ;;; "SUBRCALL Vars & Functions")

(* "FOLLOWING DEFINITIONS EXPORTED")
(RPAQQ \INITSUBRS
       ((YIELD 210)
        (BACKGROUNDSUBR 6)
        (CHECKBCPLPASSWORD 7)
        (DISKPARTITION 8)
        (DSPBOUT 9)
        (DSPRATE 10)
        (GATHERSTATS 11)
        (GETPACKETBUFFER 12)
        (LISPFINISH 13)
        (MOREVMEMFILE 14)
        (RAID 15)
        (READRAWPBI 16)
        (WRITERAWPBI 17)
        (SETSCREENCOLOR 18)
        (SHOWDISPLAY 19)
        (PUPLEVEL1STATE 20)
        (WRITESTATS 21)
        (CONTEXTSWITCH 22)
        (COPYSYS0SUBR 23)
        (WRITEMAP 24)
        (UFS-GETFILENAME 34)
        (UFS-DELETEFILE 35)
        (UFS-RENAMEFILE 36)
        (COM-READPAGES 37)
        (COM-WRITEPAGES 38)
        (COM-TRUNCATEFILE 39)
        (UFS-DIRECTORYNAMEP 41)
        (COM-GETFREEBLOCK 45)
        (SETUNIXTIME 48)
        (GETUNIXTIME 49)
        (COPYTIMESTATS 50)
        (UNIX-USERNAME 51)
        (UNIX-FULLNAME 52)
        (UNIX-GETENV 53)
        (UNIX-GETPARM 54)
        (CHECK-SUM 55)
        (ETHER-SUSPEND 56)
        (ETHER-RESUME 57)
        (ETHER-AVAILABLE 58)
        (ETHER-RESET 59)
        (ETHER-GET 60)
        (ETHER-SEND 61)
        (ETHER-SETFILTER 62)
        (ETHER-CHECK 63)
        (DSPCURSOR 64)
        (SETMOUSEXY 65)
        (DSP-VIDEOCOLOR 66)
        (DSP-SCREENWIDTH 67)
        (DSP-SCREENHEIGHT 68)
        (BITBLTSUB 69)
        (BLTCHAR 70)
        (TEDIT.BLTCHAR 71)
        (BITBLT.BITMAP 72)
        (BLTSHADE.BITMAP 73)
        (RS232C-CMD 74)
        (RS232C-READ-INIT 75)
        (RS232C-WRITE 76)
        (KEYBOARDBEEP 80)
        (KEYBOARDMAP 81)
        (KEYBOARDSTATE 82)
        (VMEMSAVE 89)
        (LISP-FINISH 90)
        (NEWPAGE 91)
        (DORECLAIM 92)
        (DUMMY-135Q 93)
        (NATIVE-MEMORY-REFERENCE 94)
        (OLD-COMPILE-LOAD-NATIVE 95)
        (DISABLEGC 96)
        (COM-SETFILEINFO 103)
        (COM-OPENFILE 104)
        (COM-CLOSEFILE 105)
        (DSK-GETFILENAME 106)
        (DSK-DELETEFILE 107)
        (DSK-RENAMEFILE 108)
        (COM-NEXT-FILE 110)
        (COM-FINISH-FINFO 111)
        (COM-GEN-FILES 112)
        (DSK-DIRECTORYNAMEP 113)
        (COM-GETFILEINFO 114)
        (COM-CHANGEDIR 116)
        (UNIX-HANDLECOMM 117)
        (RPC-CALL 119)
        (MESSAGE-READP 120)
        (MESSAGE-READ 121)
        (MONITOR-CONTROL 128)
        (GET-NATIVE-ADDR-FROM-LISP-PTR 131)
        (GET-LISP-PTR-FROM-NATIVE-ADDR 132)
        (LOAD-NATIVE-FILE 133)
        (SUSPEND-LISP 134)
        (NEW-BLTCHAR 135)
        (COLOR-INIT 136)
        (COLOR-SCREENMODE 137)
        (COLOR-MAP 138)
        (COLOR-BASE 139)
        (C-SlowBltChar 140)
        (UNCOLORIZE-BITMAP 141)
        (COLORIZE-BITMAP 142)
        (COLOR-8BPPDRAWLINE 143)
        (TCP-OP 144)
        (WITH-SYMBOL 145)
        (CAUSE-INTERRUPT 146)
        (OPEN-SOCKET 160)
        (CLOSE-SOCKET 161)
        (READ-SOCKET 162)
        (WRITE-SOCKET 163)
        (CALL-C-FUNCTION 167)
        (DLD-LINK 168)
        (DLD-UNLINK-BY-FILE 169)
        (DLD-UNLINK-BY-SYMBOL 170)
        (DLD-GET-SYMBOL 171)
        (DLD-GET-FUNC 172)
        (DLD-FUNCTION-EXECUTABLE-P 173)
        (DLD-LIST-UNDEFINED-SYMBOLS 174)
        (C-MALLOC 175)
        (C-FREE 176)
        (C-PUTBASEBYTE 177)
        (C-GETBASEBYTE 178)
        (CHAR-OPENFILE 200)
        (CHAR-BIN 201)
        (CHAR-BOUT 202)
        (CHAR-IOCTL 203)
        (CHAR-CLOSEFILE 204)
        (CHAR-EOFP 205)
        (CHAR-READP 206)
        (CHAR-BINS 207)
        (CHAR-BOUTS 208)
        (CHAR-FILLBUFFER 209)))

(* "END EXPORTED DEFINITIONS")


(DEFMACRO SUBRCALL (NAME &REST ARGS)
   [LET [(ARGNAMES (MAPCAR ARGS #'(LAMBDA (X)
                                    (GENSYM]
        `(CL:FUNCALL [CL:COMPILE NIL '(LAMBDA ,ARGNAMES
                                        ((OPCODES SUBRCALL ,(SUBRNUMBER NAME)
                                                ,(LENGTH ARGS))
                                         ,@ARGNAMES]
                ,@ARGS])

(DEFOPTIMIZER SUBRCALL (NAME &REST ARGS)
                           `((OPCODES SUBRCALL ,(SUBRNUMBER NAME)
                                    ,(LENGTH ARGS))
                             ,@ARGS))
(DEFINEQ

(SUBRNUMBER
  [LAMBDA (NAME)                                         (* ; "Edited  5-Feb-92 16:49 by jds")

    (* ;; "Given a SUBR's NAME or number, return the corresponding subr number.")

    (LET (NUMBER)
         (COND
            ((FIXP NAME)
             (CL:WARN "SUBR name (~d) is a number; should be abstracted." NAME)
             NAME)
            ((CADR (ASSOC NAME \INITSUBRS)))
            ([SETQ NUMBER (CADR (CL:ASSOC NAME \INITSUBRS :TEST (FUNCTION STRING.EQUAL]
             (CL:WARN "SUBR name ~s is in wrong package.  Using ~d as subr number." NAME NUMBER))
            (T (ERROR NAME " not a SUBR"])
)



(* ;; "use this to make a subrs.h file for Maiko ")

(DEFINEQ

(WRITECALLSUBRS
  [LAMBDA NIL                                          (* ; "Edited 16-Mar-2021 22:47 by larry")
    (CL:WITH-OPEN-FILE (*STANDARD-OUTPUT* "subrs.h" :DIRECTION :OUTPUT :IF-EXISTS :NEW-VERSION)
           (CL:FORMAT T "/* This file written from LLSUBRS on ~A                      */~&" (DATE))
           (CL:FORMAT T "/* Do not edit this file! Instead, edit the list \initsubrs */~&")
           (CL:FORMAT T "/* on the lisp file LLSUBRS and then call WRITECALLSUBRS to  */~&")
           (CL:FORMAT T "/* generate a new version.                                   */~&")
           (CL:FORMAT T "#ifndef SUBRS_H~&#define SUBRS_H 1~&")
           (for X in \INITSUBRS do (CL:FORMAT T "#define sb_~A	0~O~&" (FIX-SUBR-NAME
                                                                                   (CAR X))
                                                      (CADR X)))
           (CL:FORMAT T "~&~&/* MISCN opcodes */~&")
           (for X in \MISCN-TABLE-LIST do (CL:FORMAT T "#define miscn_~A	0~O~&"
                                                             (FIX-SUBR-NAME (CAR X))
                                                             (CADR X)))
           (CL:FORMAT T "~&~&/* Assigned USER SUBR numbers */~&")
           (for X in \USER-SUBR-LIST do (CL:FORMAT T "#define user_subr_~A	0~O~&"
                                                           (FIX-SUBR-NAME (CAR X))
                                                           (CADR X])

(FIX-SUBR-NAME
(LAMBDA (NAME) (* ; "Edited 13-Feb-89 16:17 by jds") (* ;; "Fix up a SUBR name for use as a symbol in the C code, by:") (* ;; "Converting all -'s to _'s") (* ;; "Converting all .'s to _'s") (* ;; "Removing all \'s.") (* ;; "This allows us to use fairly normal Lisp symbols for SUBR names (like \TEDIT.BLTCHAR), while having them translate pleasantly.") (CONCATCODES (DREMOVE (CHARCODE \) (SUBST (CHARCODE _) (CHARCODE %.) (SUBST (CHARCODE _) (CHARCODE -) (CHCON NAME))))))
)
)

(PUTPROPS SUBRCALL ARGNAMES (NAME &REST ARGS))
(DECLARE%: DONTCOPY 
(DECLARE%: EVAL@COMPILE 

[PUTDEF 'UNIXSTRING 'RESOURCES '(NEW (ALLOCSTRING 512]
)
)

(/SETTOPVAL '\UNIXSTRING.GLOBALRESOURCE NIL)
(DEFINEQ

(\MOREVMEMFILE
(LAMBDA (FILEPAGE) (* ; "Edited 27-Apr-88 13:36 by MASINTER") (SUBRCALL MOREVMEMFILE FILEPAGE)))

(\WRITEMAP
(LAMBDA (VP RP FLAGS) (* ; "Edited 27-Apr-88 13:37 by MASINTER") (SUBRCALL WRITEMAP VP RP FLAGS)))

(\COPYSYS0SUBR
(LAMBDA (FID) (* ; "Edited 20-Apr-88 12:36 by MASINTER") (SUBRCALL COPYSYS0SUBR FID)))

(\PUPLEVEL1STATE
(LAMBDA (FLG) (* ; "Edited 20-Apr-88 12:37 by MASINTER") (SUBRCALL PUPLEVEL1STATE FLG)))

(SHOWDISPLAY
(LAMBDA (BASE RASTERWIDTH) (* ; "Edited 27-Apr-88 13:40 by MASINTER") (* ;; "comments are done with semicolons one comment is at the right margin, it automatically do you type ") (SUBRCALL SHOWDISPLAY BASE RASTERWIDTH))
)

(SETSCREENCOLOR
(LAMBDA (FLG) (* ; "Edited 20-Apr-88 12:37 by MASINTER") (SUBRCALL SETSCREENCOLOR FLG)))

(\WRITERAWPBI
(LAMBDA (PBI) (* ; "Edited 20-Apr-88 12:38 by MASINTER") (SUBRCALL WRITERAWPBI PBI)))

(\READRAWPBI
(LAMBDA NIL (* ; "Edited 20-Apr-88 12:38 by MASINTER") (SUBRCALL READRAWPBI)))

(RAID
(LAMBDA (MESS1 MESS2 FLG) (* ; "Edited 20-Apr-88 12:38 by MASINTER") (SUBRCALL RAID MESS1 MESS2 FLG)))

(\LISPFINISH
(LAMBDA (DUMMY) (* ; "Edited 20-Apr-88 12:38 by MASINTER") (SUBRCALL LISPFINISH DUMMY)))

(\GETPACKETBUFFER
(LAMBDA NIL (* ; "Edited 20-Apr-88 12:38 by MASINTER") (SUBRCALL GETPACKETBUFFER)))

(\GATHERSTATS
(LAMBDA (FID) (* ; "Edited 20-Apr-88 12:38 by MASINTER") (SUBRCALL GATHERSTATS FID)))

(\DSPRATE
(LAMBDA (AC0 AC1 AC2) (* ; "Edited 20-Apr-88 12:39 by MASINTER") (* ; "Edited 20-Apr-88 12:39 by MASINTER") (SUBRCALL DSPRATE AC0 AC1 AC2))
)

(DSPBOUT
(LAMBDA (CHARCODE) (* ; "Edited 20-Apr-88 12:39 by MASINTER") (SUBRCALL DSPBOUT CHARCODE)))

(DISKPARTITION
(LAMBDA NIL (* ; "Edited 20-Apr-88 12:39 by MASINTER") (SELECTQ (MACHINETYPE) ((DORADO DOLPHIN) (SUBRCALL DISKPARTITION)) ((DANDELION DOVE) (\DFSCurrentVolume)) NIL))
)

(\CHECKBCPLPASSWORD
(LAMBDA (USER PASSWORD) (* ; "Edited 14-Jun-88 13:33 by drc:") (SUBRCALL CHECKBCPLPASSWORD USER PASSWORD))
)

(SUSPEND-LISP
(LAMBDA NIL (* ; "Edited 20-Jun-88 15:24 by greep") (if (EQ (MACHINETYPE) (QUOTE MAIKO)) then (SUBRCALL SUSPEND-LISP) T else NIL))
)

(UNIX-USERNAME
(LAMBDA NIL (* ; "Edited  1-Aug-88 23:22 by masinter") (if (EQ \MACHINETYPE \MAIKO) then (WITH-RESOURCE UNIXSTRING (if (SUBRCALL UNIX-USERNAME UNIXSTRING) then (CONCAT (SUBSTRING UNIXSTRING 1 (CL:POSITION #\Null UNIXSTRING)))))))
)

(UNIX-FULLNAME
(LAMBDA NIL (* ; "Edited 18-Jul-88 03:47 by masinter") (if (EQ \MACHINETYPE \MAIKO) then (WITH-RESOURCES UNIXSTRING (if (SUBRCALL UNIX-FULLNAME UNIXSTRING) then (CONCAT (SUBSTRING UNIXSTRING 1 (CL:POSITION #\Null UNIXSTRING)))))))
)

(UNIX-GETENV
  [LAMBDA (NAME)                                       (* ; "Edited 21-Feb-2021 21:09 by larry")
    (WITH-RESOURCES
     UNIXSTRING
     (LET ((X UNIXSTRING))
          (if (SUBRCALL UNIX-GETENV (MKSTRING NAME)
                         X)
              then (CONCAT (SUBSTRING X 1 (for I from 1
                                                 do (if (FMEMB (NTHCHARCODE X I)
                                                                       '(0 NIL))
                                                            then (RETURN (SUB1 I])

(UNIX-GETPARM
(LAMBDA (NAME) (* ; "Edited 27-Feb-91 17:11 by nm") (* ;; "Read information from the C emulator.  Usually gets info about configuration of the machine we're running on.") (* ;; "Used to use CL:POSITION, but now called in the INIT if you're on a Sun, so I changed it to STRPOS.") (* ;; "SUBRCALL UNIX-GETPARM now returns the length of the string.") (if (EQ \MACHINETYPE \MAIKO) then (LET (LEN) (WITH-RESOURCE UNIXSTRING (SETQ LEN (SUBRCALL UNIX-GETPARM (MKSTRING NAME) UNIXSTRING)) (COND ((SMALLP LEN) (if (> LEN 0) then (CONCAT (SUBSTRING UNIXSTRING 1 LEN)))) (LEN (CONCAT (SUBSTRING UNIXSTRING 1 (SUB1 (STRPOS #\Null UNIXSTRING))))))))))
)
)

(PUTPROPS SHOWDISPLAY ARGNAMES (BASE RASTERWIDTH))

(PUTPROPS SETSCREENCOLOR ARGNAMES (FLG))

(PUTPROPS \WRITERAWPBI ARGNAMES (PBI))

(PUTPROPS \READRAWPBI ARGNAMES NIL)

(PUTPROPS RAID ARGNAMES (MESS1 MESS2 FLG))

(PUTPROPS \LISPFINISH ARGNAMES (DUMMY))

(PUTPROPS \GETPACKETBUFFER ARGNAMES NIL)

(PUTPROPS \GATHERSTATS ARGNAMES (FID))

(PUTPROPS \DSPRATE ARGNAMES (AC0 AC1 AC2))

(PUTPROPS DSPBOUT ARGNAMES (CHARCODE))

(PUTPROPS DISKPARTITION ARGNAMES NIL)

(PUTPROPS \CHECKBCPLPASSWORD ARGNAMES (PASS CL:VECTOR))

(PUTPROPS LLSUBRS FILETYPE CL:COMPILE-FILE)
(PUTPROPS LLSUBRS COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1988 1989 1990 1991 1992 
2021))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (3658 6447 (MISCN-NUMBER 3668 . 3823) (\MISCN.UFN 3825 . 5280) (\UNDEFINED-MISCN-UFN 
5282 . 5550) (MISCN-COLLECT 5552 . 5719) (\GET-MY-BF 5721 . 5864) (\INIT-MISCN-TABLE 5866 . 6445)) (
7831 9120 (ADD-USER-SUBR 7831 . 9120)) (9121 10486 (\USER-SUBR-UFN 9131 . 9571) (\INIT-USER-SUBR-TABLE
 9573 . 9900) (\UNDEFINED-USER-SUBR-UFN 9902 . 10201) (USER-SUBR-NUMBER 10203 . 10364) (EQ-TO-CAR 
10366 . 10423) (EQ-TO-CADR 10425 . 10484)) (14769 15418 (SUBRNUMBER 14779 . 15416)) (15479 17528 (
WRITECALLSUBRS 15489 . 17031) (FIX-SUBR-NAME 17033 . 17526)) (17737 21684 (\MOREVMEMFILE 17747 . 17862
) (\WRITEMAP 17864 . 17977) (\COPYSYS0SUBR 17979 . 18084) (\PUPLEVEL1STATE 18086 . 18195) (SHOWDISPLAY
 18197 . 18435) (SETSCREENCOLOR 18437 . 18545) (\WRITERAWPBI 18547 . 18650) (\READRAWPBI 18652 . 18747
) (RAID 18749 . 18861) (\LISPFINISH 18863 . 18968) (\GETPACKETBUFFER 18970 . 19075) (\GATHERSTATS 
19077 . 19180) (\DSPRATE 19182 . 19337) (DSPBOUT 19339 . 19443) (DISKPARTITION 19445 . 19632) (
\CHECKBCPLPASSWORD 19634 . 19766) (SUSPEND-LISP 19768 . 19918) (UNIX-USERNAME 19920 . 20170) (
UNIX-FULLNAME 20172 . 20423) (UNIX-GETENV 20425 . 21022) (UNIX-GETPARM 21024 . 21682)))))
STOP
\ No newline at end of file
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "17-Mar-2021 11:10:55" {DSK}<home>larry>ilisp>medley>sources>LLSUBRS.;6 27745  

      changes to%:  (VARS \INITSUBRS)
                    (FNS MISCN-NUMBER \MISCN.UFN \UNDEFINED-MISCN-UFN MISCN-COLLECT \GET-MY-BF 
                         \INIT-MISCN-TABLE \USER-SUBR-UFN \INIT-USER-SUBR-TABLE 
                         \UNDEFINED-USER-SUBR-UFN USER-SUBR-NUMBER EQ-TO-CAR EQ-TO-CADR SUBRNUMBER 
                         WRITECALLSUBRS FIX-SUBR-NAME \MOREVMEMFILE \WRITEMAP \COPYSYS0SUBR 
                         \PUPLEVEL1STATE SHOWDISPLAY SETSCREENCOLOR \WRITERAWPBI \READRAWPBI RAID 
                         \LISPFINISH \GETPACKETBUFFER \GATHERSTATS \DSPRATE DSPBOUT DISKPARTITION 
                         \CHECKBCPLPASSWORD SUSPEND-LISP UNIX-USERNAME UNIX-FULLNAME UNIX-GETENV 
                         UNIX-GETPARM)

      previous date%: "16-Mar-2021 23:00:15" {DSK}<home>larry>ilisp>medley>sources>LLSUBRS.;3)


(* ; "
Copyright (c) 1983-1986, 1988-1992, 2021 by Venue & Xerox Corporation.
")

(PRETTYCOMPRINT LLSUBRSCOMS)

(RPAQQ LLSUBRSCOMS
       ((DECLARE%: EVAL@COMPILE DONTCOPY (ADDVARS (DONTCOMPILEFNS SUBRCALL MISCN FIX-SUBR-NAME 
                                                         WRITECALLSUBRS)))
        

(* ;;; "MISCN  Vars & Functions")

        (EXPORT (VARS \MISCN-TABLE-LIST))
        (FUNCTIONS MISCN)
        (OPTIMIZERS MISCN)
        (FNS MISCN-NUMBER \MISCN.UFN \UNDEFINED-MISCN-UFN MISCN-COLLECT \GET-MY-BF \INIT-MISCN-TABLE)
        (PROP ARGNAMES MISCN)
        (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS MISCN-UFN-SPEC MISCN-UFN-ENTRY))
        

(* ;;; " USER-SUBR Vars & Functions")

        (EXPORT (VARS \USER-SUBR-LIST))
        (FUNCTIONS USER-SUBR ADD-USER-SUBR)
        (FNS \USER-SUBR-UFN \INIT-USER-SUBR-TABLE \UNDEFINED-USER-SUBR-UFN USER-SUBR-NUMBER EQ-TO-CAR
             EQ-TO-CADR)
        (PROP ARGNAMES USER-SUBR)
        

(* ;;; "SUBRCALL Vars & Functions")

        (EXPORT (VARS \INITSUBRS))
        (FUNCTIONS SUBRCALL)
        (OPTIMIZERS SUBRCALL)
        (FNS SUBRNUMBER)
        
        (* ;; "use this to make a subrs.h file for Maiko ")

        (FNS WRITECALLSUBRS FIX-SUBR-NAME)
        (PROP ARGNAMES SUBRCALL)
        (DECLARE%: DONTCOPY (RESOURCES UNIXSTRING))
        (INITRESOURCES UNIXSTRING)
        (FNS \MOREVMEMFILE \WRITEMAP \COPYSYS0SUBR \PUPLEVEL1STATE SHOWDISPLAY SETSCREENCOLOR 
             \WRITERAWPBI \READRAWPBI RAID \LISPFINISH \GETPACKETBUFFER \GATHERSTATS \DSPRATE DSPBOUT
             DISKPARTITION \CHECKBCPLPASSWORD SUSPEND-LISP UNIX-USERNAME UNIX-FULLNAME UNIX-GETENV 
             UNIX-GETPARM)
        (IFPROP ARGNAMES SHOWDISPLAY SETSCREENCOLOR \WRITERAWPBI \READRAWPBI RAID \LISPFINISH 
               \GETPACKETBUFFER \GATHERSTATS \DSPRATE DSPBOUT DISKPARTITION \CHECKBCPLPASSWORD)
        (PROPS (LLSUBRS FILETYPE))))
(DECLARE%: EVAL@COMPILE DONTCOPY 

(ADDTOVAR DONTCOMPILEFNS SUBRCALL MISCN FIX-SUBR-NAME WRITECALLSUBRS)
)



(* ;;; "MISCN  Vars & Functions")

(* "FOLLOWING DEFINITIONS EXPORTED")
(RPAQQ \MISCN-TABLE-LIST
       ((USER-SUBR 0 \USER-SUBR-UFN T)
        (CL:VALUES 1 CL::VALUES-UFN NIL)
        (CL:SXHASH 2 CL::SXHASH-UFN NIL)
        (CL::EQLHASHBITSFN 3 CL::EQLHASHBITSFN-UFN NIL)
        (STRINGHASHBITS 4 \STRINGHASHBITS-UFN NIL)
        (STRING-EQUAL-HASHBITS 5 \STRING-EQUAL-HASHBITS-UFN NIL)
        (CL:VALUES-LIST 6 CL::VALUES-LIST-UFN NIL)
        (LCFetchMethod 7 LCFetchMethod NIL)
        (LCFetchMethodOrHelp 8 NIL NIL)
        (LCFindVarIndex 9 NIL NIL)
        (LCGetIVValue 10 NIL NIL)
        (LCPutIVValue 11 NIL NIL)))

(* "END EXPORTED DEFINITIONS")


(DEFMACRO MISCN (NAME &REST ARGS)
   [LET [(ARGNAMES (MAPCAR ARGS #'(LAMBDA (X)
                                    (GENSYM]
        `(CL:FUNCALL [CL:COMPILE NIL '(LAMBDA ,ARGNAMES
                                        ((OPCODES MISCN ,(MISCN-NUMBER NAME)
                                                ,(LENGTH ARGS))
                                         ,@ARGNAMES]
                ,@ARGS])

(DEFOPTIMIZER MISCN (NAME &REST ARGS)
                        `((OPCODES MISCN ,(MISCN-NUMBER NAME)
                                 ,(LENGTH ARGS))
                          ,@ARGS))
(DEFINEQ

(MISCN-NUMBER
  [LAMBDA (NAME)                                      (* ; "Edited  7-Nov-88 15:21 by krivacic")
    (CADR (OR (ASSOC NAME \MISCN-TABLE-LIST)
              (ERROR NAME " not a MISCN index"])

(\MISCN.UFN
  [LAMBDA (ALPHA-BETA)                                   (* ; "Edited  8-Jun-89 16:57 by jds")

    (* ;; "The UFN for the MISCN opcode.")

    (DECLARE (GLOBALVARS \MISCN-TABLE))

    (* ;; "Get the misc index & number of args from the code stream")

    (LET ((INDEX (LRSH ALPHA-BETA 8))
          (ARG-COUNT (LOGAND ALPHA-BETA 255)))

         (* ;; "compute the position of the real IVARS on the stack.  Create a pointer to these args and pass it to the Handler routine.")

         (COND
            ((NOT (AND (BOUNDP '\MISCN-TABLE)
                       \MISCN-TABLE))
             (\INIT-MISCN-TABLE)))
         (LET* [(CALLER (\MYALINK))
                (MY-BF (\GET-MY-BF))
                (MY-IVAR (fetch (BF IVAR) of MY-BF))
                (RESULT-IVAR (- MY-IVAR (LLSH ARG-COUNT 1)))
                (MY-PARMS-PTR (\VAG2 1 RESULT-IVAR))
                (UFN-ENTRY (\ADDBASE \MISCN-TABLE (LLSH INDEX 1]
               (COND
                  ((fetch (MISCN-UFN-ENTRY MISCN-MVS) OF UFN-ENTRY)

                   (* ;; "This UFN can return Multiple values, so we need to preserve them.")

                   (CL:UNWIND-PROTECT
                       (APPLY* (\GETBASEPTR UFN-ENTRY 0)
                              INDEX ARG-COUNT MY-PARMS-PTR)
                       (replace (BF IVAR) of MY-BF with RESULT-IVAR)
                       (REPLACE (FX NEXTBLOCK) OF CALLER WITH RESULT-IVAR)))
                  (T 
                     (* ;; "He said no MVs are possible, so don't even TRY to preserve them.  This is an expanded and cleaned up version of CL:UNWIND-PROTECT, so watch it!")

                     (PROG1 (.UNWIND.PROTECT. [FUNCTION (LAMBDA NIL
                                                          (replace (BF IVAR) of MY-BF
                                                             with RESULT-IVAR]
                                   (APPLY* (\GETBASEPTR UFN-ENTRY 0)
                                          INDEX ARG-COUNT MY-PARMS-PTR))
                         (replace (BF IVAR) of MY-BF with RESULT-IVAR)
                         (REPLACE (FX NEXTBLOCK) OF CALLER WITH RESULT-IVAR))])

(\UNDEFINED-MISCN-UFN
  [LAMBDA (INDEX ARG-COUNT ARG-PTR)                   (* ; "Edited  3-Nov-88 15:56 by krivacic")
    (PRINTOUT T "index " INDEX ", arg count " ARG-COUNT T)
    (ERROR (CL:FORMAT T "Undefined MISCN[~d] with ~d args." INDEX ARG-COUNT)
           (MISCN-COLLECT ARG-COUNT ARG-PTR])

(MISCN-COLLECT
  [LAMBDA (ARG-COUNT ARG-PTR)                         (* ; "Edited  3-Nov-88 11:52 by krivacic")
    (FOR I FROM 0 TO (- ARG-COUNT 1) COLLECT (\GETBASEPTR ARG-PTR (LLSH I 1])

(\GET-MY-BF
  [LAMBDA NIL                                         (* ; "Edited  3-Nov-88 11:08 by krivacic")

    (* ;; "Returns the stack index of the caller's BF.")

    (- (\MYALINK)
       2])

(\INIT-MISCN-TABLE
  [LAMBDA NIL
    (DECLARE (GLOBALVARS \MISCN-TABLE-LIST \MISCN-TABLE))
                                                             (* ; "Edited  7-Mar-89 09:43 by jds")
    (LET ((OP-NUMBER 36)
          (OP-LENGTH 3)
          BASE)
         (SETQ \MISCN-TABLE (ARRAY 256 'POINTER '\UNDEFINED-MISCN-UFN 0))
         (SETQ BASE (FETCH (ARRAYP BASE) OF \MISCN-TABLE))
         (for MISCN-ENTRY in \MISCN-TABLE-LIST do (SETA \MISCN-TABLE (CADR MISCN-ENTRY)
                                                                    (CADDR MISCN-ENTRY))
                                                             (REPLACE (MISCN-UFN-ENTRY MISCN-MVS)
                                                                OF (\ADDBASE2 BASE
                                                                              (FETCH (
                                                                                       MISCN-UFN-SPEC
                                                                                          INDEX)
                                                                                 OF MISCN-ENTRY))
                                                                WITH (FETCH (MISCN-UFN-SPEC
                                                                                     MVS)
                                                                            OF MISCN-ENTRY)))
         (SETQ \MISCN-TABLE BASE])
)

(PUTPROPS MISCN ARGNAMES (NAME &REST ARGS))
(DECLARE%: EVAL@COMPILE DONTCOPY 
(DECLARE%: EVAL@COMPILE

(RECORD MISCN-UFN-SPEC (
                            (* ;; 
                "This is the description for a MISCN opcode's UFN, as placed in \MISCN-TABLE-LIST.")

                            NAME                             (* ; 
                                                    "Name of the MISCN, for the MISCN macro's use.")
                            INDEX                            (* ; "Sub-opcode index.")
                            UFN-NAME                         (* ; "Name of the UFN")
                            MVS                              (* ; 
              "T if the UFN can returnmultiple values.  If this is NIL, MVs WILL NOT BE PRESERVED.")
                            ))

(BLOCKRECORD MISCN-UFN-ENTRY ((MISCN-MVS FLAG)
                                  (NIL BITS 3)
                                  (MISCN-UFN POINTER)))
)
)



(* ;;; " USER-SUBR Vars & Functions")

(* "FOLLOWING DEFINITIONS EXPORTED")
(RPAQQ \USER-SUBR-LIST ((DUMMY 10 DUMMY-UFN)
                            (SAMPLE-USER-SUBR 0 SAMPLE-USER-SUBR-UFN)))

(* "END EXPORTED DEFINITIONS")


(DEFMACRO USER-SUBR (USER-SUBR-NAME &REST ARGS)
   `(MISCN USER-SUBR ,(USER-SUBR-NUMBER USER-SUBR-NAME)
           ,@ARGS))

(CL:DEFUN ADD-USER-SUBR (USER-SUBR-NAME USER-SUBR-INDEX USER-SUBR-UFN)
   (DECLARE (GLOBALVARS \USER-SUBR-TABLE \USER-SUBR-LIST))

   (* ;; "Make Sure \USER-SUBR-TABLE is made")

   (IF (NOT (AND (BOUNDP '\USER-SUBR-TABLE)
                     \USER-SUBR-TABLE))
       THEN (\INIT-USER-SUBR-TABLE))

   (* ;; "See if the Name is already defined")

   [AND (FASSOC USER-SUBR-NAME \USER-SUBR-LIST)
        (CL:CERROR "Delete old User-subr" "User-subr ~S already defined" USER-SUBR-NAME)
        (SETA \USER-SUBR-TABLE (CADR (FASSOC USER-SUBR-NAME \USER-SUBR-LIST))
              '\UNDEFINED-USER-SUBR-UFN)
        (SETQ \USER-SUBR-LIST (CL:REMOVE USER-SUBR-NAME \USER-SUBR-LIST :TEST 'EQ-TO-CAR]

   (* ;; "See if the UFN is already defined")

   [AND (OR (NEQ (ELT \USER-SUBR-TABLE USER-SUBR-INDEX)
                 '\UNDEFINED-USER-SUBR-UFN)
            (CL:FIND USER-SUBR-INDEX \USER-SUBR-LIST :KEY #'CL:SECOND))
        (CL:CERROR "Delete old User-subr" " User-subr index ~d already defined" USER-SUBR-INDEX)
        (SETQ \USER-SUBR-LIST (CL:REMOVE USER-SUBR-INDEX \USER-SUBR-LIST :TEST 'EQ-TO-CADR]
   (CL:PUSH (LIST USER-SUBR-NAME USER-SUBR-INDEX (OR USER-SUBR-UFN '\UNDEFINED-USER-SUBR-UFN))
          \USER-SUBR-LIST)
   (\INIT-USER-SUBR-TABLE))
(DEFINEQ

(\USER-SUBR-UFN
  [LAMBDA (INDEX ARG-COUNT ARG-PTR)
    (DECLARE (GLOBALVARS \USER-SUBR-TABLE))       (* ; "Edited  4-Nov-88 18:43 by krivacic")
    (IF (NOT (AND (BOUNDP '\USER-SUBR-TABLE)
                      \USER-SUBR-TABLE))
        THEN (\INIT-USER-SUBR-TABLE))
    (LET ((USER-SUBR-INDEX (\GETBASE ARG-PTR 1)))

         (* ;; "User SUBR ufn.  Index on the User subr indexes")

         (APPLY* (ELT \USER-SUBR-TABLE USER-SUBR-INDEX)
                USER-SUBR-INDEX
                (- ARG-COUNT 1)
                (\ADDBASE ARG-PTR 2])

(\INIT-USER-SUBR-TABLE
  [LAMBDA NIL
    (DECLARE (GLOBALVARS \USER-SUBR-TABLE \USER-SUBR-LIST))
                                                          (* ; "Edited  4-Nov-88 18:58 by krivacic")
    (SETQ \USER-SUBR-TABLE (ARRAY 256 'POINTER '\UNDEFINED-USER-SUBR-UFN 0))
    (for SUBR-ENTRY in \USER-SUBR-LIST do (SETA \USER-SUBR-TABLE (CADR SUBR-ENTRY)
                                                            (CADDR SUBR-ENTRY])

(\UNDEFINED-USER-SUBR-UFN
  [LAMBDA (USER-SUBR-INDEX ARG-COUNT ARG-PTR)         (* ; "Edited  7-Nov-88 14:33 by krivacic")

    (* ;; "User SUBR ufn.  Index on the User subr indexes")

    (ERROR (CL:FORMAT NIL "Undefined USER-SUBR[~d] with ~d args." USER-SUBR-INDEX ARG-COUNT)
           (MISCN-COLLECT ARG-COUNT ARG-PTR])

(USER-SUBR-NUMBER
  [LAMBDA (NAME)                                      (* ; "Edited  4-Nov-88 18:42 by krivacic")
    (CADR (OR (ASSOC NAME \USER-SUBR-LIST)
              (ERROR NAME " not a USER-SUBR index"])

(EQ-TO-CAR
  [LAMBDA (ITEM LIST)
    (EQ ITEM (CAR LIST])

(EQ-TO-CADR
  [LAMBDA (ITEM LIST)
    (EQ ITEM (CADR LIST])
)

(PUTPROPS USER-SUBR ARGNAMES (USER-SUBR-NAME &REST ARGS))



(* ;;; "SUBRCALL Vars & Functions")

(* "FOLLOWING DEFINITIONS EXPORTED")
(RPAQQ \INITSUBRS
       ((YIELD 210)
        (BACKGROUNDSUBR 6)
        (CHECKBCPLPASSWORD 7)
        (DISKPARTITION 8)
        (DSPBOUT 9)
        (DSPRATE 10)
        (GATHERSTATS 11)
        (GETPACKETBUFFER 12)
        (LISPFINISH 13)
        (MOREVMEMFILE 14)
        (RAID 15)
        (READRAWPBI 16)
        (WRITERAWPBI 17)
        (SETSCREENCOLOR 18)
        (SHOWDISPLAY 19)
        (PUPLEVEL1STATE 20)
        (WRITESTATS 21)
        (CONTEXTSWITCH 22)
        (COPYSYS0SUBR 23)
        (WRITEMAP 24)
        (UFS-GETFILENAME 34)
        (UFS-DELETEFILE 35)
        (UFS-RENAMEFILE 36)
        (COM-READPAGES 37)
        (COM-WRITEPAGES 38)
        (COM-TRUNCATEFILE 39)
        (UFS-DIRECTORYNAMEP 41)
        (COM-GETFREEBLOCK 45)
        (SETUNIXTIME 48)
        (GETUNIXTIME 49)
        (COPYTIMESTATS 50)
        (UNIX-USERNAME 51)
        (UNIX-FULLNAME 52)
        (UNIX-GETENV 53)
        (UNIX-GETPARM 54)
        (CHECK-SUM 55)
        (ETHER-SUSPEND 56)
        (ETHER-RESUME 57)
        (ETHER-AVAILABLE 58)
        (ETHER-RESET 59)
        (ETHER-GET 60)
        (ETHER-SEND 61)
        (ETHER-SETFILTER 62)
        (ETHER-CHECK 63)
        (DSPCURSOR 64)
        (SETMOUSEXY 65)
        (DSP-VIDEOCOLOR 66)
        (DSP-SCREENWIDTH 67)
        (DSP-SCREENHEIGHT 68)
        (BITBLTSUB 69)
        (BLTCHAR 70)
        (TEDIT.BLTCHAR 71)
        (BITBLT.BITMAP 72)
        (BLTSHADE.BITMAP 73)
        (RS232C-CMD 74)
        (RS232C-READ-INIT 75)
        (RS232C-WRITE 76)
        (KEYBOARDBEEP 80)
        (KEYBOARDMAP 81)
        (KEYBOARDSTATE 82)
        (VMEMSAVE 89)
        (LISP-FINISH 90)
        (NEWPAGE 91)
        (DORECLAIM 92)
        (DUMMY-135Q 93)
        (NATIVE-MEMORY-REFERENCE 94)
        (OLD-COMPILE-LOAD-NATIVE 95)
        (DISABLEGC 96)
        (COM-SETFILEINFO 103)
        (COM-OPENFILE 104)
        (COM-CLOSEFILE 105)
        (DSK-GETFILENAME 106)
        (DSK-DELETEFILE 107)
        (DSK-RENAMEFILE 108)
        (COM-NEXT-FILE 110)
        (COM-FINISH-FINFO 111)
        (COM-GEN-FILES 112)
        (DSK-DIRECTORYNAMEP 113)
        (COM-GETFILEINFO 114)
        (COM-CHANGEDIR 116)
        (UNIX-HANDLECOMM 117)
        (RPC-CALL 119)
        (MESSAGE-READP 120)
        (MESSAGE-READ 121)
        (MONITOR-CONTROL 128)
        (GET-NATIVE-ADDR-FROM-LISP-PTR 131)
        (GET-LISP-PTR-FROM-NATIVE-ADDR 132)
        (LOAD-NATIVE-FILE 133)
        (SUSPEND-LISP 134)
        (NEW-BLTCHAR 135)
        (COLOR-INIT 136)
        (COLOR-SCREENMODE 137)
        (COLOR-MAP 138)
        (COLOR-BASE 139)
        (C-SlowBltChar 140)
        (UNCOLORIZE-BITMAP 141)
        (COLORIZE-BITMAP 142)
        (COLOR-8BPPDRAWLINE 143)
        (TCP-OP 144)
        (WITH-SYMBOL 145)
        (CAUSE-INTERRUPT 146)
        (OPEN-SOCKET 160)
        (CLOSE-SOCKET 161)
        (READ-SOCKET 162)
        (WRITE-SOCKET 163)
        (CALL-C-FUNCTION 167)
        (DLD-LINK 168)
        (DLD-UNLINK-BY-FILE 169)
        (DLD-UNLINK-BY-SYMBOL 170)
        (DLD-GET-SYMBOL 171)
        (DLD-GET-FUNC 172)
        (DLD-FUNCTION-EXECUTABLE-P 173)
        (DLD-LIST-UNDEFINED-SYMBOLS 174)
        (C-MALLOC 175)
        (C-FREE 176)
        (C-PUTBASEBYTE 177)
        (C-GETBASEBYTE 178)
        (CHAR-OPENFILE 200)
        (CHAR-BIN 201)
        (CHAR-BOUT 202)
        (CHAR-IOCTL 203)
        (CHAR-CLOSEFILE 204)
        (CHAR-EOFP 205)
        (CHAR-READP 206)
        (CHAR-BINS 207)
        (CHAR-BOUTS 208)
        (CHAR-FILLBUFFER 209)))

(* "END EXPORTED DEFINITIONS")


(DEFMACRO SUBRCALL (NAME &REST ARGS)
   [LET [(ARGNAMES (MAPCAR ARGS #'(LAMBDA (X)
                                    (GENSYM]
        `(CL:FUNCALL [CL:COMPILE NIL '(LAMBDA ,ARGNAMES
                                        ((OPCODES SUBRCALL ,(SUBRNUMBER NAME)
                                                ,(LENGTH ARGS))
                                         ,@ARGNAMES]
                ,@ARGS])

(DEFOPTIMIZER SUBRCALL (NAME &REST ARGS)
                           `((OPCODES SUBRCALL ,(SUBRNUMBER NAME)
                                    ,(LENGTH ARGS))
                             ,@ARGS))
(DEFINEQ

(SUBRNUMBER
  [LAMBDA (NAME)                                         (* ; "Edited  5-Feb-92 16:49 by jds")

    (* ;; "Given a SUBR's NAME or number, return the corresponding subr number.")

    (LET (NUMBER)
         (COND
            ((FIXP NAME)
             (CL:WARN "SUBR name (~d) is a number; should be abstracted." NAME)
             NAME)
            ((CADR (ASSOC NAME \INITSUBRS)))
            ([SETQ NUMBER (CADR (CL:ASSOC NAME \INITSUBRS :TEST (FUNCTION STRING.EQUAL]
             (CL:WARN "SUBR name ~s is in wrong package.  Using ~d as subr number." NAME NUMBER))
            (T (ERROR NAME " not a SUBR"])
)



(* ;; "use this to make a subrs.h file for Maiko ")

(DEFINEQ

(WRITECALLSUBRS
  [LAMBDA NIL                                          (* ; "Edited 17-Mar-2021 11:05 by larry")
    (CL:WITH-OPEN-FILE (*STANDARD-OUTPUT* "subrs.h" :DIRECTION :OUTPUT :IF-EXISTS :NEW-VERSION)
           (CL:FORMAT T "/* This file written from LLSUBRS on ~A                      */~&" (DATE))
           (CL:FORMAT T "/* Do not edit this file! Instead, edit the list \initsubrs */~&")
           (CL:FORMAT T "/* on the lisp file LLSUBRS and then call WRITECALLSUBRS to  */~&")
           (CL:FORMAT T "/* generate a new version.                                   */~&")
           (CL:FORMAT T "#ifndef SUBRS_H~&#define SUBRS_H 1~&")
           (for X in \INITSUBRS do (CL:FORMAT T "#define sb_~A	0~O~&" (FIX-SUBR-NAME
                                                                                   (CAR X))
                                                      (CADR X)))
           (CL:FORMAT T "~&~&/* MISCN opcodes */~&")
           (for X in \MISCN-TABLE-LIST do (CL:FORMAT T "#define miscn_~A	0~O~&"
                                                             (FIX-SUBR-NAME (CAR X))
                                                             (CADR X)))
           (CL:FORMAT T "~&~&/* Assigned USER SUBR numbers */~&")
           (for X in \USER-SUBR-LIST do (CL:FORMAT T "#define user_subr_~A	0~O~&"
                                                           (FIX-SUBR-NAME (CAR X))
                                                           (CADR X)))
           (CL:FORMAT T "#endif ~&"])

(FIX-SUBR-NAME
  [LAMBDA (NAME)                                         (* ; "Edited 13-Feb-89 16:17 by jds")

    (* ;; "Fix up a SUBR name for use as a symbol in the C code, by:")

    (* ;; "Converting all -'s to _'s")

    (* ;; "Converting all .'s to _'s")

    (* ;; "Removing all \'s.")

    (* ;; "This allows us to use fairly normal Lisp symbols for SUBR names (like \TEDIT.BLTCHAR), while having them translate pleasantly.")

    (CONCATCODES (DREMOVE (CHARCODE \)
                        (SUBST (CHARCODE _)
                               (CHARCODE %.)
                               (SUBST (CHARCODE _)
                                      (CHARCODE -)
                                      (CHCON NAME])
)

(PUTPROPS SUBRCALL ARGNAMES (NAME &REST ARGS))
(DECLARE%: DONTCOPY 
(DECLARE%: EVAL@COMPILE 

[PUTDEF 'UNIXSTRING 'RESOURCES '(NEW (ALLOCSTRING 512]
)
)

(/SETTOPVAL '\UNIXSTRING.GLOBALRESOURCE NIL)
(DEFINEQ

(\MOREVMEMFILE
  [LAMBDA (FILEPAGE)                                  (* ; "Edited 27-Apr-88 13:36 by MASINTER")
    (SUBRCALL MOREVMEMFILE FILEPAGE])

(\WRITEMAP
  [LAMBDA (VP RP FLAGS)                               (* ; "Edited 27-Apr-88 13:37 by MASINTER")
    (SUBRCALL WRITEMAP VP RP FLAGS])

(\COPYSYS0SUBR
  [LAMBDA (FID)                                       (* ; "Edited 20-Apr-88 12:36 by MASINTER")
    (SUBRCALL COPYSYS0SUBR FID])

(\PUPLEVEL1STATE
  [LAMBDA (FLG)                                       (* ; "Edited 20-Apr-88 12:37 by MASINTER")
    (SUBRCALL PUPLEVEL1STATE FLG])

(SHOWDISPLAY
  [LAMBDA (BASE RASTERWIDTH)                          (* ; "Edited 27-Apr-88 13:40 by MASINTER")

    (* ;; "comments are done with semicolons one comment is at the right margin, it automatically do you type ")

    (SUBRCALL SHOWDISPLAY BASE RASTERWIDTH])

(SETSCREENCOLOR
  [LAMBDA (FLG)                                       (* ; "Edited 20-Apr-88 12:37 by MASINTER")
    (SUBRCALL SETSCREENCOLOR FLG])

(\WRITERAWPBI
  [LAMBDA (PBI)                                       (* ; "Edited 20-Apr-88 12:38 by MASINTER")
    (SUBRCALL WRITERAWPBI PBI])

(\READRAWPBI
  [LAMBDA NIL                                         (* ; "Edited 20-Apr-88 12:38 by MASINTER")
    (SUBRCALL READRAWPBI])

(RAID
  [LAMBDA (MESS1 MESS2 FLG)                           (* ; "Edited 20-Apr-88 12:38 by MASINTER")
    (SUBRCALL RAID MESS1 MESS2 FLG])

(\LISPFINISH
  [LAMBDA (DUMMY)                                     (* ; "Edited 20-Apr-88 12:38 by MASINTER")
    (SUBRCALL LISPFINISH DUMMY])

(\GETPACKETBUFFER
  [LAMBDA NIL                                         (* ; "Edited 20-Apr-88 12:38 by MASINTER")
    (SUBRCALL GETPACKETBUFFER])

(\GATHERSTATS
  [LAMBDA (FID)                                       (* ; "Edited 20-Apr-88 12:38 by MASINTER")
    (SUBRCALL GATHERSTATS FID])

(\DSPRATE
  [LAMBDA (AC0 AC1 AC2)                               (* ; "Edited 20-Apr-88 12:39 by MASINTER")
                                                          (* ; "Edited 20-Apr-88 12:39 by MASINTER")
    (SUBRCALL DSPRATE AC0 AC1 AC2])

(DSPBOUT
  [LAMBDA (CHARCODE)                                  (* ; "Edited 20-Apr-88 12:39 by MASINTER")
    (SUBRCALL DSPBOUT CHARCODE])

(DISKPARTITION
  [LAMBDA NIL                                         (* ; "Edited 20-Apr-88 12:39 by MASINTER")
    (SELECTQ (MACHINETYPE)
        ((DORADO DOLPHIN) 
             (SUBRCALL DISKPARTITION))
        ((DANDELION DOVE) 
             (\DFSCurrentVolume))
        NIL])

(\CHECKBCPLPASSWORD
  [LAMBDA (USER PASSWORD)                                (* ; "Edited 14-Jun-88 13:33 by drc:")
    (SUBRCALL CHECKBCPLPASSWORD USER PASSWORD])

(SUSPEND-LISP
  [LAMBDA NIL                                            (* ; "Edited 20-Jun-88 15:24 by greep")
    (if (EQ (MACHINETYPE)
                'MAIKO)
        then (SUBRCALL SUSPEND-LISP)
              T
      else NIL])

(UNIX-USERNAME
  [LAMBDA NIL                                         (* ; "Edited  1-Aug-88 23:22 by masinter")
    (if (EQ \MACHINETYPE \MAIKO)
        then (WITH-RESOURCE UNIXSTRING (if (SUBRCALL UNIX-USERNAME UNIXSTRING)
                                               then (CONCAT (SUBSTRING UNIXSTRING 1
                                                                       (CL:POSITION #\Null UNIXSTRING
                                                                              ])

(UNIX-FULLNAME
  [LAMBDA NIL                                         (* ; "Edited 18-Jul-88 03:47 by masinter")
    (if (EQ \MACHINETYPE \MAIKO)
        then (WITH-RESOURCES UNIXSTRING (if (SUBRCALL UNIX-FULLNAME UNIXSTRING)
                                                then (CONCAT (SUBSTRING UNIXSTRING 1
                                                                        (CL:POSITION #\Null 
                                                                               UNIXSTRING])

(UNIX-GETENV
  [LAMBDA (NAME)                                       (* ; "Edited 21-Feb-2021 21:09 by larry")
    (WITH-RESOURCES
     UNIXSTRING
     (LET ((X UNIXSTRING))
          (if (SUBRCALL UNIX-GETENV (MKSTRING NAME)
                         X)
              then (CONCAT (SUBSTRING X 1 (for I from 1
                                                 do (if (FMEMB (NTHCHARCODE X I)
                                                                       '(0 NIL))
                                                            then (RETURN (SUB1 I])

(UNIX-GETPARM
  [LAMBDA (NAME)                                         (* ; "Edited 27-Feb-91 17:11 by nm")

    (* ;; "Read information from the C emulator.  Usually gets info about configuration of the machine we're running on.")

    (* ;; 
"Used to use CL:POSITION, but now called in the INIT if you're on a Sun, so I changed it to STRPOS.")

    (* ;; "SUBRCALL UNIX-GETPARM now returns the length of the string.")

    (if (EQ \MACHINETYPE \MAIKO)
        then (LET (LEN)
                      (WITH-RESOURCE UNIXSTRING (SETQ LEN (SUBRCALL UNIX-GETPARM (MKSTRING NAME)
                                                                 UNIXSTRING))
                             (COND
                                [(SMALLP LEN)
                                 (if (> LEN 0)
                                     then (CONCAT (SUBSTRING UNIXSTRING 1 LEN]
                                (LEN (CONCAT (SUBSTRING UNIXSTRING 1 (SUB1 (STRPOS #\Null UNIXSTRING])
)

(PUTPROPS SHOWDISPLAY ARGNAMES (BASE RASTERWIDTH))

(PUTPROPS SETSCREENCOLOR ARGNAMES (FLG))

(PUTPROPS \WRITERAWPBI ARGNAMES (PBI))

(PUTPROPS \READRAWPBI ARGNAMES NIL)

(PUTPROPS RAID ARGNAMES (MESS1 MESS2 FLG))

(PUTPROPS \LISPFINISH ARGNAMES (DUMMY))

(PUTPROPS \GETPACKETBUFFER ARGNAMES NIL)

(PUTPROPS \GATHERSTATS ARGNAMES (FID))

(PUTPROPS \DSPRATE ARGNAMES (AC0 AC1 AC2))

(PUTPROPS DSPBOUT ARGNAMES (CHARCODE))

(PUTPROPS DISKPARTITION ARGNAMES NIL)

(PUTPROPS \CHECKBCPLPASSWORD ARGNAMES (PASS CL:VECTOR))

(PUTPROPS LLSUBRS FILETYPE CL:COMPILE-FILE)
(PUTPROPS LLSUBRS COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1988 1989 1990 1991 1992 
2021))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (4322 9066 (MISCN-NUMBER 4332 . 4548) (\MISCN.UFN 4550 . 6807) (\UNDEFINED-MISCN-UFN 
6809 . 7125) (MISCN-COLLECT 7127 . 7344) (\GET-MY-BF 7346 . 7558) (\INIT-MISCN-TABLE 7560 . 9064)) (
10450 11739 (ADD-USER-SUBR 10450 . 11739)) (11740 13491 (\USER-SUBR-UFN 11750 . 12325) (
\INIT-USER-SUBR-TABLE 12327 . 12792) (\UNDEFINED-USER-SUBR-UFN 12794 . 13137) (USER-SUBR-NUMBER 13139
 . 13361) (EQ-TO-CAR 13363 . 13424) (EQ-TO-CADR 13426 . 13489)) (17774 18423 (SUBRNUMBER 17784 . 18421
)) (18484 20832 (WRITECALLSUBRS 18494 . 20075) (FIX-SUBR-NAME 20077 . 20830)) (21041 26945 (
\MOREVMEMFILE 21051 . 21216) (\WRITEMAP 21218 . 21378) (\COPYSYS0SUBR 21380 . 21540) (\PUPLEVEL1STATE 
21542 . 21706) (SHOWDISPLAY 21708 . 21997) (SETSCREENCOLOR 21999 . 22162) (\WRITERAWPBI 22164 . 22322)
 (\READRAWPBI 22324 . 22476) (RAID 22478 . 22633) (\LISPFINISH 22635 . 22793) (\GETPACKETBUFFER 22795
 . 22957) (\GATHERSTATS 22959 . 23117) (\DSPRATE 23119 . 23386) (DSPBOUT 23388 . 23542) (DISKPARTITION
 23544 . 23839) (\CHECKBCPLPASSWORD 23841 . 24020) (SUSPEND-LISP 24022 . 24280) (UNIX-USERNAME 24282
 . 24804) (UNIX-FULLNAME 24806 . 25332) (UNIX-GETENV 25334 . 25931) (UNIX-GETPARM 25933 . 26943)))))
STOP
\ No newline at end of file
diff --git a/sources/LLSUBRS.LCOM b/sources/LLSUBRS.LCOM
index 696f011141f418c1b5392f142f46c4b31d0b682f..ccc6b7ec46626c29788901e40ef31628c7ce799f 100644
GIT binary patch
diff --git a/sources/subrs.h b/sources/subrs.h
index c49b914e..8f8dd528 100644
--- a/sources/subrs.h
+++ b/sources/subrs.h
@@ -1,4 +1,4 @@
-/* This file written from LLSUBRS on 16-Mar-2021 23:02:48                      */
+/* This file written from LLSUBRS on 17-Mar-2021 11:14:28                      */
 /* Do not edit this file! Instead, edit the list \initsubrs */
 /* on the lisp file LLSUBRS and then call WRITECALLSUBRS to  */
 /* generate a new version.                                   */
@@ -147,3 +147,4 @@
 /* Assigned USER SUBR numbers */
 #define user_subr_DUMMY	012
 #define user_subr_SAMPLE_USER_SUBR	00
+#endif 
