odds and ends --
This commit is contained in:
Larry Masinter
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
Binary file not shown.
Reference in New Issue
Block a user