(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)

(FILECREATED "13-Sep-2021 17:12:03" {DSK}<Users>briggs>Projects>medley>sources>LLSUBRS.;8
 27017  

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

      previous date%: "13-Sep-2021 16:07:08" {DSK}<VAR>TMP>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 '\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

       ((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)
        (YIELD 210)))

(* "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 13-Sep-2021 15:19 by briggs")

    (CL:WITH-OPEN-FILE (*STANDARD-OUTPUT* "subrs.h" :DIRECTION :OUTPUT :IF-EXISTS :NEW-VERSION)
           (CL:FORMAT T "#ifndef SUBRS_H~&#define SUBRS_H 1~&")
           (CL:FORMAT T "/* This file written from LLSUBRS on ~22A */~&" (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.                                  */~&")
           (for
 X in
 \INITSUBRS do
 (CL:FORMAT T "#define sb_~42A 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_~39A 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_~35A 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 (3639 8383 (MISCN-NUMBER 3649 . 3865) (\MISCN.UFN 3867 . 6124) (\UNDEFINED-MISCN-UFN 
6126 . 6442) (MISCN-COLLECT 6444 . 6661) (\GET-MY-BF 6663 . 6875) (\INIT-MISCN-TABLE 6877 . 8381)) (
9767 11056 (ADD-USER-SUBR 9767 . 11056)) (11057 12808 (\USER-SUBR-UFN 11067 . 11642) (
\INIT-USER-SUBR-TABLE 11644 . 12109) (\UNDEFINED-USER-SUBR-UFN 12111 . 12454) (USER-SUBR-NUMBER 12456
 . 12678) (EQ-TO-CAR 12680 . 12741) (EQ-TO-CADR 12743 . 12806)) (17091 17740 (SUBRNUMBER 17101 . 17738
)) (17801 20104 (WRITECALLSUBRS 17811 . 19347) (FIX-SUBR-NAME 19349 . 20102)) (20313 26217 (
\MOREVMEMFILE 20323 . 20488) (\WRITEMAP 20490 . 20650) (\COPYSYS0SUBR 20652 . 20812) (\PUPLEVEL1STATE 
20814 . 20978) (SHOWDISPLAY 20980 . 21269) (SETSCREENCOLOR 21271 . 21434) (\WRITERAWPBI 21436 . 21594)
 (\READRAWPBI 21596 . 21748) (RAID 21750 . 21905) (\LISPFINISH 21907 . 22065) (\GETPACKETBUFFER 22067
 . 22229) (\GATHERSTATS 22231 . 22389) (\DSPRATE 22391 . 22658) (DSPBOUT 22660 . 22814) (DISKPARTITION
 22816 . 23111) (\CHECKBCPLPASSWORD 23113 . 23292) (SUSPEND-LISP 23294 . 23552) (UNIX-USERNAME 23554
 . 24076) (UNIX-FULLNAME 24078 . 24604) (UNIX-GETENV 24606 . 25203) (UNIX-GETPARM 25205 . 26215)))))
STOP