remove files moved to history
This commit is contained in:
Larry Masinter
parent
6424116dc9
commit
84acd5861e
BIN
current/INIT
BIN
current/INIT
Binary file not shown.
Binary file not shown.
Binary file not shown.
BIN
current/INIT.~1~
BIN
current/INIT.~1~
Binary file not shown.
@ -1,219 +0,0 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
(FILECREATED "26-Apr-2018 13:24:14" {DSK}<Users>kaplan>Local>medley3.5>current>LOCAL-INIT.;41 10332
|
||||
|
||||
changes to%: (VARS LOCAL-INITCOMS)
|
||||
|
||||
previous date%: "23-Apr-2018 22:12:02" {DSK}<Users>kaplan>Local>medley3.5>current>LOCAL-INIT.;40
|
||||
)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT LOCAL-INITCOMS)
|
||||
|
||||
(RPAQQ LOCAL-INITCOMS
|
||||
[
|
||||
(* ;; "Local (Mac) system greeting file")
|
||||
|
||||
(FNS INTERLISPMODE)
|
||||
(VARS (COMPILEIGNOREDECL T)
|
||||
(MEDLEYDIR (UNIX-GETENV 'MEDLEYDIR))
|
||||
(SITE 'LOCAL-MAC))
|
||||
(P (BKSYSBUF " ")
|
||||
(* ;
|
||||
"So tty window doesn't hang during greeting")
|
||||
(INTERLISPMODE)
|
||||
(DEFCOMMAND ("show" :QUIET)
|
||||
(&REST EVENTSPEC)
|
||||
(CL:PPRINT (VALUOF EVENTSPEC T)
|
||||
T)))
|
||||
(FNS LOCAL-INIT LoadPatches COLLECT-PATCH-FILES FIXMETA)
|
||||
(P (FIXMETA))
|
||||
(FUNCTIONS WITHOUT.PAGEHOLD)
|
||||
(VARS (LISPUSERSDIRECTORIES (LIST (CONCAT MEDLEYDIR "/lispcore/lispusers")
|
||||
(CONCAT MEDLEYDIR "/lispcore/library")))
|
||||
(LISPSOURCEDIRECTORIES (LIST (CONCAT MEDLEYDIR "/lispcore/sources")))
|
||||
(DIRECTORIES (APPEND (CONS (CONCAT MEDLEYDIR "/lispcore/patches"))
|
||||
LISPUSERSDIRECTORIES LISPSOURCEDIRECTORIES))
|
||||
(LOCALPATCHDIRECTORY (CONCAT MEDLEYDIR "/lispcore/patches")))
|
||||
[VARS (USERGREETFILES '(({DSK}/Users/ USER /Lisp/INIT.LCOM)
|
||||
({DSK}/Users/ USER /Lisp/INIT.DFASLs)
|
||||
({DSK}/Users/ USER /Lisp/INIT]
|
||||
[VARS (*USEOLDFONTDIRECTORIES* NIL)
|
||||
[DISPLAYFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/lispcore/fonts/displayfonts)
|
||||
(CONCAT MEDLEYDIR '/lispcore/fonts/altofonts]
|
||||
[INTERPRESSFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/lispcore/fonts/ipfonts]
|
||||
(POSTSCRIPTFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/lispcore/fonts/postscriptfonts]
|
||||
(DECLARE%: DONTEVAL@LOAD DOCOPY (P (LOCAL-INIT)
|
||||
(* ;
|
||||
"(SETQ USERNAME (UNIX-GETENV %"USER%"))")
|
||||
)
|
||||
(* ; "To get personal greeting to work, since GREET computes the USERNAME before USERNAMEPATCH is loaded.")
|
||||
)
|
||||
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
|
||||
(NLAML)
|
||||
(LAMA])
|
||||
|
||||
|
||||
|
||||
(* ;; "Local (Mac) system greeting file")
|
||||
|
||||
(DEFINEQ
|
||||
|
||||
(INTERLISPMODE
|
||||
[LAMBDA (OLD?) (* N.H.Briggs " 2-Feb-88 14:26")
|
||||
(PROCESSPROP 'EXEC 'PROFILE (XCL:COPY-PROFILE (if OLD?
|
||||
then "OLD-INTERLISP-T"
|
||||
else "INTERLISP")))
|
||||
(XCL:SET-DEFAULT-EXEC-TYPE (if OLD?
|
||||
then "OLD-INTERLISP-T"
|
||||
else "INTERLISP"))
|
||||
(SETQ *DEFAULT-MAKEFILE-ENVIRONMENT* (LIST :READTABLE (if OLD?
|
||||
then "OLD-INTERLISP-FILE"
|
||||
else "INTERLISP")
|
||||
:PACKAGE "INTERLISP"])
|
||||
)
|
||||
|
||||
(RPAQQ COMPILEIGNOREDECL T)
|
||||
|
||||
(RPAQ MEDLEYDIR (UNIX-GETENV 'MEDLEYDIR))
|
||||
|
||||
(RPAQQ SITE LOCAL-MAC)
|
||||
|
||||
(BKSYSBUF " ")
|
||||
|
||||
(* ;
|
||||
"So tty window doesn't hang during greeting")
|
||||
|
||||
(INTERLISPMODE)
|
||||
|
||||
(DEFCOMMAND ("show" :QUIET) (&REST EVENTSPEC) (CL:PPRINT (VALUOF EVENTSPEC T)
|
||||
T))
|
||||
(DEFINEQ
|
||||
|
||||
(LOCAL-INIT
|
||||
[LAMBDA NIL
|
||||
(DECLARE (GLOBALVARS MAKESYSNAME LOCALPATCHDIRECTORY))
|
||||
(* ; "Edited 14-Jun-2017 14:45 by kaplan")
|
||||
(* ; "Edited 14-Jun-2017 11:15 by kaplan")
|
||||
|
||||
(* ;; "This is what gets called when LOCAL-INIT is loaded.")
|
||||
|
||||
(BKSYSBUF " ")
|
||||
|
||||
(* ;; "do the real work")
|
||||
|
||||
(WITHOUT.PAGEHOLD (WFROMDS (GETSTREAM T 'OUTPUT))
|
||||
(CL:WHEN LOCALPATCHDIRECTORY
|
||||
(LoadPatches LOCALPATCHDIRECTORY 'SYSLOAD MAKESYSDATE))])
|
||||
|
||||
(LoadPatches
|
||||
[LAMBDA (DIRECTORY LDFLG AFTERDATE) (* ; "Edited 7-Feb-92 11:50 by bbb")
|
||||
|
||||
(* ;;; "Load all compiled files from the directory")
|
||||
|
||||
(DECLARE (GLOBALVARS *COMPILED-EXTENSIONS*))
|
||||
(LET [(files (SORT (for EXT in *COMPILED-EXTENSIONS*
|
||||
bind (AFTERIDATE _ (if AFTERDATE
|
||||
then (OR (IDATE AFTERDATE)
|
||||
0)
|
||||
else 0)) join (COLLECT-PATCH-FILES
|
||||
(DIRECTORYNAME DIRECTORY)
|
||||
EXT AFTERIDATE))
|
||||
(FUNCTION (LAMBDA (X Y)
|
||||
(LESSP (CDR X)
|
||||
(CDR Y] (* ;
|
||||
"files are sorted by increasing date")
|
||||
(for file in files do (SELECTQ LDFLG
|
||||
(HIDDEN (* ;
|
||||
"Load the file, but don't put it on FILELST")
|
||||
(LOAD? (CAR file)
|
||||
T)
|
||||
(SETQ FILELST (DREMOVE (FILENAMEFIELD
|
||||
(CAR file)
|
||||
'NAME)
|
||||
FILELST)))
|
||||
(LOAD? (CAR file)
|
||||
LDFLG)))
|
||||
files])
|
||||
|
||||
(COLLECT-PATCH-FILES
|
||||
[LAMBDA (DIRECTORY EXT AFTERIDATE) (* ; "Edited 7-Feb-92 11:49 by bbb")
|
||||
|
||||
(* ;; "Generate list of files in DIRECTORY with extension EXT more recent than idate AFTERIDATE. Return list of pairs (file . date). Omits subdirectories.")
|
||||
|
||||
(RESETLST
|
||||
(LET ((FILING.ENUMERATION.DEPTH 1)
|
||||
(NAKED-DIR (UNPACKFILENAME.STRING DIRECTORY 'DIRECTORY))
|
||||
FILE DATE)
|
||||
(bind [GEN _ (\GENERATEFILES (CONCAT DIRECTORY "*." EXT ";")
|
||||
'(ICREATIONDATE)
|
||||
'(SORT RESETLST] while (SETQ FILE (\GENERATENEXTFILE GEN))
|
||||
when (AND (STRING-EQUAL (UNPACKFILENAME.STRING FILE 'DIRECTORY)
|
||||
NAKED-DIR)
|
||||
(> (SETQ DATE (\GENERATEFILEINFO GEN 'ICREATIONDATE))
|
||||
AFTERIDATE)) collect (CONS FILE DATE))))])
|
||||
|
||||
(FIXMETA
|
||||
[LAMBDA NIL (* ; "Edited 25-Jun-2017 17:12 by rmk:")
|
||||
(KEYACTION 'BLANK-TOP '(METADOWN . METAUP)
|
||||
\CURRENTKEYACTION)
|
||||
(KEYACTION 'BLANK-TOP '(METADOWN . METAUP])
|
||||
)
|
||||
|
||||
(FIXMETA)
|
||||
|
||||
(DEFMACRO WITHOUT.PAGEHOLD (WINDOW &BODY FORMS)
|
||||
`(RESETLST
|
||||
(LET* ((TTYWINDOW ,WINDOW)
|
||||
(ORIGINAL.PAGEFULLFN (WINDOWPROP TTYWINDOW 'PAGEFULLFN))
|
||||
(NEW.PAGEFULLFN (FUNCTION NILL)))
|
||||
(RESETSAVE (WINDOWPROP TTYWINDOW 'PAGEFULLFN NEW.PAGEFULLFN)
|
||||
(LIST [FUNCTION (LAMBDA (TTYWINDOW NEW.PAGEFULLFN ORIGINAL.PAGEFULLFN)
|
||||
(COND
|
||||
((EQ (WINDOWPROP TTYWINDOW 'PAGEFULLFN)
|
||||
NEW.PAGEFULLFN)
|
||||
(WINDOWPROP TTYWINDOW 'PAGEFULLFN ORIGINAL.PAGEFULLFN]
|
||||
TTYWINDOW NEW.PAGEFULLFN ORIGINAL.PAGEFULLFN)))
|
||||
,@FORMS))
|
||||
|
||||
(RPAQ LISPUSERSDIRECTORIES (LIST (CONCAT MEDLEYDIR "/lispcore/lispusers")
|
||||
(CONCAT MEDLEYDIR "/lispcore/library")))
|
||||
|
||||
(RPAQ LISPSOURCEDIRECTORIES (LIST (CONCAT MEDLEYDIR "/lispcore/sources")))
|
||||
|
||||
(RPAQ DIRECTORIES (APPEND (CONS (CONCAT MEDLEYDIR "/lispcore/patches"))
|
||||
LISPUSERSDIRECTORIES LISPSOURCEDIRECTORIES))
|
||||
|
||||
(RPAQ LOCALPATCHDIRECTORY (CONCAT MEDLEYDIR "/lispcore/patches"))
|
||||
|
||||
(RPAQQ USERGREETFILES (({DSK}/Users/ USER /Lisp/INIT.LCOM)
|
||||
({DSK}/Users/ USER /Lisp/INIT.DFASLs)
|
||||
({DSK}/Users/ USER /Lisp/INIT)))
|
||||
|
||||
(RPAQQ *USEOLDFONTDIRECTORIES* NIL)
|
||||
|
||||
(RPAQ DISPLAYFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/lispcore/fonts/displayfonts)
|
||||
(CONCAT MEDLEYDIR '/lispcore/fonts/altofonts)))
|
||||
|
||||
(RPAQ INTERPRESSFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/lispcore/fonts/ipfonts)))
|
||||
|
||||
(RPAQ POSTSCRIPTFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/lispcore/fonts/postscriptfonts)))
|
||||
(DECLARE%: DONTEVAL@LOAD DOCOPY
|
||||
|
||||
(LOCAL-INIT)
|
||||
|
||||
(* ;
|
||||
"(SETQ USERNAME (UNIX-GETENV %"USER%"))")
|
||||
)
|
||||
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
|
||||
|
||||
(ADDTOVAR NLAMA )
|
||||
|
||||
(ADDTOVAR NLAML )
|
||||
|
||||
(ADDTOVAR LAMA )
|
||||
)
|
||||
(PUTPROPS LOCAL-INIT COPYRIGHT (NONE))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (2990 3815 (INTERLISPMODE 3000 . 3813)) (4274 8070 (LOCAL-INIT 4284 . 4895) (LoadPatches
|
||||
4897 . 6845) (COLLECT-PATCH-FILES 6847 . 7824) (FIXMETA 7826 . 8068)))))
|
||||
STOP
|
||||
Binary file not shown.
Binary file not shown.
@ -1,55 +0,0 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "22-Jun-2017 22:48:46" {DSK}<Volumes>Personal>local>medley3.5>current>LOCAL-INIT.;32 9225
changes to%: (VARS LOCAL-INITCOMS)
previous date%: "15-Jun-2017 22:06:37"
{DSK}<Volumes>Personal>local>medley3.5>current>LOCAL-INIT.;31)
(PRETTYCOMPRINT LOCAL-INITCOMS)
(RPAQQ LOCAL-INITCOMS
[
(* ;; "Local (Mac) system greeting file")
(FNS INTERLISPMODE)
(VARS (COMPILEIGNOREDECL T)
(MEDLEYDIR (UNIX-GETENV 'MEDLEYDIR))
(SITE 'LOCAL-MAC))
(P (BKSYSBUF " ")
(* ;
"So tty window doesn't hang during greeting")
(KEYACTION 'BLANK-TOP '(METADOWN . METAUP)
\CURRENTKEYACTION)
(KEYACTION 'BLANK-TOP '(METADOWN . METAUP))
(INTERLISPMODE)
(DEFCOMMAND ("show" :QUIET)
(&REST EVENTSPEC)
(CL:PPRINT (VALUOF EVENTSPEC T)
T)))
(FNS LOCAL-INIT LoadPatches COLLECT-PATCH-FILES)
(FUNCTIONS WITHOUT.PAGEHOLD)
(VARS (LISPUSERSDIRECTORIES (LIST (CONCAT MEDLEYDIR "/lispusers")
(CONCAT MEDLEYDIR "/library")))
(LISPSOURCEDIRECTORIES (LIST (CONCAT MEDLEYDIR "/sources")))
(DIRECTORIES (APPEND LISPUSERSDIRECTORIES LISPSOURCEDIRECTORIES))
(LOCALPATCHDIRECTORY (CONCAT MEDLEYDIR "/patches")))
[VARS (USERGREETFILES '(({DSK}/Users/ USER /Lisp/INIT.LCOM)
({DSK}/Users/ USER /Lisp/INIT.DFASLs)
({DSK}/Users/ USER /Lisp/INIT]
[VARS (*USEOLDFONTDIRECTORIES* NIL)
(DISPLAYFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/displayfonts]
(DECLARE%: DONTEVAL@LOAD DOCOPY (P (LOCAL-INIT)
(SETQ USERNAME (UNIX-GETENV "USER")))
(* ; "To get personal greeting to work, since GREET computes the USERNAME before USERNAMEPATCH is loaded.")
)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML)
(LAMA])
(* ;; "Local (Mac) system greeting file")
(DEFINEQ
(INTERLISPMODE
|
||||
[LAMBDA (OLD?) (* N.H.Briggs " 2-Feb-88 14:26")
|
||||
(PROCESSPROP 'EXEC 'PROFILE (XCL:COPY-PROFILE (if OLD?
|
||||
then "OLD-INTERLISP-T"
|
||||
else "INTERLISP")))
|
||||
(XCL:SET-DEFAULT-EXEC-TYPE (if OLD?
|
||||
then "OLD-INTERLISP-T"
|
||||
else "INTERLISP"))
|
||||
(SETQ *DEFAULT-MAKEFILE-ENVIRONMENT* (LIST :READTABLE (if OLD?
|
||||
then "OLD-INTERLISP-FILE"
|
||||
else "INTERLISP")
|
||||
:PACKAGE "INTERLISP"])
)
(RPAQQ COMPILEIGNOREDECL T)
(RPAQ MEDLEYDIR (UNIX-GETENV 'MEDLEYDIR))
(RPAQQ SITE LOCAL-MAC)
(BKSYSBUF " ")
(* ;
"So tty window doesn't hang during greeting")
(KEYACTION 'BLANK-TOP '(METADOWN . METAUP)
\CURRENTKEYACTION)
(KEYACTION 'BLANK-TOP '(METADOWN . METAUP))
(INTERLISPMODE)
(DEFCOMMAND ("show" :QUIET) (&REST EVENTSPEC) (CL:PPRINT (VALUOF EVENTSPEC T)
T))
(DEFINEQ
(LOCAL-INIT
[LAMBDA NIL
(DECLARE (GLOBALVARS MAKESYSNAME LOCALPATCHDIRECTORY))
(* ; "Edited 14-Jun-2017 14:45 by kaplan")
(* ; "Edited 14-Jun-2017 11:15 by kaplan")
(* ;; "This is what gets called when LOCAL-INIT is loaded.")
(BKSYSBUF " ")
(* ;; "do the real work")
(WITHOUT.PAGEHOLD (WFROMDS (GETSTREAM T 'OUTPUT))
(CL:WHEN LOCALPATCHDIRECTORY
(LoadPatches LOCALPATCHDIRECTORY 'SYSLOAD MAKESYSDATE))])
(LoadPatches
|
||||
[LAMBDA (DIRECTORY LDFLG AFTERDATE) (* ; "Edited 7-Feb-92 11:50 by bbb")
|
||||
|
||||
(* ;;; "Load all compiled files from the directory")
|
||||
|
||||
(DECLARE (GLOBALVARS *COMPILED-EXTENSIONS*))
|
||||
(LET [(files (SORT (for EXT in *COMPILED-EXTENSIONS*
|
||||
bind (AFTERIDATE _ (if AFTERDATE
|
||||
then (OR (IDATE AFTERDATE)
|
||||
0)
|
||||
else 0)) join (COLLECT-PATCH-FILES
|
||||
(DIRECTORYNAME DIRECTORY)
|
||||
EXT AFTERIDATE))
|
||||
(FUNCTION (LAMBDA (X Y)
|
||||
(LESSP (CDR X)
|
||||
(CDR Y] (* ;
|
||||
"files are sorted by increasing date")
|
||||
(for file in files do (SELECTQ LDFLG
|
||||
(HIDDEN (* ;
|
||||
"Load the file, but don't put it on FILELST")
|
||||
(LOAD? (CAR file)
|
||||
T)
|
||||
(SETQ FILELST (DREMOVE (FILENAMEFIELD
|
||||
(CAR file)
|
||||
'NAME)
|
||||
FILELST)))
|
||||
(LOAD? (CAR file)
|
||||
LDFLG)))
|
||||
files])
(COLLECT-PATCH-FILES
|
||||
[LAMBDA (DIRECTORY EXT AFTERIDATE) (* ; "Edited 7-Feb-92 11:49 by bbb")
|
||||
|
||||
(* ;; "Generate list of files in DIRECTORY with extension EXT more recent than idate AFTERIDATE. Return list of pairs (file . date). Omits subdirectories.")
|
||||
|
||||
(RESETLST
|
||||
(LET ((FILING.ENUMERATION.DEPTH 1)
|
||||
(NAKED-DIR (UNPACKFILENAME.STRING DIRECTORY 'DIRECTORY))
|
||||
FILE DATE)
|
||||
(bind [GEN _ (\GENERATEFILES (CONCAT DIRECTORY "*." EXT ";")
|
||||
'(ICREATIONDATE)
|
||||
'(SORT RESETLST] while (SETQ FILE (\GENERATENEXTFILE GEN))
|
||||
when (AND (STRING-EQUAL (UNPACKFILENAME.STRING FILE 'DIRECTORY)
|
||||
NAKED-DIR)
|
||||
(> (SETQ DATE (\GENERATEFILEINFO GEN 'ICREATIONDATE))
|
||||
AFTERIDATE)) collect (CONS FILE DATE))))])
)
(DEFMACRO WITHOUT.PAGEHOLD (WINDOW &BODY FORMS)
`(RESETLST
(LET* ((TTYWINDOW ,WINDOW)
(ORIGINAL.PAGEFULLFN (WINDOWPROP TTYWINDOW 'PAGEFULLFN))
(NEW.PAGEFULLFN (FUNCTION NILL)))
(RESETSAVE (WINDOWPROP TTYWINDOW 'PAGEFULLFN NEW.PAGEFULLFN)
(LIST [FUNCTION (LAMBDA (TTYWINDOW NEW.PAGEFULLFN ORIGINAL.PAGEFULLFN)
(COND
((EQ (WINDOWPROP TTYWINDOW 'PAGEFULLFN)
NEW.PAGEFULLFN)
(WINDOWPROP TTYWINDOW 'PAGEFULLFN ORIGINAL.PAGEFULLFN]
TTYWINDOW NEW.PAGEFULLFN ORIGINAL.PAGEFULLFN)))
,@FORMS))
(RPAQ LISPUSERSDIRECTORIES (LIST (CONCAT MEDLEYDIR "/lispusers")
(CONCAT MEDLEYDIR "/library")))
(RPAQ LISPSOURCEDIRECTORIES (LIST (CONCAT MEDLEYDIR "/sources")))
(RPAQ DIRECTORIES (APPEND LISPUSERSDIRECTORIES LISPSOURCEDIRECTORIES))
(RPAQ LOCALPATCHDIRECTORY (CONCAT MEDLEYDIR "/patches"))
(RPAQQ USERGREETFILES (({DSK}/Users/ USER /Lisp/INIT.LCOM)
({DSK}/Users/ USER /Lisp/INIT.DFASLs)
({DSK}/Users/ USER /Lisp/INIT)))
(RPAQQ *USEOLDFONTDIRECTORIES* NIL)
(RPAQ DISPLAYFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/displayfonts)))
(DECLARE%: DONTEVAL@LOAD DOCOPY
(LOCAL-INIT)
(SETQ USERNAME (UNIX-GETENV "USER"))
)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA )
)
(PUTPROPS LOCAL-INIT COPYRIGHT (NONE))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (2563 3388 (INTERLISPMODE 2573 . 3386)) (3962 7514 (LOCAL-INIT 3972 . 4583) (LoadPatches
4585 . 6533) (COLLECT-PATCH-FILES 6535 . 7512)))))
STOP
|
||||
@ -1,55 +0,0 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED " 2-Jul-2017 17:13:31" {DSK}<Volumes>Personal>local>medley3.5>current>LOCAL-INIT.;36 9762
changes to%: (VARS LOCAL-INITCOMS)
previous date%: "26-Jun-2017 13:36:35"
{DSK}<Volumes>Personal>local>medley3.5>current>LOCAL-INIT.;35)
(PRETTYCOMPRINT LOCAL-INITCOMS)
(RPAQQ LOCAL-INITCOMS
[
(* ;; "Local (Mac) system greeting file")
(FNS INTERLISPMODE)
(VARS (COMPILEIGNOREDECL T)
(MEDLEYDIR (UNIX-GETENV 'MEDLEYDIR))
(SITE 'LOCAL-MAC))
(P (BKSYSBUF " ")
(* ;
"So tty window doesn't hang during greeting")
(INTERLISPMODE)
(DEFCOMMAND ("show" :QUIET)
(&REST EVENTSPEC)
(CL:PPRINT (VALUOF EVENTSPEC T)
T)))
(FNS LOCAL-INIT LoadPatches COLLECT-PATCH-FILES FIXMETA)
(P (FIXMETA))
(FUNCTIONS WITHOUT.PAGEHOLD)
(VARS (LISPUSERSDIRECTORIES (LIST (CONCAT MEDLEYDIR "/lispusers")
(CONCAT MEDLEYDIR "/library")))
(LISPSOURCEDIRECTORIES (LIST (CONCAT MEDLEYDIR "/sources")))
(DIRECTORIES (APPEND LISPUSERSDIRECTORIES LISPSOURCEDIRECTORIES))
(LOCALPATCHDIRECTORY (CONCAT MEDLEYDIR "/patches")))
[VARS (USERGREETFILES '(({DSK}/Users/ USER /Lisp/INIT.LCOM)
({DSK}/Users/ USER /Lisp/INIT.DFASLs)
({DSK}/Users/ USER /Lisp/INIT]
[VARS (*USEOLDFONTDIRECTORIES* NIL)
[DISPLAYFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/fonts/displayfonts)
(CONCAT MEDLEYDIR '/fonts/altofonts]
[INTERPRESSFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/fonts/ipfonts]
(POSTSCRIPTFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/fonts/postscriptfonts]
(DECLARE%: DONTEVAL@LOAD DOCOPY (P (LOCAL-INIT)
(SETQ USERNAME (UNIX-GETENV "USER")))
(* ; "To get personal greeting to work, since GREET computes the USERNAME before USERNAMEPATCH is loaded.")
)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML)
(LAMA])
(* ;; "Local (Mac) system greeting file")
(DEFINEQ
(INTERLISPMODE
|
||||
[LAMBDA (OLD?) (* N.H.Briggs " 2-Feb-88 14:26")
|
||||
(PROCESSPROP 'EXEC 'PROFILE (XCL:COPY-PROFILE (if OLD?
|
||||
then "OLD-INTERLISP-T"
|
||||
else "INTERLISP")))
|
||||
(XCL:SET-DEFAULT-EXEC-TYPE (if OLD?
|
||||
then "OLD-INTERLISP-T"
|
||||
else "INTERLISP"))
|
||||
(SETQ *DEFAULT-MAKEFILE-ENVIRONMENT* (LIST :READTABLE (if OLD?
|
||||
then "OLD-INTERLISP-FILE"
|
||||
else "INTERLISP")
|
||||
:PACKAGE "INTERLISP"])
)
(RPAQQ COMPILEIGNOREDECL T)
(RPAQ MEDLEYDIR (UNIX-GETENV 'MEDLEYDIR))
(RPAQQ SITE LOCAL-MAC)
(BKSYSBUF " ")
(* ;
"So tty window doesn't hang during greeting")
(INTERLISPMODE)
(DEFCOMMAND ("show" :QUIET) (&REST EVENTSPEC) (CL:PPRINT (VALUOF EVENTSPEC T)
T))
(DEFINEQ
(LOCAL-INIT
[LAMBDA NIL
(DECLARE (GLOBALVARS MAKESYSNAME LOCALPATCHDIRECTORY))
(* ; "Edited 14-Jun-2017 14:45 by kaplan")
(* ; "Edited 14-Jun-2017 11:15 by kaplan")
(* ;; "This is what gets called when LOCAL-INIT is loaded.")
(BKSYSBUF " ")
(* ;; "do the real work")
(WITHOUT.PAGEHOLD (WFROMDS (GETSTREAM T 'OUTPUT))
(CL:WHEN LOCALPATCHDIRECTORY
(LoadPatches LOCALPATCHDIRECTORY 'SYSLOAD MAKESYSDATE))])
(LoadPatches
|
||||
[LAMBDA (DIRECTORY LDFLG AFTERDATE) (* ; "Edited 7-Feb-92 11:50 by bbb")
|
||||
|
||||
(* ;;; "Load all compiled files from the directory")
|
||||
|
||||
(DECLARE (GLOBALVARS *COMPILED-EXTENSIONS*))
|
||||
(LET [(files (SORT (for EXT in *COMPILED-EXTENSIONS*
|
||||
bind (AFTERIDATE _ (if AFTERDATE
|
||||
then (OR (IDATE AFTERDATE)
|
||||
0)
|
||||
else 0)) join (COLLECT-PATCH-FILES
|
||||
(DIRECTORYNAME DIRECTORY)
|
||||
EXT AFTERIDATE))
|
||||
(FUNCTION (LAMBDA (X Y)
|
||||
(LESSP (CDR X)
|
||||
(CDR Y] (* ;
|
||||
"files are sorted by increasing date")
|
||||
(for file in files do (SELECTQ LDFLG
|
||||
(HIDDEN (* ;
|
||||
"Load the file, but don't put it on FILELST")
|
||||
(LOAD? (CAR file)
|
||||
T)
|
||||
(SETQ FILELST (DREMOVE (FILENAMEFIELD
|
||||
(CAR file)
|
||||
'NAME)
|
||||
FILELST)))
|
||||
(LOAD? (CAR file)
|
||||
LDFLG)))
|
||||
files])
(COLLECT-PATCH-FILES
|
||||
[LAMBDA (DIRECTORY EXT AFTERIDATE) (* ; "Edited 7-Feb-92 11:49 by bbb")
|
||||
|
||||
(* ;; "Generate list of files in DIRECTORY with extension EXT more recent than idate AFTERIDATE. Return list of pairs (file . date). Omits subdirectories.")
|
||||
|
||||
(RESETLST
|
||||
(LET ((FILING.ENUMERATION.DEPTH 1)
|
||||
(NAKED-DIR (UNPACKFILENAME.STRING DIRECTORY 'DIRECTORY))
|
||||
FILE DATE)
|
||||
(bind [GEN _ (\GENERATEFILES (CONCAT DIRECTORY "*." EXT ";")
|
||||
'(ICREATIONDATE)
|
||||
'(SORT RESETLST] while (SETQ FILE (\GENERATENEXTFILE GEN))
|
||||
when (AND (STRING-EQUAL (UNPACKFILENAME.STRING FILE 'DIRECTORY)
|
||||
NAKED-DIR)
|
||||
(> (SETQ DATE (\GENERATEFILEINFO GEN 'ICREATIONDATE))
|
||||
AFTERIDATE)) collect (CONS FILE DATE))))])
(FIXMETA
[LAMBDA NIL (* ; "Edited 25-Jun-2017 17:12 by rmk:")
(KEYACTION 'BLANK-TOP '(METADOWN . METAUP)
\CURRENTKEYACTION)
(KEYACTION 'BLANK-TOP '(METADOWN . METAUP])
)
(FIXMETA)
(DEFMACRO WITHOUT.PAGEHOLD (WINDOW &BODY FORMS)
`(RESETLST
(LET* ((TTYWINDOW ,WINDOW)
(ORIGINAL.PAGEFULLFN (WINDOWPROP TTYWINDOW 'PAGEFULLFN))
(NEW.PAGEFULLFN (FUNCTION NILL)))
(RESETSAVE (WINDOWPROP TTYWINDOW 'PAGEFULLFN NEW.PAGEFULLFN)
(LIST [FUNCTION (LAMBDA (TTYWINDOW NEW.PAGEFULLFN ORIGINAL.PAGEFULLFN)
(COND
((EQ (WINDOWPROP TTYWINDOW 'PAGEFULLFN)
NEW.PAGEFULLFN)
(WINDOWPROP TTYWINDOW 'PAGEFULLFN ORIGINAL.PAGEFULLFN]
TTYWINDOW NEW.PAGEFULLFN ORIGINAL.PAGEFULLFN)))
,@FORMS))
(RPAQ LISPUSERSDIRECTORIES (LIST (CONCAT MEDLEYDIR "/lispusers")
(CONCAT MEDLEYDIR "/library")))
(RPAQ LISPSOURCEDIRECTORIES (LIST (CONCAT MEDLEYDIR "/sources")))
(RPAQ DIRECTORIES (APPEND LISPUSERSDIRECTORIES LISPSOURCEDIRECTORIES))
(RPAQ LOCALPATCHDIRECTORY (CONCAT MEDLEYDIR "/patches"))
(RPAQQ USERGREETFILES (({DSK}/Users/ USER /Lisp/INIT.LCOM)
({DSK}/Users/ USER /Lisp/INIT.DFASLs)
({DSK}/Users/ USER /Lisp/INIT)))
(RPAQQ *USEOLDFONTDIRECTORIES* NIL)
(RPAQ DISPLAYFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/fonts/displayfonts)
(CONCAT MEDLEYDIR '/fonts/altofonts)))
(RPAQ INTERPRESSFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/fonts/ipfonts)))
(RPAQ POSTSCRIPTFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/fonts/postscriptfonts)))
(DECLARE%: DONTEVAL@LOAD DOCOPY
(LOCAL-INIT)
(SETQ USERNAME (UNIX-GETENV "USER"))
)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA )
)
(PUTPROPS LOCAL-INIT COPYRIGHT (NONE))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (2706 3531 (INTERLISPMODE 2716 . 3529)) (3990 7786 (LOCAL-INIT 4000 . 4611) (LoadPatches
4613 . 6561) (COLLECT-PATCH-FILES 6563 . 7540) (FIXMETA 7542 . 7784)))))
STOP
|
||||
@ -1,55 +0,0 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED " 4-Apr-2018 11:06:31" {DSK}<Users>kaplan>Local>medley3.5>current>LOCAL-INIT.;39 10035
changes to%: (VARS LOCAL-INITCOMS)
previous date%: "27-Mar-2018 07:18:26" {DSK}<Users>kaplan>Local>medley3.5>current>LOCAL-INIT.;38
)
(PRETTYCOMPRINT LOCAL-INITCOMS)
(RPAQQ LOCAL-INITCOMS
[
(* ;; "Local (Mac) system greeting file")
(FNS INTERLISPMODE)
(VARS (COMPILEIGNOREDECL T)
(MEDLEYDIR (UNIX-GETENV 'MEDLEYDIR))
(SITE 'LOCAL-MAC))
(P (BKSYSBUF " ")
(* ;
"So tty window doesn't hang during greeting")
(INTERLISPMODE)
(DEFCOMMAND ("show" :QUIET)
(&REST EVENTSPEC)
(CL:PPRINT (VALUOF EVENTSPEC T)
T)))
(FNS LOCAL-INIT LoadPatches COLLECT-PATCH-FILES FIXMETA)
(P (FIXMETA))
(FUNCTIONS WITHOUT.PAGEHOLD)
(VARS (LISPUSERSDIRECTORIES (LIST (CONCAT MEDLEYDIR "/lispcore/lispusers")
(CONCAT MEDLEYDIR "/lispcore/library")))
(LISPSOURCEDIRECTORIES (LIST (CONCAT MEDLEYDIR "/lispcore/sources")))
(DIRECTORIES (APPEND (CONS (CONCAT MEDLEYDIR "/lispcore/patches"))
LISPUSERSDIRECTORIES LISPSOURCEDIRECTORIES))
(LOCALPATCHDIRECTORY (CONCAT MEDLEYDIR "/patches")))
[VARS (USERGREETFILES '(({DSK}/Users/ USER /Lisp/INIT.LCOM)
({DSK}/Users/ USER /Lisp/INIT.DFASLs)
({DSK}/Users/ USER /Lisp/INIT]
[VARS (*USEOLDFONTDIRECTORIES* NIL)
[DISPLAYFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/lispcore/fonts/displayfonts)
(CONCAT MEDLEYDIR '/lispcore/fonts/altofonts]
[INTERPRESSFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/lispcore/fonts/ipfonts]
(POSTSCRIPTFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/lispcore/fonts/postscriptfonts]
(DECLARE%: DONTEVAL@LOAD DOCOPY (P (LOCAL-INIT)
(SETQ USERNAME (UNIX-GETENV "USER")))
(* ; "To get personal greeting to work, since GREET computes the USERNAME before USERNAMEPATCH is loaded.")
)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML)
(LAMA])
(* ;; "Local (Mac) system greeting file")
(DEFINEQ
(INTERLISPMODE
|
||||
[LAMBDA (OLD?) (* N.H.Briggs " 2-Feb-88 14:26")
|
||||
(PROCESSPROP 'EXEC 'PROFILE (XCL:COPY-PROFILE (if OLD?
|
||||
then "OLD-INTERLISP-T"
|
||||
else "INTERLISP")))
|
||||
(XCL:SET-DEFAULT-EXEC-TYPE (if OLD?
|
||||
then "OLD-INTERLISP-T"
|
||||
else "INTERLISP"))
|
||||
(SETQ *DEFAULT-MAKEFILE-ENVIRONMENT* (LIST :READTABLE (if OLD?
|
||||
then "OLD-INTERLISP-FILE"
|
||||
else "INTERLISP")
|
||||
:PACKAGE "INTERLISP"])
)
(RPAQQ COMPILEIGNOREDECL T)
(RPAQ MEDLEYDIR (UNIX-GETENV 'MEDLEYDIR))
(RPAQQ SITE LOCAL-MAC)
(BKSYSBUF " ")
(* ;
"So tty window doesn't hang during greeting")
(INTERLISPMODE)
(DEFCOMMAND ("show" :QUIET) (&REST EVENTSPEC) (CL:PPRINT (VALUOF EVENTSPEC T)
T))
(DEFINEQ
(LOCAL-INIT
[LAMBDA NIL
(DECLARE (GLOBALVARS MAKESYSNAME LOCALPATCHDIRECTORY))
(* ; "Edited 14-Jun-2017 14:45 by kaplan")
(* ; "Edited 14-Jun-2017 11:15 by kaplan")
(* ;; "This is what gets called when LOCAL-INIT is loaded.")
(BKSYSBUF " ")
(* ;; "do the real work")
(WITHOUT.PAGEHOLD (WFROMDS (GETSTREAM T 'OUTPUT))
(CL:WHEN LOCALPATCHDIRECTORY
(LoadPatches LOCALPATCHDIRECTORY 'SYSLOAD MAKESYSDATE))])
(LoadPatches
|
||||
[LAMBDA (DIRECTORY LDFLG AFTERDATE) (* ; "Edited 7-Feb-92 11:50 by bbb")
|
||||
|
||||
(* ;;; "Load all compiled files from the directory")
|
||||
|
||||
(DECLARE (GLOBALVARS *COMPILED-EXTENSIONS*))
|
||||
(LET [(files (SORT (for EXT in *COMPILED-EXTENSIONS*
|
||||
bind (AFTERIDATE _ (if AFTERDATE
|
||||
then (OR (IDATE AFTERDATE)
|
||||
0)
|
||||
else 0)) join (COLLECT-PATCH-FILES
|
||||
(DIRECTORYNAME DIRECTORY)
|
||||
EXT AFTERIDATE))
|
||||
(FUNCTION (LAMBDA (X Y)
|
||||
(LESSP (CDR X)
|
||||
(CDR Y] (* ;
|
||||
"files are sorted by increasing date")
|
||||
(for file in files do (SELECTQ LDFLG
|
||||
(HIDDEN (* ;
|
||||
"Load the file, but don't put it on FILELST")
|
||||
(LOAD? (CAR file)
|
||||
T)
|
||||
(SETQ FILELST (DREMOVE (FILENAMEFIELD
|
||||
(CAR file)
|
||||
'NAME)
|
||||
FILELST)))
|
||||
(LOAD? (CAR file)
|
||||
LDFLG)))
|
||||
files])
(COLLECT-PATCH-FILES
|
||||
[LAMBDA (DIRECTORY EXT AFTERIDATE) (* ; "Edited 7-Feb-92 11:49 by bbb")
|
||||
|
||||
(* ;; "Generate list of files in DIRECTORY with extension EXT more recent than idate AFTERIDATE. Return list of pairs (file . date). Omits subdirectories.")
|
||||
|
||||
(RESETLST
|
||||
(LET ((FILING.ENUMERATION.DEPTH 1)
|
||||
(NAKED-DIR (UNPACKFILENAME.STRING DIRECTORY 'DIRECTORY))
|
||||
FILE DATE)
|
||||
(bind [GEN _ (\GENERATEFILES (CONCAT DIRECTORY "*." EXT ";")
|
||||
'(ICREATIONDATE)
|
||||
'(SORT RESETLST] while (SETQ FILE (\GENERATENEXTFILE GEN))
|
||||
when (AND (STRING-EQUAL (UNPACKFILENAME.STRING FILE 'DIRECTORY)
|
||||
NAKED-DIR)
|
||||
(> (SETQ DATE (\GENERATEFILEINFO GEN 'ICREATIONDATE))
|
||||
AFTERIDATE)) collect (CONS FILE DATE))))])
(FIXMETA
[LAMBDA NIL (* ; "Edited 25-Jun-2017 17:12 by rmk:")
(KEYACTION 'BLANK-TOP '(METADOWN . METAUP)
\CURRENTKEYACTION)
(KEYACTION 'BLANK-TOP '(METADOWN . METAUP])
)
(FIXMETA)
(DEFMACRO WITHOUT.PAGEHOLD (WINDOW &BODY FORMS)
`(RESETLST
(LET* ((TTYWINDOW ,WINDOW)
(ORIGINAL.PAGEFULLFN (WINDOWPROP TTYWINDOW 'PAGEFULLFN))
(NEW.PAGEFULLFN (FUNCTION NILL)))
(RESETSAVE (WINDOWPROP TTYWINDOW 'PAGEFULLFN NEW.PAGEFULLFN)
(LIST [FUNCTION (LAMBDA (TTYWINDOW NEW.PAGEFULLFN ORIGINAL.PAGEFULLFN)
(COND
((EQ (WINDOWPROP TTYWINDOW 'PAGEFULLFN)
NEW.PAGEFULLFN)
(WINDOWPROP TTYWINDOW 'PAGEFULLFN ORIGINAL.PAGEFULLFN]
TTYWINDOW NEW.PAGEFULLFN ORIGINAL.PAGEFULLFN)))
,@FORMS))
(RPAQ LISPUSERSDIRECTORIES (LIST (CONCAT MEDLEYDIR "/lispcore/lispusers")
(CONCAT MEDLEYDIR "/lispcore/library")))
(RPAQ LISPSOURCEDIRECTORIES (LIST (CONCAT MEDLEYDIR "/lispcore/sources")))
(RPAQ DIRECTORIES (APPEND (CONS (CONCAT MEDLEYDIR "/lispcore/patches"))
LISPUSERSDIRECTORIES LISPSOURCEDIRECTORIES))
(RPAQ LOCALPATCHDIRECTORY (CONCAT MEDLEYDIR "/patches"))
(RPAQQ USERGREETFILES (({DSK}/Users/ USER /Lisp/INIT.LCOM)
({DSK}/Users/ USER /Lisp/INIT.DFASLs)
({DSK}/Users/ USER /Lisp/INIT)))
(RPAQQ *USEOLDFONTDIRECTORIES* NIL)
(RPAQ DISPLAYFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/lispcore/fonts/displayfonts)
(CONCAT MEDLEYDIR '/lispcore/fonts/altofonts)))
(RPAQ INTERPRESSFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/lispcore/fonts/ipfonts)))
(RPAQ POSTSCRIPTFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/lispcore/fonts/postscriptfonts)))
(DECLARE%: DONTEVAL@LOAD DOCOPY
(LOCAL-INIT)
(SETQ USERNAME (UNIX-GETENV "USER"))
)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA )
)
(PUTPROPS LOCAL-INIT COPYRIGHT (NONE))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (2841 3666 (INTERLISPMODE 2851 . 3664)) (4125 7921 (LOCAL-INIT 4135 . 4746) (LoadPatches
4748 . 6696) (COLLECT-PATCH-FILES 6698 . 7675) (FIXMETA 7677 . 7919)))))
STOP
|
||||
@ -1,55 +0,0 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "26-Apr-2018 13:24:14" {DSK}<Users>kaplan>Local>medley3.5>current>LOCAL-INIT.;41 10332
changes to%: (VARS LOCAL-INITCOMS)
previous date%: "23-Apr-2018 22:12:02" {DSK}<Users>kaplan>Local>medley3.5>current>LOCAL-INIT.;40
)
(PRETTYCOMPRINT LOCAL-INITCOMS)
(RPAQQ LOCAL-INITCOMS
[
(* ;; "Local (Mac) system greeting file")
(FNS INTERLISPMODE)
(VARS (COMPILEIGNOREDECL T)
(MEDLEYDIR (UNIX-GETENV 'MEDLEYDIR))
(SITE 'LOCAL-MAC))
(P (BKSYSBUF " ")
(* ;
"So tty window doesn't hang during greeting")
(INTERLISPMODE)
(DEFCOMMAND ("show" :QUIET)
(&REST EVENTSPEC)
(CL:PPRINT (VALUOF EVENTSPEC T)
T)))
(FNS LOCAL-INIT LoadPatches COLLECT-PATCH-FILES FIXMETA)
(P (FIXMETA))
(FUNCTIONS WITHOUT.PAGEHOLD)
(VARS (LISPUSERSDIRECTORIES (LIST (CONCAT MEDLEYDIR "/lispcore/lispusers")
(CONCAT MEDLEYDIR "/lispcore/library")))
(LISPSOURCEDIRECTORIES (LIST (CONCAT MEDLEYDIR "/lispcore/sources")))
(DIRECTORIES (APPEND (CONS (CONCAT MEDLEYDIR "/lispcore/patches"))
LISPUSERSDIRECTORIES LISPSOURCEDIRECTORIES))
(LOCALPATCHDIRECTORY (CONCAT MEDLEYDIR "/lispcore/patches")))
[VARS (USERGREETFILES '(({DSK}/Users/ USER /Lisp/INIT.LCOM)
({DSK}/Users/ USER /Lisp/INIT.DFASLs)
({DSK}/Users/ USER /Lisp/INIT]
[VARS (*USEOLDFONTDIRECTORIES* NIL)
[DISPLAYFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/lispcore/fonts/displayfonts)
(CONCAT MEDLEYDIR '/lispcore/fonts/altofonts]
[INTERPRESSFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/lispcore/fonts/ipfonts]
(POSTSCRIPTFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/lispcore/fonts/postscriptfonts]
(DECLARE%: DONTEVAL@LOAD DOCOPY (P (LOCAL-INIT)
(* ;
"(SETQ USERNAME (UNIX-GETENV %"USER%"))")
)
(* ; "To get personal greeting to work, since GREET computes the USERNAME before USERNAMEPATCH is loaded.")
)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML)
(LAMA])
(* ;; "Local (Mac) system greeting file")
(DEFINEQ
(INTERLISPMODE
|
||||
[LAMBDA (OLD?) (* N.H.Briggs " 2-Feb-88 14:26")
|
||||
(PROCESSPROP 'EXEC 'PROFILE (XCL:COPY-PROFILE (if OLD?
|
||||
then "OLD-INTERLISP-T"
|
||||
else "INTERLISP")))
|
||||
(XCL:SET-DEFAULT-EXEC-TYPE (if OLD?
|
||||
then "OLD-INTERLISP-T"
|
||||
else "INTERLISP"))
|
||||
(SETQ *DEFAULT-MAKEFILE-ENVIRONMENT* (LIST :READTABLE (if OLD?
|
||||
then "OLD-INTERLISP-FILE"
|
||||
else "INTERLISP")
|
||||
:PACKAGE "INTERLISP"])
)
(RPAQQ COMPILEIGNOREDECL T)
(RPAQ MEDLEYDIR (UNIX-GETENV 'MEDLEYDIR))
(RPAQQ SITE LOCAL-MAC)
(BKSYSBUF " ")
(* ;
"So tty window doesn't hang during greeting")
(INTERLISPMODE)
(DEFCOMMAND ("show" :QUIET) (&REST EVENTSPEC) (CL:PPRINT (VALUOF EVENTSPEC T)
T))
(DEFINEQ
(LOCAL-INIT
[LAMBDA NIL
(DECLARE (GLOBALVARS MAKESYSNAME LOCALPATCHDIRECTORY))
(* ; "Edited 14-Jun-2017 14:45 by kaplan")
(* ; "Edited 14-Jun-2017 11:15 by kaplan")
(* ;; "This is what gets called when LOCAL-INIT is loaded.")
(BKSYSBUF " ")
(* ;; "do the real work")
(WITHOUT.PAGEHOLD (WFROMDS (GETSTREAM T 'OUTPUT))
(CL:WHEN LOCALPATCHDIRECTORY
(LoadPatches LOCALPATCHDIRECTORY 'SYSLOAD MAKESYSDATE))])
(LoadPatches
|
||||
[LAMBDA (DIRECTORY LDFLG AFTERDATE) (* ; "Edited 7-Feb-92 11:50 by bbb")
|
||||
|
||||
(* ;;; "Load all compiled files from the directory")
|
||||
|
||||
(DECLARE (GLOBALVARS *COMPILED-EXTENSIONS*))
|
||||
(LET [(files (SORT (for EXT in *COMPILED-EXTENSIONS*
|
||||
bind (AFTERIDATE _ (if AFTERDATE
|
||||
then (OR (IDATE AFTERDATE)
|
||||
0)
|
||||
else 0)) join (COLLECT-PATCH-FILES
|
||||
(DIRECTORYNAME DIRECTORY)
|
||||
EXT AFTERIDATE))
|
||||
(FUNCTION (LAMBDA (X Y)
|
||||
(LESSP (CDR X)
|
||||
(CDR Y] (* ;
|
||||
"files are sorted by increasing date")
|
||||
(for file in files do (SELECTQ LDFLG
|
||||
(HIDDEN (* ;
|
||||
"Load the file, but don't put it on FILELST")
|
||||
(LOAD? (CAR file)
|
||||
T)
|
||||
(SETQ FILELST (DREMOVE (FILENAMEFIELD
|
||||
(CAR file)
|
||||
'NAME)
|
||||
FILELST)))
|
||||
(LOAD? (CAR file)
|
||||
LDFLG)))
|
||||
files])
(COLLECT-PATCH-FILES
|
||||
[LAMBDA (DIRECTORY EXT AFTERIDATE) (* ; "Edited 7-Feb-92 11:49 by bbb")
|
||||
|
||||
(* ;; "Generate list of files in DIRECTORY with extension EXT more recent than idate AFTERIDATE. Return list of pairs (file . date). Omits subdirectories.")
|
||||
|
||||
(RESETLST
|
||||
(LET ((FILING.ENUMERATION.DEPTH 1)
|
||||
(NAKED-DIR (UNPACKFILENAME.STRING DIRECTORY 'DIRECTORY))
|
||||
FILE DATE)
|
||||
(bind [GEN _ (\GENERATEFILES (CONCAT DIRECTORY "*." EXT ";")
|
||||
'(ICREATIONDATE)
|
||||
'(SORT RESETLST] while (SETQ FILE (\GENERATENEXTFILE GEN))
|
||||
when (AND (STRING-EQUAL (UNPACKFILENAME.STRING FILE 'DIRECTORY)
|
||||
NAKED-DIR)
|
||||
(> (SETQ DATE (\GENERATEFILEINFO GEN 'ICREATIONDATE))
|
||||
AFTERIDATE)) collect (CONS FILE DATE))))])
(FIXMETA
[LAMBDA NIL (* ; "Edited 25-Jun-2017 17:12 by rmk:")
(KEYACTION 'BLANK-TOP '(METADOWN . METAUP)
\CURRENTKEYACTION)
(KEYACTION 'BLANK-TOP '(METADOWN . METAUP])
)
(FIXMETA)
(DEFMACRO WITHOUT.PAGEHOLD (WINDOW &BODY FORMS)
`(RESETLST
(LET* ((TTYWINDOW ,WINDOW)
(ORIGINAL.PAGEFULLFN (WINDOWPROP TTYWINDOW 'PAGEFULLFN))
(NEW.PAGEFULLFN (FUNCTION NILL)))
(RESETSAVE (WINDOWPROP TTYWINDOW 'PAGEFULLFN NEW.PAGEFULLFN)
(LIST [FUNCTION (LAMBDA (TTYWINDOW NEW.PAGEFULLFN ORIGINAL.PAGEFULLFN)
(COND
((EQ (WINDOWPROP TTYWINDOW 'PAGEFULLFN)
NEW.PAGEFULLFN)
(WINDOWPROP TTYWINDOW 'PAGEFULLFN ORIGINAL.PAGEFULLFN]
TTYWINDOW NEW.PAGEFULLFN ORIGINAL.PAGEFULLFN)))
,@FORMS))
(RPAQ LISPUSERSDIRECTORIES (LIST (CONCAT MEDLEYDIR "/lispcore/lispusers")
(CONCAT MEDLEYDIR "/lispcore/library")))
(RPAQ LISPSOURCEDIRECTORIES (LIST (CONCAT MEDLEYDIR "/lispcore/sources")))
(RPAQ DIRECTORIES (APPEND (CONS (CONCAT MEDLEYDIR "/lispcore/patches"))
LISPUSERSDIRECTORIES LISPSOURCEDIRECTORIES))
(RPAQ LOCALPATCHDIRECTORY (CONCAT MEDLEYDIR "/lispcore/patches"))
(RPAQQ USERGREETFILES (({DSK}/Users/ USER /Lisp/INIT.LCOM)
({DSK}/Users/ USER /Lisp/INIT.DFASLs)
({DSK}/Users/ USER /Lisp/INIT)))
(RPAQQ *USEOLDFONTDIRECTORIES* NIL)
(RPAQ DISPLAYFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/lispcore/fonts/displayfonts)
(CONCAT MEDLEYDIR '/lispcore/fonts/altofonts)))
(RPAQ INTERPRESSFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/lispcore/fonts/ipfonts)))
(RPAQ POSTSCRIPTFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/lispcore/fonts/postscriptfonts)))
(DECLARE%: DONTEVAL@LOAD DOCOPY
(LOCAL-INIT)
(* ;
"(SETQ USERNAME (UNIX-GETENV %"USER%"))")
)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA )
)
(PUTPROPS LOCAL-INIT COPYRIGHT (NONE))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (2990 3815 (INTERLISPMODE 3000 . 3813)) (4274 8070 (LOCAL-INIT 4284 . 4895) (LoadPatches
4897 . 6845) (COLLECT-PATCH-FILES 6847 . 7824) (FIXMETA 7826 . 8068)))))
STOP
|
||||
File diff suppressed because one or more lines are too long
Binary file not shown.
Binary file not shown.
@ -1 +0,0 @@
|
||||
(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED "24-Jun-2017 19:27:26"
{DSK}<Volumes>Personal>local>medley3.5>current>MAKEINITGREET.;1 4254
changes to%: (VARS MAKEINITGREETCOMS)
(FNS MAKEINITGREET))
(PRETTYCOMPRINT MAKEINITGREETCOMS)
(RPAQQ MAKEINITGREETCOMS ((FNS MAKEINITGREET)))
(DEFINEQ
(MAKEINITGREET
[LAMBDA NIL (* ; "Edited 24-Jun-2017 19:26 by rmk:")
((
(* ;; "Make the INIT.DLINIT starting sysout for a new loadup. Derived from MAKEINIT.CM")
(* ;; "IF YOU EDIT THIS FILE, EDIT LOADINITSLOW.CM TOO!!!! ")
(* ;; " Edit November 3, 1987 by vanMelle, note comment ")
(* ;; " The path given to the Lisp command below should point to the LispCore sysout cache. ")
(* ;; " Code that runs after Lisp starts up assures that the cached sysout is the most recent, and if not, fetches a new one and restarts itself. ")
(* ;; " Edited so that the most recent patch file is loaded ")
(* ;; " Updated Lisp version for big physical memory --bvm |11/3/87")
(* ;;
"Delete INIT.DFASL!* INIT.SAVE*, otherwise Lisp might read INIT.LISP!2 Copy INIT.SAVE _ INIT.DFASL ")
(* ;; " save away site file to be restored below")
)
(* ;; "Start inside $medleydir medley -greet current/MAKEINITGREET -lisp")
(* ;; "")
(XCL:RESTORE-PROFILE "INTERLISP")
(DELFILE 'current/INIT.DFASL)
(AND (INFILEP 'current/INIT.SAVE)
(RENAMEFILE 'current/INIT.SAVE current/INIT.DFASL))
(DIRECTORY 'current/INIT.DLINIT;* '(DELETE)) (* Make sure we have a valid sysout)
[LET [(DATE (CAR (NLSETQ (GETFILEINFO basics/FULL.SYSOUT 'ICREATIONDATE]
(IF [AND NIL DATE (IGREATERP DATE (GETFILEINFO 'basics/Lisp.Sysout 'ICREATIONDATE]
THEN (* Get new saved sysout)
(NLSETQ (PROGN (COPYFILE 'basics/FULL.SYSOUT '{DSK7}LispCore.Sysout;1)
(COPYFILE '{DSK}REM.CM;1 '{CORE}REM.CM)
(* Repeat current command now)
(OUTFILE '{DSK}REM.CM;1)
(PRIN1 '@LoadInit.cm@)
(COPYBYTES (OPENSTREAM '{CORE}REM.CM 'INPUT))
(CLOSEF)
(LOGOUT T]
(PROGN (* Make old sysout work with new
read tables)
(SETSYNTAX (CHARCODE ^^)
'PACKAGEDELIM FILERDTBL)
(SETSYNTAX (CHARCODE ^^)
'PACKAGEDELIM CODERDTBL)
(SETSYNTAX (CHARCODE ^^)
'PACKAGEDELIM \ORIGREADTABLE)) (* (LOAD (QUOTE LOAD-LISPCORE-PATCH)))
(* ; "Doesn't exist")
(SETQ DIRECTORIES '(sources/ /library internal/library))
(SETQ LITATOM-PACKAGE-CONVERSION-ENABLED NIL)
(SETQ *REMOVE-INTERLISP-COMMENTS* NIL) (* Get new exports since last loadup)
(LOAD 'CONDITION-PACKAGE.LCOM 'SYSLOAD)
(LOAD 'XCL-PACKAGE.LCOM 'SYSLOAD) (* FILESETS has where to get things
from)
(LOAD 'FILESETS)
(FILESLOAD RENAMEFNS MAKEINIT DLFIXINIT CMLARRAY-SUPPORT)
(* Versions are Lisp Microcode Bcpl)
(PROGN (CNDIR '{CORE}) (* ; "CNDIR doesn't know about {CORE}")
(IDLE.SET.OPTION 'TIMEOUT 0)
(IDLE.SET.OPTION 'SAVEVM 0)
(DORENAME 'I)
(DLFIXINIT (MAKEINIT '(39424 5682 11008)
NIL NIL '(sources/ /internal/library/ library/)
'INIT.DLINIT LispDLion.db 300)
(LOGOUT T)))
NIL])
)
(PUTPROPS MAKEINITGREET COPYRIGHT (NONE))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (355 4189 (MAKEINITGREET 365 . 4187)))))
STOP
|
||||
File diff suppressed because one or more lines are too long
File diff suppressed because one or more lines are too long
Binary file not shown.
File diff suppressed because one or more lines are too long
@ -1,4 +0,0 @@
|
||||
lldb ../../maiko/darwin.386/ldeinit
|
||||
|
||||
break set -n error
|
||||
run ./INIT.DLINIT -INIT -NF
|
||||
Binary file not shown.
@ -1,32 +0,0 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
(FILECREATED "23-Feb-89 18:28:23" |{NB:PARC:XEROX}<NFS>MEDLEY>FIX-FILE-TYPES.;2| 1684
|
||||
|
||||
changes to%: (VARS FIX-FILE-TYPE-INFO)
|
||||
|
||||
previous date%: "16-Dec-88 18:27:36" |{NB:PARC:XEROX}<NFS>MEDLEY>FIX-FILE-TYPES.;1|)
|
||||
|
||||
|
||||
(* "
|
||||
Copyright (c) 1988, 1989 by Xerox Corporation. All rights reserved.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT FIX-FILE-TYPESCOMS)
|
||||
|
||||
(RPAQQ FIX-FILE-TYPESCOMS ((FNS FIX-FILE-TYPES)
|
||||
(VARS FIX-FILE-TYPE-INFO)))
|
||||
(DEFINEQ
|
||||
|
||||
(FIX-FILE-TYPES
|
||||
(LAMBDA (DIR) (* ; "Edited 16-Dec-88 18:24 by bvm") (for TYPEINFO in FIX-FILE-TYPE-INFO bind (N _ 0) do (RESETLST (LET ((GEN (\GENERATEFILES (if DIR then (PACKFILENAME.STRING (QUOTE DIRECTORY) DIR (QUOTE BODY) (CAR TYPEINFO)) else (CAR TYPEINFO)) (QUOTE (TYPE)) (QUOTE (RESETLST)))) FILE TYPE) (while (SETQ FILE (\GENERATENEXTFILE GEN)) do (CASE (SETQ TYPE (\GENERATEFILEINFO GEN (QUOTE TYPE))) ((NIL TEXT) (* ; "Maybe inappropriately TEXT") (if (OR (NULL (CADDR TYPEINFO)) (CL:FUNCALL (CADDR TYPEINFO) FILE)) then (add N 1) (CL:FORMAT T "~&~A ~A => " FILE TYPE) (if (SETFILEINFO FILE (QUOTE TYPE) (CADR TYPEINFO)) then (PRIN1 (CADR TYPEINFO)) else (PRIN1 "***Could not set type***")))))))) finally (RETURN (CL:FORMAT NIL "~d files with bad type found" N))))
|
||||
)
|
||||
)
|
||||
|
||||
(RPAQQ FIX-FILE-TYPE-INFO (("*.mail" LAFITE)
|
||||
("*.mail-lafite-toc" BINARY)
|
||||
("*.dfasl" BINARY)
|
||||
("*.lcom" BINARY)
|
||||
("*.lafite-form" BINARY)))
|
||||
(PUTPROPS FIX-FILE-TYPES COPYRIGHT ("Xerox Corporation" 1988 1989))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (534 1326 (FIX-FILE-TYPES 544 . 1324)))))
|
||||
STOP
|
||||
@ -1,56 +0,0 @@
|
||||
(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP")
|
||||
(FILECREATED "31-Jan-89 21:46:29" |{NB:PARC:XEROX}<NFS>MEDLEY>FIX-FILES.;1| 2462
|
||||
|
||||
|changes| |to:| (VARS FIX-FILESCOMS)
|
||||
(FNS FIX-FILES))
|
||||
|
||||
|
||||
; Copyright (c) 1989 by Xerox Corporation. All rights reserved.
|
||||
|
||||
(PRETTYCOMPRINT FIX-FILESCOMS)
|
||||
|
||||
(RPAQQ FIX-FILESCOMS ((FILES |{NB:PARC:XEROX}<NFS>MEDLEY>FIX-FILE-TYPES|)
|
||||
(FNS FIX-FILES)))
|
||||
|
||||
(FILESLOAD |{NB:PARC:XEROX}<NFS>MEDLEY>FIX-FILE-TYPES|)
|
||||
(DEFINEQ
|
||||
|
||||
(FIX-FILES
|
||||
(LAMBDA (DIR) (* \; "Edited 31-Jan-89 21:43 by bbb")
|
||||
|
||||
(* |;;| "Fix the file types")
|
||||
|
||||
(FIX-FILE-TYPES DIR)
|
||||
|
||||
(* |;;| "Now change the names to eliminate slashes")
|
||||
|
||||
(RESETLST
|
||||
(LET ((GEN (\\GENERATEFILES (|if| DIR
|
||||
|then| (PACKFILENAME.STRING 'DIRECTORY DIR 'BODY "*.*")
|
||||
|else| "*.*")
|
||||
NIL
|
||||
'(RESETLST)))
|
||||
FILE NEWFILE)
|
||||
(|while| (SETQ FILE (\\GENERATENEXTFILE GEN)) |bind| |SlashPos|
|
||||
|do| (|if| (SETQ |SlashPos| (STRPOSL (LIST (CHARCODE /))
|
||||
FILE 1))
|
||||
|then|
|
||||
|
||||
(* |;;|
|
||||
"Found a slash. Go through and replace all slashes (/) with hyphens (-)")
|
||||
|
||||
(SETQ NEWFILE (CONCAT FILE))
|
||||
(|while| |SlashPos| |do| (SETQ NEWFILE (RPLCHARCODE
|
||||
NEWFILE |SlashPos|
|
||||
(CHARCODE "-")))
|
||||
(SETQ |SlashPos|
|
||||
(STRPOSL (LIST (CHARCODE /))
|
||||
NEWFILE
|
||||
(ADD1 |SlashPos|))))
|
||||
(RENAMEFILE FILE NEWFILE)
|
||||
(|printout| T "renaming " FILE " to " NEWFILE T)))))))
|
||||
)
|
||||
(PUTPROPS FIX-FILES COPYRIGHT ("Xerox Corporation" 1989))
|
||||
(DECLARE\: DONTCOPY
|
||||
(FILEMAP (NIL (511 2381 (FIX-FILES 521 . 2379)))))
|
||||
STOP
|
||||
210
nfs/NFSDECLS
210
nfs/NFSDECLS
@ -1,210 +0,0 @@
|
||||
(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "NFS")
|
||||
(il:filecreated "12-Oct-89 17:18:40" "{piglet/n}<piglet>nfs>sources>NFSDECLS;16" 13059
|
||||
|
||||
il:|changes| il:|to:| (il:functions mount-name) (il:vars il:nfsdeclscoms)
|
||||
|
||||
il:|previous| il:|date:| "12-Oct-89 17:16:57" "{piglet/n}<piglet>nfs>sources>NFSDECLS;15")
|
||||
|
||||
|
||||
; Copyright (c) 1989 by Xerox Corporation. All rights reserved.
|
||||
|
||||
(il:prettycomprint il:nfsdeclscoms)
|
||||
|
||||
(il:rpaqq il:nfsdeclscoms ((il:prop (il:makefile-environment il:filetype) il:nfsdecls) (il:variables bytesperpage logbytesperpage) (il:functions fix-this) (il:coms (il:* il:\; "Protocol constants. At least the ADDVARS has to be here, lest NFSCOMS be unloadable due to missing package") (il:addvars (rpc2:*xdr-primitive-types* (rfd-list read-rfd-list . il:shouldnt) (input-buffer read-input-buffer . il:shouldnt))) (il:variables *fattr-size* *cookie-size*)) (il:coms (il:* il:\; "Macros") (il:functions nfs-rpc-call string-concat string-from-integer fattr-binaryp copy-pathname evalcase prompt-format get-meta-timestamp mount-name) (il:addvars (il:prettyequivlst (evalcase . case))) (il:* il:\; "Some common record accessors") (il:functions stream-device stream-epage stream-eoffset stream-info stream-validation)) (il:p (proclaim (quote (special il:defaultfiletype il:filing.enumeration.depth il:filelinelength il:\\stream.default.maxbuffers il:promptwindow *read-buffer*))) (proclaim (quote (global il:\\noimageops il:\\ip.default.configuration il:*maximum-packet-size* il:\\filedevices)))) (il:coms (il:* il:\; "NFS protocol enumeration values. This lets us avoid converting to silly literals every time we read/write something") (il:variables *nfs-status-codes* *nfs-file-types* *nfs-mode-bits*) (il:p (il:* il:|;;| "Define a constant for each of those. By putting these here in the decls file, I assume compiler will compile them all away") (il:* il:|;;| "Blecch. I really should just do `(defconstant ,@trip) here, but I don't want the silly File Manager confused about where all those constants \"live\"") (il:apply (quote il:constants) (mapcan (function (lambda (trip) (cond ((first trip) (set (first trip) (second trip)) (list (list (first trip) (second trip))))))) (if (boundp (quote *nfs-status-codes*)) *nfs-status-codes* (let ((il:dfnflg t)) (il:* il:\; "Stupid File Manager PROP...") (eval (il:getdef (quote *nfs-status-codes*) (quote il:variables)))))))) (il:constants il:* (progn *nfs-file-types*)) (il:constants il:* (progn *nfs-mode-bits*))) (il:coms (il:* il:\; "More stuff to accelerate rpc calls. A more thorough rpc compiler would save us some of this grief") (il:functions make-proc-vector) (il:variables *nfs-proc-indices* *mount-proc-indices*) (il:constants il:* (progn *nfs-proc-indices*)) (il:constants il:* (progn *mount-proc-indices*)) (il:p (proclaim (quote (global *mount-program* *mount-proc-vector* *nfs-program* *nfs-proc-vector*))))) (il:coms (il:* il:\; "Debugging stuff") (il:variables *nfsdevicefns*) (il:commands il:whonot))))
|
||||
|
||||
(il:putprops il:nfsdecls il:makefile-environment (:readtable "XCL" :package "NFS"))
|
||||
|
||||
(il:putprops il:nfsdecls il:filetype :compile-file)
|
||||
|
||||
(defconstant bytesperpage 512 "Number of bytes per 1100 memory page")
|
||||
|
||||
(defconstant logbytesperpage 9 "Bit shift of byte offset to get page offset")
|
||||
|
||||
(defmacro fix-this (&body code) (il:bquote (progn (il:\\\,@ code))))
|
||||
|
||||
|
||||
|
||||
(il:* il:\;
|
||||
"Protocol constants. At least the ADDVARS has to be here, lest NFSCOMS be unloadable due to missing package"
|
||||
)
|
||||
|
||||
|
||||
(il:addtovar rpc2:*xdr-primitive-types* (rfd-list read-rfd-list . il:shouldnt) (input-buffer read-input-buffer . il:shouldnt))
|
||||
|
||||
(defconstant *fattr-size* 68 "Size of FATTR in bytes")
|
||||
|
||||
(defconstant *cookie-size* 4 "Size of ReadFromDirectory cookie in bytes")
|
||||
|
||||
|
||||
|
||||
(il:* il:\; "Macros")
|
||||
|
||||
|
||||
(defmacro nfs-rpc-call (dinfo prog proc arglist) (il:bquote (let ((rpc2:*msec-until-timeout* *nfs-default-timeout*)) (rpc2:perform-rpc nil (il:\\\, prog) (il:\\\, prog) (il:\\\, proc) (or (deviceinfo-rpcstream (il:\\\, dinfo)) (setf (deviceinfo-rpcstream (il:\\\, dinfo)) (make-nfs-rpc-stream (deviceinfo-host (il:\\\, dinfo)) (deviceinfo-destaddr (il:\\\, dinfo))))) (il:\\\, arglist) (nfscredentials-credentials (dinfo-credentials (il:\\\, dinfo)))))))
|
||||
|
||||
(defmacro string-concat (&body args) (il:bquote (concatenate (quote string) (il:\\\,@ args))))
|
||||
|
||||
(defmacro string-from-integer (n) (il:bquote (write-to-string (il:\\\, n) :radix nil :base 10)))
|
||||
|
||||
(defmacro fattr-binaryp (fattr) (il:bquote (not (eql 0 (logand (fattr-mode (il:\\\, fattr)) *mode-binary-p*)))))
|
||||
|
||||
(defmacro copy-pathname (path) (il:bquote (il:ncreate (quote pathname) (il:\\\, path))))
|
||||
|
||||
(defmacro evalcase (keyform &rest clauses) (il:* il:|;;| "Version of CASE that uses the values of the keys instead of the keys themselves") (il:bquote (case (il:\\\, keyform) (il:\\\,@ (mapcar (function (lambda (c) (cons (cond ((listp (first c)) (mapcar (function eval) (first c))) ((eq (first c) (quote otherwise)) (quote otherwise)) (t (eval (first c)))) (rest c)))) clauses)))))
|
||||
|
||||
(defmacro prompt-format (&rest args) (il:bquote (format il:promptwindow (il:\\\,@ args))))
|
||||
|
||||
(defmacro get-meta-timestamp nil (il:* il:|;;| "Return a number that reflects \"now\" in seconds, for comparison purposes. Portable way is get-universal-time") (quote (il:idate)))
|
||||
|
||||
(defmacro mount-name (unixpath) (il:* il:|;;| "Return a string to give to a mount/unmount call. Really, this means turn the null string into \"/\"") (il:bquote (let ((path (il:\\\, unixpath))) (if (> (length path) 0) path "/"))))
|
||||
|
||||
(il:addtovar il:prettyequivlst (evalcase . case))
|
||||
|
||||
|
||||
|
||||
(il:* il:\; "Some common record accessors")
|
||||
|
||||
|
||||
(defmacro stream-device (s) (il:bquote (il:fetch (stream il:device) il:of (il:\\\, s))))
|
||||
|
||||
(defmacro stream-epage (s) (il:bquote (il:fetch (stream il:epage) il:of (il:\\\, s))))
|
||||
|
||||
(defmacro stream-eoffset (s) (il:bquote (il:fetch (stream il:eoffset) il:of (il:\\\, s))))
|
||||
|
||||
(defmacro stream-info (stream) (il:bquote (il:fetch (stream il:f1) il:of (il:\\\, stream))))
|
||||
|
||||
(defmacro stream-validation (stream) (il:bquote (il:fetch (stream il:validation) il:of (il:\\\, stream))))
|
||||
|
||||
(proclaim (quote (special il:defaultfiletype il:filing.enumeration.depth il:filelinelength il:\\stream.default.maxbuffers il:promptwindow *read-buffer*)))
|
||||
|
||||
(proclaim (quote (global il:\\noimageops il:\\ip.default.configuration il:*maximum-packet-size* il:\\filedevices)))
|
||||
|
||||
|
||||
|
||||
(il:* il:\;
|
||||
"NFS protocol enumeration values. This lets us avoid converting to silly literals every time we read/write something"
|
||||
)
|
||||
|
||||
|
||||
(defglobalparameter *nfs-status-codes* (quote ((nfs-ok 0 "Success") (nil 1 "Caller does not have ownership rights") (nfs-err-noent 2 "No such file or directory") (nil 5 "I/O Error") (nil 6 "No such device or address") (nfs-err-acces 13 "Permission denied") (nfs-err-exist 17 "File already exists") (nfs-err-crossdev 18 "Operation crosses device boundaries") (nil 19 "No such device") (nfs-err-notdir 20 "Not a directory") (nil 21 "Is a directory") (nil 22 "Invalid argument") (nil 27 "File too large") (nil 28 "No space left on device") (nil 30 "File system is read-only") (nil 63 "File name is too long") (nil 66 "Directory is not empty") (nfs-err-dquot 69 "Disk quota exceeded") (nfs-err-stale 70 "File handle is stale") (nil 71 "File system is not local to this server") (nil 99 "Write cache flushed"))) "Possible status replies from NFS protocol")
|
||||
|
||||
(defglobalparameter *nfs-file-types* (quote ((nfnon 0) (nfreg 1) (nfdir 2) (nfblk 3) (nfchr 4) (nflnk 5))) "Codes for the TYPE field of a fattr.")
|
||||
|
||||
(defglobalparameter *nfs-mode-bits* (quote ((*mode-directory* 16384) (*mode-regular* 32768) (*mode-set-gid* 1024) (*mode-inheritable* 2047) (il:* il:\; "Mask for the inheritable mode bits = #o3777 i.e., up thru set-gid") (*mode-protection* 4095) (il:* il:\; "Mask for the bits that indicate protection = #o7777") (*mode-binary* 64) (il:* il:\; "The bit we set to indicate binary = #o100 = owner execute") (*mode-binary-p* 3657) (il:* il:\; "Any of these imply binary. #o7111 = Set-u, set-g, sticky plus executable bits") (*mode-not-binary* 438) (il:* il:\; "All but the executable bits"))))
|
||||
|
||||
(il:* il:|;;| "Define a constant for each of those. By putting these here in the decls file, I assume compiler will compile them all away")
|
||||
|
||||
(il:* il:|;;| "Blecch. I really should just do `(defconstant ,@trip) here, but I don't want the silly File Manager confused about where all those constants \"live\"")
|
||||
|
||||
(il:apply (quote il:constants) (mapcan (function (lambda (trip) (cond ((first trip) (set (first trip) (second trip)) (list (list (first trip) (second trip))))))) (if (boundp (quote *nfs-status-codes*)) *nfs-status-codes* (let ((il:dfnflg t)) (il:* il:\; "Stupid File Manager PROP...") (eval (il:getdef (quote *nfs-status-codes*) (quote il:variables)))))))
|
||||
(il:declare\: il:eval@compile
|
||||
|
||||
(il:rpaqq nfnon 0)
|
||||
|
||||
(il:rpaqq nfreg 1)
|
||||
|
||||
(il:rpaqq nfdir 2)
|
||||
|
||||
(il:rpaqq nfblk 3)
|
||||
|
||||
(il:rpaqq nfchr 4)
|
||||
|
||||
(il:rpaqq nflnk 5)
|
||||
|
||||
|
||||
(il:constants (nfnon 0) (nfreg 1) (nfdir 2) (nfblk 3) (nfchr 4) (nflnk 5))
|
||||
)
|
||||
(il:declare\: il:eval@compile
|
||||
|
||||
(il:rpaqq *mode-directory* 16384)
|
||||
|
||||
(il:rpaqq *mode-regular* 32768)
|
||||
|
||||
(il:rpaqq *mode-set-gid* 1024)
|
||||
|
||||
(il:rpaqq *mode-inheritable* 2047)
|
||||
|
||||
(il:rpaqq *mode-protection* 4095)
|
||||
|
||||
(il:rpaqq *mode-binary* 64)
|
||||
|
||||
(il:rpaqq *mode-binary-p* 3657)
|
||||
|
||||
(il:rpaqq *mode-not-binary* 438)
|
||||
|
||||
|
||||
(il:constants (*mode-directory* 16384) (*mode-regular* 32768) (*mode-set-gid* 1024) (*mode-inheritable* 2047) (*mode-protection* 4095) (*mode-binary* 64) (*mode-binary-p* 3657) (*mode-not-binary* 438))
|
||||
)
|
||||
|
||||
|
||||
|
||||
(il:* il:\;
|
||||
"More stuff to accelerate rpc calls. A more thorough rpc compiler would save us some of this grief")
|
||||
|
||||
|
||||
(defmacro make-proc-vector (progname vecname indices) (let ((indices (eval indices))) (il:bquote (progn (setq (il:\\\, vecname) (make-array (il:\\\, (length indices)))) (il:* il:\; "Now for each index, set that slot of vecname to be the actual procedure object") (il:\\\,@ (mapcar (function (lambda (indexpair) (il:* il:\; "INDEXPAIR = (*procname* index). Strip the *'s off the first element to get the procedure name") (let ((const (symbol-name (first indexpair)))) (il:bquote (setf (aref (il:\\\, vecname) (il:\\\, (second indexpair))) (rpc2:find-rpc-procedure (il:\\\, progname) (quote (il:\\\, (intern (subseq const 1 (1- (length const)))))))))))) indices))))))
|
||||
|
||||
(defglobalparameter *nfs-proc-indices* (quote ((*get-file-attributes* 0) (*set-file-attributes* 1) (*lookup-file-name* 2) (*read-from-symbolic-link* 3) (*fast-read-from-file* 4) (*null-read-from-file* 5) (*fast-write-to-file* 6) (*create-file* 7) (*remove-file* 8) (*rename-file* 9) (*create-link-to-file* 10) (*create-symbolic-link* 11) (*create-directory* 12) (*remove-directory* 13) (*read-from-directory* 14))) "Procedures I want to access quickly with arbitrarily assigned indices")
|
||||
|
||||
(defglobalparameter *mount-proc-indices* (quote ((*add-mount-entry* 0) (*remove-mount-entry* 1) (*return-export-list* 2))) "Procedures I want to access quickly with arbitrarily assigned indices")
|
||||
(il:declare\: il:eval@compile
|
||||
|
||||
(il:rpaqq *get-file-attributes* 0)
|
||||
|
||||
(il:rpaqq *set-file-attributes* 1)
|
||||
|
||||
(il:rpaqq *lookup-file-name* 2)
|
||||
|
||||
(il:rpaqq *read-from-symbolic-link* 3)
|
||||
|
||||
(il:rpaqq *fast-read-from-file* 4)
|
||||
|
||||
(il:rpaqq *null-read-from-file* 5)
|
||||
|
||||
(il:rpaqq *fast-write-to-file* 6)
|
||||
|
||||
(il:rpaqq *create-file* 7)
|
||||
|
||||
(il:rpaqq *remove-file* 8)
|
||||
|
||||
(il:rpaqq *rename-file* 9)
|
||||
|
||||
(il:rpaqq *create-link-to-file* 10)
|
||||
|
||||
(il:rpaqq *create-symbolic-link* 11)
|
||||
|
||||
(il:rpaqq *create-directory* 12)
|
||||
|
||||
(il:rpaqq *remove-directory* 13)
|
||||
|
||||
(il:rpaqq *read-from-directory* 14)
|
||||
|
||||
|
||||
(il:constants (*get-file-attributes* 0) (*set-file-attributes* 1) (*lookup-file-name* 2) (*read-from-symbolic-link* 3) (*fast-read-from-file* 4) (*null-read-from-file* 5) (*fast-write-to-file* 6) (*create-file* 7) (*remove-file* 8) (*rename-file* 9) (*create-link-to-file* 10) (*create-symbolic-link* 11) (*create-directory* 12) (*remove-directory* 13) (*read-from-directory* 14))
|
||||
)
|
||||
(il:declare\: il:eval@compile
|
||||
|
||||
(il:rpaqq *add-mount-entry* 0)
|
||||
|
||||
(il:rpaqq *remove-mount-entry* 1)
|
||||
|
||||
(il:rpaqq *return-export-list* 2)
|
||||
|
||||
|
||||
(il:constants (*add-mount-entry* 0) (*remove-mount-entry* 1) (*return-export-list* 2))
|
||||
)
|
||||
|
||||
(proclaim (quote (global *mount-program* *mount-proc-vector* *nfs-program* *nfs-proc-vector*)))
|
||||
|
||||
|
||||
|
||||
(il:* il:\; "Debugging stuff")
|
||||
|
||||
|
||||
(defglobalparameter *nfsdevicefns* (quote (clear-server-cache nfs-breakconnection nfs-closefile nfs-deletefile nfs-directorynamep nfs-eventfn nfs-fileinfofn nfs-generatefiles nfs-getfileinfo nfs-getfilename nfs-hostnamep nfs-nextfilefn nfs-openfile nfs-openp nfs-readpages nfs-renamefile nfs-unregisterfile nfs-writepages print-deviceinfo print-dirinfo print-fileinfo print-nfspath reset-nfs-cache-vars reset-nfscredentials-cache)) "Functions called from 'literals' or otherwise undetected by Masterscope--for development.")
|
||||
|
||||
(defcommand il:whonot nil (set-difference (il:\. il:who il:in (il:filecomslst (quote il:nfsdevice) (quote il:functions)) il:is not il:called) *nfsdevicefns*))
|
||||
(il:putprops il:nfsdecls il:copyright ("Xerox Corporation" 1989))
|
||||
(il:declare\: il:dontcopy
|
||||
(il:filemap (nil)))
|
||||
il:stop
|
||||
Binary file not shown.
@ -1,45 +0,0 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "NFS" READTABLE "XCL")
|
||||
(il:filecreated "18-Apr-90 18:00:50" "{piglet/n}<piglet>nfs>sources>NFSVOLUME;11" 5881
|
||||
|
||||
il:|changes| il:|to:| (il:functions find-volume)
|
||||
|
||||
il:|previous| il:|date:| "13-Oct-89 16:01:54" "{piglet/n}<piglet>nfs>sources>NFSVOLUME;10")
|
||||
|
||||
|
||||
; Copyright (c) 1989, 1990 by Xerox Corporation. All rights reserved.
|
||||
|
||||
(il:prettycomprint il:nfsvolumecoms)
|
||||
|
||||
(il:rpaqq il:nfsvolumecoms ((il:functions read-auto-entry auto-whitespacep find-volume find-volume-lookup create-volume-map make-volume-hash) (il:variables *nfs-volume-map* *volume-map-name* *auto-mount-names*) (il:addvars (il:\\systemcachevars *nfs-volume-map*) (*nfs-cache-vars* *nfs-volume-map*)) (il:p (export (quote (find-volume read-volume-map *volume-map-name* *auto-mount-names*)))) (il:prop (il:makefile-environment il:filetype) il:nfsvolume)))
|
||||
|
||||
(defun read-auto-entry (line) (il:* il:|;;| "Reads a line from an auto.mumble map and returns (host . path), or NIL if the line is malformed.") (il:* il:|;;| "Line is of the form <whitespace> host:path <whitespace> <anything>, but <whitespace> can be \"edge of line\".") (let ((colon (position #\: line))) (and colon (let* ((end (position-if (quote auto-whitespacep) line :start colon)) (host (subseq line (1+ (or (position-if (quote auto-whitespacep) line :end colon :from-end t) -1)) colon)) (path (subseq line (1+ colon) end)) (pathcolon (position #\: path)) (dirpath (cond (pathcolon (il:* il:\; "Path is actually mountpoint:rest-of-path. We don't care about this subtlety") (concatenate (quote string) (subseq path 0 pathcolon) "/" (subseq path (if (eql (char path (1+ pathcolon)) #\/) (+ 2 pathcolon) (1+ pathcolon))))) (t path)))) (il:* il:|;;| "Entry now broken into host and directory. On Maiko, this is enough, since the local file system will further munge these strings beyond our control. On D machine, parse into (devicename . parsed-path) so we don't have to do this work every time") (if (eq il:\\machinetype il:\\maiko) (cons host dirpath) (cons (il:pack* (string-upcase host) "/N") (parse-dir-string (escape-uppercase-chars dirpath 1 nil t))))))))
|
||||
|
||||
(defun auto-whitespacep (c) (or (eq c #\Space) (eq c #\Tab)))
|
||||
|
||||
(defun find-volume (volname &optional dirlst) (il:* il:|;;| "Returns a cons of 2 values: a host name and a parsed directory path (i.e. dirs in reverse order) describing where to find the volume VOLNAME. NIL if not in map. If DIRLST is supplied, it is destructively modified (if possible) and the returned directory path is the concatenation of the volume location and rest of DIRLST.") (let ((hash (or *nfs-volume-map* (create-volume-map))) host entry) (cond ((eq hash t) nil) ((eq (setq entry (find-volume-lookup volname hash)) t) (il:* il:\; "Not found ") nil) ((and (consp entry) (not (hash-table-p (setq host (car entry))))) (il:* il:\; "Normal case, Entry = (\"host\" . \"/path...\")") (cond (dirlst (cons host (nconc (butlast dirlst 1) (cdr entry)))) (t entry))) ((cdr dirlst) (il:* il:|;;| "Handle automount entry. Next dir is pseudo, something to be looked up somehow. Skip this if not enough more dirs to look at. In particular, on Maiko, the host os handles automount, so the call to find-volume passes dirlst = nil.") (let ((tail (il:nleft dirlst 2))) (il:* il:\; "CAR of this is the next dir") (cond (host (il:* il:\; "Look up next dir in this table") (and (not (eq t (setq entry (find-volume-lookup (car tail) entry)))) (cons (car entry) (nconc (nbutlast dirlst 2) (cdr entry))))) ((eq entry :net) (il:* il:\; "Host is next dir") (cons (il:pack* (string-upcase (car tail)) "/N") (nbutlast dirlst 2)))))))))
|
||||
|
||||
(defun find-volume-lookup (volname map) (il:* il:|;;| "Look up volname in map, which is a pair (hashtable . mapname). This may do a yp lookup.") (let ((entry (gethash volname (car map)))) (cond (entry) (t (il:* il:\; "Not looked up yet") (setf (gethash volname (car map)) (or (and (setq entry (yp:yp-match (cdr map) (downcase-unquoted-chars volname))) (read-auto-entry entry)) t))))))
|
||||
|
||||
(defun create-volume-map nil (il:* il:|;;| "Creates the hash array mapping volume name to (host path).") (setq *nfs-volume-map* (and *volume-map-name* (let ((map (make-volume-hash *volume-map-name*))) (when (consp map) (dolist (other *auto-mount-names*) (il:* il:\; "More things to add to map") (setf (gethash (car other) (car map)) (case (cdr other) (:net (il:* il:\; "Special case: /net/foo means look on host foo") :net) (t (il:* il:\; "Name of a map") (make-volume-hash (cdr other))))))) map))))
|
||||
|
||||
(defun make-volume-hash (mapname) (il:* il:|;;| "Return an object for caching entries in MAPNAME. Value is (hashtable . mapname). Keys in the hash table are to be keys in the map. ") (let ((test (block testblk (yp:read-map mapname (function (lambda (key line) (il:* il:\; "Map is readable, so get out now") (return-from testblk nil))))))) (cond ((and test (symbolp test)) (il:* il:\; "error return") (format il:promptwindow "~&Can't read YP map ~A because: ~A" mapname test) nil) (t (il:* il:\; "map is ok, so return a hash pair") (cons (il:hasharray 10 nil (quote il:string-equal-hashbits) (quote string-equal)) mapname)))))
|
||||
|
||||
(defglobalparameter *nfs-volume-map* nil "Maintains map from volume name to host & path")
|
||||
|
||||
(defvar *volume-map-name* "auto.volume" "Name of the YP map used to map volumes to hosts")
|
||||
|
||||
(defvar *auto-mount-names* nil "A-list of names to do 'automount' for. Car is the pseudo-volume name, cdr is the yp map.")
|
||||
|
||||
(il:addtovar il:\\systemcachevars *nfs-volume-map*)
|
||||
|
||||
(il:addtovar *nfs-cache-vars* *nfs-volume-map*)
|
||||
|
||||
(export (quote (find-volume read-volume-map *volume-map-name* *auto-mount-names*)))
|
||||
|
||||
(il:putprops il:nfsvolume il:makefile-environment (:package "NFS" :readtable "XCL"))
|
||||
|
||||
(il:putprops il:nfsvolume il:filetype :compile-file)
|
||||
(il:putprops il:nfsvolume il:copyright ("Xerox Corporation" 1989 1990))
|
||||
(il:declare\: il:dontcopy
|
||||
(il:filemap (nil)))
|
||||
il:stop
|
||||
Binary file not shown.
77
nfs/RPC
77
nfs/RPC
@ -1,77 +0,0 @@
|
||||
(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE "RPC2" ( USE "LISP" "XCL")))
|
||||
(il:filecreated "27-Mar-89 14:51:07" il:{piglet/n}<piglet>nfs>sources>rpc\;4 5021
|
||||
|
||||
il:|changes| il:|to:| (il:vars il:rpccoms) (il:variables *use-os-networking*) (il:functions rpc-around-exit)
|
||||
|
||||
il:|previous| il:|date:| "13-Mar-89 14:36:20" il:{piglet/n}<piglet>nfs>sources>rpc\;3)
|
||||
|
||||
|
||||
; Copyright (c) 1987, 1988, 1989 by Stanford University and Xerox Corporation. All rights reserved.
|
||||
|
||||
(il:prettycomprint il:rpccoms)
|
||||
|
||||
(il:rpaqq il:rpccoms ((il:* il:|;;;;| "SUN REMOTE PROCEDURE CALLS") (il:* il:|;;;;| "Originally written by Jeff Finger at the SUMEX-AIM Computing Resource at Stanford University under support from National Institutes of Health Grant NIH 5P41 RR00785.") (il:* il:|;;;;| "Modified to work under Medley 1.0-S by Atty Mullins & Doug Cutting.") (il:* il:|;;;;| "Extensively revised by Bill van Melle") (il:props (il:rpc il:makefile-environment il:filetype)) (il:p (export (quote (define-remote-program undefine-remote-program remote-procedure-call call-via-portmapper create-unix-authentication setup-rpc perform-rpc open-rpcstream close-rpcstream list-remote-programs find-rpc-program find-rpc-procedure find-rpc-host xdr-make-opaque cache-socket clear-cache))) (export (quote (xdr-codegen xdr-codegen-1 xdr-read-boolean xdr-read-integer xdr-read-unsigned xdr-read-float xdr-read-string xdr-write-boolean xdr-write-integer xdr-write-unsigned xdr-write-float xdr-write-string xdr-gencode-inline))) (export (quote (udp tcp))) (export (quote (*debug* *compile-xdr-code* *xdr-primitive-types* *xdr-constructed-types* *rpc-programs* *msec-until-timeout* *msec-between-tries* *rpc-ok-to-cache* *rpc-socket-cache* *rpc-well-known-sockets* *rpc-protocol-types* *use-os-networking*)))) (il:variables *use-os-networking*) (il:functions rpc-around-exit) (eval-when (load) (il:appendvars (il:aroundexitfns rpc-around-exit)) (il:* il:\; "This is an APPENDVARS so that RPC-AROUND-EXIT runs FIRST at startup, before GREET in particular") (il:files (il:sysload) il:rpcstruct il:rpcrpc il:rpcxdr) (il:p (il:* il:\; "Load the appropriate transport.") (cond ((rpc-around-exit) (il:* il:\; "On Maiko") (il:filesload (il:sysload) il:rpcos)) (t (il:* il:\; "Load only UDP. If you want to use RPC over TCP, you must load TCP yourself") (il:filesload (il:sysload) il:tcpllip il:tcpudp il:rpcudp)))) (il:files (il:sysload) il:rpcportmapper))))
|
||||
|
||||
|
||||
|
||||
(il:* il:|;;;;| "SUN REMOTE PROCEDURE CALLS")
|
||||
|
||||
|
||||
|
||||
|
||||
(il:* il:|;;;;|
|
||||
"Originally written by Jeff Finger at the SUMEX-AIM Computing Resource at Stanford University under support from National Institutes of Health Grant NIH 5P41 RR00785."
|
||||
)
|
||||
|
||||
|
||||
|
||||
|
||||
(il:* il:|;;;;| "Modified to work under Medley 1.0-S by Atty Mullins & Doug Cutting.")
|
||||
|
||||
|
||||
|
||||
|
||||
(il:* il:|;;;;| "Extensively revised by Bill van Melle")
|
||||
|
||||
|
||||
(il:putprops il:rpc il:makefile-environment (:readtable "XCL" :package (defpackage "RPC2" (:use "LISP" "XCL"))))
|
||||
|
||||
(il:putprops il:rpc il:filetype :compile-file)
|
||||
|
||||
(export (quote (define-remote-program undefine-remote-program remote-procedure-call call-via-portmapper create-unix-authentication setup-rpc perform-rpc open-rpcstream close-rpcstream list-remote-programs find-rpc-program find-rpc-procedure find-rpc-host xdr-make-opaque cache-socket clear-cache)))
|
||||
|
||||
(export (quote (xdr-codegen xdr-codegen-1 xdr-read-boolean xdr-read-integer xdr-read-unsigned xdr-read-float xdr-read-string xdr-write-boolean xdr-write-integer xdr-write-unsigned xdr-write-float xdr-write-string xdr-gencode-inline)))
|
||||
|
||||
(export (quote (udp tcp)))
|
||||
|
||||
(export (quote (*debug* *compile-xdr-code* *xdr-primitive-types* *xdr-constructed-types* *rpc-programs* *msec-until-timeout* *msec-between-tries* *rpc-ok-to-cache* *rpc-socket-cache* *rpc-well-known-sockets* *rpc-protocol-types* *use-os-networking*)))
|
||||
|
||||
(defglobalparameter *use-os-networking* nil "If false, RPC will use Interlisp-D TCP/IP, if true RPC will use the host operating system's IPC mechanism.")
|
||||
|
||||
(defun rpc-around-exit (&optional event) (il:* il:|;;| "Set flag so when we wake up on Maiko we know to use RPCOS. User still has to have loaded it, though.") (case event ((il:afterlogout il:aftersysout il:aftersavevm il:aftermakesys nil) (setq *use-os-networking* (eq (il:machinetype) (quote il:maiko)))) (t nil)))
|
||||
(eval-when (load)
|
||||
|
||||
(il:appendtovar il:aroundexitfns rpc-around-exit)
|
||||
|
||||
|
||||
|
||||
|
||||
(il:* il:\;
|
||||
"This is an APPENDVARS so that RPC-AROUND-EXIT runs FIRST at startup, before GREET in particular")
|
||||
|
||||
|
||||
|
||||
(il:filesload (il:sysload) il:rpcstruct il:rpcrpc il:rpcxdr)
|
||||
|
||||
|
||||
(il:* il:\; "Load the appropriate transport.")
|
||||
|
||||
(cond ((rpc-around-exit) (il:* il:\; "On Maiko") (il:filesload (il:sysload) il:rpcos)) (t (il:* il:\; "Load only UDP. If you want to use RPC over TCP, you must load TCP yourself") (il:filesload (il:sysload) il:tcpllip il:tcpudp il:rpcudp)))
|
||||
|
||||
|
||||
(il:filesload (il:sysload) il:rpcportmapper)
|
||||
)
|
||||
(il:putprops il:rpc il:copyright ("Stanford University and Xerox Corporation" 1987 1988 1989))
|
||||
(il:declare\: il:dontcopy
|
||||
(il:filemap (nil)))
|
||||
il:stop
|
||||
BIN
nfs/RPC.DFASL
BIN
nfs/RPC.DFASL
Binary file not shown.
BIN
nfs/RPCCOMMON
BIN
nfs/RPCCOMMON
Binary file not shown.
117
nfs/RPCDECLS
117
nfs/RPCDECLS
@ -1,117 +0,0 @@
|
||||
(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "RPC2")
|
||||
(il:filecreated "11-Jan-89 14:52:06" il:|{NB:PARC:XEROX}<NFS>SOURCES>RPCDECLS.;2| 9474
|
||||
|
||||
il:|changes| il:|to:| (il:vars il:rpcdeclscoms) (il:variables *rpc-accept-program-unavailable* *portmapper-socket*)
|
||||
|
||||
il:|previous| il:|date:| "19-Oct-88 18:29:59" il:|{NB:PARC:XEROX}<NFS>SOURCES>RPCDECLS.;1|)
|
||||
|
||||
|
||||
; Copyright (c) 1988, 1989 by Xerox Corporation. All rights reserved.
|
||||
|
||||
(il:prettycomprint il:rpcdeclscoms)
|
||||
|
||||
(il:rpaqq il:rpcdeclscoms ((il:* il:|;;| "Macros useful for low-level RPC hacking.") (il:props (il:rpcdecls il:makefile-environment il:filetype)) (il:functions getbase-integer getbase-unsigned integer-from-bytes unsigned-from-bytes unsigned-from-signed putbase-integer foldlo unfold vector-base vector-offset padding-bytes) (il:* il:\; "Call methods") (il:functions rpc-method rpc-call-method reinitialize-rpcstream getbyte getrawbytes skipbytes getcell getoffset putbyte putrawbytes zerobytes putcell getunsigned putunsigned) (il:variables *words-per-cell* *bytes-per-cell* *bytes-per-word*) (il:* il:\; "Well-known RPC constants") (il:variables *rpc-msg-call* *rpc-msg-reply* *rpc-reply-accepted* *rpc-reply-rejected* *rpc-accept-success* *rpc-accept-program-unavailable* *rpc-version* *internal-time-units-per-msec* *portmapper-socket*) (il:* il:\; "For those that need IP/TCP stuff") (il:functions load-tcp-exports)))
|
||||
|
||||
|
||||
|
||||
(il:* il:|;;| "Macros useful for low-level RPC hacking.")
|
||||
|
||||
|
||||
(il:putprops il:rpcdecls il:makefile-environment (:readtable "XCL" :package "RPC2"))
|
||||
|
||||
(il:putprops il:rpcdecls il:filetype :compile-file)
|
||||
|
||||
(defmacro getbase-integer (base byteoffset) "Interpret 32 bits at BYTEOFFSET from BASE as a signed integer." (il:bquote (let ((base (il:\\addbase (il:\\\, base) (foldlo (il:\\\, byteoffset) *bytes-per-word*)))) (il:\\makenumber (il:\\getbase base 0) (il:\\getbase base 1)))))
|
||||
|
||||
(defmacro getbase-unsigned (base byteoffset) "Interpret 32 bits at BYTEOFFSET from BASE as an unsigned integer." (il:* il:|;;| "This differs from GETBASE-INTEGER only when the high bit is on, in which case we are forced to make (choke) a bignum, which we try to do efficiently.") (il:bquote (let* ((base (il:\\addbase (il:\\\, base) (foldlo (il:\\\, byteoffset) *bytes-per-word*))) (hi (il:\\getbase base 0))) (if (> hi 32767) (bignum-make-number hi (il:\\getbase base 1)) (il:\\makenumber hi (il:\\getbase base 1))))))
|
||||
|
||||
(defmacro integer-from-bytes (byte0 byte1 byte2 byte3) "Interprets these 32 bits as a signed integer" (il:bquote (il:\\makenumber (+ (unfold (il:\\\, byte0) 256) (il:\\\, byte1)) (+ (unfold (il:\\\, byte2) 256) (il:\\\, byte3)))))
|
||||
|
||||
(defmacro unsigned-from-bytes (byte0 byte1 byte2 byte3) "Interprets these 32 bits as an unsigned integer" (il:bquote (let* ((hi (+ (unfold (il:\\\, byte0) 256) (il:\\\, byte1))) (lo (+ (unfold (il:\\\, byte2) 256) (il:\\\, byte3)))) (if (> hi 32767) (bignum-make-number hi lo) (il:\\makenumber hi lo)))))
|
||||
|
||||
(defmacro unsigned-from-signed (value) "Interpret the 32 bits of VALUE's representation as an unsigned integer." (il:bquote (let ((value (il:\\\, value))) (if (> 0 value) (+ value twoto32nd) value))))
|
||||
|
||||
(defmacro putbase-integer (base byteoffset value) "Store integer VALUE at BYTEOFFSET bytes beyond BASE." (il:* il:|;;| "Note this handles both \"signed\" and \"unsigned\" numbers. We do type analysis here to avoid gratuitous consing when handling anything large.") (il:bquote (let ((base (il:\\addbase (il:\\\, base) (foldlo (il:\\\, byteoffset) *bytes-per-word*))) (value (il:\\\, value))) (cond ((il:smallp value) (il:* il:\; "An immediate value") (il:\\putbase base 0 (if (< value 0) 65535 0)) (il:\\putbase base 1 (il:\\loloc value))) ((eq (il:ntypx value) il:\\fixp) (il:* il:\; "A 32-bit integer box--just blt it") (il:\\blt base value 2)) (t (putbase-bignum base value))))))
|
||||
|
||||
(defmacro foldlo (form divisor) (let ((div (if (constantp divisor) (eval divisor) divisor))) (or (and div (il:poweroftwop div)) (il:\\illegal.arg div)) (list (quote il:lrsh) form (il:sub1 (il:integerlength div)))))
|
||||
|
||||
(defmacro unfold (form divisor) (let ((div (if (constantp divisor) (eval divisor) divisor))) (or (and div (il:poweroftwop div)) (il:\\illegal.arg div)) (list (quote il:llsh) form (il:sub1 (il:integerlength div)))))
|
||||
|
||||
(defmacro vector-base (vector) "Get raw string/vector base address. Use VECTOR-OFFSET, too, unless you know this is a brand new one without displacement." (il:bquote (il:|fetch| (il:oned-array il:base) il:|of| (il:\\\, vector))))
|
||||
|
||||
(defmacro vector-offset (vector) "Get raw vector offset. Interpretation depends on element type, of course." (il:bquote (il:|fetch| (il:oned-array il:offset) il:|of| (il:\\\, vector))))
|
||||
|
||||
(defmacro padding-bytes (bytecount) "Returns number of bytes needed to pad BYTECOUNT bytes out to a multiple of 32 bits." (il:bquote (let ((n (il:\\\, bytecount))) (- (logand (+ n 3) -4) n))))
|
||||
|
||||
|
||||
|
||||
(il:* il:\; "Call methods")
|
||||
|
||||
|
||||
(defmacro rpc-method (op stream) "Returns the function that implements OP (unevaluated) on STREAM." (il:bquote ((il:\\\, (intern (concatenate (quote string) "RPC-METHODS-" (string op)) "RPC2")) (rpc-stream-methods (il:\\\, stream)))))
|
||||
|
||||
(defmacro rpc-call-method (op &rest args) "Invoke the OP method on ARGS, the first of which must be the RPC-STREAM that defines the method" (il:bquote (funcall (rpc-method (il:\\\, op) (il:\\\, (first args))) (il:\\\,@ args))))
|
||||
|
||||
(defmacro reinitialize-rpcstream (stream destaddr destsocket) "Reuse an existing RPC Stream to send a new packet. Resets length counters, reinitializes packets, etc." (il:bquote (rpc-call-method initialize (il:\\\, stream) (il:\\\, destaddr) (il:\\\, destsocket))))
|
||||
|
||||
(defmacro getbyte (xdrstream) "Applies the GETBYTE method of an RPC Stream to read in and return the next byte of the stream." (il:bquote (rpc-call-method getbyte (il:\\\, xdrstream))))
|
||||
|
||||
(defmacro getrawbytes (xdrstream base offset nbytes) "Applies the GETRAWBYTES method of an RPC stream to read NBYTES bytes from the stream to BASE,OFFSET." (il:bquote (rpc-call-method getrawbytes (il:\\\, xdrstream) (il:\\\, base) (il:\\\, offset) (il:\\\, nbytes))))
|
||||
|
||||
(defmacro skipbytes (rpcstream nbytes) "Applies the SKIPBYTES method of an RPC stream to skip NBYTES bytes of input." (il:bquote (rpc-call-method skipbytes (il:\\\, rpcstream) (il:\\\, nbytes))))
|
||||
|
||||
(defmacro getcell (xdrstream) "Applies the GETCELL method of an RPC Stream to read in and return the next cell of the stream. A cell is a 32-bit two's complement integer." (il:bquote (rpc-call-method getcell (il:\\\, xdrstream))))
|
||||
|
||||
(defmacro getoffset (xdrstream) "Returns dotted pair (base . byteoffset), pointing at current position in incoming packet" (il:bquote (rpc-call-method getoffset (il:\\\, xdrstream))))
|
||||
|
||||
(defmacro putbyte (rpcstream value) "Applies the PUTBYTE method of an RPC Stream to write the byte VALUE on that stream. VALUE is an integer between 0 and 255 inclusive." (il:bquote (rpc-call-method putbyte (il:\\\, rpcstream) (il:\\\, value))))
|
||||
|
||||
(defmacro putrawbytes (rpcstream base offset nbytes) "Applies the PUTRAWBYTES method of an RPC stream to write the NBYTES bytes from BASE,OFFSET to the stream." (il:bquote (rpc-call-method putrawbytes (il:\\\, rpcstream) (il:\\\, base) (il:\\\, offset) (il:\\\, nbytes))))
|
||||
|
||||
(defmacro zerobytes (rpcstream nbytes) "Applies the ZEROBYTES method of an RPC stream to write NBYTES bytes of zero to the output." (il:bquote (rpc-call-method zerobytes (il:\\\, rpcstream) (il:\\\, nbytes))))
|
||||
|
||||
(defmacro putcell (rpcstream value) "Applies the PUTCELL method of an RPC Stream to write the cell VALUE on that stream. A cell is a 32-bit two's complement integer." (il:bquote (rpc-call-method putcell (il:\\\, rpcstream) (il:\\\, value))))
|
||||
|
||||
(defmacro getunsigned (rpcstream) "Fetch an unsigned 32-bit integer from RPCSTREAM. Uses the GETUNSIGNED method." (il:bquote (rpc-call-method getunsigned (il:\\\, rpcstream))))
|
||||
|
||||
(defmacro putunsigned (rpcstream value) "Write a 32-bit unsigned integer to RPCSTREAM. Uses PUTCELL method." (il:* il:|;;| "Note that no coercion is need here, because the bits of the bignum are the same as the bits of the signed integer.") (il:bquote (putcell (il:\\\, rpcstream) (il:\\\, value))))
|
||||
|
||||
(defconstant *words-per-cell* 2 "The number of words (16 bits) per cell.")
|
||||
|
||||
(defconstant *bytes-per-cell* 4 "Number of 8-bit bytes per RPC cell.")
|
||||
|
||||
(defconstant *bytes-per-word* 2)
|
||||
|
||||
|
||||
|
||||
(il:* il:\; "Well-known RPC constants")
|
||||
|
||||
|
||||
(defconstant *rpc-msg-call* 0 "Constant 0 in packet means RPC call, 1 means reply")
|
||||
|
||||
(defconstant *rpc-msg-reply* 1)
|
||||
|
||||
(defconstant *rpc-reply-accepted* 0 "Switch in reply body")
|
||||
|
||||
(defconstant *rpc-reply-rejected* 1 "Switch in reply body")
|
||||
|
||||
(defconstant *rpc-accept-success* 0 "Switch in accepted reply.")
|
||||
|
||||
(defconstant *rpc-accept-program-unavailable* 1)
|
||||
|
||||
(defconstant *rpc-version* 2 "This code will only work for SUN RPC Version 2")
|
||||
|
||||
(defconstant *internal-time-units-per-msec* (/ internal-time-units-per-second 1000) "This gets used in EXCHANGE-UDP-PACKETS.")
|
||||
|
||||
(defconstant *portmapper-socket* 111 "Well-known socket for portmapper")
|
||||
|
||||
|
||||
|
||||
(il:* il:\; "For those that need IP/TCP stuff")
|
||||
|
||||
|
||||
(defun load-tcp-exports nil (prog1 (il:filesload (il:source) il:tcpexports) (il:* il:\; "Now stop us from loading it again (This really ought to be on TCPEXPORTS)") (or (get (quote il:tcpexports) (quote il:filedates)) (setf (get (quote il:tcpexports) (quote il:filedates)) t))))
|
||||
(il:putprops il:rpcdecls il:copyright ("Xerox Corporation" 1988 1989))
|
||||
(il:declare\: il:dontcopy
|
||||
(il:filemap (nil)))
|
||||
il:stop
|
||||
Binary file not shown.
@ -1 +0,0 @@
|
||||
(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED " 8-Aug-88 11:21:37" {ERINYES}<LISPUSERS>MEDLEY>RPCLOWLEVEL.;3 3722
changes to%: (VARS RPCLOWLEVELCOMS) (FNS STRING.ZEROBYTES)
previous date%: " 8-Aug-88 11:13:29" {ERINYES}<LISPUSERS>MEDLEY>RPCLOWLEVEL.;2)
(* "
Copyright (c) 1987, 1988 by Stanford University and Xerox Corporation. All rights reserved.
")
(PRETTYCOMPRINT RPCLOWLEVELCOMS)
(RPAQQ RPCLOWLEVELCOMS ((PROPS (RPCLOWLEVEL MAKEFILE-ENVIRONMENT FILETYPE)) (FNS TCP.STREAM.SOCKET TCP.SOCKET.EVENT STRING.ZEROBYTES STRING.BOUTS STRING.BINS \IP.APPEND.BYTES UDP.APPEND.BYTES UDP.GET.BYTES UDP.MYGET.STRING \UDP.SET.CHECKSUM.ZERO) (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (SOURCE) TCPEXPORTS)) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (CHANGENAME (QUOTE UDP.SEND) (QUOTE \UDP.SET.CHECKSUM) (QUOTE \UDP.SET.CHECKSUM.ZERO))))))
(PUTPROPS RPCLOWLEVEL MAKEFILE-ENVIRONMENT (:READTABLE "INTERLISP" :PACKAGE "INTERLISP"))
(PUTPROPS RPCLOWLEVEL FILETYPE :COMPILE-FILE)
(DEFINEQ
(TCP.STREAM.SOCKET
(LAMBDA (STREAM) (* ; "Edited 27-Apr-88 21:51 by drc:") (* ;;; "Return IPSOCKET of a TCP Stream") (fetch TCB.IPSOCKET of (fetch F1 of STREAM)))
)
(TCP.SOCKET.EVENT
(LAMBDA (IPSOCKET) (* ; "Edited 27-Apr-88 21:51 by drc:") (* ;;; "For some reason Eric did not include this function, but it is identical to UDP.SOCKET.NUMBER, anyway.") (fetch (IPSOCKET IPSEVENT) of IPSOCKET))
)
(STRING.ZEROBYTES
(LAMBDA (STRING FIRST NBYTES) (* ; "Edited 5-Aug-88 18:20 by bvm") (* ;;; "Zero bytes of a string") (\CLEARBYTES (fetch (STRINGP BASE) of STRING) FIRST NBYTES))
)
(STRING.BOUTS
(LAMBDA (STREAM STRING FIRST NBYTES) (* ; "Edited 27-Apr-88 21:51 by drc:") (* ;;; "Write substring to stream") (\BOUTS STREAM (fetch (STRINGP BASE) of STRING) FIRST NBYTES))
)
(STRING.BINS
(LAMBDA (STREAM STRING FIRST NBYTES) (* ; "Edited 27-Apr-88 21:51 by drc:") (* ;;; "Read substring from stream") (\BINS STREAM (fetch (STRINGP BASE) of STRING) FIRST NBYTES))
)
(\IP.APPEND.BYTES
(LAMBDA (IP ADDR OFFSET LENGTH) (* ; "Edited 27-Apr-88 21:51 by drc:") (* ;;; "Append bytes (not necessarily a string) to IPPACKET. ") (\MOVEBYTES ADDR OFFSET (fetch (IP IPBASE) of IP) (fetch (IP IPTOTALLENGTH) of IP) LENGTH) (add (ffetch (IP IPTOTALLENGTH) of IP) LENGTH))
)
(UDP.APPEND.BYTES
(LAMBDA (UDP ADDR OFFSET NBYTES) (* ; "Edited 27-Apr-88 21:52 by drc:") (* ;;; "Append bytes (not necessarily a string) to UDP Packet") (\IP.APPEND.BYTES UDP ADDR OFFSET NBYTES) (add (fetch (UDP UDPLENGTH) of UDP) NBYTES))
)
(UDP.GET.BYTES
(LAMBDA (UDP SOFFSET DEST DOFFSET NBYTES) (* ; "Edited 27-Apr-88 21:52 by drc:") (* ;;; "Move bytes out of UDP Packet to another buffer without string creation") (\MOVEBYTES (fetch (UDP UDPCONTENTS) of UDP) SOFFSET DEST DOFFSET NBYTES) DEST)
)
(UDP.MYGET.STRING
(LAMBDA (UDP OFFSET LENGTH) (* ; "Edited 27-Apr-88 21:52 by drc:") (* ;;; "Fetch string from packet. String does not go to end of packet as in UDP.GET.STRING.") (OR (SMALLP OFFSET) (SETQ OFFSET 0)) (LET* ((STRING (ALLOCSTRING LENGTH))) (\MOVEBYTES (fetch (UDP UDPCONTENTS) of UDP) OFFSET (fetch (STRINGP BASE) of STRING) (fetch (STRINGP OFFST) of STRING) LENGTH) STRING))
)
(\UDP.SET.CHECKSUM.ZERO
(LAMBDA (UDP) (* ; "Edited 27-Apr-88 21:52 by drc:") (* ;;; "Avoid doing a UDP checksum. Packet already gets IP Checksum.") (replace (UDP UDPCHECKSUM) of UDP with 0))
)
)
(DECLARE%: EVAL@COMPILE DONTCOPY
(FILESLOAD (SOURCE) TCPEXPORTS)
)
(DECLARE%: DONTEVAL@LOAD DOCOPY
(CHANGENAME (QUOTE UDP.SEND) (QUOTE \UDP.SET.CHECKSUM) (QUOTE \UDP.SET.CHECKSUM.ZERO))
)
(PUTPROPS RPCLOWLEVEL COPYRIGHT ("Stanford University and Xerox Corporation" 1987 1988))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (1018 3418 (TCP.STREAM.SOCKET 1028 . 1196) (TCP.SOCKET.EVENT 1198 . 1432) (
STRING.ZEROBYTES 1434 . 1619) (STRING.BOUTS 1621 . 1815) (STRING.BINS 1817 . 2010) (\IP.APPEND.BYTES
2012 . 2309) (UDP.APPEND.BYTES 2311 . 2557) (UDP.GET.BYTES 2559 . 2821) (UDP.MYGET.STRING 2823 . 3218)
(\UDP.SET.CHECKSUM.ZERO 3220 . 3416)))))
STOP
|
||||
BIN
nfs/RPCOS.DFASL
BIN
nfs/RPCOS.DFASL
Binary file not shown.
@ -1,32 +0,0 @@
|
||||
(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "RPC2")
|
||||
(il:filecreated "15-Nov-88 14:31:18" il:|{NB:PARC:XEROX}<NFS>SOURCES>RPCPORTMAPPER.;2| 2519
|
||||
|
||||
il:|changes| il:|to:| (il:vars il:rpcportmappercoms)
|
||||
|
||||
il:|previous| il:|date:| "16-Sep-88 18:38:56" il:|{NB:PARC:XEROX}<NFS>SOURCES>RPCPORTMAPPER.;1|
|
||||
)
|
||||
|
||||
|
||||
; Copyright (c) 1987, 1988 by Stanford University and Xerox Corporation. All rights reserved.
|
||||
|
||||
(il:prettycomprint il:rpcportmappercoms)
|
||||
|
||||
(il:rpaqq il:rpcportmappercoms ((il:props (il:rpcportmapper il:makefile-environment il:filetype)) (eval-when (compile load eval) (il:structures mapsequence)) (il:functions portmapperdef) (eval-when (load) (il:p (portmapperdef)))))
|
||||
|
||||
(il:putprops il:rpcportmapper il:makefile-environment (:readtable "XCL" :package "RPC2"))
|
||||
|
||||
(il:putprops il:rpcportmapper il:filetype :compile-file)
|
||||
(eval-when (compile load eval)
|
||||
|
||||
(defstruct mapsequence program vers protocol port)
|
||||
)
|
||||
|
||||
(defun portmapperdef nil (il:* il:|;;| "Program that maps from programs to ports") (il:nill) (il:* il:\; "Keep DEFUN from expanding the DEFINE-REMOTE-PROGRAM macro any more than necessary") (when nil (il:* il:\; "This is what the result type of the DUMP protocol is formally specified as, but there's really no excuse for using this recursive definition in practice. ") (quote (mapstruct (:union :boolean (nil :void) (t (:struct mapstruct (program :unsigned) (vers :unsigned) (prot :unsigned) (port :unsigned) (therest mapstruct))))))) (define-remote-program (quote portmapper) 100000 2 (quote udp) :types (quote ((mapsequence (:sequence (:struct mapsequence (program :unsigned) (vers :unsigned) (protocol :unsigned) (port :unsigned)))))) :procedures (quote ((null 0 nil nil) (lookup 3 (:unsigned :unsigned :unsigned :unsigned) (:unsigned)) (dump 4 nil (mapsequence)) (indirect 5 (:unsigned :unsigned :unsigned :string) (:unsigned :string))))) (il:* il:|;;| "TCP version of same. Sad that we need this redundancy.") (define-remote-program (quote tcpportmapper) 100000 2 (quote tcp) :types (quote ((mapsequence (:sequence (:struct mapsequence (program :unsigned) (vers :unsigned) (protocol :unsigned) (port :unsigned)))))) :procedures (quote ((null 0 nil nil) (lookup 3 (:unsigned :unsigned :unsigned :unsigned) (:unsigned)) (dump 4 nil (mapsequence)) (indirect 5 (:unsigned :unsigned :unsigned :string) (:unsigned :string))))))
|
||||
(eval-when (load)
|
||||
|
||||
(portmapperdef)
|
||||
)
|
||||
(il:putprops il:rpcportmapper il:copyright ("Stanford University and Xerox Corporation" 1987 1988))
|
||||
(il:declare\: il:dontcopy
|
||||
(il:filemap (nil)))
|
||||
il:stop
|
||||
Binary file not shown.
1277
nfs/RPCRPC
1277
nfs/RPCRPC
File diff suppressed because it is too large
Load Diff
BIN
nfs/RPCRPC.DFASL
BIN
nfs/RPCRPC.DFASL
Binary file not shown.
@ -1,59 +0,0 @@
|
||||
(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "RPC2")
|
||||
(il:filecreated "21-Jun-89 17:56:08" il:|{NB:PARC:XEROX}<NFS>SOURCES>RPCSTRUCT.;3| 8883
|
||||
|
||||
il:|changes| il:|to:| (il:functions rpc-error-reply-report)
|
||||
|
||||
il:|previous| il:|date:| "20-Mar-89 15:51:49" il:{piglet/n}<piglet>nfs>sources>rpcstruct\;2)
|
||||
|
||||
|
||||
; Copyright (c) 1987, 1988, 1989 by Stanford University and Xerox Corporation. All rights reserved.
|
||||
|
||||
(il:prettycomprint il:rpcstructcoms)
|
||||
|
||||
(il:rpaqq il:rpcstructcoms ((il:props (il:rpcstruct il:makefile-environment il:filetype)) (eval-when (eval compile) (il:files il:rpcdecls) (il:p (il:* il:\; "For RPC-STREAM-PRINT-FUNCTION") (load-tcp-exports))) (il:functions rpc-stream-print-function) (il:structures rpc-stream rpc-methods rpc-program rpc-procedure authentication) (il:functions rpc-error-reply-report) (il:p (export (quote (rpc-error rpc-connection-error rpc-timeout rpc-error-reply rpc-no-socket xdr-error rpc-stream rpc-program rpc-procedure authentication rpc-stream-monitorlock rpc-stream-private)))) (il:structures rpc-error rpc-connection-error rpc-timeout rpc-error-reply rpc-no-socket xdr-error)))
|
||||
|
||||
(il:putprops il:rpcstruct il:makefile-environment (:readtable "XCL" :package "RPC2"))
|
||||
|
||||
(il:putprops il:rpcstruct il:filetype :compile-file)
|
||||
(eval-when (eval compile)
|
||||
|
||||
(il:filesload il:rpcdecls)
|
||||
|
||||
|
||||
(il:* il:\; "For RPC-STREAM-PRINT-FUNCTION")
|
||||
|
||||
(load-tcp-exports)
|
||||
)
|
||||
|
||||
(defun rpc-stream-print-function (obj stream depth) (let ((destaddr (rpc-stream-destaddr obj)) (destsocket (rpc-stream-destsocket obj))) (format stream "#<RPC ~A conn~@[ to ~A~@[#~A~]~]>" (rpc-stream-protocol obj) (if (integerp destaddr) (ipaddress-to-string destaddr) destaddr) (if (typep destsocket (quote rpc-program)) (rpc-program-name destsocket) destsocket))))
|
||||
|
||||
(defstruct (rpc-stream (:print-function rpc-stream-print-function)) "Holds info and functions for encoding, decoding and executing remote procedure calls" protocol (il:* il:\; "UDP, TCP, STRING, etc.") ipsocket (il:* il:\; "Local IP Socket") destaddr (il:* il:\; "Address of the destination.") destsocket (il:* il:\; "destination socket, or remote program whose socket should be looked up") instream (il:* il:\; "Incoming (Reply) Stream or Packet") inbyteptr (il:* il:\; "Byte Pointer to current position in incoming data. For UDP it is the byte pointer in the UDP packet. For TCP it is decremented, saying how many bytes left in this RM record before another RM header must be read.") outstream (il:* il:\; "UDP outgoing packet, or outgoing stream used by TCP and STRING.") outbyteptr (il:* il:\; "Byte Pointer to current position in UDP packet or outgoing buffer used to build RM record for TCP. See page 10 of \"Remote Procedure Call Protocol Specification\" for details of the RM 'Record Marking Standard'.") outstring (il:* il:\; "Buffer used by TCP to build RM record before sending") methods (il:* il:\; "Vector of operations") credentials (il:* il:\; "the credentials, if any, the caller gave us") credentials-cache (il:* il:\; "possible short credentials the server has given us") timeout-handler (il:* il:\; "what to do on timeouts") error-handler (il:* il:\; "what to do returned errors (this may not be the right place for these two)") socket-cache (il:* il:\; "Cached version of destsocket") private (il:* il:\; "Can be used by user as desired") monitorlock (il:* il:\; "Monitor which is locked during PERFORM-RPC."))
|
||||
|
||||
(defstruct (rpc-methods (:print-function (lambda (obj stream depth) (format stream "#<~A rpc methods>" (rpc-methods-protocol obj))))) "Vector of operations for a kind of rpc stream." protocol (il:* il:\; "UDP, TCP etc") (il:* il:|;;| "Input methods") getbyte (il:* il:\; "Function to read byte of incoming data") skipbytes (il:* il:\; "(stream #bytes) => skips number of bytes of incoming data") getcell (il:* il:\; "Function to get 32 bit two's complement integer of incoming data.") getunsigned (il:* il:\; "Function to get 32 bit unsigned integer from incoming data.") getoffset (il:* il:\; "Get current offset into incoming data (for string-pointer kludge)") getrawbytes (il:* il:\; "(stream base offset #bytes) -- bulk read of incoming data") (il:* il:|;;| "Output methods") putbyte (il:* il:\; "Function to write byte of outgoing data") zerobytes (il:* il:\; "(stream #bytes) writes zeros to output.") putcell (il:* il:\; "Function to write 32 bit two's complement integer of outgoing data.") putrawbytes (il:* il:\; "(stream base offset #bytes) -- bulk write of incoming data") (il:* il:|;;| "Miscellaneous methods") close (il:* il:\; "Function to cleanup stream when closed") initialize (il:* il:\; "(stream &optional destaddr destsocket) Sets up stream for beginning of call") exchange (il:* il:\; "(stream errorflg xid) performs the actual RPC exchange") openp (il:* il:\; "(stream) => true if still open"))
|
||||
|
||||
(defstruct (rpc-program (:print-function (lambda (pgm stream depth) (format stream "#<RPC Program ~S, #~D v~D>" (rpc-program-name pgm) (rpc-program-number pgm) (rpc-program-version pgm))))) "Structure describing a Sun RPC Protocol Remote Program." (number 0 :type integer) (il:* il:\; "RPC Program Number") (version 0 :type integer) (il:* il:\; "RPC Version Number") name (il:* il:\; "String or Symbol. This name is used only by this program and has no significance to the remote program. The name is assumed to uniquely specify an RPC structure. ") protocol (il:* il:\; "A symbol. Either RPC::UDP or RPC::TCP.") constants (il:* il:\; "List of (<constant> <def>) pairs.") types (il:* il:\; "List of (<typename> <typedef>) pairs") inherits (il:* il:\; "List of names of RPC names whose types and constants are inherited by this RPC.") procedures (il:* il:\; "List of RPC-PROCEDURE structures defining the procedures for this remote program."))
|
||||
|
||||
(defstruct (rpc-procedure (:print-function (lambda (p stream depth) (format stream "#<RPC Procedure ~S, #~D>" (rpc-procedure-name p) (rpc-procedure-procnum p))))) "Strcture defining a single procedure of a SUN RPC Protcol remote program.
|
||||
" name (il:* il:\; "The procedure name. A string or symbol.") (procnum 0 :type integer) (il:* il:\; "The procedure number. An integer.") argtypes (il:* il:\; "List of argument types. May be typenames or typedefs. NIL for no arguments.") resulttypes (il:* il:\; "Same as ARGTYPES except for returned values."))
|
||||
|
||||
(defstruct authentication "Sun RPC Version 2 Authentication Record" type (il:* il:\; "0 = NULL") (il:* il:\; "1 = Unix") (il:* il:\; "2 = Short") string (il:* il:\; "") (il:* il:\; "Encoding of any fields of that type authentication. String is a Common Lisp string rather than an XDR-STRING."))
|
||||
|
||||
(defun rpc-error-reply-report (condition stream) (il:* il:|;;| "Condition reporter for RPC-ERROR-REPLY. CONDITION has two slots, a TYPE and type-specific ARGS.") (let ((type (rpc-error-reply-type condition)) (args (rpc-error-reply-args condition))) (case type (program-unavailable (destructuring-bind (pgm . more) args (format stream "RPC Program ~@[~A ~]Unavailable~@[ ~A~]" (and (rpc-program-p pgm) (rpc-program-name pgm)) more))) (program-mismatch (format stream "RPC Program Version Mismatch: High: ~A Low: ~A" (first args) (second args))) (procedure-unavailable (format stream "RPC Procedure Unavailable")) (garbage-arguments (format stream "RPC Garbage Arguments")) (system-error (format stream "RPC System Error during call")) (rpc-version-mismatch (format stream "RPC Version Mismatch: High: ~A Low: ~A" (first args) (second args))) (authentication (format stream "Authentication Error: ~A" (first args))) (not-a-reply (format stream "RPC reply packet not of type reply: ~D" (first args))) (illegal-reply-type (format stream "Unknown RPC reply code: ~D" (first args))) (otherwise (format stream "RPC Error: ~A~@[ ~A~]" type args)))))
|
||||
|
||||
(export (quote (rpc-error rpc-connection-error rpc-timeout rpc-error-reply rpc-no-socket xdr-error rpc-stream rpc-program rpc-procedure authentication rpc-stream-monitorlock rpc-stream-private)))
|
||||
|
||||
(define-condition rpc-error (error))
|
||||
|
||||
(define-condition rpc-connection-error (rpc-error))
|
||||
|
||||
(define-condition rpc-timeout (rpc-connection-error) nil (:report "Timeout of RPC call"))
|
||||
|
||||
(define-condition rpc-error-reply (rpc-error) (type args) (:report rpc-error-reply-report))
|
||||
|
||||
(define-condition rpc-no-socket (rpc-connection-error) (program address) (:report (lambda (condition stream) (let ((prg (rpc-no-socket-program condition))) (format stream "Host ~A does not supply service ~A over ~A" (il:\\ip.address.to.string (rpc-no-socket-address condition)) (rpc-program-name prg) (rpc-program-protocol prg))))))
|
||||
|
||||
(define-condition xdr-error (rpc-connection-error) (format-string format-args) (:report (lambda (c stream) (apply (function format) stream (xdr-error-format-string c) (xdr-error-format-args c)))))
|
||||
(il:putprops il:rpcstruct il:copyright ("Stanford University and Xerox Corporation" 1987 1988 1989))
|
||||
(il:declare\: il:dontcopy
|
||||
(il:filemap (nil)))
|
||||
il:stop
|
||||
Binary file not shown.
283
nfs/RPCXDR
283
nfs/RPCXDR
@ -1,283 +0,0 @@
|
||||
(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "RPC2")
|
||||
(il:filecreated "17-Nov-88 15:29:51" il:|{NB:PARC:XEROX}<NFS>SOURCES>RPCXDR.;3| 31720
|
||||
|
||||
il:|changes| il:|to:| (il:functions xdr-enumeration-fault)
|
||||
|
||||
il:|previous| il:|date:| "11-Nov-88 18:45:06" il:|{NB:PARC:XEROX}<NFS>SOURCES>RPCXDR.;2|)
|
||||
|
||||
|
||||
; Copyright (c) 1987, 1988 by Stanford University and Xerox Corporation. All rights reserved.
|
||||
|
||||
(il:prettycomprint il:rpcxdrcoms)
|
||||
|
||||
(il:rpaqq il:rpcxdrcoms ((il:props (il:rpcxdr il:makefile-environment il:filetype)) (eval-when (eval compile) (il:files il:rpcdecls)) (il:coms (il:* il:\; "Useful Constants") (il:variables twoto31minusone twoto31st twoto32nd twoto32minusone twoto63minusone twoto64minusone twoto64th minus2to31 minus2to63)) (il:variables *xdr-primitive-types* *xdr-constructed-types* *xdr-codegen-recursivelst*) (il:structures typstk) (il:coms (il:* il:\; "Miscellaneous XDR Utility Functions") (il:functions access-fcn-name constructor-fcn-name find-in-type-stack)) (il:coms (il:* il:\; "Type Declarations and Predicates") (il:types xdr-integer xdr-unsigned xdr-hyperinteger xdr-hyperunsigned) (il:functions xdr-integer-p xdr-unsigned-p xdr-hyperinteger-p xdr-hyperunsigned-p)) (il:coms (il:* il:\; "XDR Code Generation for Constructed Functions") (il:functions xdr-codegen-comment xdr-codegen xdr-codegen-1 xdr-codegen-2 xdr-codegen-3 xdr-codegen-recursion xdr-codegen-constant xdr-codegen-enumeration xdr-codegen-union xdr-codegen-union-cases xdr-codegen-list xdr-codegen-struct xdr-codegen-fixed-array xdr-codegen-counted-array xdr-codegen-list-of xdr-codegen-opaque xdr-codegen-skip xdr-codegen-sequence)) (il:coms (il:* il:\; "XDR run-time primitives") (il:functions xdr-read-integer xdr-write-integer xdr-read-boolean xdr-write-boolean xdr-read-unsigned xdr-write-unsigned xdr-read-hyperinteger xdr-write-hyperinteger xdr-read-hyperunsigned xdr-write-hyperunsigned xdr-read-string xdr-write-string xdr-read-float xdr-write-float xdr-read-string-pointer xdr-read-array xdr-write-array xdr-write-string-pointer xdr-skip-primitive xdr-zero-primitive xdr-read-write-void xdr-enumeration-fault xdr-make-opaque) (il:* il:\; "These are for backward compatibility") (il:functions xdr-boolean xdr-integer xdr-unsigned xdr-hyperinteger xdr-hyperunsigned xdr-string xdr-string-pointer xdr-float xdr-void xdr-opaque-primitive))))
|
||||
|
||||
(il:putprops il:rpcxdr il:makefile-environment (:readtable "XCL" :package "RPC2"))
|
||||
|
||||
(il:putprops il:rpcxdr il:filetype :compile-file)
|
||||
(eval-when (eval compile)
|
||||
|
||||
(il:filesload il:rpcdecls)
|
||||
)
|
||||
|
||||
|
||||
|
||||
(il:* il:\; "Useful Constants")
|
||||
|
||||
|
||||
(defconstant twoto31minusone 2147483647)
|
||||
|
||||
(defconstant twoto31st 2147483648)
|
||||
|
||||
(defconstant twoto32nd 4294967296)
|
||||
|
||||
(defconstant twoto32minusone 4294967295)
|
||||
|
||||
(defconstant twoto63minusone 9223372036854775807)
|
||||
|
||||
(defconstant twoto64minusone 18446744073709551615)
|
||||
|
||||
(defconstant twoto64th 18446744073709551616)
|
||||
|
||||
(defconstant minus2to31 -2147483648)
|
||||
|
||||
(defconstant minus2to63 -9223372036854775808)
|
||||
|
||||
(defparameter *xdr-primitive-types* (quote ((:integer xdr-read-integer . xdr-write-integer) (:boolean xdr-read-boolean . xdr-write-boolean) (:unsigned xdr-read-unsigned . xdr-write-unsigned) (:hyperinteger xdr-read-hyperinteger . xdr-write-hyperinteger) (:hyperunsigned xdr-read-hyperunsigned . xdr-write-hyperunsigned) (:string xdr-read-string . xdr-write-string) (:void . xdr-read-write-void) (:float xdr-read-float . xdr-write-float) (:double . xdr-double) (:string-pointer xdr-read-string-pointer . xdr-write-string-pointer))) "An alist of XDR primitive types and the function(s) that encodes/decodes that type. If CDR is a list, it is (readfn . writefn).")
|
||||
|
||||
(defparameter *xdr-constructed-types* (quote ((:enumeration . xdr-codegen-enumeration) (:union . xdr-codegen-union) (:struct . xdr-codegen-struct) (:list . xdr-codegen-list) (:fixed-array . xdr-codegen-fixed-array) (:counted-array . xdr-codegen-counted-array) (:opaque . xdr-codegen-opaque) (:skip . xdr-codegen-skip) (:sequence . xdr-codegen-sequence) (:list-of . xdr-codegen-list-of))) "Association list of XDR constructed types and the functions that create functions to read/write them")
|
||||
|
||||
(defglobalvar *xdr-codegen-recursivelst* nil "
|
||||
Place for XDR-CODEGEN to save recursive functions it found in making an expansion.
|
||||
A list of TYPSTK structs
|
||||
")
|
||||
|
||||
(defstruct typstk "Element on stack of types for which code already generated." prog type xdrproc oper args)
|
||||
|
||||
|
||||
|
||||
(il:* il:\; "Miscellaneous XDR Utility Functions")
|
||||
|
||||
|
||||
(defun access-fcn-name (struct field) "
|
||||
Maps struct name and field name (strings or symbols) into the
|
||||
access function name for that slot." (il:* il:\; "") (intern (concatenate (quote string) (string struct) "-" (string field)) (symbol-package struct)))
|
||||
|
||||
(defun constructor-fcn-name (struct) "
|
||||
Maps a symbol or string naming a defstruct into the constructor function symbol
|
||||
for that defstruct type" (intern (concatenate (quote string) "MAKE-" (string struct)) (symbol-package struct)))
|
||||
|
||||
(defun find-in-type-stack (prg typ stack) "
|
||||
Find the first element in a list of TYPSTK's such that PRG and TYP
|
||||
match the PROG and TYPE fields of the TYPSTK.
|
||||
" (dolist (el stack) (if (and (eql prg (typstk-prog el)) (eql typ (typstk-type el))) (return el))))
|
||||
|
||||
|
||||
|
||||
(il:* il:\; "Type Declarations and Predicates")
|
||||
|
||||
|
||||
(deftype xdr-integer nil (quote (and integer (satisfies xdr-integer-p))))
|
||||
|
||||
(deftype xdr-unsigned nil (quote (and integer (satisfies xdr-unsigned-p))))
|
||||
|
||||
(deftype xdr-hyperinteger nil (quote (and integer (satisfies xdr-hyperinteger-p))))
|
||||
|
||||
(deftype xdr-hyperunsigned nil (quote (and integer (satisfies xdr-hyperunsigned-p))))
|
||||
|
||||
(defun xdr-integer-p (i) (and (>= i minus2to31) (< i twoto31st)))
|
||||
|
||||
(defun xdr-unsigned-p (i) (or (and (typep i (quote fixnum)) (>= (the fixnum i) 0)) (and (>= i 0) (< i twoto32nd))))
|
||||
|
||||
(defun xdr-hyperinteger-p (i) (and (>= i minus2to63) (<= i twoto63minusone)))
|
||||
|
||||
(defun xdr-hyperunsigned-p (i) (and (>= i 0) (<= i twoto64minusone)))
|
||||
|
||||
|
||||
|
||||
(il:* il:\; "XDR Code Generation for Constructed Functions")
|
||||
|
||||
|
||||
(defun xdr-codegen-comment nil "
|
||||
***************************************************
|
||||
**** Code Generation for XCL Constructed Types ****
|
||||
***************************************************
|
||||
The following functions generate code for translating between Common Lisp
|
||||
and XDR. For each function,
|
||||
CONTEXT is an RPC-PROGRAM structure with respect to which a
|
||||
typedef is being constructed.
|
||||
TYPEDEF is an XDR type definition, and
|
||||
OPER is either READ (decode) or WRITE (encode).
|
||||
For all functions except XDR-CODEGEN, a third argument ARGS is a list of
|
||||
arguments to the code being generated. It always begins with an XDR-stream argument
|
||||
and for OPER=WRITE is usually followed by the object to be written.
|
||||
|
||||
WARNINGS:
|
||||
|
||||
(1) DO NOT, REPEAT DO NOT pass an (XDR-CODEGEN-xxx) as the argument of an
|
||||
(XDR-CODEGEN-xxx). If you do, you might cause the code generated for
|
||||
the argument to be evaluated multiple times in the code for the resulting
|
||||
expression.
|
||||
|
||||
(2) The XDR-CODEGEN-xxx functions code in-line rather than wrap themselves
|
||||
in LET's or LAMBDA's or whatever. To avoid complications with functions
|
||||
that require a location-specifier (CHECK-TYPE or CCASE, for example), an
|
||||
XDR-CODEGEN-xxx function may ***not*** generate code that assumes that its
|
||||
arguments ARGS or various COUNTs are legitimate location-specifiers. If a
|
||||
CHECK-TYPE or similar function is to be done, a LET (or other binding
|
||||
mechanism) should be generated to create a legal location-specifier." nil)
|
||||
|
||||
(defun xdr-codegen (context typedef oper) "
|
||||
Top-level XDR Code Generation function. Returns code to read/write
|
||||
an XDR element of type TYPEDEF.
|
||||
|
||||
CONTEXT is an RPC-PROGRAM structure with respect to which the
|
||||
TYPEDEF is interpreted (in terms of inheritance).
|
||||
|
||||
TYPEDEF is an XDR Type or Type definition.
|
||||
|
||||
OPER is either 'RPC2::READ or 'RPC::WRITE.
|
||||
|
||||
See documentation of XDR-CODEGEN-COMMENT.
|
||||
" (setq *xdr-codegen-recursivelst* nil) (let* ((args (ecase oper (read (quote (xdr-stream))) (write (quote (xdr-stream xdr-toplevel-item))))) (fcn (xdr-codegen-1 context typedef oper args nil))) (if fcn (if (null *xdr-codegen-recursivelst*) (list (quote lambda) args fcn) (list (quote lambda) args (il:bquote (labels (il:\\\, (xdr-codegen-3 *xdr-codegen-recursivelst*)) (il:\\\, fcn))))) (error "Could not parse XDR Type ~S" typedef))))
|
||||
|
||||
(defun xdr-codegen-1 (context typedef oper args stk) "Generates code to read or write an element of type TYPEDEF.
|
||||
|
||||
CONTEXT, TYPEDEF, and OPER are as in XDR-CODEGEN.
|
||||
|
||||
ARGS is a list of the arguments forms for the generated code.
|
||||
For OPER=READ it will (<rpc-stream-name>), and
|
||||
For OPER=WRITE it will be (<rpc-stream-name> <element>).
|
||||
|
||||
STK is a list of TYPSTK elements, one for each named type above this one in this expansion." (or (cond ((symbolp typedef) (il:* il:\; "Primitive, local or inherited type") (let ((tem (cdr (assoc typedef *xdr-primitive-types*)))) (cond (tem (il:* il:\; "Here's how to read/write it.") (cons (cond ((not (consp tem)) (il:* il:\; "Old way is single fn") tem) ((eq oper (quote read)) (il:* il:\; "New way is (read . write)") (car tem)) (t (cdr tem))) args)) ((setq tem (find-rpc-typename context typedef)) (il:* il:\; "It's defined in this program") (xdr-codegen-2 context tem oper args stk)) (t (il:* il:\; "Try to inherit it") (some (function (lambda (progname) (let ((prg (find-rpc-program :name progname)) td) (and prg (setq td (find-rpc-typename prg typedef)) (xdr-codegen-2 prg td oper args stk))))) (rpc-program-inherits context)))))) ((consp typedef) (il:* il:\; "Constructed or qualified type") (let ((fn (cdr (assoc (car typedef) *xdr-constructed-types*))) prg td) (cond (fn (il:* il:\; "Here's a function to generate code") (funcall fn context typedef oper args stk)) ((and (symbolp (car typedef)) (symbolp (cdr typedef)) (setq prg (find-rpc-program :name (car typedef))) (setq td (find-rpc-typedef prg (cdr typedef)))) (il:* il:\; "Qualified def (prgname . type)") (xdr-codegen-2 prg td oper args stk)))))) (error "Could not resolve XDR Type Definition: ~S" typedef)))
|
||||
|
||||
(defun xdr-codegen-2 (context typename oper args stk) "
|
||||
Expands named types.
|
||||
|
||||
(1) Sees whether type already seen above here in this expansion.
|
||||
Otherwise,
|
||||
(2) Notes the name on TYPESTK,
|
||||
(3) Finds the definition of this type,
|
||||
(4) Calls XDR-CODEGEN-1 to expand the type definition.
|
||||
(5) Sees whether the XDR-CODEGEN-1 call found this type below,
|
||||
if so, notes this on *XDR-CODEGEN-RECURSIVELST* and returns
|
||||
call to the recursive function for this type.
|
||||
otherwise just returns the code.
|
||||
" (il:* il:|;;| "Every named type expansion passes through here and gets expanded. Since it is only named types that can be recursive, this is the only place we check for recursion") (or (xdr-codegen-recursion context typename oper args stk) (let (td code top) (il:* il:\; "No") (push (make-typstk :prog context :type typename :oper oper :args (if (eql oper (quote read)) args (quote (rpcstream rvalue)))) stk) (il:* il:\; "Push type on stack") (unless (setq td (find-rpc-typedef context typename)) (error "Null type definition for Program ~A, Type ~A" (and context (rpc-program-name context)) typename)) (setq code (xdr-codegen-1 context td oper args stk)) (il:* il:\; "Generate code") (setq top (car stk)) (il:* il:\; "\"Pop\" stack") (if (null (typstk-xdrproc top)) (il:* il:\; "Was this type called recursively?") code (il:* il:\; "No, just return code") (progn (push top *xdr-codegen-recursivelst*) (il:* il:\; "Yes, save recursive type") (il:bquote ((il:\\\, (typstk-xdrproc top)) (il:\\\,@ args))) (il:* il:\; "Return call to recursive function"))))))
|
||||
|
||||
(defun xdr-codegen-3 (rlist) (il:* il:|;;| "Generate the set of function definitions for LABELS. RLIST is a list of TYPSTK structs.") (mapcar (function (lambda (typstk) (il:bquote ((il:\\\, (typstk-xdrproc typstk)) (il:\\\, (typstk-args typstk)) (il:\\\, (xdr-codegen-1 (typstk-prog typstk) (or (find-rpc-typedef (typstk-prog typstk) (typstk-type typstk)) (error "No typedef for Program ~A, Type ~A" (rpc-program-name (typstk-prog typstk)) (typstk-type typstk))) (typstk-oper typstk) (typstk-args typstk) rlist)))))) rlist))
|
||||
|
||||
(defun xdr-codegen-recursion (prg typ oper args stack) (il:* il:|;;| " If type has already be seen, mark as recursive and return code calling that function") (let ((instack (find-in-type-stack prg typ stack))) (when instack (il:* il:\; "Seen it before") (setf (typstk-xdrproc instack) (or (typstk-xdrproc instack) (intern (symbol-name (gensym (concatenate (quote string) "XDR-" (symbol-name oper) "-" (symbol-name typ) "-")))))) (il:bquote ((il:\\\, (typstk-xdrproc instack)) (il:\\\,@ args))))))
|
||||
|
||||
(defun xdr-codegen-constant (context constant) (cond ((null constant) (error "Could not resolve nil constant definition from RPC program ~a~%" (rpc-program-name context))) ((integerp constant) constant) (il:* il:\; " Immediate Constant Definition") ((and (symbolp constant) (or (find-xdr-constant context constant) (il:* il:\; " Local Constant Definition") (some (function (lambda (cntx) (find-xdr-constant (find-rpc-program :name cntx) constant))) (rpc-program-inherits context)) (il:* il:\; " Inherited Constant Definition")))) ((and (consp constant) (il:* il:\; "Qualified Constant Definition ") (symbolp (cdr constant)) (find-xdr-constant (find-rpc-program :name (car constant)) (cdr constant)))) ((error "Could not resolve XDR constant ~a~%" constant))))
|
||||
|
||||
(defun xdr-codegen-enumeration (context typedef oper args stk) (let ((cases (cdr typedef)) (selector (if (eq oper (quote read)) (quote key) (cadr args))) default parent) (cond ((eq (first cases) :noerrors) (il:* il:\; "Means allow values other than shown here, which we will just represent by the integer value") (setq cases (cdr cases)) (setq default selector)) (t (il:* il:\; "Generate error clause if selector invalid. Inlcude the type that produced this enumeration if it's simple") (setq default (il:bquote (xdr-enumeration-fault (il:\\\, selector) (quote (il:\\\, oper)) (il:\\\,@ (and (consp stk) (symbolp (setq parent (typstk-type (first stk)))) (il:bquote ((quote (il:\\\, parent))))))))))) (if (eq oper (quote read)) (il:bquote (let ((key (xdr-read-integer (il:\\\, (car args))))) (case key (il:\\\,. (mapcar (function (lambda (x) (il:bquote ((il:\\\, (xdr-codegen-constant context (cadr x))) (quote (il:\\\, (car x))))))) cases)) (otherwise (il:\\\, default))))) (il:bquote (xdr-write-integer (il:\\\, (car args)) (case (il:\\\, selector) (il:\\\,. (mapcar (function (lambda (x) (list (car x) (xdr-codegen-constant context (cadr x))))) cases)) (otherwise (il:\\\, default))))))))
|
||||
|
||||
(defun xdr-codegen-union (context typedef oper args stk) "
|
||||
(UNION <discriminant-type> (<enumeration-element> <arm-type>) ...(<> <>))
|
||||
Read Calling Sequence: XDR-UNION(xdrstream)
|
||||
Read Input: An integer followed by the encoding of that arm.
|
||||
Read Output: The enumeration element from the type of the discriminant
|
||||
The discriminant and arm are returned as a dotted pair.
|
||||
Write Input: An enumeration element and an unencoded arm.
|
||||
Write calling sequence: XDR-UNION(xdrstream,discriminant,arm)
|
||||
Write Output: The (integer) encoding of the discriminant and the encoded arm.
|
||||
" (let ((discrim-type (second typedef)) (xdrstream (first args)) (unionlist (second args))) (if (eq oper (quote read)) (il:bquote (let ((discriminant (il:\\\, (xdr-codegen-1 context discrim-type oper args stk)))) (list discriminant (case discriminant (il:\\\,. (xdr-codegen-union-cases context typedef oper args stk)))))) (il:bquote (progn (il:\\\, (xdr-codegen-1 context discrim-type oper (il:bquote ((il:\\\, xdrstream) (car (il:\\\, unionlist)))) stk)) (case (car (il:\\\, unionlist)) (il:\\\,. (xdr-codegen-union-cases context typedef oper args stk))))))))
|
||||
|
||||
(defun xdr-codegen-union-cases (context typedef oper args stk) (il:* il:|;;| "Generate the clauses for a CASE statement which resolves the cases of TYPEDEF = (:UNION enum . cases).") (do ((pairs (cddr typedef) (cdr pairs)) (recurargs (if (eq oper (quote read)) args (il:* il:\; "For WRITE, ARGS = (stream item). Recursive calls will write (stream (cadr item)).") (il:bquote ((il:\\\, (first args)) (cadr (il:\\\, (second args))))))) (arms) (pair)) ((null pairs) (nreverse arms)) (setq pair (car pairs)) (push (il:bquote ((il:\\\, (if (or (eq (car pair) (quote otherwise)) (and (symbolp (car pair)) (string= (car pair) (quote default)))) (quote otherwise) (il:* il:\; "Default arm turns into OTHERWISE case.") (il:bquote ((il:\\\, (car pair)))))) (il:\\\, (xdr-codegen-1 context (cadr pair) oper recurargs stk)))) arms)))
|
||||
|
||||
(defun xdr-codegen-list (context typedef oper args stk) "TYPEDEF = (LIST <typedef-1> ... <typedef-n>)" (if (eq oper (quote read)) (il:bquote (list (il:\\\,. (mapcar (function (lambda (td) (xdr-codegen-1 context td oper args stk))) (cdr typedef))))) (let ((xdrstream (first args)) (thelist (second args)) (firsttime t)) (il:* il:|;;| "Walk down the list we're printing, generating code to write the CAR by the appropriate type def.") (il:bquote (let ((thelist (il:\\\, (second args)))) (il:\\\,@ (mapcar (function (lambda (type) (xdr-codegen-1 context type oper (il:bquote ((il:\\\, xdrstream) (car (il:\\\, (cond (firsttime (setq firsttime nil) (quote thelist)) (t (il:* il:\; "Get next tail") (quote (setq thelist (cdr thelist))))))))) stk))) (cdr typedef))))))))
|
||||
|
||||
(defun xdr-codegen-struct (context typedef oper args stk) "(STRUCT <defstruct-type> (<field-name> <type>) ... (<field-name> <type>))" (let ((struct-type (cadr typedef)) (xdrstream (first args)) (thestruct (second args))) (if (eq oper (quote read)) (il:bquote ((il:\\\, (constructor-fcn-name struct-type)) (il:* il:\; "Call the constructor with list of key val ...") (il:\\\,@ (mapcan (function (lambda (x) (il:* il:\; "X = (slotname type)") (list (intern (symbol-name (car x)) (find-package "KEYWORD")) (xdr-codegen-1 context (cadr x) oper args stk)))) (cddr typedef))))) (il:bquote (progn (il:\\\,@ (mapcar (function (lambda (x) (xdr-codegen-1 context (cadr x) oper (il:bquote ((il:\\\, xdrstream) ((il:\\\, (access-fcn-name struct-type (car x))) (il:\\\, thestruct)))) stk))) (cddr typedef))))))))
|
||||
|
||||
(defun xdr-codegen-fixed-array (context typedef oper args stk &optional run-time-count) "typedef is (:fixed-array elttype count), or (:counted-array elttype) with RUN-TIME-COUNT giving a run-time expression." (il:* il:|;;| "Read or write a sequence of exactly COUNT objects of type ELTTYPE") (let* ((element-type (second typedef)) (count (cond (run-time-count) (t (il:* il:\; "For FIXED-ARRAY, the count is a constant known at compile time and not encoded in the stream") (xdr-codegen-constant context (third typedef))))) (xdrstream (first args))) (unless run-time-count (check-type count (integer 0 *))) (if (eq oper (quote read)) (il:bquote (let* ((thecount (il:\\\, count)) (thearray (make-array thecount))) (dotimes (i thecount thearray) (setf (aref thearray i) (il:\\\, (xdr-codegen-1 context element-type oper args stk)))))) (il:bquote (let ((thearray (il:\\\, (second args)))) (dotimes (i (il:\\\, count) thearray) (il:\\\, (xdr-codegen-1 context element-type oper (il:bquote ((il:\\\, xdrstream) (aref thearray i))) stk))))))))
|
||||
|
||||
(defun xdr-codegen-counted-array (context typedef oper args stk) "typedef is (:counted-array element-type)" (il:* il:|;;| "Counted arrays are just like fixed arrays, except that they are preceded by their length (unsigned).") (if (eq oper (quote read)) (xdr-codegen-fixed-array context typedef oper args stk (xdr-codegen-1 context :unsigned oper args stk)) (let ((xdrstream (first args))) (il:bquote (let* ((thearray (il:\\\, (second args))) (thecount (length thearray))) (il:\\\, (xdr-codegen-1 context :unsigned oper (il:bquote ((il:\\\, xdrstream) thecount)) stk)) (il:\\\, (xdr-codegen-fixed-array context typedef oper (il:bquote ((il:\\\, xdrstream) thearray)) stk (quote thecount))))))))
|
||||
|
||||
(defun xdr-codegen-list-of (context typedef oper args stk) "typedef is (:list-of element-type)" (il:* il:|;;| "Read or write a list of elements all of the same type. Stream encoding is the length of the list followed by the elements.") (let ((element-type (second typedef)) (xdrstream (first args))) (if (eq oper (quote read)) (il:bquote (il:to (il:\\\, (xdr-codegen-1 context :unsigned oper args stk)) il:collect (il:\\\, (xdr-codegen-1 context element-type oper args stk)))) (il:bquote (let* ((thelist (il:\\\, (second args))) (thecount (list-length thelist))) (il:\\\, (xdr-codegen-1 context :unsigned oper (il:bquote ((il:\\\, xdrstream) thecount)) stk)) (mapc (function (lambda (obj) (il:\\\, (xdr-codegen-1 context element-type oper (il:bquote ((il:\\\, xdrstream) obj)) stk)))) thelist))))))
|
||||
|
||||
(defun xdr-codegen-opaque (context typedef oper args stk) "Declaration is (opaque <bytecount> <array-type>)" (let ((bytecount (xdr-codegen-constant context (second typedef))) (element-type (third typedef)) (xdrstream (first args))) (check-type bytecount (integer 0 *) "Opaque size must be integral") (il:* il:\; "Might want to check ELEMENT-TYPE here, too") (if (eq oper (quote read)) (il:bquote (xdr-read-array (il:\\\, xdrstream) (il:\\\, bytecount) (quote (il:\\\, element-type)))) (il:bquote (xdr-write-array (il:\\\, xdrstream) (il:\\\, bytecount) (quote (il:\\\, element-type)) (il:\\\, (second args)))))))
|
||||
|
||||
(defun xdr-codegen-skip (context typedef oper args stk) (let ((bytecount (xdr-codegen-constant context (second typedef)))) (check-type bytecount (integer 0 *)) (il:bquote ((il:\\\, (if (eql oper (quote read)) (quote xdr-skip-primitive) (quote xdr-zero-primitive))) (il:\\\, (first args)) (il:\\\, (logand (+ bytecount 3) -4))))))
|
||||
|
||||
(defun xdr-codegen-sequence (context typedef oper args stk) (il:* il:|;;| "Non-recursive way of handling a recursive type. Each item is preceded on the stream with a boolean T, than a boolean NIL follows the last arg. In Lisp, we represent this as a simple list.") (let ((stream (first args)) (elttype (second typedef))) (if (eq oper (quote read)) (il:bquote (il:while (xdr-read-boolean (il:\\\, stream)) il:collect (il:\\\, (xdr-codegen-1 context elttype oper args stk)))) (il:bquote (dolist (el (il:\\\, (second args)) (xdr-boolean (il:\\\, stream) nil)) (xdr-write-boolean (il:\\\, stream) t) (il:\\\, (xdr-codegen-1 context elttype oper (il:bquote ((il:\\\, stream) el)) stk)))))))
|
||||
|
||||
|
||||
|
||||
(il:* il:\; "XDR run-time primitives")
|
||||
|
||||
|
||||
(defun xdr-read-integer (xdrstream) (getcell xdrstream))
|
||||
|
||||
(defun xdr-write-integer (xdrstream value) (check-type value integer) (putcell xdrstream value))
|
||||
|
||||
(defun xdr-read-boolean (xdrstream) (let ((value (getcell xdrstream))) (case value (0 nil) (1 t) (otherwise (rpc-signal-error t (il:bquote (illegal-boolean (il:\\\, value))))))))
|
||||
|
||||
(defun xdr-write-boolean (xdrstream value) (putcell xdrstream (if (null value) 0 1)))
|
||||
|
||||
(defun xdr-read-unsigned (xdrstream) (getunsigned xdrstream))
|
||||
|
||||
(defun xdr-write-unsigned (xdrstream value) (putunsigned xdrstream value))
|
||||
|
||||
(defun xdr-read-hyperinteger (xdrstream) (let ((value (+ (ash (getunsigned xdrstream) 32) (getunsigned xdrstream)))) (if (> value twoto63minusone) (- value twoto64th) value)))
|
||||
|
||||
(defun xdr-write-hyperinteger (xdrstream value) (check-type value xdr-hyperinteger) (putunsigned xdrstream (ash value -32)) (putunsigned xdrstream (logand value twoto32minusone)))
|
||||
|
||||
(defun xdr-read-hyperunsigned (xdrstream) (+ (ash (getunsigned xdrstream) 32) (getunsigned xdrstream)))
|
||||
|
||||
(defun xdr-write-hyperunsigned (xdrstream value) (check-type value xdr-hyperunsigned) (putunsigned xdrstream (ash value -32)) (putunsigned xdrstream (logand value twoto32minusone)))
|
||||
|
||||
(defun xdr-read-string (xdrstream) (let* ((nbytes (xdr-unsigned xdrstream)) (string (il:allocstring nbytes))) (getrawbytes xdrstream (vector-base string) 0 nbytes) (skipbytes xdrstream (padding-bytes nbytes)) string))
|
||||
|
||||
(defun xdr-write-string (xdrstream string) (check-type string string) (when (and (il:%fat-string-array-p string) (il:%fat-string-array-p (setq string (copy-seq string)))) (il:* il:\; "Only 8-bit chars supported in xdr. COPY-SEQ is just in case it was all thin chars in a formerly fat string.") (error "XDR string contains NS characters: ~S" string)) (let ((nbytes (il:nchars string))) (xdr-unsigned xdrstream nbytes) (putrawbytes xdrstream (vector-base string) (vector-offset string) nbytes) (zerobytes xdrstream (padding-bytes nbytes))))
|
||||
|
||||
(defun xdr-read-float (xdrstream) (il:* il:|;;| "Read a single-precision IEEE floating point number. Fortunately, that's our internal format as well.") (let ((value (il:ncreate (quote il:floatp)))) (getrawbytes xdrstream value 0 4)))
|
||||
|
||||
(defun xdr-write-float (xdrstream v) (il:* il:|;;| "Write a single-precision IEEE floating point number. Fortunately, that's our internal format as well.") (putrawbytes xdrstream (il:\\dtest v (quote floatp)) 0 4))
|
||||
|
||||
(defun xdr-read-string-pointer (xdrstream) "This is a gross hack to handle what amounts to bulk data." (let* ((nbytes (xdr-unsigned xdrstream)) (place (getoffset xdrstream)) (packet (car place)) (byteoffset (cdr place))) (il:* il:|;;| "This only works for UDP!!") (il:* il:|;;| "Returns ((packet . byteoffset) . number-of-bytes))") (prog1 (cons (cons packet byteoffset) nbytes) (skipbytes xdrstream (padding-bytes nbytes)))))
|
||||
|
||||
(defun xdr-read-array (xdrstream bytecount element-type) "Read an opaque array of bytecount bytes." (let ((quadbytecount (logand (+ bytecount 3) -4))) (il:* il:|;;| "QUADBYTECOUNT is BYTECOUNT rounded up to multiple of 4, which is the number of actual bytes on the stream. Note that we will always be able to read the extra bytes, if any, in the same operation because arrays in this system are always a multiple of 4 bytes long.") (if (eq element-type :unboxed) (let ((array (il:\\allocblock (ash quadbytecount -2)))) (il:* il:\; "Just get into raw array block") (getrawbytes xdrstream array 0 quadbytecount) array) (let ((array (make-array bytecount :element-type (or element-type (quote string-char))))) (il:* il:\; "Read into array of specified type. We assume the type packs tensely") (getrawbytes xdrstream (il:|fetch| (il:oned-array il:base) il:|of| array) 0 quadbytecount) array))))
|
||||
|
||||
(defun xdr-write-array (xdrstream bytecount element-type array) "Write an opaque array of bytecount bytes." (cond ((null array) (il:* il:\; "Convenient shorthand: write all zeros") (zerobytes xdrstream bytecount)) ((eq element-type :unboxed) (putrawbytes xdrstream array 0 bytecount)) (t (putrawbytes xdrstream (il:|fetch| (il:oned-array il:base) il:|of| array) (il:|fetch| (il:oned-array il:offset) il:|of| array) bytecount))))
|
||||
|
||||
(defun xdr-write-string-pointer (xdrstream value) "This is a gross hack to handle what amounts to bulk data." (il:* il:|;;| "Value is ((buffer . offset) . nbytes), where the first element can be just buffer if offset is zero.") (let* ((buffer (car value)) (nbytes (cdr value)) (outstream (rpc-stream-outstream xdrstream)) (offset 0)) (when (consp buffer) (setq offset (cdr buffer) buffer (car buffer))) (xdr-unsigned xdrstream nbytes) (putrawbytes xdrstream buffer offset nbytes) (zerobytes xdrstream (padding-bytes nbytes))))
|
||||
|
||||
(defun xdr-skip-primitive (xdrstream n) (skipbytes xdrstream n))
|
||||
|
||||
(defun xdr-zero-primitive (xdrstream n) (zerobytes xdrstream n))
|
||||
|
||||
(defmacro xdr-read-write-void (&rest ignore) "VOID type compiles into this" (quote (progn nil)))
|
||||
|
||||
(defun xdr-enumeration-fault (key oper type) (il:* il:|;;| "Called when you try to read/write (per OPER) the value KEY, which is not valid for an enumeration. TYPE may be the parent type.") (case oper (read (cerror "Return the integer ~D as the value" "Read unrecognized value ~D for enumeration type~@[ ~S~]~@[ in program ~A~]" key type (and *program* (rpc-program-name *program*))) key) (write (error "~S not a valid value for enumeration type~@[ ~S~]~@[ in program ~A~]" key type (and *program* (rpc-program-name *program*))))))
|
||||
|
||||
(defun xdr-make-opaque (bytecount &optional element-type) "Create an XDR object of type (:opaque bytecount element-type) initialized to zero." (if (eq element-type :unboxed) (il:\\allocblock (ash (+ bytecount 3) -2)) (make-array bytecount :element-type (or element-type (quote string-char)))))
|
||||
|
||||
|
||||
|
||||
(il:* il:\; "These are for backward compatibility")
|
||||
|
||||
|
||||
(defun xdr-boolean (xdrstream &optional (value t writep)) (cond (writep (putcell xdrstream (if (null value) 0 1))) (t (setq value (getcell xdrstream)) (ccase value (0 nil) (1 t)))))
|
||||
|
||||
(defun xdr-integer (xdrstream &optional (value nil writep)) (cond (writep (check-type value integer) (putcell xdrstream value)) (t (getcell xdrstream))))
|
||||
|
||||
(defun xdr-unsigned (xdrstream &optional (value nil writep)) (if writep (putunsigned xdrstream value) (getunsigned xdrstream)))
|
||||
|
||||
(defun xdr-hyperinteger (xdrstream &optional (value nil writep)) (cond (writep (xdr-write-hyperinteger xdrstream value)) (t (xdr-read-hyperinteger xdrstream))))
|
||||
|
||||
(defun xdr-hyperunsigned (xdrstream &optional (value nil writep)) (cond (writep (xdr-write-hyperunsigned xdrstream value)) (t (xdr-read-hyperunsigned xdrstream))))
|
||||
|
||||
(defun xdr-string (xdrstream &optional (string nil writep)) (cond (writep (check-type string string) (when (and (il:%fat-string-array-p string) (il:%fat-string-array-p (setq string (copy-seq string)))) (il:* il:\; "Only 8-bit chars supported in xdr. COPY-SEQ is just in case it was all thin chars in a formerly fat string.") (error "XDR string contains NS characters: ~S" string)) (let ((nbytes (il:nchars string))) (xdr-unsigned xdrstream nbytes) (putrawbytes xdrstream (vector-base string) (vector-offset string) nbytes) (zerobytes xdrstream (padding-bytes nbytes)))) (t (let* ((nbytes (xdr-unsigned xdrstream)) (string (il:allocstring nbytes))) (getrawbytes xdrstream (vector-base string) 0 nbytes) (skipbytes xdrstream (padding-bytes nbytes)) string))))
|
||||
|
||||
(defun xdr-string-pointer (xdrstream &optional (value t writep)) "This is a gross hack to handle what amounts to bulk data." (if writep (let* ((buffer (car value)) (nbytes (cdr value)) (outstream (rpc-stream-outstream xdrstream)) (offset 0)) (il:* il:\; "Value is ((buffer . offset) . nbytes), where the first element can be just buffer if offset is zero.") (when (consp buffer) (setq offset (cdr buffer) buffer (car buffer))) (xdr-unsigned xdrstream nbytes) (putrawbytes xdrstream buffer offset nbytes) (zerobytes xdrstream (padding-bytes nbytes))) (let* ((nbytes (xdr-unsigned xdrstream)) (place (getoffset xdrstream)) (packet (car place)) (byteoffset (cdr place))) (il:* il:|;;| "This only works for UDP!!") (il:* il:|;;| "Returns ((packet . byteoffset) . number-of-bytes))") (prog1 (cons (cons packet byteoffset) nbytes) (skipbytes xdrstream (padding-bytes nbytes))))))
|
||||
|
||||
(defun xdr-float (xdrstream &optional (v nil writep)) (il:* il:|;;| "Read or write a single-precision IEEE floating point number. Fortunately, that's our internal format as well.") (if writep (putrawbytes xdrstream (il:\\dtest v (quote floatp)) 0 4) (let ((value (il:ncreate (quote il:floatp)))) (getrawbytes xdrstream value 0 4))))
|
||||
|
||||
(defun xdr-void (xdrstream &optional (value t writep)) nil)
|
||||
|
||||
(defun xdr-opaque-primitive (xdrstream nbytes &optional (string nil writep)) (il:* il:|;;| "Strictly for backward-compatibility with old compiled rpc code") (cond (writep (putrawbytes xdrstream (il:|fetch| (il:stringp il:base) il:|of| string) (il:|fetch| (il:stringp il:offst) il:|of| string) nbytes) (unless (eql (setq nbytes (logand nbytes 3)) 0) (dotimes (i (- 4 nbytes)) (putbyte xdrstream 0)))) (t (let ((string (il:allocstring nbytes))) (getrawbytes xdrstream (il:|fetch| (il:stringp il:base) il:|of| string) (il:|fetch| (il:stringp il:offst) il:|of| string) nbytes) (unless (eql (setq nbytes (logand nbytes 3)) 0) (dotimes (i (- 4 nbytes)) (getbyte xdrstream))) string))))
|
||||
(il:putprops il:rpcxdr il:copyright ("Stanford University and Xerox Corporation" 1987 1988))
|
||||
(il:declare\: il:dontcopy
|
||||
(il:filemap (nil)))
|
||||
il:stop
|
||||
BIN
nfs/RPCXDR.DFASL
BIN
nfs/RPCXDR.DFASL
Binary file not shown.
420
nfs/TCPEXPORTS
420
nfs/TCPEXPORTS
@ -1,420 +0,0 @@
|
||||
(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
|
||||
(LISPXPRIN1 "EXPORTS GATHERED FROM {ERIS}<LispCore>Library>TCP*.; ON 11-Sep-89 16:08:46" T)
|
||||
(LISPXTERPRI T)
|
||||
(RPAQQ \TCP.CTRL.ACK 16)
|
||||
(RPAQQ \TCP.CTRL.FIN 1)
|
||||
(RPAQQ \TCP.CTRL.PSH 8)
|
||||
(RPAQQ \TCP.CTRL.RST 4)
|
||||
(RPAQQ \TCP.CTRL.SYN 2)
|
||||
(RPAQQ \TCP.CTRL.URG 32)
|
||||
(CONSTANTS \TCP.CTRL.ACK \TCP.CTRL.FIN \TCP.CTRL.PSH \TCP.CTRL.RST \TCP.CTRL.SYN \TCP.CTRL.URG)
|
||||
(RPAQQ \TCPOPT.END 0)
|
||||
(RPAQQ \TCPOPT.NOP 1)
|
||||
(RPAQQ \TCPOPT.MAXSEG 2)
|
||||
(CONSTANTS \TCPOPT.END \TCPOPT.NOP \TCPOPT.MAXSEG)
|
||||
(RPAQQ \TCP.PROTOCOL 6)
|
||||
(CONSTANTS \TCP.PROTOCOL)
|
||||
(RPAQQ \TCP.HEADER.LENGTH 20)
|
||||
(CONSTANTS \TCP.HEADER.LENGTH)
|
||||
(RPAQQ \TCP.MIN.DATA.OFFSET 5)
|
||||
(CONSTANTS \TCP.MIN.DATA.OFFSET)
|
||||
(RPAQQ \TCP.DEFAULT.MAXSEG 536)
|
||||
(CONSTANTS \TCP.DEFAULT.MAXSEG)
|
||||
(ACCESSFNS TCPSEGMENT ((TCPHEADER (\IPDATABASE DATUM))) (BLOCKRECORD TCPHEADER ((TCP.SRC.PORT WORD) (
|
||||
TCP.DST.PORT WORD) (TCP.SEQ FIXP) (TCP.ACK FIXP) (TCP.DATA.OFFSET BITS 4) (TCP.MBZ BITS 6) (TCP.CTRL
|
||||
BITS 6) (TCP.WINDOW WORD) (TCP.CHECKSUM WORD) (TCP.URG.PTR WORD))) (ACCESSFNS TCPSEGMENT ((
|
||||
TCP.DATA.LENGTH (fetch (IP IPHEADERCHECKSUM) of DATUM) (replace (IP IPHEADERCHECKSUM) of DATUM with
|
||||
NEWVALUE)) (TCP.SRC.ADDR (fetch (IP IPSOURCEADDRESS) of DATUM) (replace (IP IPSOURCEADDRESS) of DATUM
|
||||
with NEWVALUE)) (TCP.DST.ADDR (fetch (IP IPDESTINATIONADDRESS) of DATUM) (replace (IP
|
||||
IPDESTINATIONADDRESS) of DATUM with NEWVALUE)) (TCP.HEADER.LENGTH (LLSH (fetch TCP.DATA.OFFSET of
|
||||
DATUM) 2)) (TCP.CONTENTS (\ADDBASE (fetch TCPHEADER of DATUM) (UNFOLD (fetch TCP.DATA.OFFSET of DATUM)
|
||||
WORDSPERCELL))) (TCP.OPTIONS (\ADDBASE (fetch TCPHEADER of DATUM) (UNFOLD \TCP.MIN.DATA.OFFSET
|
||||
WORDSPERCELL))))))
|
||||
(DATATYPE TCP.CONTROL.BLOCK ((TCB.LOCK POINTER) (* ; "monitor lock for synchronizing access") (
|
||||
TCB.STATE POINTER) (* ;
|
||||
"one of CLOSED LISTEN SYN.SENT SYN.RECEIVED ESTABLISHED FIN.WAIT.1 FIN.WAIT.2 CLOSE.WAIT CLOSING LAST.ACK TIME.WAIT"
|
||||
) (TCB.SND.STREAM POINTER) (* ; "user's send stream") (TCB.SND.SEGMENT POINTER) (* ;
|
||||
"current output packet being filled") (TCB.RCV.STREAM POINTER) (* ; "user's receive stream") (
|
||||
TCB.RCV.SEGMENT POINTER) (* ; "current input packet being read") (TCB.2MSL.TIMER POINTER) (* ;
|
||||
"2*MSL quiet time") (TCB.MAXSEG POINTER) (* ; "maximum segment size") (TCB.CLOSEDFLG POINTER) (* ;
|
||||
"T if user has initiated close (no more data to send)") (TCB.FINSEQ POINTER) (* ;
|
||||
"one past the sequence number of the FIN we sent") (TCB.ACKFLG POINTER) (* ;
|
||||
"when to ACK peer: NOW or LATER") (TCB.TEMPLATE POINTER) (* ; "TCP header template") (TCB.PH POINTER)
|
||||
(* ; "TCP pseudo-header for checksumming") (TCB.SRC.PORT WORD) (* ; "local port") (TCB.DST.PORT WORD)
|
||||
(* ; "remote port") (TCB.DST.HOST FIXP) (* ; "remote host address") (TCB.INPUT.QUEUE POINTER) (* ;
|
||||
"queue of received segments to be read") (TCB.REXMT.QUEUE POINTER) (* ;
|
||||
"queue of unacked segments to be retransmitted") (TCB.SND.UNA FIXP) (* ;
|
||||
"first unacknowledged sequence number") (TCB.SND.NXT FIXP) (* ; "next sequence number to be sent") (
|
||||
TCB.SND.UP FIXP) (* ; "send urgent pointer") (TCB.SND.WL1 FIXP) (* ;
|
||||
"segment sequence number used for last window update") (TCB.SND.WL2 FIXP) (* ;
|
||||
"segment acknowledgment number used for last window update") (TCB.ISS FIXP) (* ;
|
||||
"initial send sequence number") (TCB.SND.WND WORD) (* ; "send window") (TCB.RCV.WND WORD) (* ;
|
||||
"receive window") (TCB.RCV.NXT FIXP) (* ; "next sequence number expected") (TCB.RCV.UP FIXP) (* ;
|
||||
"receive urgent pointer") (TCB.IRS FIXP) (* ; "initial receive sequence number") (TCB.USER.TIMEOUT
|
||||
POINTER) (* ; "in milliseconds") (TCB.ESTABLISHED POINTER) (* ;
|
||||
"processes waiting for this event are notified when the connection becomes established") (
|
||||
TCB.SND.EVENT POINTER) (* ;
|
||||
"processes waiting for this event are notified when the send window opens up") (TCB.RCV.EVENT POINTER)
|
||||
(* ; "processes waiting for this event are notified when data is received") (TCB.URGENT.EVENT POINTER
|
||||
) (* ; "processes waiting for this event are notified when urgent data is received") (
|
||||
TCB.FINACKED.EVENT POINTER) (* ;
|
||||
"processes waiting for this event are notified when our FIN has been acked") (TCB.MODE POINTER) (* ;
|
||||
"ACTIVE or PASSIVE") (TCB.RTFLG POINTER) (* ; "T if round trip time being measured") (TCB.RTSEQ
|
||||
POINTER) (* ; "sequence number being timed") (TCB.RTTIMER POINTER) (* ; "round trip timer") (TCB.SRTT
|
||||
POINTER) (* ; "smoothed round trip time") (TCB.RTO POINTER) (* ;
|
||||
"retransmission timeout based on smoothed round trip time") (TCB.PROBE.TIMER POINTER) (* ;
|
||||
"timer for delayed ACKs and window probes") (TCB.IPSOCKET POINTER) (* ;
|
||||
"Pointer to open IP socket for this connection") (TCB.PROCESS POINTER) (* ;
|
||||
"TCP monitor process for this connection") (TCB.SENT.ZERO FLAG) (* ;
|
||||
"Sent a zero allocation last time") (TCB.OUTPUT.HELD FLAG) (* ; "True if output window shut") (
|
||||
TCB.NO.IDLE.PROBING FLAG) (* ; "True if we don't probe when nothing to output") (NIL BITS 5) (
|
||||
TCB.OUR.MAXSEG WORD) (TCB.LAST.SENT.RCV.WND WORD) (* ; "The value of the last rcv window we sent"))
|
||||
TCB.LOCK _ (CREATE.MONITORLOCK) TCB.STATE _ (QUOTE CLOSED) TCB.RCV.WND _ \TCP.DEFAULT.RECEIVE.WINDOW
|
||||
TCB.USER.TIMEOUT _ \TCP.DEFAULT.USER.TIMEOUT TCB.ESTABLISHED _ (CREATE.EVENT) TCB.SND.EVENT _ (
|
||||
CREATE.EVENT) TCB.RCV.EVENT _ (CREATE.EVENT) TCB.URGENT.EVENT _ (CREATE.EVENT) TCB.FINACKED.EVENT _ (
|
||||
CREATE.EVENT) TCB.MAXSEG _ \TCP.DEFAULT.MAXSEG TCB.OUR.MAXSEG _ \TCP.DEFAULT.MAXSEG TCB.SRTT _
|
||||
\TCP.INITIAL.RTO TCB.RTO _ \TCP.INITIAL.RTO)
|
||||
(ACCESSFNS TCPSTREAM ((TCB (fetch (STREAM F1) of DATUM) (replace (STREAM F1) of DATUM with NEWVALUE))
|
||||
(BYTECOUNT (fetch (STREAM F2) of DATUM) (replace (STREAM F2) of DATUM with NEWVALUE)) (ACCESS (fetch (
|
||||
STREAM ACCESS) of DATUM) (replace (STREAM ACCESS) of DATUM with NEWVALUE)) (ORIGINAL.COFFSET (fetch (
|
||||
STREAM FW6) of DATUM) (replace (STREAM FW6) of DATUM with NEWVALUE))) (CREATE (create STREAM DEVICE _
|
||||
\TCP.DEVICE)))
|
||||
(PUTPROP (QUOTE TCP) (QUOTE IMPORTDATE) (IDATE " 6-Sep-89 17:01:28"))
|
||||
|
||||
(PUTPROP (QUOTE TCPCHAT) (QUOTE IMPORTDATE) (IDATE " 7-Jul-88 18:21:44"))
|
||||
|
||||
(RECORD IPINIT (LOCAL.ADDRESSES LOCAL.NETWORKS DEFAULT.GATEWAY HTE.FILE HOSTNAME SUBNETMASK
|
||||
DOMAIN.SERVERS LOCAL.DOMAIN LOCAL.NSHOSTNUMBER))
|
||||
(PUTPROP (QUOTE TCPCONFIG) (QUOTE IMPORTDATE) (IDATE "18-Apr-88 21:05:32"))
|
||||
|
||||
(PUTPROP (QUOTE TCPDEBUG) (QUOTE IMPORTDATE) (IDATE "16-Apr-87 15:16:27"))
|
||||
|
||||
(RPAQQ \UDPDOMAIN.WDS 6)
|
||||
(CONSTANTS (\UDPDOMAIN.WDS 6))
|
||||
(BLOCKRECORD DOMAIN.HEADER ((ID WORD) (RESPONSEFLG FLAG) (OPCODE BITS 4) (AUTHORITYFLG FLAG) (
|
||||
TRUNCATEDFLG FLAG) (WANTRECURSEFLG FLAG) (CANRECURSEFLG FLAG) (NIL BITS 3) (RESPONSECODE BITS 4) (
|
||||
QDCOUNT WORD) (ANCOUNT WORD) (NSCOUNT WORD) (ARCOUNT WORD)))
|
||||
(RPAQQ DOMAIN.OPCODES ((DOMAIN.QUERY 0) (DOMAIN.IQUERY 1) (DOMAIN.CQUERYM 2) (DOMAIN.CQUERYU 3)))
|
||||
(RPAQQ DOMAIN.QUERY 0)
|
||||
(RPAQQ DOMAIN.IQUERY 1)
|
||||
(RPAQQ DOMAIN.CQUERYM 2)
|
||||
(RPAQQ DOMAIN.CQUERYU 3)
|
||||
(CONSTANTS (DOMAIN.QUERY 0) (DOMAIN.IQUERY 1) (DOMAIN.CQUERYM 2) (DOMAIN.CQUERYU 3))
|
||||
(RPAQQ DOMAIN.RCODES ((RCODE.OK 0) (RCODE.FORMATERROR 1) (RCODE.SERVERFAILED 2) (RCODE.NAMEERROR 3) (
|
||||
RCODE.NOTIMPLEMENTED 4) (RCODE.REFUSED 5)))
|
||||
(RPAQQ RCODE.OK 0)
|
||||
(RPAQQ RCODE.FORMATERROR 1)
|
||||
(RPAQQ RCODE.SERVERFAILED 2)
|
||||
(RPAQQ RCODE.NAMEERROR 3)
|
||||
(RPAQQ RCODE.NOTIMPLEMENTED 4)
|
||||
(RPAQQ RCODE.REFUSED 5)
|
||||
(CONSTANTS (RCODE.OK 0) (RCODE.FORMATERROR 1) (RCODE.SERVERFAILED 2) (RCODE.NAMEERROR 3) (
|
||||
RCODE.NOTIMPLEMENTED 4) (RCODE.REFUSED 5))
|
||||
(RPAQQ DOMAIN.RRTYPES ((RRTYPE.A 1) (RRTYPE.NS 2) (RRTYPE.MD 3) (RRTYPE.MF 4) (RRTYPE.CNAME 5) (
|
||||
RRTYPE.SOA 6) (RRTYPE.MB 7) (RRTYPE.MG 8) (RRTYPE.MR 9) (RRTYPE.NULL 10) (RRTYPE.WKS 11) (RRTYPE.PTR
|
||||
12) (RRTYPE.HINFO 13) (RRTYPE.MINFO 14) (RRTYPE.MX 15)))
|
||||
(RPAQQ RRTYPE.A 1)
|
||||
(RPAQQ RRTYPE.NS 2)
|
||||
(RPAQQ RRTYPE.MD 3)
|
||||
(RPAQQ RRTYPE.MF 4)
|
||||
(RPAQQ RRTYPE.CNAME 5)
|
||||
(RPAQQ RRTYPE.SOA 6)
|
||||
(RPAQQ RRTYPE.MB 7)
|
||||
(RPAQQ RRTYPE.MG 8)
|
||||
(RPAQQ RRTYPE.MR 9)
|
||||
(RPAQQ RRTYPE.NULL 10)
|
||||
(RPAQQ RRTYPE.WKS 11)
|
||||
(RPAQQ RRTYPE.PTR 12)
|
||||
(RPAQQ RRTYPE.HINFO 13)
|
||||
(RPAQQ RRTYPE.MINFO 14)
|
||||
(RPAQQ RRTYPE.MX 15)
|
||||
(CONSTANTS (RRTYPE.A 1) (RRTYPE.NS 2) (RRTYPE.MD 3) (RRTYPE.MF 4) (RRTYPE.CNAME 5) (RRTYPE.SOA 6) (
|
||||
RRTYPE.MB 7) (RRTYPE.MG 8) (RRTYPE.MR 9) (RRTYPE.NULL 10) (RRTYPE.WKS 11) (RRTYPE.PTR 12) (
|
||||
RRTYPE.HINFO 13) (RRTYPE.MINFO 14) (RRTYPE.MX 15))
|
||||
(RPAQQ DOMAIN.CLASSTYPES ((CLASSTYPE.IN 1) (CLASSTYPE.CSNET 2) (CLASSTYPE.CHAOS 3)))
|
||||
(RPAQQ CLASSTYPE.IN 1)
|
||||
(RPAQQ CLASSTYPE.CSNET 2)
|
||||
(RPAQQ CLASSTYPE.CHAOS 3)
|
||||
(CONSTANTS (CLASSTYPE.IN 1) (CLASSTYPE.CSNET 2) (CLASSTYPE.CHAOS 3))
|
||||
(RPAQQ \DOMAIN.PORT 53)
|
||||
(CONSTANTS (\DOMAIN.PORT 53))
|
||||
(PUTPROP (QUOTE tcpdomain) (QUOTE IMPORTDATE) (IDATE "15-Feb-88 17:40:22"))
|
||||
|
||||
(PUTPROP (QUOTE tcpexports) (QUOTE IMPORTDATE) (IDATE " 6-Sep-89 17:23:47"))
|
||||
|
||||
(ACCESSFNS TCPDATASTREAM ((TCPCONTROLDEVICE (fetch (STREAM F3) of DATUM) (replace (STREAM F3) of DATUM
|
||||
with NEWVALUE)) (SEENEOS (fetch (STREAM F4) of DATUM) (replace (STREAM F4) of DATUM with NEWVALUE)) (
|
||||
TCPFTPCON (fetch (STREAM F5) of DATUM) (replace (STREAM F5) of DATUM with NEWVALUE))))
|
||||
(RECORD TCPFTPCON (TCPIN TCPOUT DATASTREAM BUSY? IDLETIMER GENERATEFILESDIRECTORY))
|
||||
(PUTPROP (QUOTE TCPFTP) (QUOTE IMPORTDATE) (IDATE "11-Sep-89 15:22:47"))
|
||||
|
||||
(PUTPROP (QUOTE tcpftpsrv) (QUOTE IMPORTDATE) (IDATE "24-Aug-87 18:26:25"))
|
||||
|
||||
(PUTPROP (QUOTE TCPHTE) (QUOTE IMPORTDATE) (IDATE "24-May-88 17:06:10"))
|
||||
|
||||
(ACCESSFNS AR ((ARBASE (LOCF (fetch (ETHERPACKET EPBODY) of DATUM)))) (BLOCKRECORD ARBASE ((
|
||||
ARHARDWARESPACE WORD) (ARPROTOCOLSPACE WORD) (ARHARDWARELEN BYTE) (ARPROTOCOLLEN BYTE) (AROPCODE WORD)
|
||||
(AR1STWORD WORD)) (ACCESSFNS AR1STWORD ((ARCONTENTS (LOCF DATUM))))))
|
||||
(ACCESSFNS ARETHER ((ARETHERBASE (fetch (AR ARCONTENTS) of DATUM))) (BLOCKRECORD ARETHERBASE ((
|
||||
ARLCLHDW0 WORD) (ARLCLHDW1 WORD) (ARLCLHDW2 WORD) (ARLCLPTCL FIXP) (ARFRNHDW0 WORD) (ARFRNHDW1 WORD) (
|
||||
ARFRNHDW2 WORD) (ARFRNPTCL FIXP)) (ACCESSFNS ARLCLHDW0 ((ARSENDERHDW (\LOADNSHOSTNUMBER (LOCF DATUM))
|
||||
(\STORENSHOSTNUMBER (LOCF DATUM) NEWVALUE)))) (ACCESSFNS ARFRNHDW0 ((ARTARGETHDW (\LOADNSHOSTNUMBER (
|
||||
LOCF DATUM)) (\STORENSHOSTNUMBER (LOCF DATUM) NEWVALUE))))))
|
||||
(ACCESSFNS AREXPETHER ((ARETHERBASE (fetch (AR ARCONTENTS) of DATUM))) (BLOCKRECORD ARETHERBASE ((
|
||||
ARLCLHDW WORD) (ARLCLPTCL FIXP) (ARFRNHDW WORD) (ARFRNPTCL FIXP))))
|
||||
(DATATYPE ARENTRY ((RECENT FLAG) (SEARCHING FLAG) (IPADDRESS POINTER) (ETHERADDRESS POINTER) (TIMER
|
||||
POINTER)) TIMER _ (NCREATE (QUOTE FIXP)))
|
||||
(RPAQQ \AR.HARDWARE.SPACE.ETHERNET 1)
|
||||
(RPAQQ \AR.ETHERNET.ADDRESS.LENGTH 6)
|
||||
(RPAQQ \AR.IP.ADDRESS.LENGTH 4)
|
||||
(RPAQQ \AR.REQUEST 1)
|
||||
(RPAQQ \AR.RESPONSE 2)
|
||||
(RPAQQ \AR.ETHER.PACKET.LENGTH 28)
|
||||
(CONSTANTS (\AR.HARDWARE.SPACE.ETHERNET 1) (\AR.ETHERNET.ADDRESS.LENGTH 6) (\AR.IP.ADDRESS.LENGTH 4) (
|
||||
\AR.REQUEST 1) (\AR.RESPONSE 2) (\AR.ETHER.PACKET.LENGTH 28))
|
||||
(PUTPROP (QUOTE TCPLLAR) (QUOTE IMPORTDATE) (IDATE " 6-Sep-89 15:50:14"))
|
||||
|
||||
(ACCESSFNS ICMPADMASK ((ICMPADMASKBASE (fetch (ICMP ICMPCONTENTS) of DATUM))) (BLOCKRECORD
|
||||
ICMPADMASKBASE ((ICMPADMASKID WORD) (ICMPADMASKSEQNO WORD) (ICMPADMASKADMASK FIXP))))
|
||||
(ACCESSFNS ICMP ((ICMPBASE (\IPDATABASE DATUM))) (BLOCKRECORD ICMPBASE ((ICMPTYPE BYTE) (ICMPCODE BYTE
|
||||
) (ICMPCHECKSUM WORD) (ICMPDATASTART WORD))) (ACCESSFNS ICMP ((ICMPCONTENTS (LOCF (fetch (ICMP
|
||||
ICMPDATASTART) of DATUM))))))
|
||||
(ACCESSFNS ICMPECHO ((ICMPECHOBASE (fetch (ICMP ICMPCONTENTS) of DATUM))) (BLOCKRECORD ICMPECHOBASE ((
|
||||
ICMPECHOID WORD) (ICMPECHOSEQNO WORD) (ICMPECHODATA BYTE))))
|
||||
(ACCESSFNS ICMPDESTUN ((ICMPECHOBASE (fetch (ICMP ICMPCONTENTS) of DATUM))) (BLOCKRECORD ICMPECHOBASE
|
||||
((NIL FIXP) (ICMPIPSTART WORD))) (ACCESSFNS ICMPDESTUN ((ICMPIPHEADER (LOCF (fetch (ICMPDESTUN
|
||||
ICMPIPSTART) of DATUM))))))
|
||||
(ACCESSFNS ICMPREDIRECT ((ICMPREDIRECTBASE (fetch (ICMP ICMPCONTENTS) of DATUM))) (BLOCKRECORD
|
||||
ICMPREDIRECTBASE ((ICMPGATEWAY FIXP) (ICMPIPSTART WORD))) (ACCESSFNS ICMPREDIRECT ((ICMPIPHEADER (LOCF
|
||||
(fetch (ICMPREDIRECT ICMPIPSTART) of DATUM))))))
|
||||
(RPAQQ ICMPTYPES ((\ICMP.ECHO.REPLY 0) (\ICMP.DEST.UNREACHABLE 3) (\ICMP.SOURCE.QUENCH 4) (
|
||||
\ICMP.REDIRECT 5) (\ICMP.ECHO 8) (\ICMP.TIME.EXCEEDED 11) (\ICMP.PARAMETER.PROBLEM 12) (
|
||||
\ICMP.TIMESTAMP 13) (\ICMP.TIMESTAMP.REPLY 14) (\ICMP.INFO.REQUEST 15) (\ICMP.INFO.REPLY 16) (
|
||||
\ICMP.ADDRESS.MASK.REQUEST 17) (\ICMP.ADDRESS.MASK.REPLY 18)))
|
||||
(RPAQQ \ICMP.ECHO.REPLY 0)
|
||||
(RPAQQ \ICMP.DEST.UNREACHABLE 3)
|
||||
(RPAQQ \ICMP.SOURCE.QUENCH 4)
|
||||
(RPAQQ \ICMP.REDIRECT 5)
|
||||
(RPAQQ \ICMP.ECHO 8)
|
||||
(RPAQQ \ICMP.TIME.EXCEEDED 11)
|
||||
(RPAQQ \ICMP.PARAMETER.PROBLEM 12)
|
||||
(RPAQQ \ICMP.TIMESTAMP 13)
|
||||
(RPAQQ \ICMP.TIMESTAMP.REPLY 14)
|
||||
(RPAQQ \ICMP.INFO.REQUEST 15)
|
||||
(RPAQQ \ICMP.INFO.REPLY 16)
|
||||
(RPAQQ \ICMP.ADDRESS.MASK.REQUEST 17)
|
||||
(RPAQQ \ICMP.ADDRESS.MASK.REPLY 18)
|
||||
(CONSTANTS (\ICMP.ECHO.REPLY 0) (\ICMP.DEST.UNREACHABLE 3) (\ICMP.SOURCE.QUENCH 4) (\ICMP.REDIRECT 5)
|
||||
(\ICMP.ECHO 8) (\ICMP.TIME.EXCEEDED 11) (\ICMP.PARAMETER.PROBLEM 12) (\ICMP.TIMESTAMP 13) (
|
||||
\ICMP.TIMESTAMP.REPLY 14) (\ICMP.INFO.REQUEST 15) (\ICMP.INFO.REPLY 16) (\ICMP.ADDRESS.MASK.REQUEST 17
|
||||
) (\ICMP.ADDRESS.MASK.REPLY 18))
|
||||
(RPAQQ ICMPUNREACHABLES ((\ICMP.NET.UNREACHABLE 0) (\ICMP.HOST.UNREACHABLE 1) (
|
||||
\ICMP.PROTOCOL.UNREACHABLE 2) (\ICMP.PORT.UNREACHABLE 3) (\ICMP.CANT.FRAGMENT 4) (\ICMP.SOURCE.ROUTE 5
|
||||
)))
|
||||
(RPAQQ \ICMP.NET.UNREACHABLE 0)
|
||||
(RPAQQ \ICMP.HOST.UNREACHABLE 1)
|
||||
(RPAQQ \ICMP.PROTOCOL.UNREACHABLE 2)
|
||||
(RPAQQ \ICMP.PORT.UNREACHABLE 3)
|
||||
(RPAQQ \ICMP.CANT.FRAGMENT 4)
|
||||
(RPAQQ \ICMP.SOURCE.ROUTE 5)
|
||||
(CONSTANTS (\ICMP.NET.UNREACHABLE 0) (\ICMP.HOST.UNREACHABLE 1) (\ICMP.PROTOCOL.UNREACHABLE 2) (
|
||||
\ICMP.PORT.UNREACHABLE 3) (\ICMP.CANT.FRAGMENT 4) (\ICMP.SOURCE.ROUTE 5))
|
||||
(RPAQQ ICMPREDIRECTS ((\ICMP.REDIRECT.NET 0) (\ICMP.REDIRECT.HOST 1) (\ICMP.REDIRECT.SVC.AND.NET 2) (
|
||||
\ICMP.REDIRECT.SVC.AND.HOST 3)))
|
||||
(RPAQQ \ICMP.REDIRECT.NET 0)
|
||||
(RPAQQ \ICMP.REDIRECT.HOST 1)
|
||||
(RPAQQ \ICMP.REDIRECT.SVC.AND.NET 2)
|
||||
(RPAQQ \ICMP.REDIRECT.SVC.AND.HOST 3)
|
||||
(CONSTANTS (\ICMP.REDIRECT.NET 0) (\ICMP.REDIRECT.HOST 1) (\ICMP.REDIRECT.SVC.AND.NET 2) (
|
||||
\ICMP.REDIRECT.SVC.AND.HOST 3))
|
||||
(RPAQQ ICMPTIMEXS ((\ICMP.TRANSIT.TIME.EXCEEDED 0) (\ICMP.FRAGMENT.TIME.EXCEEDED 1)))
|
||||
(RPAQQ \ICMP.TRANSIT.TIME.EXCEEDED 0)
|
||||
(RPAQQ \ICMP.FRAGMENT.TIME.EXCEEDED 1)
|
||||
(CONSTANTS (\ICMP.TRANSIT.TIME.EXCEEDED 0) (\ICMP.FRAGMENT.TIME.EXCEEDED 1))
|
||||
(RPAQQ \ICMPOVLEN 4)
|
||||
(CONSTANTS \ICMPOVLEN)
|
||||
(RPAQQ \ICMP.PROTOCOL 1)
|
||||
(CONSTANTS \ICMP.PROTOCOL)
|
||||
(PUTPROPS ICMPLENGTH MACRO (LAMBDA (ICMP) (IDIFFERENCE (fetch (IP IPTOTALLENGTH) of ICMP) (LLSH (fetch
|
||||
(IP IPHEADERLENGTH) of ICMP) 2))))
|
||||
(PUTPROP (QUOTE TCPLLICMP) (QUOTE IMPORTDATE) (IDATE " 6-Sep-89 16:28:51"))
|
||||
|
||||
(ACCESSFNS IP ((IPBASE (LOCF (fetch (ETHERPACKET EPBODY) of DATUM)))) (BLOCKRECORD IPBASE ((IPVERSION
|
||||
BITS 4) (* ; "Protocol version") (IPHEADERLENGTH BITS 4) (* ; "Head length, in cells") (IPSERVICE BYTE
|
||||
) (* ; "Service type") (IPTOTALLENGTH WORD) (* ; "Packet length, in bytes") (IPID WORD) (* ;
|
||||
"Packet id") (NIL BITS 1) (IPDONTFRAGMENT FLAG) (* ; "Don't fragment me") (IPMOREFRAGMENTS FLAG) (* ;
|
||||
"Last fragment") (IPFRAGMENTOFFSET BITS 13) (* ; "Fragment position") (IPTIMETOLIVE BYTE) (* ;
|
||||
"Hop limiter") (IPPROTOCOL BYTE) (* ; "Client protocol") (IPHEADERCHECKSUM WORD) (* ;
|
||||
"Header-only checksum") (IPSOURCEADDRESS FIXP) (IPDESTINATIONADDRESS FIXP) (IPOPTIONSSTART BYTE) (* ;
|
||||
"Options or data start here")) (ACCESSFNS IPSERVICE ((IPSERVICEBASE (LOCF DATUM))) (BLOCKRECORD
|
||||
IPSERVICEBASE ((IPPRECEDENCE BITS 3) (IPDELAY FLAG) (IPTHROUGHPUT FLAG) (IPRELIABILITY FLAG) (NIL BITS
|
||||
2)))) (* ;
|
||||
"Replace is not supported on any of the following because there is ambiguity about the address class."
|
||||
) (ACCESSFNS IPDESTINATIONADDRESS ((IPDESTBASE (LOCF DATUM))) (ACCESSFNS IPDESTBASE ((IPDESTINATIONNET
|
||||
(COND ((EQ \IP.CLASS.A (fetch (IPADDRESS CLASSA) of DATUM)) (fetch (IPADDRESS CLASSANET) of DATUM)) (
|
||||
(EQ \IP.CLASS.B (fetch (IPADDRESS CLASSB) of DATUM)) (fetch (IPADDRESS CLASSBNET) of DATUM)) (T (* ;
|
||||
"Class C or error") (fetch (IPADDRESS CLASSCNET) of DATUM)))) (IPDESTINATIONHOST (COND ((EQ
|
||||
\IP.CLASS.A (fetch (IPADDRESS CLASSA) of DATUM)) (fetch (IPADDRESS CLASSAHOST) of DATUM)) ((EQ
|
||||
\IP.CLASS.B (fetch (IPADDRESS CLASSB) of DATUM)) (fetch (IPADDRESS CLASSBHOST) of DATUM)) (T (* ;
|
||||
"Class C or error") (fetch (IPADDRESS CLASSCHOST) of DATUM))))))) (ACCESSFNS IPSOURCEADDRESS ((
|
||||
IPSOURCEBASE (LOCF DATUM))) (ACCESSFNS IPSOURCEBASE ((IPSOURCENET (COND ((EQ \IP.CLASS.A (fetch (
|
||||
IPADDRESS CLASSA) of DATUM)) (fetch (IPADDRESS CLASSANET) of DATUM)) ((EQ \IP.CLASS.B (fetch (
|
||||
IPADDRESS CLASSB) of DATUM)) (fetch (IPADDRESS CLASSBNET) of DATUM)) (T (fetch (IPADDRESS CLASSCNET)
|
||||
of DATUM)))) (IPSOURCEHOST (COND ((EQ \IP.CLASS.A (fetch (IPADDRESS CLASSA) of DATUM)) (fetch (
|
||||
IPADDRESS CLASSAHOST) of DATUM)) ((EQ \IP.CLASS.B (fetch (IPADDRESS CLASSB) of DATUM)) (fetch (
|
||||
IPADDRESS CLASSBHOST) of DATUM)) (T (fetch (IPADDRESS CLASSCHOST) of DATUM)))))))) (TYPE? (type?
|
||||
ETHERPACKET DATUM)))
|
||||
(DATATYPE IPSOCKET ((PROTOCOL BYTE) (IPSLINK POINTER) (* ; "Other sockets of this protocol type") (NIL
|
||||
BYTE) (IPSQUEUE POINTER) (* ; "Queue of packets for this protocol") (IPSQUEUELENGTH WORD) (* ;
|
||||
"Count of packets of input queue") (IPSQUEUEALLOC WORD) (* ; "Max count allowed") (
|
||||
IPSDESTSOCKETCOMPAREFN POINTER) (* ; "Call this to compare dest protocol socket to this socket") (
|
||||
IPSOCKET POINTER) (* ; "This socket") (IPSINPUTFN POINTER) (* ; "Call to hand packet to protocol") (
|
||||
IPSEVENT POINTER) (* ; "Notify me when a packet arrives") (IPSNOSOCKETFN POINTER) (* ;
|
||||
"Call this when no socket found") (IPSICMPFN POINTER) (* ;
|
||||
"Call this when an ICMP packet is received on this protocol")) IPSQUEUE _ (create SYSQUEUE)
|
||||
IPSQUEUEALLOC _ \IP.MAX.EPKTS.ON.QUEUE IPSEVENT _ (CREATE.EVENT) IPSINPUTFN _ (FUNCTION
|
||||
\IP.DEFAULT.INPUTFN) IPSICMPFN _ (FUNCTION \RELEASE.ETHERPACKET))
|
||||
(BLOCKRECORD IPADDRESS ((ADDRESS FIXP)) (* ;; "Class A nets: high bit is 0") (BLOCKRECORD IPADDRESS ((
|
||||
CLASSA BITS 1) (CLASSANET BITS 7) (CLASSAHOST BITS 24))) (* ;; "Class B nets: high 2 bits are 10") (
|
||||
BLOCKRECORD IPADDRESS ((CLASSB BITS 2))) (BLOCKRECORD IPADDRESS ((CLASSBNET BITS 16) (CLASSBHOST BITS
|
||||
16))) (* ;; "Class C nets: high 3 bits are 110") (BLOCKRECORD IPADDRESS ((CLASSC BITS 3))) (
|
||||
BLOCKRECORD IPADDRESS ((CLASSCNETB1 BITS 8) (CLASSCNETB2 BITS 8) (CLASSCNETB3 BITS 8) (CLASSCHOST BITS
|
||||
8))) (* ; "I wish I could say just net bits 24, host bits 8, but BLOCKRECORD barfs") (BLOCKRECORD
|
||||
IPADDRESS ((CLASSCNETHI BITS 16))) (ACCESSFNS IPADDRESS ((CLASSCNET (\MAKENUMBER (FETCH CLASSCNETB1 OF
|
||||
DATUM) (LOGOR (LLSH (FETCH CLASSCNETB2 OF DATUM) 8) (FETCH CLASSCNETB3 OF DATUM))) (PROGN (REPLACE
|
||||
CLASSCNETHI OF DATUM WITH (LRSH NEWVALUE 8)) (REPLACE CLASSCNETB3 OF DATUM WITH (LOGAND NEWVALUE 255))
|
||||
DATUM)))))
|
||||
(RPAQQ \IPOVLEN 20)
|
||||
(RPAQQ \MAX.IPDATALENGTH 556)
|
||||
(RPAQQ \IP.PROTOCOLVERSION 4)
|
||||
(RPAQQ \IP.MAX.EPKTS.ON.QUEUE 16)
|
||||
(RPAQQ \IP.DEFAULT.TIME.TO.LIVE 120)
|
||||
(RPAQQ \IP.WAKEUP.INTERVAL 15000)
|
||||
(CONSTANTS \IPOVLEN \MAX.IPDATALENGTH \IP.PROTOCOLVERSION \IP.MAX.EPKTS.ON.QUEUE
|
||||
\IP.DEFAULT.TIME.TO.LIVE \IP.WAKEUP.INTERVAL)
|
||||
(RPAQQ IPPACKETTYPES ((\EPT.IP 2048) (\EPT.AR 2054) (\EET.IP 513) (\EPT.CHAOS 2052)))
|
||||
(RPAQQ \EPT.IP 2048)
|
||||
(RPAQQ \EPT.AR 2054)
|
||||
(RPAQQ \EET.IP 513)
|
||||
(RPAQQ \EPT.CHAOS 2052)
|
||||
(CONSTANTS (\EPT.IP 2048) (\EPT.AR 2054) (\EET.IP 513) (\EPT.CHAOS 2052))
|
||||
(RPAQQ ICMPUNREACHABLES ((\ICMP.NET.UNREACHABLE 0) (\ICMP.HOST.UNREACHABLE 1) (
|
||||
\ICMP.PROTOCOL.UNREACHABLE 2) (\ICMP.PORT.UNREACHABLE 3) (\ICMP.CANT.FRAGMENT 4) (\ICMP.SOURCE.ROUTE 5
|
||||
)))
|
||||
(RPAQQ \ICMP.NET.UNREACHABLE 0)
|
||||
(RPAQQ \ICMP.HOST.UNREACHABLE 1)
|
||||
(RPAQQ \ICMP.PROTOCOL.UNREACHABLE 2)
|
||||
(RPAQQ \ICMP.PORT.UNREACHABLE 3)
|
||||
(RPAQQ \ICMP.CANT.FRAGMENT 4)
|
||||
(RPAQQ \ICMP.SOURCE.ROUTE 5)
|
||||
(CONSTANTS (\ICMP.NET.UNREACHABLE 0) (\ICMP.HOST.UNREACHABLE 1) (\ICMP.PROTOCOL.UNREACHABLE 2) (
|
||||
\ICMP.PORT.UNREACHABLE 3) (\ICMP.CANT.FRAGMENT 4) (\ICMP.SOURCE.ROUTE 5))
|
||||
(PUTPROPS \IPDATABASE MACRO (LAMBDA (IP) (* ;
|
||||
"Returns the LOCF of the start of the data in the packet") (\ADDBASE (fetch (IP IPBASE) of IP) (UNFOLD
|
||||
(fetch (IP IPHEADERLENGTH) of IP) 2))))
|
||||
(PUTPROPS \IPDATALENGTH MACRO (LAMBDA (IP) (IDIFFERENCE (fetch (IP IPTOTALLENGTH) of IP) (LLSH (fetch
|
||||
(IP IPHEADERLENGTH) of IP) 2))))
|
||||
(RPAQQ IPADDRESSTYPES ((\IP.CLASS.A 0) (\IP.CLASS.A.BYTESPEC (BYTE 1 31)) (\IP.CLASS.A.NET.BYTESPEC (
|
||||
BYTE 8 24)) (\IP.CLASS.A.HOST.BYTESPEC (BYTE 24 0)) (\IP.CLASS.B 2) (\IP.CLASS.B.BYTESPEC (BYTE 2 30))
|
||||
(\IP.CLASS.B.NET.BYTESPEC (BYTE 16 16)) (\IP.CLASS.B.HOST.BYTESPEC (BYTE 16 0)) (\IP.CLASS.C 6) (
|
||||
\IP.CLASS.C.BYTESPEC (BYTE 3 29)) (\IP.CLASS.C.NET.BYTESPEC (BYTE 24 8)) (\IP.CLASS.C.HOST.BYTESPEC (
|
||||
BYTE 8 0))))
|
||||
(RPAQQ \IP.CLASS.A 0)
|
||||
(RPAQ \IP.CLASS.A.BYTESPEC (BYTE 1 31))
|
||||
(RPAQ \IP.CLASS.A.NET.BYTESPEC (BYTE 8 24))
|
||||
(RPAQ \IP.CLASS.A.HOST.BYTESPEC (BYTE 24 0))
|
||||
(RPAQQ \IP.CLASS.B 2)
|
||||
(RPAQ \IP.CLASS.B.BYTESPEC (BYTE 2 30))
|
||||
(RPAQ \IP.CLASS.B.NET.BYTESPEC (BYTE 16 16))
|
||||
(RPAQ \IP.CLASS.B.HOST.BYTESPEC (BYTE 16 0))
|
||||
(RPAQQ \IP.CLASS.C 6)
|
||||
(RPAQ \IP.CLASS.C.BYTESPEC (BYTE 3 29))
|
||||
(RPAQ \IP.CLASS.C.NET.BYTESPEC (BYTE 24 8))
|
||||
(RPAQ \IP.CLASS.C.HOST.BYTESPEC (BYTE 8 0))
|
||||
(CONSTANTS (\IP.CLASS.A 0) (\IP.CLASS.A.BYTESPEC (BYTE 1 31)) (\IP.CLASS.A.NET.BYTESPEC (BYTE 8 24)) (
|
||||
\IP.CLASS.A.HOST.BYTESPEC (BYTE 24 0)) (\IP.CLASS.B 2) (\IP.CLASS.B.BYTESPEC (BYTE 2 30)) (
|
||||
\IP.CLASS.B.NET.BYTESPEC (BYTE 16 16)) (\IP.CLASS.B.HOST.BYTESPEC (BYTE 16 0)) (\IP.CLASS.C 6) (
|
||||
\IP.CLASS.C.BYTESPEC (BYTE 3 29)) (\IP.CLASS.C.NET.BYTESPEC (BYTE 24 8)) (\IP.CLASS.C.HOST.BYTESPEC (
|
||||
BYTE 8 0)))
|
||||
(RPAQQ IPPROTOCOLTYPES ((\ICMP.PROTOCOL 1) (\TCP.PROTOCOL 6) (\UDP.PROTOCOL 17)))
|
||||
(RPAQQ \ICMP.PROTOCOL 1)
|
||||
(RPAQQ \TCP.PROTOCOL 6)
|
||||
(RPAQQ \UDP.PROTOCOL 17)
|
||||
(CONSTANTS (\ICMP.PROTOCOL 1) (\TCP.PROTOCOL 6) (\UDP.PROTOCOL 17))
|
||||
(RECORD AssemblyRecord (Packet FirstHole Fragments Timeout) Packet _ (\ALLOCATE.ETHERPACKET) FirstHole
|
||||
_ 0)
|
||||
(RECORD FragmentRecord (Start Length LastFragment))
|
||||
(RECORD FragmentID (AssemblyRecord SourceAddress ID Protocol . DestinationAddress))
|
||||
(RPAQQ IPOPTIONTYPES ((IPOPT.END 0) (IPOPT.NOP 1) (IPOPT.SECURITY 2) (IPOPT.LSRR 3) (IPOPT.TIMESTAMP 4
|
||||
) (IPOPT.RECRT 7) (IPOPT.STREAMID 8) (IPOPT.SSSR 9)))
|
||||
(RPAQQ IPOPT.END 0)
|
||||
(RPAQQ IPOPT.NOP 1)
|
||||
(RPAQQ IPOPT.SECURITY 2)
|
||||
(RPAQQ IPOPT.LSRR 3)
|
||||
(RPAQQ IPOPT.TIMESTAMP 4)
|
||||
(RPAQQ IPOPT.RECRT 7)
|
||||
(RPAQQ IPOPT.STREAMID 8)
|
||||
(RPAQQ IPOPT.SSSR 9)
|
||||
(CONSTANTS (IPOPT.END 0) (IPOPT.NOP 1) (IPOPT.SECURITY 2) (IPOPT.LSRR 3) (IPOPT.TIMESTAMP 4) (
|
||||
IPOPT.RECRT 7) (IPOPT.STREAMID 8) (IPOPT.SSSR 9))
|
||||
(RPAQ IP.OPTION.NUMBER.BYTESPEC (BYTE 5 0))
|
||||
(CONSTANTS (IP.OPTION.NUMBER.BYTESPEC (BYTE 5 0)))
|
||||
(PUTPROPS \IP.GET.BYTE DMACRO (LAMBDA (IP BYTE INHEADER) (* ;;
|
||||
"Retrieve a byte from an IP packet. If INHEADER is T, BYTE is an offset from the start of the packet, else it's an offset from the start of the IP data section"
|
||||
) (\GETBASEBYTE (COND (INHEADER (fetch (IP IPBASE) of IP)) (T (\IPDATABASE IP))) BYTE)))
|
||||
(PUTPROPS \IP.GET.CELL DMACRO (LAMBDA (IP CELL INHEADER) (* ;;
|
||||
"Retrieve a cell from an IP packet. If INHEADER is not NIL, the cell is written to the header portion of the IP packet, else it's written to the data portion. CELL is the offset, in 16-bit units"
|
||||
) (\GETBASEFIXP (COND (INHEADER (fetch (IP IPBASE) of IP)) (T (\IPDATABASE IP))) CELL)))
|
||||
(PUTPROPS \IP.GET.STRING DMACRO (LAMBDA (IP BYTEOFFSET NCHARS INHEADER) (* ;;
|
||||
"Retrieve a string from an IP packet. If INHEADER is T, BYTEOFFSET is an offset from the start of the packet, else it's an offset from the start of the IP data section"
|
||||
) (\GETBASESTRING (COND (INHEADER (fetch (IP IPBASE) of IP)) (T (\IPDATABASE IP))) BYTEOFFSET NCHARS))
|
||||
)
|
||||
(PUTPROPS \IP.GET.WORD DMACRO (LAMBDA (IP WORD INHEADER) (* ;;
|
||||
"Retrieve a word from an IP packet. If INHEADER is T, WORD is an offset from the start of the packet, else it's an offset from the start of the IP data section"
|
||||
) (\GETBASE (COND (INHEADER (fetch (IP IPBASE) of IP)) (T (\IPDATABASE IP))) WORD)))
|
||||
(PUTPROPS \IP.PUT.BYTE DMACRO (LAMBDA (IP BYTE VALUE INHEADER) (* ;;
|
||||
"Store a byte in an IP packet. If INHEADER is T, BYTE is an offset from the start of the packet, else it's an offset from the start of the IP data section"
|
||||
) (\PUTBASEBYTE (COND (INHEADER (fetch (IP IPBASE) of IP)) (T (\IPDATABASE IP))) BYTE VALUE)))
|
||||
(PUTPROPS \IP.PUT.CELL DMACRO (LAMBDA (IP CELL VALUE INHEADER) (* ;;
|
||||
"Store a cell in an IP packet. If INHEADER is not NIL, the cell is written to the header portion of the IP packet, else it's written to the data portion. CELL is the offset, in 16-bit units"
|
||||
) (\PUTBASEFIXP (COND (INHEADER (fetch (IP IPBASE) of IP)) (T (\IPDATABASE IP))) CELL VALUE)))
|
||||
(PUTPROPS \IP.PUT.STRING DMACRO (LAMBDA (IP BYTEOFFSET STRING INHEADER) (* ;;
|
||||
"Store a string ib an IP packet. If INHEADER is T, BYTEOFFSET is an offset from the start of the packet, else it's an offset from the start of the IP data section"
|
||||
) (\PUTBASESTRING (COND (INHEADER (fetch (IP IPBASE) of IP)) (T (\IPDATABASE IP))) BYTEOFFSET STRING))
|
||||
)
|
||||
(PUTPROPS \IP.PUT.WORD DMACRO (LAMBDA (IP WORD VALUE INHEADER) (* ;;
|
||||
"Store a word in an IP packet. If INHEADER is T, WORD is an offset from the start of the packet, else it's an offset from the start of the IP data section"
|
||||
) (\PUTBASE (COND (INHEADER (fetch (IP IPBASE) of IP)) (T (\IPDATABASE IP))) WORD VALUE)))
|
||||
(PUTPROP (QUOTE TCPLLIP) (QUOTE IMPORTDATE) (IDATE "11-Sep-89 15:24:32"))
|
||||
|
||||
(PUTPROP (QUOTE TCPNAMES) (QUOTE IMPORTDATE) (IDATE " 2-Jun-88 20:58:40"))
|
||||
|
||||
(RECORD TFTPCON (UDPSOCKET DESTSOCKET STREAM HOST))
|
||||
(ACCESSFNS TFTP ((TFTPBASE (fetch (UDP UDPCONTENTS) of DATUM))) (BLOCKRECORD TFTPBASE ((OPCODE WORD) (
|
||||
BLOCK# WORD))) (ACCESSFNS TFTP ((TFTPCONTENTS (\ADDBASE (fetch (UDP UDPCONTENTS) of DATUM) (FOLDHI
|
||||
\TFTPOVLEN BYTESPERWORD))))) (BLOCKRECORD TFTPBASE ((NIL WORD) (ERRORCODE WORD))))
|
||||
(ACCESSFNS TFTPSTREAM ((TFTPCON (fetch (STREAM F1) of DATUM) (replace (STREAM F1) of DATUM with
|
||||
NEWVALUE)) (LASTPACKETIN (fetch (STREAM F2) of DATUM) (replace (STREAM F2) of DATUM with NEWVALUE))))
|
||||
(RPAQQ \TFTPOVLEN 4)
|
||||
(RPAQQ \TFTP.SOCKET 69)
|
||||
(CONSTANTS (\TFTPOVLEN 4) (\TFTP.SOCKET 69))
|
||||
(RPAQQ TFTPOPCODES ((\TFTP.RRQ 1) (\TFTP.WRQ 2) (\TFTP.DATA 3) (\TFTP.ACK 4) (\TFTP.ERROR 5)))
|
||||
(RPAQQ \TFTP.RRQ 1)
|
||||
(RPAQQ \TFTP.WRQ 2)
|
||||
(RPAQQ \TFTP.DATA 3)
|
||||
(RPAQQ \TFTP.ACK 4)
|
||||
(RPAQQ \TFTP.ERROR 5)
|
||||
(CONSTANTS (\TFTP.RRQ 1) (\TFTP.WRQ 2) (\TFTP.DATA 3) (\TFTP.ACK 4) (\TFTP.ERROR 5))
|
||||
(PUTPROP (QUOTE TCPTFTP) (QUOTE IMPORTDATE) (IDATE " 1-Jul-87 10:54:35"))
|
||||
|
||||
(ACCESSFNS UDP ((UDPBASE (\IPDATABASE DATUM))) (BLOCKRECORD UDPBASE ((UDPSOURCEPORT WORD) (UDPDESTPORT
|
||||
WORD) (UDPLENGTH WORD) (UDPCHECKSUM WORD))) (ACCESSFNS UDP ((UDPCONTENTS (\ADDBASE (\IPDATABASE DATUM
|
||||
) (FOLDHI \UDPOVLEN BYTESPERWORD))))))
|
||||
(RPAQQ \UDPOVLEN 8)
|
||||
(CONSTANTS (\UDPOVLEN 8))
|
||||
(PUTPROP (QUOTE TCPUDP) (QUOTE IMPORTDATE) (IDATE " 6-Jan-89 16:37:41"))
|
||||
|
||||
(PUTPROP (QUOTE TCPEXPORTS) (QUOTE FILEDATES) (QUOTE (("11-Sep-89 16:22:57" . "{ERIS}<LispCore>Library>TCPEXPORTS.;8"))))
|
||||
|
||||
STOP
|
||||
|
||||
38
nfs/YP
38
nfs/YP
@ -1,38 +0,0 @@
|
||||
(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE "YP" ( USE "XCL" "LISP")))
|
||||
(il:filecreated "13-Nov-89 18:59:25" "{piglet/n}<piglet>nfs>sources>YP;3" 3116
|
||||
|
||||
il:|changes| il:|to:| (il:vars il:ypcoms) (il:files il:ypimpl) (il:functions ypdef)
|
||||
|
||||
il:|previous| il:|date:| "15-Nov-88 18:42:19" "{piglet/n}<piglet>nfs>sources>YP;1")
|
||||
|
||||
|
||||
; Copyright (c) 1988, 1989 by Xerox Corporation. All rights reserved.
|
||||
|
||||
(il:prettycomprint il:ypcoms)
|
||||
|
||||
(il:rpaqq il:ypcoms ((il:* il:|;;;| "Yellow Pages Service... Requires Sun-RPC.") (il:declare\: il:dontcopy (il:prop (il:filetype il:makefile-environment) il:yp)) (il:structures map-parameters) (il:functions ypdef) (eval-when (load) (il:p (ypdef))) (il:files il:ypimpl)))
|
||||
|
||||
|
||||
|
||||
(il:* il:|;;;| "Yellow Pages Service... Requires Sun-RPC.")
|
||||
|
||||
(il:declare\: il:dontcopy
|
||||
|
||||
(il:putprops il:yp il:filetype :compile-file)
|
||||
|
||||
(il:putprops il:yp il:makefile-environment (:readtable "XCL" :package (defpackage "YP" (:use "XCL" "LISP"))))
|
||||
)
|
||||
|
||||
(defstruct (map-parameters) domain-name map-name order-num peer-name)
|
||||
|
||||
(defun ypdef nil (quote dummy) (il:* il:\; "Keep defun from macroexpanding this needlessly") (rpc2:define-remote-program (quote yp) 100004 2 (quote rpc2:udp) :constants (quote ((maxrecord 1024) (maxdomain 64) (maxmap 64) (maxpeer 64))) :types (quote ((status (:enumeration (t 1) (nil 0) (:no-more 2) (:no-map -1) (:no-domain -2) (:no-key -3) (:bad-operation -4) (:bad-data-base -5) (:yp-server-error -6) (:bad-arguments -7) (:version-mismatch -8))) (transfer-status (:enumeration (t 1) (:age 2) (:no-map -1) (:no-domain -2) (:resource-failure -3) (:rpc-failure -4) (:master-address -5) (:yp-server-error -6) (:bad-arguments -7) (:data-base-failure -8) (:file-error -9) (:skew -10) (:cant-clear -11) (:force -12) (:transfer-error -13) (:server-refused -14))) (domain-name :string) (map-name :string) (peer-name :string) (key-data :string) (value-data :string) (order-number :unsigned) (map-list (:sequence map-name)) (transaction-id :unsigned) (program :unsigned) (port :unsigned) (map-parameters (:struct map-parameters (domain-name domain-name) (map-name map-name) (order-num :unsigned) (peer-name peer-name))) (response-all (:union (:enumeration (t 1) (nil 0)) (t (:list status value-data key-data)) (nil :void))))) :procedures (quote ((null 0 nil nil) (serve-domain-p 1 (domain-name) (:boolean)) (serve-domain-p-no-nack 2 (domain-name) (:boolean)) (match-key 3 (domain-name map-name key-data) (status value-data)) (first-pair 4 (domain-name map-name key-data) (status value-data key-data)) (next-pair 5 (domain-name map-name key-data) (status value-data key-data)) (transfer-map 6 (map-parameters transaction-id program port) (transaction-id transfer-status)) (clear 7 nil nil) (get-all-pairs 8 (domain-name map-name) response-all) (map-master-name 9 (domain-name map-name) (status peer-name)) (map-order 10 (domain-name map-name) (status order-number)) (get-all-maps 11 (domain-name) (status map-list))))))
|
||||
(eval-when (load)
|
||||
|
||||
(ypdef)
|
||||
)
|
||||
|
||||
(il:filesload il:ypimpl)
|
||||
(il:putprops il:yp il:copyright ("Xerox Corporation" 1988 1989))
|
||||
(il:declare\: il:dontcopy
|
||||
(il:filemap (nil)))
|
||||
il:stop
|
||||
BIN
nfs/YP.DFASL
BIN
nfs/YP.DFASL
Binary file not shown.
484
nfs/YPIMPL
484
nfs/YPIMPL
@ -1,484 +0,0 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "YP" READTABLE "XCL" BASE 10)
|
||||
(IL:FILECREATED " 3-Jun-93 14:37:24" IL:|{DSK}<project>medley2.0>nfs>YPIMPL.;7| 25855
|
||||
|
||||
IL:|changes| IL:|to:| (IL:FUNCTIONS MAIKO-BROADCAST-FOR-SERVERS)
|
||||
|
||||
IL:|previous| IL:|date:| " 7-Oct-92 12:41:01" IL:|{DSK}<project>medley2.0>nfs>YPIMPL.;6|)
|
||||
|
||||
|
||||
; Copyright (c) 1988, 1989, 1990, 1992, 1993 by Xerox Corporation. All rights reserved.
|
||||
|
||||
(IL:PRETTYCOMPRINT IL:YPIMPLCOMS)
|
||||
|
||||
(IL:RPAQQ IL:YPIMPLCOMS
|
||||
(
|
||||
(IL:* IL:|;;| "Meat of YP. Separate file to avoid recompiling the rpc def all the time")
|
||||
|
||||
(EVAL-WHEN (EVAL)
|
||||
(IL:PROPS (IL:YPIMPL IL:MAKEFILE-ENVIRONMENT)
|
||||
(IL:YPIMPL IL:FILETYPE)))
|
||||
(IL:P (EXPORT '(YP YP-RESTART *YP-DOMAIN* *YP-SERVERS* *YP-NET-HINTS* *GIDS-FROM-USER-MAP*
|
||||
YP-CALL YP-MATCH GET-UID GET-USER-GIDS GROUP-GID UID-NAME GID-NAME
|
||||
HOST-ADDRESS HOST-NAME READ-MAP INTEGER-FROM-STRING)))
|
||||
(EVAL-WHEN (EVAL COMPILE)
|
||||
(IL:P (PROCLAIM '(GLOBAL IL:\\IP.HOSTNUMBERS IL:\\IP.HOSTNAMES IL:\\10MBLOCALNDB
|
||||
IL:\\IP.DEFAULT.GATEWAY IL:NETWORKOSTYPES))
|
||||
(PROCLAIM '(SPECIAL IL:PROMPTWINDOW))))
|
||||
(IL:VARIABLES *UID-TO-NAME-TABLE* *GID-TO-NAME-TABLE* *GIDS-FROM-USER-MAP* *YP-DOMAIN*
|
||||
*YP-SERVERS* *YP-NET-HINTS* *YP-PROGRAM* *YP-LOCK* *BROADCASTING*)
|
||||
(IL:ADDVARS (IL:SYSTEMINITVARS (*YP-DOMAIN*)
|
||||
(*YP-NET-HINTS*)))
|
||||
(IL:FUNCTIONS YP-RESTART READ-YP-INIT-FILE BROADCAST-FOR-SERVERS
|
||||
MAIKO-BROADCAST-FOR-SERVERS D-BROADCAST-FOR-SERVERS)
|
||||
(IL:FUNCTIONS YP-CALL YP-MATCH UID-NAME GID-NAME GROUP-GID GET-UID GET-USER-GIDS
|
||||
HOST-ADDRESS RECORD-HOST-ADDRESS HOST-NAME READ-MAP INTEGER-FROM-STRING)
|
||||
(EVAL-WHEN (LOAD)
|
||||
(IL:APPENDVARS (IL:RESTARTETHERFNS YP-RESTART))
|
||||
(IL:P
|
||||
(IL:* IL:|;;| "Read the YP.INIT file right now so it's in the world when saved out. Don't look for servers yet; we wouldn't use them if we did.")
|
||||
|
||||
(YP-RESTART)))))
|
||||
|
||||
|
||||
|
||||
(IL:* IL:|;;| "Meat of YP. Separate file to avoid recompiling the rpc def all the time")
|
||||
|
||||
(EVAL-WHEN (EVAL)
|
||||
|
||||
(IL:PUTPROPS IL:YPIMPL IL:MAKEFILE-ENVIRONMENT (:PACKAGE "YP" :READTABLE "XCL" :BASE 10))
|
||||
|
||||
(IL:PUTPROPS IL:YPIMPL IL:FILETYPE :COMPILE-FILE)
|
||||
)
|
||||
|
||||
(EXPORT '(YP YP-RESTART *YP-DOMAIN* *YP-SERVERS* *YP-NET-HINTS* *GIDS-FROM-USER-MAP* YP-CALL YP-MATCH
|
||||
GET-UID GET-USER-GIDS GROUP-GID UID-NAME GID-NAME HOST-ADDRESS HOST-NAME READ-MAP
|
||||
INTEGER-FROM-STRING))
|
||||
(EVAL-WHEN (EVAL COMPILE)
|
||||
|
||||
(PROCLAIM '(GLOBAL IL:\\IP.HOSTNUMBERS IL:\\IP.HOSTNAMES IL:\\10MBLOCALNDB IL:\\IP.DEFAULT.GATEWAY
|
||||
IL:NETWORKOSTYPES))
|
||||
|
||||
(PROCLAIM '(SPECIAL IL:PROMPTWINDOW))
|
||||
)
|
||||
|
||||
(DEFVAR *UID-TO-NAME-TABLE* (MAKE-HASH-TABLE))
|
||||
|
||||
(DEFVAR *GID-TO-NAME-TABLE* (MAKE-HASH-TABLE))
|
||||
|
||||
(DEFVAR *GIDS-FROM-USER-MAP* NIL
|
||||
"Name of map that returns list of GIDs given user name. If NIL, we invert (painfully) group.byname."
|
||||
)
|
||||
|
||||
(DEFVAR *YP-DOMAIN* NIL)
|
||||
|
||||
(DEFVAR *YP-SERVERS* NIL)
|
||||
|
||||
(DEFVAR *YP-NET-HINTS* NIL)
|
||||
|
||||
(DEFVAR *YP-PROGRAM* NIL
|
||||
"Pointer to YP program object. Set by YP-RESTART")
|
||||
|
||||
(DEFGLOBALVAR *YP-LOCK* (IL:CREATE.MONITORLOCK "YP calls"))
|
||||
|
||||
(DEFVAR *BROADCASTING* NIL
|
||||
"True inside broadcast for servers call")
|
||||
|
||||
(IL:ADDTOVAR IL:SYSTEMINITVARS (*YP-DOMAIN*)
|
||||
(*YP-NET-HINTS*))
|
||||
|
||||
(DEFUN YP-RESTART (&OPTIONAL EVENT)
|
||||
|
||||
(IL:* IL:|;;| "Called by around exit events and restart.ether. Clear our knowledge of yp servers and start afresh")
|
||||
|
||||
(CASE EVENT
|
||||
((IL:AFTERLOGOUT IL:AFTERMAKESYS IL:AFTERSYSOUT IL:AFTERSAVEVM IL:RESTART NIL)
|
||||
(SETQ *YP-PROGRAM* (RPC2:FIND-RPC-PROGRAM :NAME 'YP))
|
||||
(IL:* IL:\; "Cache this")
|
||||
(RPC2:CLEAR-CACHE *YP-PROGRAM*) (IL:* IL:\; "Forget about old sockets")
|
||||
(DOLIST (S *YP-SERVERS*) (IL:* IL:\; "Close old streams")
|
||||
(WHEN (THIRD S)
|
||||
(RPC2:CLOSE-RPCSTREAM (THIRD S))
|
||||
(RPLACD (CDR S)
|
||||
NIL)))
|
||||
(SETQ *YP-SERVERS* NIL)
|
||||
(CLRHASH *UID-TO-NAME-TABLE*)
|
||||
(WHEN (OR (NULL *YP-NET-HINTS*)
|
||||
(NULL *YP-DOMAIN*))
|
||||
|
||||
(IL:* IL:|;;| "If we haven't a clue, read the file.")
|
||||
|
||||
(READ-YP-INIT-FILE T)))))
|
||||
|
||||
(DEFUN READ-YP-INIT-FILE (NOWARNING)
|
||||
(COND
|
||||
((PROBE-FILE "{dsk}yp.init")
|
||||
(WITH-OPEN-FILE (YPINITFILE "{dsk}yp.init")
|
||||
(DECLARE (SPECIAL IL:PROMPTWINDOW))
|
||||
(FORMAT IL:PROMPTWINDOW "~&Reading ~A" (NAMESTRING YPINITFILE))
|
||||
(SETQ *YP-DOMAIN* (READ YPINITFILE)
|
||||
*YP-NET-HINTS*
|
||||
(READ YPINITFILE))))
|
||||
((AND (NULL *YP-DOMAIN*)
|
||||
(NOT NOWARNING))
|
||||
(WARN "No YP.INIT file found. You need to set yp:*yp-domain* in order to use yp."))))
|
||||
|
||||
(DEFUN BROADCAST-FOR-SERVERS ()
|
||||
(COND
|
||||
((NULL *YP-DOMAIN*)
|
||||
(FORMAT IL:PROMPTWINDOW "~&YP:*YP-DOMAIN* is not set.")
|
||||
NIL)
|
||||
((COND
|
||||
((EQ (IL:MACHINETYPE)
|
||||
'IL:MAIKO)
|
||||
(MAIKO-BROADCAST-FOR-SERVERS))
|
||||
(T (D-BROADCAST-FOR-SERVERS))))
|
||||
(T (FORMAT IL:PROMPTWINDOW "~&Couldn't find YP server for domain ~A." *YP-DOMAIN*)
|
||||
NIL)))
|
||||
|
||||
(DEFUN MAIKO-BROADCAST-FOR-SERVERS () (IL:* IL:\; "Edited 3-Jun-93 14:36 by rmk:")
|
||||
|
||||
(IL:* IL:|;;| "On Sun, we can't do broadcast call. Just ask the local machine who a YP host is. NLSETQ to avoid end-of-stream error (perhaps due to some sort of network delays?). Try again 4 times before simply returning NIL.")
|
||||
|
||||
(IL:FOR I SERVER IL:FROM 1 IL:TO 4
|
||||
IL:WHEN (SETQ SERVER (LET ((S (IL:CREATE-PROCESS-STREAM (CONCATENATE 'STRING "ypwhich -d "
|
||||
*YP-DOMAIN*))))
|
||||
(UNWIND-PROTECT
|
||||
(LET ((SERVER (CAR (IL:NLSETQ (READ-LINE S)))))
|
||||
(COND
|
||||
((AND SERVER (> (LENGTH SERVER)
|
||||
0)
|
||||
(NOT (POSITION #\Space SERVER)))
|
||||
|
||||
(IL:* IL:|;;|
|
||||
"Assume any non-null response that's just one word is ok.")
|
||||
|
||||
(FORMAT IL:PROMPTWINDOW "~&Using YP server ~A."
|
||||
SERVER)
|
||||
(PUSH (SETQ SERVER (LIST *YP-DOMAIN* SERVER))
|
||||
*YP-SERVERS*)
|
||||
SERVER)))
|
||||
(IL:UNIX-STREAM-CLOSE S)))) IL:DO (RETURN SERVER)))
|
||||
|
||||
(DEFUN D-BROADCAST-FOR-SERVERS ()
|
||||
(FORMAT IL:PROMPTWINDOW "~&Searching for YP server for domain ~A... " *YP-DOMAIN*)
|
||||
(LET ((*BROADCASTING* T)
|
||||
(HINTS *YP-NET-HINTS*)
|
||||
(ARGS (LIST *YP-DOMAIN*)))
|
||||
(WHEN IL:\\10MBLOCALNDB (IL:* IL:\;
|
||||
"Assume YP servers are only on 10mb nets. Try local net first")
|
||||
(PUSH 0 HINTS))
|
||||
(DOTIMES (I 2)
|
||||
(DOLIST (HINT HINTS)
|
||||
(MULTIPLE-VALUE-BIND (RESULTS PORT ADDRESS)
|
||||
(LET ((RPC2:*MSEC-UNTIL-TIMEOUT* 1000)
|
||||
(RPC2:*MSEC-BETWEEN-TRIES* 300))(IL:* IL:\;
|
||||
"Bind these in here so they don't affect the call to host-name below")
|
||||
(CONDITION-CASE (RPC2:CALL-VIA-PORTMAPPER HINT 'YP
|
||||
'SERVE-DOMAIN-P-NO-NACK ARGS)
|
||||
(RPC2:RPC-TIMEOUT NIL)))
|
||||
(WHEN ADDRESS
|
||||
(LET ((SERVER (LIST *YP-DOMAIN* ADDRESS)))
|
||||
(PUSH SERVER *YP-SERVERS*)
|
||||
(RPC2:CACHE-SOCKET *YP-PROGRAM* ADDRESS PORT)
|
||||
(FORMAT IL:PROMPTWINDOW " found ~a~%" (OR (HOST-NAME ADDRESS)
|
||||
(IL:\\IP.ADDRESS.TO.STRING
|
||||
ADDRESS)))
|
||||
(RETURN-FROM D-BROADCAST-FOR-SERVERS SERVER))))))
|
||||
|
||||
(IL:* IL:|;;| "Failed after 2 tries")
|
||||
|
||||
NIL))
|
||||
|
||||
(DEFUN YP-CALL (PROC ARGS)
|
||||
|
||||
(IL:* IL:|;;| "Ask a YP server to do the call PROC on ARGS")
|
||||
|
||||
(IL:WITH.MONITOR *YP-LOCK*
|
||||
(PROG ((RESTARTED *BROADCASTING*)
|
||||
SERVER)
|
||||
RESTART
|
||||
(RETURN
|
||||
(COND
|
||||
((SETQ SERVER (COND
|
||||
((AND *YP-SERVERS* (EQ (CAAR *YP-SERVERS*)
|
||||
*YP-DOMAIN*))
|
||||
(IL:* IL:\;
|
||||
"Small optimization for this usual case")
|
||||
(CAR *YP-SERVERS*))
|
||||
((NULL *YP-DOMAIN*)
|
||||
NIL)
|
||||
((ASSOC *YP-DOMAIN* *YP-SERVERS* :TEST #'STRING-EQUAL))
|
||||
(T (BROADCAST-FOR-SERVERS))))
|
||||
(LET ((STRM (THIRD SERVER)))
|
||||
(WHEN (NULL STRM) (IL:* IL:\; "Cache an RPC stream here")
|
||||
(RPLACD (CDR SERVER)
|
||||
(LIST (SETQ STRM (RPC2:OPEN-RPCSTREAM
|
||||
'RPC2:UDP
|
||||
(SECOND SERVER)
|
||||
'YP NIL #'(LAMBDA (STREAM COUNT)
|
||||
(IL:* IL:\;
|
||||
"If this call times out, we want to search for other servers")
|
||||
(THROW 'YP-RESTART 'YP-RESTART))
|
||||
)))))
|
||||
(LET ((RESULT (HANDLER-BIND ((RPC2:RPC-ERROR
|
||||
(IF RESTARTED
|
||||
#'(LAMBDA (CONDITION)
|
||||
(IL:* IL:\;
|
||||
"If get RPC error again, just report it")
|
||||
(FORMAT IL:PROMPTWINDOW
|
||||
"~&YP call ~A failed because: ~A"
|
||||
PROC CONDITION)
|
||||
(THROW 'YP-RESTART NIL))
|
||||
#'(LAMBDA (CONDITION)
|
||||
(IL:* IL:\;
|
||||
"If get RPC error (e.g., no such program), give up on this server")
|
||||
(THROW 'YP-RESTART 'YP-RESTART)))))
|
||||
(CATCH 'YP-RESTART
|
||||
(RPC2:PERFORM-RPC NIL NIL *YP-PROGRAM* PROC STRM
|
||||
ARGS NIL)))))
|
||||
(COND
|
||||
((NOT (EQ RESULT 'YP-RESTART))(IL:* IL:\; "Valid result")
|
||||
RESULT)
|
||||
(RESTARTED (IL:* IL:\;
|
||||
"Already tried restarting once, so just return nil")
|
||||
(FORMAT IL:PROMPTWINDOW "~&YP server timed out ~A call" PROC)
|
||||
NIL)
|
||||
(T (IL:* IL:\;
|
||||
"No response from server, so try another server")
|
||||
(SETQ RESTARTED T)
|
||||
(SETQ *YP-SERVERS* (DELETE SERVER *YP-SERVERS*))
|
||||
(RPC2:CLOSE-RPCSTREAM STRM)
|
||||
(GO RESTART)))))))))))
|
||||
|
||||
(DEFUN YP-MATCH (MAP DATA &OPTIONAL (DOMAIN *YP-DOMAIN*))
|
||||
|
||||
(IL:* IL:|;;| "Call YP's MATCH-KEY procedure with the specified map, data and domain. Returns NIL or a string of data")
|
||||
|
||||
(DESTRUCTURING-BIND (STATUS VALUE-DATA)
|
||||
(YP-CALL 'MATCH-KEY (LIST DOMAIN MAP DATA))
|
||||
(AND (EQ STATUS 'T)
|
||||
VALUE-DATA)))
|
||||
|
||||
(DEFUN UID-NAME (UID)
|
||||
(OR (GETHASH UID *UID-TO-NAME-TABLE*)
|
||||
(SETF (GETHASH UID *UID-TO-NAME-TABLE*)
|
||||
(LET ((LINE (YP-MATCH "passwd.byuid" (WRITE-TO-STRING UID :BASE 10 :RADIX NIL))))
|
||||
(AND LINE (SUBSEQ LINE 0 (POSITION #\: LINE)))))))
|
||||
|
||||
(DEFUN GID-NAME (GID)
|
||||
(OR (GETHASH GID *GID-TO-NAME-TABLE*)
|
||||
(SETF (GETHASH GID *GID-TO-NAME-TABLE*)
|
||||
(LET ((LINE (YP-MATCH "group.bygid" (WRITE-TO-STRING GID :BASE 10 :RADIX NIL))))
|
||||
(AND LINE (SUBSEQ LINE 0 (POSITION #\: LINE)))))))
|
||||
|
||||
(DEFUN GROUP-GID (GROUP-NAME)
|
||||
(LET ((LINE (YP-MATCH "group.byname" GROUP-NAME))
|
||||
COLON)
|
||||
|
||||
(IL:* IL:|;;| "Format of response data is \"group:*:gid:\"")
|
||||
|
||||
(AND LINE (SETQ COLON (POSITION #\: LINE))
|
||||
(SETQ COLON (POSITION #\: LINE :START (1+ COLON)))
|
||||
(INTEGER-FROM-STRING LINE (1+ COLON)
|
||||
(POSITION #\: LINE :START (1+ COLON))))))
|
||||
|
||||
(DEFUN GET-UID (&OPTIONAL (USER-NAME (CAR (IL:\\INTERNAL/GETPASSWORD 'IL:--NFS-- NIL NIL NIL NIL
|
||||
'IL:UNIX))))
|
||||
"Return values UID, GID, HOMEDIR"
|
||||
(LET* ((UNAME (STRING-DOWNCASE (STRING USER-NAME)))
|
||||
(LINE (YP-MATCH "passwd.byname" (IF (> (LENGTH UNAME)
|
||||
8)
|
||||
(SUBSEQ UNAME 0 8)
|
||||
UNAME))))
|
||||
(COND
|
||||
(LINE
|
||||
(IL:* IL:|;;| "Format is \"name:encryptedpasswd:uid:gid:fullname:homedir:shell\"")
|
||||
|
||||
(LET* ((FIRSTCOLON (POSITION #\: LINE))
|
||||
(SECONDCOLON (POSITION #\: LINE :START (1+ FIRSTCOLON)))
|
||||
(THIRDCOLON (POSITION #\: LINE :START (1+ SECONDCOLON)))
|
||||
(FOURTHCOLON (POSITION #\: LINE :START (1+ THIRDCOLON)))
|
||||
(FIFTHCOLON (POSITION #\: LINE :START (1+ FOURTHCOLON)))
|
||||
(SIXTHCOLON (POSITION #\: LINE :START (1+ FIFTHCOLON))))
|
||||
(VALUES (INTEGER-FROM-STRING LINE (1+ SECONDCOLON)
|
||||
THIRDCOLON)
|
||||
(INTEGER-FROM-STRING LINE (1+ THIRDCOLON)
|
||||
FOURTHCOLON)
|
||||
(SUBSEQ LINE (1+ FIFTHCOLON)
|
||||
SIXTHCOLON)))))))
|
||||
|
||||
(DEFUN GET-USER-GIDS (USER-NAME)
|
||||
(UNLESS (STRINGP USER-NAME)
|
||||
(SETQ USER-NAME (STRING USER-NAME)))
|
||||
(LET
|
||||
((GIDS
|
||||
(COND
|
||||
(*GIDS-FROM-USER-MAP* (IL:* IL:\;
|
||||
"There's already a nice inverted map, use it.")
|
||||
(LET ((ENTRY (YP-MATCH *GIDS-FROM-USER-MAP* (IF (> (LENGTH USER-NAME)
|
||||
8)
|
||||
(SUBSEQ USER-NAME 0 8)
|
||||
USER-NAME))))
|
||||
(AND ENTRY (LET ((*READ-BASE* 10))
|
||||
(READ-FROM-STRING ENTRY)))))
|
||||
(T
|
||||
|
||||
(IL:* IL:|;;| "Ugh, have to invert group.bygid manually. I.e., enumerate it, and search for user-name in each entry.")
|
||||
|
||||
(LET
|
||||
((NAME-LENGTH (LENGTH USER-NAME)))
|
||||
(READ-MAP
|
||||
"group.bygid"
|
||||
#'(LAMBDA (KEY LINE)
|
||||
|
||||
(IL:* IL:|;;|
|
||||
"Format of LINE is \"groupname:*:id:members\", where members is list of users separated by commas")
|
||||
|
||||
(LET ((COLON (POSITION #\: LINE)))
|
||||
(AND COLON (SETQ COLON (POSITION #\: LINE :START (1+ COLON)))
|
||||
(SETQ COLON (POSITION #\: LINE :START (1+ COLON)))
|
||||
(IL:* IL:\;
|
||||
"Proper format so far, so search for username among members")
|
||||
(LET ((START (+ COLON 2))
|
||||
END)
|
||||
(LOOP (UNLESS (SETQ START (IL:STRPOS USER-NAME LINE START))
|
||||
(IL:* IL:\;
|
||||
"Gosh, I'd use SEARCH instead, but STRPOS is 10 times faster")
|
||||
(RETURN NIL))
|
||||
(SETQ END (+ START NAME-LENGTH))
|
||||
(CASE (CHAR LINE (- START 2))
|
||||
((#\: #\,) (IL:* IL:\;
|
||||
"Good, name started on name boundary")
|
||||
(WHEN (OR (>= END (LENGTH LINE))
|
||||
(EQL (CHAR LINE (1- END))
|
||||
#\,))
|
||||
(IL:* IL:\;
|
||||
"Good, name ends on name boundary")
|
||||
(RETURN (INTEGER-FROM-STRING KEY)))))
|
||||
(SETQ START END))))))))))))
|
||||
(IF (LISTP GIDS)
|
||||
GIDS
|
||||
(FORMAT IL:PROMPTWINDOW "~&Couldn't find group IDs for user ~A because ~A" USER-NAME GIDS))))
|
||||
|
||||
(DEFUN HOST-ADDRESS (HOSTNAME)
|
||||
(LET ((LINE (YP-MATCH "hosts.byname" (STRING-DOWNCASE (STRING HOSTNAME)))))
|
||||
(IF LINE
|
||||
(LET* ((WSPOS (IL:STRPOSL '(#\Space #\Tab #\Linefeed #\Newline)
|
||||
LINE))
|
||||
(ADDRESS (IL:\\IP.READ.STRING.ADDRESS (IL:SUBSTRING LINE 1 (AND WSPOS (1- WSPOS)))
|
||||
)))
|
||||
(COND
|
||||
((AND ADDRESS (NOT (EQL ADDRESS 0))) (IL:* IL:\;
|
||||
"Guard against malformed entries")
|
||||
(RECORD-HOST-ADDRESS (IL:MKATOM (IL:U-CASE HOSTNAME))
|
||||
ADDRESS)
|
||||
ADDRESS))))))
|
||||
|
||||
(DEFUN RECORD-HOST-ADDRESS (HOSTSYMBOL ADDRESS)
|
||||
|
||||
(IL:* IL:|;;| "No-op unless for D machine")
|
||||
|
||||
(IL:* IL:|;;| "(SETF (GETHASH HOSTSYMBOL IL:\\\\IP.HOSTNAMES) (IL:|create| IL:HOSTS.TXT.ENTRY IL:HTE.ADDRESSES IL:_ (LIST ADDRESS) IL:HTE.TYPE IL:_ 'IL:HOST IL:HTE.NAMES IL:_ (LIST HOSTSYMBOL) IL:HTE.MACHINE.TYPE IL:_ 'IL:SUN IL:HTE.OS.TYPE IL:_ 'IL:UNIX)) (PUSHNEW (CONS HOSTSYMBOL 'IL:UNIX) IL:NETWORKOSTYPES :KEY 'CAR) (PUSHNEW (CONS ADDRESS HOSTSYMBOL) IL:\\\\IP.HOSTNUMBERS :KEY 'CAR)")
|
||||
|
||||
NIL)
|
||||
|
||||
(DEFUN HOST-NAME (ADDRESS)
|
||||
(LET* ((STRING (YP-MATCH "hosts.byaddr" (ETYPECASE ADDRESS
|
||||
(INTEGER (IL:\\IP.ADDRESS.TO.STRING ADDRESS))
|
||||
(STRING ADDRESS)
|
||||
(SYMBOL (STRING ADDRESS)))))
|
||||
SHORTNAME)
|
||||
(WHEN STRING
|
||||
(DO* ((NAME)
|
||||
(LENGTH MOST-POSITIVE-FIXNUM)
|
||||
(THISNAME)
|
||||
(THISLENGTH)
|
||||
(LASTWS NIL WS)
|
||||
(WS (IL:STRPOSL '(#\Space #\Tab #\Newline #\Linefeed)
|
||||
STRING)
|
||||
(IL:STRPOSL '(#\Space #\Tab #\Newline #\Linefeed)
|
||||
STRING
|
||||
(1+ WS))))
|
||||
((NULL WS)
|
||||
(SETQ SHORTNAME (IF (< (LENGTH (SETQ THISNAME (IL:SUBSTRING STRING (1+ LASTWS))))
|
||||
LENGTH)
|
||||
THISNAME
|
||||
NAME)))
|
||||
(WHEN (AND LASTWS (< (SETQ THISLENGTH (LENGTH (SETQ THISNAME (IL:SUBSTRING
|
||||
STRING
|
||||
(1+ LASTWS)
|
||||
(1- WS)))))
|
||||
LENGTH))
|
||||
(SETQ NAME THISNAME LENGTH THISLENGTH)))
|
||||
(LET ((HOSTSYMBOL (IL:MKATOM (STRING-UPCASE SHORTNAME))))
|
||||
(PUSHNEW (CONS (IF (INTEGERP ADDRESS)
|
||||
ADDRESS
|
||||
(SETQ ADDRESS (IL:\\IP.READ.STRING.ADDRESS ADDRESS)))
|
||||
HOSTSYMBOL)
|
||||
IL:\\IP.HOSTNUMBERS :KEY 'CAR)
|
||||
(UNLESS (GETHASH HOSTSYMBOL IL:\\IP.HOSTNAMES)
|
||||
(RECORD-HOST-ADDRESS HOSTSYMBOL ADDRESS))
|
||||
HOSTSYMBOL))))
|
||||
|
||||
(DEFUN READ-MAP (MAPNAME &OPTIONAL (PREDICATE 'LIST))
|
||||
|
||||
(IL:* IL:|;;| "Collect all the elements of a YP map. If PREDICATE is supplied, then it is called for each item (args: key line) and the non-NIL values returned from it are collected into a list. Otherwise, returns a list of ALL items, each in the form (key line). ")
|
||||
|
||||
(LOOP (BLOCK RETRY
|
||||
(RETURN-FROM READ-MAP
|
||||
(LET* ((ARGS (LIST *YP-DOMAIN* MAPNAME ""))
|
||||
(PROC 'FIRST-PAIR)
|
||||
VALUE)
|
||||
(WITH-COLLECTION (LOOP (DESTRUCTURING-BIND
|
||||
(STATUS VALUE-DATA KEY-DATA)
|
||||
(YP-CALL PROC ARGS)
|
||||
(CASE STATUS
|
||||
((T) (IL:* IL:\; "Good response")
|
||||
(SETF (THIRD ARGS)
|
||||
KEY-DATA)
|
||||
(WHEN (SETQ VALUE (FUNCALL PREDICATE
|
||||
KEY-DATA VALUE-DATA
|
||||
))
|
||||
(COLLECT VALUE)))
|
||||
(:NO-MORE
|
||||
(IL:* IL:\;
|
||||
"No more entries, we're done")
|
||||
(RETURN))
|
||||
((NIL) (IL:* IL:\; "No response ")
|
||||
(CERROR "Retry YP call"
|
||||
"YP server not responding for map ~A"
|
||||
MAPNAME)
|
||||
(IL:* IL:\;
|
||||
"Continue from error means try over again")
|
||||
(RETURN-FROM RETRY))
|
||||
(OTHERWISE
|
||||
(IL:* IL:\;
|
||||
"Some sort of error return")
|
||||
(RETURN-FROM READ-MAP STATUS))))
|
||||
(SETQ PROC 'NEXT-PAIR))))))))
|
||||
|
||||
(DEFUN INTEGER-FROM-STRING (STR &OPTIONAL START END)
|
||||
|
||||
(IL:* IL:|;;| "Like PARSE-INTEGER but returns NIL on failure instead of erroring")
|
||||
|
||||
(MULTIPLE-VALUE-BIND (N J)
|
||||
(PARSE-INTEGER STR :JUNK-ALLOWED T :START (OR START 0)
|
||||
:END
|
||||
(OR END (SETQ END (LENGTH STR))))
|
||||
(AND (EQL J END)
|
||||
N)))
|
||||
(EVAL-WHEN (LOAD)
|
||||
|
||||
(IL:APPENDTOVAR IL:RESTARTETHERFNS YP-RESTART)
|
||||
|
||||
|
||||
|
||||
(IL:* IL:|;;| "Read the YP.INIT file right now so it's in the world when saved out. Don't look for servers yet; we wouldn't use them if we did.")
|
||||
|
||||
|
||||
(YP-RESTART)
|
||||
)
|
||||
(IL:PUTPROPS IL:YPIMPL IL:COPYRIGHT ("Xerox Corporation" 1988 1989 1990 1992 1993))
|
||||
(IL:DECLARE\: IL:DONTCOPY
|
||||
(IL:FILEMAP (NIL)))
|
||||
IL:STOP
|
||||
BIN
nfs/YPIMPL.DFASL
BIN
nfs/YPIMPL.DFASL
Binary file not shown.
@ -1 +0,0 @@
|
||||
Too recompile the RPC files, they all should be first loaded symbolically, including TCPEXPORTS and RPCDECLS. Then they can be compile-files.
|
||||
46
nfs/mini-nfs
46
nfs/mini-nfs
@ -1,46 +0,0 @@
|
||||
(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
|
||||
(FILECREATED "26-Apr-92 09:26:12" {DSK}<project>medley2.0>nfs>mini-nfs.;2 1366
|
||||
|
||||
changes to%: (VARS MINI-NFSCOMS)
|
||||
|
||||
previous date%: " 1-Mar-91 16:57:24" {DSK}<project>medley2.0>nfs>mini-nfs.;1)
|
||||
|
||||
|
||||
(* ; "
|
||||
Copyright (c) 1991, 1992 by Xerox Corporation. All rights reserved.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT MINI-NFSCOMS)
|
||||
|
||||
(RPAQQ MINI-NFSCOMS
|
||||
((DECLARE%: DONTEVAL@LOAD DOCOPY (P (DEFPACKAGE "NFS" (:USE "LISP" "XCL"))
|
||||
|
||||
(* ;; "Symbol is referenced from INIT files and UFSNFS")
|
||||
|
||||
(EXPORT (CL:INTERN "*USE-VOLUME-MAP*" "NFS")
|
||||
"NFS"))
|
||||
(FILES RPC YP NFSVOLUME))
|
||||
(PROP (FILETYPE MAKEFILE-ENVIRONMENT)
|
||||
MINI-NFS)))
|
||||
(DECLARE%: DONTEVAL@LOAD DOCOPY
|
||||
|
||||
(DEFPACKAGE "NFS" (:USE "LISP" "XCL"))
|
||||
|
||||
|
||||
(* ;; "Symbol is referenced from INIT files and UFSNFS")
|
||||
|
||||
|
||||
(EXPORT (CL:INTERN "*USE-VOLUME-MAP*" "NFS")
|
||||
"NFS")
|
||||
|
||||
|
||||
(FILESLOAD RPC YP NFSVOLUME)
|
||||
)
|
||||
|
||||
(PUTPROPS MINI-NFS FILETYPE :COMPILE-FILE)
|
||||
|
||||
(PUTPROPS MINI-NFS MAKEFILE-ENVIRONMENT (:READTABLE "INTERLISP" :PACKAGE "INTERLISP"))
|
||||
(PUTPROPS MINI-NFS COPYRIGHT ("Xerox Corporation" 1991 1992))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL)))
|
||||
STOP
|
||||
Binary file not shown.
Loading…
x
Reference in New Issue
Block a user