github.com/Interlisp.medley
1
0
Fork 0
mirror of synced 2026-01-12 00:42:56 +00:00
Code Issues Projects Releases Wiki Activity

Merge pull request #712 from Interlisp/odds-n-ends

Browse Source 
Odds n ends
This commit is contained in:
rmkaplan 2022-03-04 21:08:09 -08:00 committed by GitHub
commit a544855c08
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
6 changed files with 4325 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

122
lispusers/HARDCOPY-RETAIN
View File

@ -1,26 +1,104 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
(filecreated "29-Sep-88 17:02:58" |{EG:PARC:XEROX}<JELLINEK>LISPUSERS>HARDCOPY-RETAIN.;3| 3423
|changes| |to:| (vars hardcopy-retaincoms)
(FILECREATED " 8-Feb-2022 09:25:36" |{DSK}<home>larry>medley>lispusers>HARDCOPY-RETAIN.;2| 6048
|previous| |date:| "29-Dec-87 14:01:40" |{EG:PARC:XEROX}<JELLINEK>LISPUSERS>HARDCOPY-RETAIN.;2|
:PREVIOUS-DATE "29-Sep-88 17:02:58" |{DSK}<home>larry>medley>lispusers>HARDCOPY-RETAIN.;1|)
; Copyright (c) 1987-1988, 2022 by Xerox Corporation.
(PRETTYCOMPRINT HARDCOPY-RETAINCOMS)
(RPAQQ HARDCOPY-RETAINCOMS ((FUNCTIONS HARDCOPYIMAGEW.TOFILE&PRINTER INSTALL-OPTION)
(DECLARE\: DONTEVAL@LOAD DOCOPY (P (INSTALL-OPTION)))))
(CL:DEFUN HARDCOPYIMAGEW.TOFILE&PRINTER (&OPTIONAL XCL-USER::WINDOW)
"Send hardcopy of WINDOW to a printer and a file."
(LET
((XCL-USER::RESULT (|GetImageFile|)))
(CL:WHEN XCL-USER::RESULT
(LET ((XCL-USER::PRINTER-NAME (|GetPrinterName|)))
(DESTRUCTURING-BIND
(XCL-USER::FILE . TYPE)
XCL-USER::RESULT
(HARDCOPY.SOMEHOW XCL-USER::WINDOW XCL-USER::FILE TYPE)
(CL:WHEN XCL-USER::PRINTER-NAME
(LET ((XCL-USER::FULL-NAME (PACKFILENAME.STRING
'HOST
(CL:PATHNAME-HOST XCL-USER::FILE)
'DEVICE
(CL:PATHNAME-DEVICE XCL-USER::FILE)
'DIRECTORY
(CL:PATHNAME-DIRECTORY XCL-USER::FILE)
'NAME
(CL:PATHNAME-NAME XCL-USER::FILE)
'EXTENSION
(OR (CL:FIRST (CL:SECOND (CL:ASSOC 'EXTENSION
(CL:REST (CL:ASSOC
TYPE
PRINTFILETYPES
)))))
TYPE)
'BODY
(CL:NAMESTRING *DEFAULT-PATHNAME-DEFAULTS*))))
(SEND.FILE.TO.PRINTER XCL-USER::FULL-NAME XCL-USER::PRINTER-NAME))))))))
(CL:DEFUN INSTALL-OPTION ()
"Install the new Hardcopy option."
(CL:LABELS ((XCL-USER::GET-SUBITEMS (XCL-USER::ITEM)
(AND (EQ (CL:FIRST (CL:FOURTH XCL-USER::ITEM))
'SUBITEMS)
(CL:REST (CL:FOURTH XCL-USER::ITEM))))
(XCL-USER::FIND-PLACE-WM
(XCL-USER::ITEM)
(LET ((XCL-USER::SUBITEMS (XCL-USER::GET-SUBITEMS XCL-USER::ITEM)))
(CL:WHEN XCL-USER::SUBITEMS
(CL:IF (EQ (CAR XCL-USER::ITEM)
'|Hardcopy|)
(CL:UNLESS (* \; "Install if not already there.")
(CL:FIND 'HARDCOPYIMAGEW.TOFILE&PRINTER XCL-USER::SUBITEMS :KEY
#'(CL:LAMBDA (XCL-USER::X)
(CL:SECOND (CL:SECOND XCL-USER::X)))
:TEST
#'EQ)
(NCONC XCL-USER::SUBITEMS (LIST (LIST "To a file and a printer"
'
'
HARDCOPYIMAGEW.TOFILE&PRINTER
"Sends image to a printer of your choosing, retaining the printer version of the file."
))))
(CL:MAPC #'XCL-USER::FIND-PLACE-WM XCL-USER::SUBITEMS)))))
(XCL-USER::FIND-PLACE-BM
(XCL-USER::ITEM)
(LET ((XCL-USER::SUBITEMS (XCL-USER::GET-SUBITEMS XCL-USER::ITEM)))
(CL:WHEN XCL-USER::SUBITEMS
(CL:IF (EQ (CAR XCL-USER::ITEM)
'|Hardcopy|)
(CL:UNLESS (* \; "Install if not already there.")
(CL:FIND 'HARDCOPYIMAGEW.TOFILE&PRINTER XCL-USER::SUBITEMS :KEY
#'(CL:LAMBDA (XCL-USER::X)
(CL:FIRST (CL:SECOND (CL:SECOND XCL-USER::X))))
:TEST
#'EQ)
(NCONC XCL-USER::SUBITEMS (LIST (LIST "To a file and a printer"
''(
 HARDCOPYIMAGEW.TOFILE&PRINTER
)
"Sends image to a printer of your choosing, retaining the printer version of the file."
))))
(CL:MAPC #'XCL-USER::FIND-PLACE-BM XCL-USER::SUBITEMS))))))
(CL:MAPC #'XCL-USER::FIND-PLACE-WM |WindowMenuCommands|)
(CL:MAPC #'XCL-USER::FIND-PLACE-BM |BackgroundMenuCommands|)
(CL:SETQ |WindowMenu| NIL)
(CL:SETQ |BackgroundMenu| NIL)))
(DECLARE\: DONTEVAL@LOAD DOCOPY
(INSTALL-OPTION)
)
; Copyright (c) 1987, 1988 by Xerox Corporation. All rights reserved.
(prettycomprint hardcopy-retaincoms)
(rpaqq hardcopy-retaincoms ((functions hardcopyimagew.tofile&printer install-option) (declare\: donteval@load docopy (p (install-option)))))
(cl:defun hardcopyimagew.tofile&printer (&optional xcl-user::window) "Send hardcopy of WINDOW to a printer and a file." (let ((xcl-user::result (|GetImageFile|))) (cl:when xcl-user::result (let ((xcl-user::printer-name (|GetPrinterName|))) (destructuring-bind (xcl-user::file . type) xcl-user::result (hardcopy.somehow xcl-user::window xcl-user::file type) (cl:when xcl-user::printer-name (let ((xcl-user::full-name (packfilename.string (quote host) (cl:pathname-host xcl-user::file) (quote device) (cl:pathname-device xcl-user::file) (quote directory) (cl:pathname-directory xcl-user::file) (quote name) (cl:pathname-name xcl-user::file) (quote extension) (or (cl:first (cl:second (cl:assoc (quote extension) (cl:rest (cl:assoc type printfiletypes))))) type) (quote body) (cl:namestring *default-pathname-defaults*)))) (send.file.to.printer xcl-user::full-name xcl-user::printer-name))))))))
(cl:defun install-option nil "Install the new Hardcopy option." (cl:labels ((xcl-user::get-subitems (xcl-user::item) (and (eq (cl:first (cl:fourth xcl-user::item)) (quote subitems)) (cl:rest (cl:fourth xcl-user::item)))) (xcl-user::find-place-wm (xcl-user::item) (let ((xcl-user::subitems (xcl-user::get-subitems xcl-user::item))) (cl:when xcl-user::subitems (cl:if (eq (car xcl-user::item) (quote |Hardcopy|)) (cl:unless (* \; "Install if not already there.") (cl:find (quote hardcopyimagew.tofile&printer) xcl-user::subitems :key (cl:function (cl:lambda (xcl-user::x) (cl:second (cl:second xcl-user::x)))) :test (cl:function eq)) (nconc xcl-user::subitems (list (list "To a file and a printer" (quote (quote hardcopyimagew.tofile&printer)) "Sends image to a printer of your choosing, retaining the printer version of the file.")))) (cl:mapc (cl:function xcl-user::find-place-wm) xcl-user::subitems))))) (xcl-user::find-place-bm (xcl-user::item) (let ((xcl-user::subitems (xcl-user::get-subitems xcl-user::item))) (cl:when xcl-user::subitems (cl:if (eq (car xcl-user::item) (quote |Hardcopy|)) (cl:unless (* \; "Install if not already there.") (cl:find (quote hardcopyimagew.tofile&printer) xcl-user::subitems :key (cl:function (cl:lambda (xcl-user::x) (cl:first (cl:second (cl:second xcl-user::x))))) :test (cl:function eq)) (nconc xcl-user::subitems (list (list "To a file and a printer" (quote (quote (hardcopyimagew.tofile&printer))) "Sends image to a printer of your choosing, retaining the printer version of the file.")))) (cl:mapc (cl:function xcl-user::find-place-bm) xcl-user::subitems)))))) (cl:mapc (cl:function xcl-user::find-place-wm) |WindowMenuCommands|) (cl:mapc (cl:function xcl-user::find-place-bm) |BackgroundMenuCommands|) (cl:setq |WindowMenu| nil) (cl:setq |BackgroundMenu| nil)))
(declare\: donteval@load docopy
(install-option)
)
(putprops hardcopy-retain copyright ("Xerox Corporation" 1987 1988))
(declare\: dontcopy
(filemap (nil)))
stop
(PUTPROPS HARDCOPY-RETAIN COPYRIGHT ("Xerox Corporation" 1987 1988 2022))
(DECLARE\: DONTCOPY
(FILEMAP (NIL (540 2464 (HARDCOPYIMAGEW.TOFILE&PRINTER 540 . 2464)) (2466 5894 (INSTALL-OPTION 2466 .
5894)))))
STOP

34
lispusers/HASHBUFFER
View File

@ -1,24 +1,23 @@
(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED "15-Sep-87 11:26:06" |{MCS:MCS:STANFORD}<LANE>HASHBUFFER.;6| 6916
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
changes to%: (VARS HASHBUFFERCOMS)
(FILECREATED "10-Feb-2022 21:52:22" {DSK}<home>larry>medley>lispusers>HASHBUFFER.;2 6788
previous date%: " 3-Sep-87 17:06:23" |{MCS:MCS:STANFORD}<LANE>HASHBUFFER.;5|)
:PREVIOUS-DATE "15-Sep-87 11:26:06" {DSK}<home>larry>medley>lispusers>HASHBUFFER.;1)
(* "
Copyright (c) 1985, 1986, 1987 by Stanford University. All rights reserved.
(* ; "
Copyright (c) 1985-1987, 2022 by Stanford University.
")
(PRETTYCOMPRINT HASHBUFFERCOMS)
(RPAQQ HASHBUFFERCOMS ((FNS CREATEHASHBUFFER OPENHASHBUFFER CLOSEHASHBUFFER GETHASHBUFFER
PUTHASHBUFFER)
(INITVARS (EMPTYHASHENTRYMARKER '**EMPTYHASHENTRY**))
(GLOBALVARS EMPTYHASHENTRYMARKER)
(FNS HASHARRAY.TO.HASHFILE HASHFILE.TO.HASHARRAY)
(DECLARE%: DONTCOPY (RECORDS HASHBUFFER))
(FILES HASH)))
(RPAQQ HASHBUFFERCOMS
((FNS CREATEHASHBUFFER OPENHASHBUFFER CLOSEHASHBUFFER GETHASHBUFFER PUTHASHBUFFER)
(INITVARS (EMPTYHASHENTRYMARKER '**EMPTYHASHENTRY**))
(GLOBALVARS EMPTYHASHENTRYMARKER)
(FNS HASHARRAY.TO.HASHFILE HASHFILE.TO.HASHARRAY)
(DECLARE%: DONTCOPY (RECORDS HASHBUFFER))
(FILES HASH)))
(DEFINEQ
(CREATEHASHBUFFER
@ -130,10 +129,11 @@ Copyright (c) 1985, 1986, 1987 by Stanford University. All rights reserved.
(RECORD HASHBUFFER (HASHARRAY HASHFILE ACCESS))
)
)
(FILESLOAD HASH)
(PUTPROPS HASHBUFFER COPYRIGHT ("Stanford University" 1985 1986 1987))
(PUTPROPS HASHBUFFER COPYRIGHT ("Stanford University" 1985 1986 1987 2022))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (848 4618 (CREATEHASHBUFFER 858 . 1987) (OPENHASHBUFFER 1989 . 3081) (CLOSEHASHBUFFER
3083 . 3472) (GETHASHBUFFER 3474 . 4317) (PUTHASHBUFFER 4319 . 4616)) (4745 6703 (
HASHARRAY.TO.HASHFILE 4755 . 5690) (HASHFILE.TO.HASHARRAY 5692 . 6701)))))
(FILEMAP (NIL (714 4484 (CREATEHASHBUFFER 724 . 1853) (OPENHASHBUFFER 1855 . 2947) (CLOSEHASHBUFFER
2949 . 3338) (GETHASHBUFFER 3340 . 4183) (PUTHASHBUFFER 4185 . 4482)) (4611 6569 (
HASHARRAY.TO.HASHFILE 4621 . 5556) (HASHFILE.TO.HASHARRAY 5558 . 6567)))))
STOP

BIN
lispusers/HISTMENU.TEDIT
View File

Binary file not shown.

11
lispusers/README.md Normal file
View File

@ -0,0 +1,11 @@
# LispUsers packages for Medley
These were contributed by people from Xerox and also from Medley and earlier customers, for distribution with sources and an implicit license for creation of derivative works; this is in the days before "Open Source" was a thing.
Some of these are included in full.sysout; some migrated between library and lispusers over time.
In order to tidy the lispusers directory, some files have been moved:
Previous enumerations of released "lispusers" packages and instructions have (temporarily) been moved to docs/lispusers.
Some files have been moved to obsolete/lispusers.

3063
lispusers/oss.lisp
View File

File diff suppressed because one or more lines are too long

1136
lispusers/osstst.lisp
View File

File diff suppressed because one or more lines are too long