(DEFINE-FILE-INFO :PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10) (FILECREATED " 7-Aug-2026 00:19:18" {MEDLEY}WINDOWOBJ.;31 33444 :EDIT-BY rmk :CHANGES-TO (FNS COPYIMAGEOBJ) :PREVIOUS-DATE " 4-Sep-2024 20:52:28" {MEDLEY}WINDOWOBJ.;29) (PRETTYCOMPRINT WINDOWOBJCOMS) (RPAQQ WINDOWOBJCOMS [(COMS (* ;  "Image object support - here so that DEDIT can use it without needing TEDIT to be loaded.") (RECORDS IMAGEOBJ IMAGEFNS IMAGEBOX) (FNS COPYINSERT IMAGEBOX IMAGEFNSCREATE IMAGEFNSP IMAGEOBJCREATE IMAGEOBJP IMAGEOBJPROP \IMAGEUSERPROP HPRINT.IMAGEOBJ COPYIMAGEOBJ READIMAGEOBJ WRITEIMAGEOBJ) (ADDVARS (HPRINTMACROS (IMAGEOBJ . WRITEIMAGEOBJ))) (GLOBALVARS (IMAGEOBJTYPES NIL) (IMAGEOBJGETFNS NIL))) (COMS (* ;  "For encapsulating unknown-type IMAGEOBJs.") (FNS ENCAPSULATEDOBJ.BUTTONEVENTINFN ENCAPSULATEDOBJ.PUTFN ENCAPSULATEDOBJ.DISPLAYFN ENCAPSULATEDOBJ.IMAGEBOXFN ENCAPSULATEDOBJP ENCAPSULATEDIMAGEFNS) (INITVARS ENCAPSULATEDIMAGEFNS) (GLOBALVARS ENCAPSULATEDIMAGEFNS)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA IMAGEOBJPROP]) (* ; "Image object support - here so that DEDIT can use it without needing TEDIT to be loaded.") (DECLARE%: EVAL@COMPILE (DATATYPE IMAGEOBJ (OBJECTDATUM IMAGEOBJPLIST IMAGEOBJFNS) (SYSTEM)) (DATATYPE IMAGEFNS (DISPLAYFN (* ;  "FN called to display the object's image") IMAGEBOXFN (* ; "To tell how big it is") PUTFN (* ; "To write it onto a file") GETFN (* ; "To read it back from the file") COPYFN (* ; "To make a copy of the object") BUTTONEVENTINFN (* ;  "Called when the mouse goes down over the object") COPYBUTTONEVENTINFN (* ;  "Called when the MIDDLE mouse button goes down over the object") WHENMOVEDFN (* ;  "Called when the object is moved within a document or other environment") WHENINSERTEDFN (* ;  "Called when the object is inserted into a context") WHENDELETEDFN (* ;  "Called when the object is removed from a context") WHENCOPIEDFN (* ;  "Called when the object is copied within a context") WHENOPERATEDONFN (* ;  "Called when something interesting happens to the object") PREPRINTFN IMAGECLASSNAME (* ;  "LITATOM unique name by which this kind of IMAGEOBJ is to be known to the world.") ) (SYSTEM)) (RECORD IMAGEBOX (XSIZE YSIZE YDESC XKERN) (SYSTEM)) ) (/DECLAREDATATYPE 'IMAGEOBJ '(POINTER POINTER POINTER) '((IMAGEOBJ 0 POINTER) (IMAGEOBJ 2 POINTER) (IMAGEOBJ 4 POINTER)) '6) (/DECLAREDATATYPE 'IMAGEFNS '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER) '((IMAGEFNS 0 POINTER) (IMAGEFNS 2 POINTER) (IMAGEFNS 4 POINTER) (IMAGEFNS 6 POINTER) (IMAGEFNS 8 POINTER) (IMAGEFNS 10 POINTER) (IMAGEFNS 12 POINTER) (IMAGEFNS 14 POINTER) (IMAGEFNS 16 POINTER) (IMAGEFNS 18 POINTER) (IMAGEFNS 20 POINTER) (IMAGEFNS 22 POINTER) (IMAGEFNS 24 POINTER) (IMAGEFNS 26 POINTER)) '28) (DEFINEQ (COPYINSERT [LAMBDA (IMAGEOBJ) (* ;; "Edited 4-Sep-2024 20:52 by rmk") (* ;; "Edited 27-Aug-2024 11:09 by rmk") (* ;; "Edited 20-Dec-2021 23:47 by rmk: IMAGEOBJ can now also be a list of objects in the COPYINSERTFN case") (* ;; "Edited 17-Sep-90 13:19 by jds") (* ;;; "inserts IMAGEOBJ into the window that currently has the tty. If this window has a COPYINSERTFN property, that is called, otherwise BKSYSBUF is called.") (* ;; "RMK: Take the window of the TTY process, if it has one (e.g. Tedit). Otherwise, (old behavior), get (or make) the window associated with the underlying TTY display stream") (PROG ([TTYW (OR (WINDOWP (PROCESSPROP (TTY.PROCESS) 'WINDOW)) (\INSUREWINDOW (WFROMDS (PROCESS.TTY (TTY.PROCESS] INSERTFN) (COND ([SETQ INSERTFN (AND TTYW (WINDOWPROP TTYW 'COPYINSERTFN] (for IMOBJ inside IMAGEOBJ do (APPLY* INSERTFN IMOBJ TTYW))) (T (* ;  "IMAGEOBJ can be a list of things too.") (for IMOBJ inside IMAGEOBJ do (BKSYSBUF (OR (COND [(IMAGEOBJP IMOBJ) (COND ((SETQ INSERTFN (IMAGEOBJPROP IMOBJ 'PREPRINTFN)) (APPLY* INSERTFN IMOBJ)) (T (IMAGEOBJPROP IMOBJ 'OBJECTDATUM] (T IMOBJ)) "") T (PROCESS.EVAL (TTY.PROCESS) '(GETREADTABLE) T]) (IMAGEBOX [LAMBDA (OBJ STREAM MODE) (* jds " 8-Feb-84 10:48") (APPLY* (IMAGEOBJPROP OBJ 'IMAGEBOXFN) OBJ STREAM MODE]) (IMAGEFNSCREATE [LAMBDA (DISPLAYFN IMAGEBOXFN PUTFN GETFN COPYFN BUTTONEVENTINFN COPYBUTTONEVENTINFN WHENMOVEDFN WHENINSERTEDFN WHENDELETEDFN WHENCOPIEDFN WHENOPERATEDONFN PREPRINTFN CLASSNAME) (* ; "Edited 17-Jul-2024 21:54 by rmk") (* jds "19-Feb-85 09:33") (* ;; "returns a structure which contains the image functions for a type of image object.") [COND (GETFN (* ;; "If a GETFN was specified, add it to the list of known GETFNs, so that people who verify them will know about it.") (OR (ASSOC GETFN IMAGEOBJGETFNS) (push IMAGEOBJGETFNS (LIST GETFN] (create IMAGEFNS DISPLAYFN _ DISPLAYFN IMAGEBOXFN _ IMAGEBOXFN PUTFN _ PUTFN GETFN _ GETFN COPYFN _ COPYFN BUTTONEVENTINFN _ BUTTONEVENTINFN COPYBUTTONEVENTINFN _ COPYBUTTONEVENTINFN WHENMOVEDFN _ WHENMOVEDFN WHENINSERTEDFN _ WHENINSERTEDFN WHENDELETEDFN _ WHENDELETEDFN WHENCOPIEDFN _ WHENCOPIEDFN WHENOPERATEDONFN _ WHENOPERATEDONFN PREPRINTFN _ PREPRINTFN IMAGECLASSNAME _ CLASSNAME]) (IMAGEFNSP [LAMBDA (X) (* rrb " 1-Feb-84 11:13") (* ; "is X an IMAGEFNS?") (AND (type? IMAGEFNS X) X]) (IMAGEOBJCREATE [LAMBDA (OBJECTDATUM IMAGEFNS) (* jds " 8-Feb-84 10:20") (* ; "returns an image object") (OR (IMAGEFNSP IMAGEFNS) (\ILLEGAL.ARG IMAGEFNS)) (* ;  "Make sure he handed us a valid set of fn references") (create IMAGEOBJ OBJECTDATUM _ OBJECTDATUM IMAGEOBJPLIST _ NIL IMAGEOBJFNS _ IMAGEFNS]) (IMAGEOBJP [LAMBDA (X) (* rrb " 1-Feb-84 16:22") (* ; "is X an IMAGEOBJ?") (AND (type? IMAGEOBJ X) X]) (IMAGEOBJPROP [LAMBDA NARGS (* jds "18-Feb-85 18:22") (* ;; "accesses and sets properties of an IMAGEOBJ.") (SELECTQ NARGS ((0 1) (\ILLEGAL.ARG NIL)) (PROG ((IMAGEOBJ (ARG NARGS 1)) (PROP (ARG NARGS 2)) (VAL (AND (IGREATERP NARGS 2) (ARG NARGS 3))) (SET? (NEQ NARGS 2)) IMAGEFNS) (COND ((NOT (IMAGEOBJP IMAGEOBJ)) (\ILLEGAL.ARG IMAGEOBJ))) (SETQ IMAGEFNS (fetch (IMAGEOBJ IMAGEOBJFNS) of IMAGEOBJ)) (RETURN (SELECTQ PROP (OBJECTDATUM (PROG1 (fetch (IMAGEOBJ OBJECTDATUM) of IMAGEOBJ) (COND (SET? (replace (IMAGEOBJ OBJECTDATUM) of IMAGEOBJ with VAL))))) (DISPLAYFN (PROG1 (fetch (IMAGEFNS DISPLAYFN) of IMAGEFNS) (COND (SET? (replace (IMAGEFNS DISPLAYFN) of IMAGEFNS with VAL))))) (IMAGEBOXFN (PROG1 (fetch (IMAGEFNS IMAGEBOXFN) of IMAGEFNS) (COND (SET? (replace (IMAGEFNS IMAGEBOXFN) of IMAGEFNS with VAL))))) (PUTFN (PROG1 (fetch (IMAGEFNS PUTFN) of IMAGEFNS) (COND (SET? (replace (IMAGEFNS PUTFN) of IMAGEFNS with VAL))))) (GETFN (PROG1 (fetch (IMAGEFNS GETFN) of IMAGEFNS) (COND (SET? (replace (IMAGEFNS GETFN) of IMAGEFNS with VAL))))) (COPYFN (PROG1 (fetch (IMAGEFNS COPYFN) of IMAGEFNS) (COND (SET? (replace (IMAGEFNS COPYFN) of IMAGEFNS with VAL))))) (BUTTONEVENTINFN (PROG1 (fetch (IMAGEFNS BUTTONEVENTINFN) of IMAGEFNS) (COND (SET? (replace (IMAGEFNS BUTTONEVENTINFN) of IMAGEFNS with VAL))))) (COPYBUTTONEVENTINFN (PROG1 (fetch (IMAGEFNS COPYBUTTONEVENTINFN) of IMAGEFNS) (COND (SET? (replace (IMAGEFNS COPYBUTTONEVENTINFN) of IMAGEFNS with VAL))))) (WHENMOVEDFN (PROG1 (fetch (IMAGEFNS WHENMOVEDFN) of IMAGEFNS) (COND (SET? (replace (IMAGEFNS WHENMOVEDFN) of IMAGEFNS with VAL))))) (WHENINSERTEDFN (PROG1 (fetch (IMAGEFNS WHENINSERTEDFN) of IMAGEFNS) (COND (SET? (replace (IMAGEFNS WHENINSERTEDFN) of IMAGEFNS with VAL))))) (WHENDELETEDFN (PROG1 (fetch (IMAGEFNS WHENDELETEDFN) of IMAGEFNS) (COND (SET? (replace (IMAGEFNS WHENDELETEDFN) of IMAGEFNS with VAL))))) (WHENCOPIEDFN (PROG1 (fetch (IMAGEFNS WHENCOPIEDFN) of IMAGEFNS) (COND (SET? (replace (IMAGEFNS WHENCOPIEDFN) of IMAGEFNS with VAL))))) (WHENOPERATEDONFN (PROG1 (fetch (IMAGEFNS WHENOPERATEDONFN) of IMAGEFNS) (COND (SET? (replace (IMAGEFNS WHENOPERATEDONFN) of IMAGEFNS with VAL))))) (PREPRINTFN (PROG1 (fetch (IMAGEFNS PREPRINTFN) of IMAGEFNS) (COND (SET? (replace (IMAGEFNS PREPRINTFN) of IMAGEFNS with VAL))))) (IMAGECLASSNAME (PROG1 (fetch (IMAGEFNS IMAGECLASSNAME) of IMAGEFNS) (COND (SET? (replace (IMAGEFNS IMAGECLASSNAME) of IMAGEFNS with VAL))))) (\IMAGEUSERPROP IMAGEOBJ PROP VAL SET?]) (\IMAGEUSERPROP [LAMBDA (IMAGEOBJ PROP VAL SET?) (* rrb " 1-Feb-84 11:44") (* ;; "reads and sets the values of properties on an IMAGEOBJ") (PROG ((PLIST (fetch (IMAGEOBJ IMAGEOBJPLIST) of IMAGEOBJ))) (RETURN (PROG1 (LISTGET PLIST PROP) [COND (SET? (COND (PLIST (LISTPUT PLIST PROP VAL)) (T (replace (IMAGEOBJ IMAGEOBJPLIST) of IMAGEOBJ with (LIST PROP VAL])]) (HPRINT.IMAGEOBJ [LAMBDA (IMAGEOBJ STREAM) (* rrb "19-Dec-84 16:22") (* ;; "HPRINT function for writing out IMAGE OBJECTS") (* ;; "write out the name of the function to read things back in with.") (PRIN2 (LIST (fetch (IMAGEFNS GETFN) of (fetch (IMAGEOBJ IMAGEOBJFNS) of IMAGEOBJ ))) STREAM HPRINTRDTBL) (APPLY* (fetch (IMAGEFNS PUTFN) of (fetch (IMAGEOBJ IMAGEOBJFNS) of IMAGEOBJ)) IMAGEOBJ STREAM) T]) (COPYIMAGEOBJ [LAMBDA (FROM TO COPYALL) (* ; "Edited 7-Aug-2026 00:06 by rmk") (* jds "19-Feb-85 09:59") (* ;; "Copis the contents of one IMAGEOBJ nto another, effectively making TO be the same object as FROM. If COPYALL, copies all of the data except for the imagefns.") (CL:UNLESS TO (SETQ TO (create IMAGEOBJ))) (if COPYALL then (replace (IMAGEOBJ OBJECTDATUM) of TO with (COPYALL (fetch (IMAGEOBJ OBJECTDATUM) of FROM))) (replace (IMAGEOBJ IMAGEOBJPLIST) of TO with (COPYALL (fetch (IMAGEOBJ IMAGEOBJPLIST) of FROM))) else (replace (IMAGEOBJ OBJECTDATUM) of TO with (fetch (IMAGEOBJ OBJECTDATUM) of FROM)) (replace (IMAGEOBJ IMAGEOBJPLIST) of TO with (fetch (IMAGEOBJ IMAGEOBJPLIST) of FROM))) (replace (IMAGEOBJ IMAGEOBJFNS) of TO with (fetch (IMAGEOBJ IMAGEOBJFNS) of FROM)) TO]) (READIMAGEOBJ [LAMBDA (STREAM GETFN NOERROR DATANBYTES) (* ;; "Edited 5-Dec-2023 21:07 by rmk") (* ;; "Edited 29-Nov-2023 14:51 by rmk") (* ;; "Edited 18-Mar-2022 21:45 by rmk: Added WHEREIS as a last resort.") (* ;; "Reads an IMAGEOBJ, using GETFN. Verifies that the GETFN is legitimate") (* ;; "the variable UNDERREADIMAGEOBJ is used in HVBAKREAD to determine if it should do a validity check on the function which is read from the file.") (* ;; "rmk: I'm not sure that it makes sense for GETFN to be NIL, as 86 code allowed. Presumably an image object without a GETFN should never have been written.") (LET (OBJ GETFNFILE GETFNFILENAME HYPHENPOS MAINFILE FAILEDMSG (UNDERREADIMAGEOBJ T)) (DECLARE (SPECVARS UNDERREADIMAGEOBJ)) (* ;; "Typically,the file containing the GETFN has already been loaded. If not, it could be the case that the GETFN and its file were pushed on the list for future reference (now), but the file wasn't loaded then. We need to download it. We use the WHEREIS database to identify the file containing the GETFN. If it has a hyphenated name FOO-FIE and it has a sister file that named with just the prefix of the hyphen FOO, then we assume that the GETFN is in an internal file of a larger application FOO application, and we load FOO instead. Presumably that provides the GETFN.") (* ;; "Note: the Prompt message only shows the NAME of the file, not the full path.") (* ;; "Clean this up if we decide to nuke the MOUSECONFIRM") (CL:WHEN (AND GETFN (NOT (GETD GETFN)) [SETQ GETFNFILENAME (OR (LISTGET (CDR (ASSOC GETFN IMAGEOBJGETFNS)) 'FILE) (CAR (WHEREIS GETFN 'FNS T)) (CAR (WHEREIS GETFN 'FUNCTIONS T] [SETQ GETFNFILE (FINDFILE-WITH-EXTENSIONS GETFNFILENAME NIL (APPEND *COMPILED-EXTENSIONS* (CONS NIL] (PROG1 T (* ;; "Is FOO a sister of FOO-FIE ?") (CL:WHEN (SETQ HYPHENPOS (STRPOS "-" GETFNFILENAME)) [SETQ MAINFILE (FINDFILE-WITH-EXTENSIONS (PACKFILENAME 'NAME (SUBSTRING GETFNFILENAME 1 (SUB1 HYPHENPOS)) 'VERSION NIL 'EXTENSION NIL 'BODY GETFNFILE) NIL (APPEND *COMPILED-EXTENSIONS* (CONS NIL])) (if T then (* ;; "This makes for an automatic attempt. If we fail, well...") (PROMPTPRINT "Getting GETFN " GETFN " by loading " (OR MAINFILE GETFNFILE)) T else (MOUSECONFIRM (CONCAT "Trying to read an IMAGEOBJ with GETFN " GETFN ". Shall I load the support file, " MAINFILE "?") NIL NIL NIL))) (* ;; "Hopefully we found the latest compiled versions") (CL:WHEN MAINFILE (DOFILESLOAD (LIST '(SYSLOAD) MAINFILE))) (CL:UNLESS (GETD GETFN) (* ;  "Didn't find the GETFN: try the original GETFNFILE.") (DOFILESLOAD (LIST '(SYSLOAD) GETFNFILE)))) (if (NULL (GETD GETFN)) then (SETQ FAILEDMSG "Unknown") elseif [SETQ OBJ (CAR (NLSETQ (APPLY* GETFN STREAM] else (SETQ FAILEDMSG "Error in")) (CL:UNLESS (OR OBJ NOERROR) (* ;  "Still no support for this kind of IMAGEOBJ. Encapsulate it in something safe.") (SETQ OBJ (IMAGEOBJCREATE NIL (ENCAPSULATEDIMAGEFNS GETFN))) (IMAGEOBJPROP OBJ 'FILE (FULLNAME STREAM) STREAM) (* ;  "Remember which file it came from so that it could be written back out.") (IMAGEOBJPROP OBJ 'FILEPTR (GETFILEPTR STREAM)) (* ; "And where on the file") (IMAGEOBJPROP OBJ 'OBJSIZE DATANBYTES) (IMAGEOBJPROP OBJ 'UNKNOWNGETFN GETFN) (* ; "And the name of its GETFN") (IMAGEOBJPROP OBJ 'FAILEDMSG FAILEDMSG) (* ; "And why it failed") (CL:WHEN DATANBYTES (SETFILEPTR STREAM (PLUS (GETFILEPTR STREAM) DATANBYTES)))) OBJ]) (WRITEIMAGEOBJ [LAMBDA (IMAGEOBJ STREAM) (* jds "19-Feb-85 09:36") (* ;; "HPRINT function for writing out IMAGE OBJECTS") (* ;; "write out the name of the function to read things back in with.") (COND ((NOT (fetch (IMAGEFNS GETFN) of (fetch (IMAGEOBJ IMAGEOBJFNS) of IMAGEOBJ))) (* ;  "This IMAGEOBJ has no GETFN. Complain!") (HELP "No GETFN for IMAGEOBJ " IMAGEOBJ))) (PRIN2 [LIST 'READIMAGEOBJ NIL (KWOTE (fetch (IMAGEFNS GETFN) of (fetch (IMAGEOBJ IMAGEOBJFNS) of IMAGEOBJ] STREAM HPRINTRDTBL) (* ;  "Write out a call to READIMAGEOBJ, which takes the input stream and a GETFN name as arguments.") (APPLY* (fetch (IMAGEFNS PUTFN) of (fetch (IMAGEOBJ IMAGEOBJFNS) of IMAGEOBJ)) IMAGEOBJ STREAM) (* ;  "Then write out the guts of the IMAGEOBJ itself.") T]) ) (ADDTOVAR HPRINTMACROS (IMAGEOBJ . WRITEIMAGEOBJ)) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS (IMAGEOBJTYPES NIL) (IMAGEOBJGETFNS NIL)) ) (* ; "For encapsulating unknown-type IMAGEOBJs.") (DEFINEQ (ENCAPSULATEDOBJ.BUTTONEVENTINFN [LAMBDA (IMAGEOBJ WINDOW) (* ; "Edited 26-Nov-2023 08:15 by rmk") (* ; "Edited 2-Apr-87 15:33 by bvm:") (* ;;; "The user hit a button inside this object. Try loading it now.") (CL:WITH-OPEN-FILE (STREAM (IMAGEOBJPROP IMAGEOBJ 'FILE)) (SETFILEPTR STREAM (IMAGEOBJPROP IMAGEOBJ 'FILEPTR)) (* ;  "Move to where the IMAGEOBJ's description started in the file we read it from") (LET ([OBJ (READIMAGEOBJ STREAM (IMAGEOBJPROP IMAGEOBJ 'UNKNOWNGETFN) T (IMAGEOBJPROP IMAGEOBJ 'ENDOFOBJFILEPTR] PROMPT) (COND (OBJ (* ;  "We succeeded in reading the object this time. Copy its guts over the placeholder.") (COPYIMAGEOBJ OBJ IMAGEOBJ) 'CHANGED) ((GETD (IMAGEOBJPROP IMAGEOBJ 'UNKNOWNGETFN)) (SETQ PROMPT (GETPROMPTWINDOW WINDOW)) (FRESHLINE PROMPT) (PRIN1 (CONCAT "Error in executing " (IMAGEOBJPROP IMAGEOBJ 'UNKNOWNGETFN)) PROMPT) NIL) (T (SETQ PROMPT (GETPROMPTWINDOW WINDOW)) (FRESHLINE PROMPT) (PRIN1 (CONCAT (IMAGEOBJPROP IMAGEOBJ 'UNKNOWNGETFN) " is still unknown") PROMPT) NIL]) (ENCAPSULATEDOBJ.PUTFN [LAMBDA (IMAGEOBJ STREAM) (* ; "Edited 24-Aug-91 14:57 by jds") (* ;;; "image object put function for unknown image objects. It copies the bytes from the source file to the output file if the range of the object is known. If not, it errors because nothing else I could think of makes sense. Since the name of the GETFN has already been written out and we don't know what format it is expecting we can't write out anything that wouldn't cause an error when read in so erroring now is better.") (PROG ((DATANBYTES (IMAGEOBJPROP IMAGEOBJ 'OBJSIZE)) (FILE (IMAGEOBJPROP IMAGEOBJ 'FILE)) (BEGOFOBJ (IMAGEOBJPROP IMAGEOBJ 'FILEPTR)) INSTREAM) (OR (NUMBERP DATANBYTES) (ERROR "No length information for this image object. Either delete this image object or load its support files." IMAGEOBJ) (RETURN)) (CL:WITH-OPEN-STREAM (INSTREAM (OPENSTREAM FILE 'INPUT)) (COPYBYTES INSTREAM STREAM BEGOFOBJ (PLUS BEGOFOBJ DATANBYTES))) T]) (ENCAPSULATEDOBJ.DISPLAYFN [LAMBDA (OBJ STREAM) (* ; "Edited 5-Dec-2023 12:12 by rmk") (* jds "19-Feb-85 10:37") (* ;; "Display function for an IMAGEOBJ that has been encapsulated for safety") (* ;;  "Displays as a box containing text saying 'Unknown IMAGEOBJ type' , and naming the unknown GETFN.") (LET* ((CURX (DSPXPOSITION NIL STREAM)) (CURY (DSPYPOSITION NIL STREAM)) (FONT (FONTCREATE 'HELVETICA 8 'BOLD NIL STREAM)) (OLDFONT (DSPFONT FONT STREAM)) (GETFN (IMAGEOBJPROP OBJ 'UNKNOWNGETFN)) (TYPE (IMAGEOBJPROP OBJ 'TYPE)) (OBJBOX (IMAGEOBJPROP OBJ 'BOUNDBOX)) (XSIZE (IDIFFERENCE (fetch XSIZE of OBJBOX) 4)) (YSIZE (IDIFFERENCE (fetch YSIZE of OBJBOX) 4))) (RELMOVETO 3 (IPLUS (FONTPROP FONT 'HEIGHT) 3) STREAM) (PRIN1 (OR (IMAGEOBJPROP OBJ 'FAILEDMSG "Unknown")) STREAM) (PRIN1 " IMAGEOBJ" STREAM) (MOVETO (IPLUS CURX 3) (IPLUS CURY 3) STREAM) (printout STREAM "GETFN: " GETFN) (MOVETO CURX (IDIFFERENCE CURY (fetch YDESC of OBJBOX)) STREAM) (RELDRAWTO XSIZE 0 2 'PAINT STREAM NIL '(16 8 8 8)) (RELDRAWTO 0 YSIZE 2 'PAINT STREAM NIL '(16 8 8 8)) (RELDRAWTO (IMINUS XSIZE) 0 2 'PAINT STREAM NIL '(16 8 8 8)) (RELDRAWTO 0 (IMINUS YSIZE) 2 'PAINT STREAM NIL '(16 8 8 8)) (DSPFONT OLDFONT STREAM]) (ENCAPSULATEDOBJ.IMAGEBOXFN [LAMBDA (IMAGEOBJ STREAM) (* ; "Edited 5-Dec-2023 11:25 by rmk") (* ; "Edited 29-Nov-2023 12:49 by rmk") (* jds "19-Feb-85 10:05") (* ;; "IMAGEOBXFN for an encapsulated IMAGEOBJ. If the GETFN now exists, another attempt is made to retrieve the underlying object and to use its boxfn. ") (LET ((GETFN (IMAGEOBJPROP IMAGEOBJ 'UNKNOWNGETFN)) NEWOBJ WIDTH HEIGHT FONT) (if [AND GETFN (CL:WITH-OPEN-FILE (STREAM (IMAGEOBJPROP IMAGEOBJ 'FILE)) (SETFILEPTR STREAM (IMAGEOBJPROP IMAGEOBJ 'FILEPTR)) (* ;  "Move to where the IMAGEOBJ's description started in the file we read it from") (SETQ NEWOBJ (READIMAGEOBJ STREAM GETFN T (IMAGEOBJPROP IMAGEOBJ 'ENDOFOBJFILEPTR] then (COPYIMAGEOBJ NEWOBJ IMAGEOBJ) (* ; "ENCAPSULATEDOBJ.BUTTONEVENTINFN also returns CHANGED to tell the caller what happened. But we have to return the box. Fingers crossed.") (APPLY* (IMAGEOBJPROP IMAGEOBJ 'IMAGEBOXFN) IMAGEOBJ STREAM) else (SETQ FONT (FONTCREATE 'HELVETICA 8 'BOLD NIL STREAM)) [SETQ HEIGHT (ITIMES 2 (FONTPROP FONT 'HEIGHT] (SETQ WIDTH (IMAX (STRINGWIDTH (CONCAT (OR (IMAGEOBJPROP IMAGEOBJ 'FAILEDMSG) "Unknown" " IMAGEOBJ")) FONT) (STRINGWIDTH (CONCAT "GETFN: " GETFN) FONT))) (create IMAGEBOX XSIZE _ (IPLUS WIDTH 6) YSIZE _ (IPLUS HEIGHT 6) YDESC _ 0 XKERN _ 0]) (ENCAPSULATEDOBJP [LAMBDA (OBJ) (* ; "Edited 23-Apr-2024 18:03 by rmk") (AND (IMAGEOBJP OBJ) (EQ (FUNCTION ENCAPSULATEDOBJ.DISPLAYFN) (fetch (IMAGEFNS DISPLAYFN) of (fetch (IMAGEOBJ IMAGEOBJFNS) of OBJ]) (ENCAPSULATEDIMAGEFNS [LAMBDA (GETFN) (* rrb " 3-Feb-86 18:31") (* ;;; "Set up the IMAGEFNS for the encapsulated-IMAGEOBJ type: The way to protect TEdit and friends from unfriendly IMAGEOBJs. The GETFN is used as the GETFN for the imagefns so that is can be written out. The imagefns are cached so that a new set doesn't have to be created for each instance of an unknown image object type.") (OR (CDR (ASSOC GETFN ENCAPSULATEDIMAGEFNS)) (PROG [(IMAGEFNS (IMAGEFNSCREATE (FUNCTION ENCAPSULATEDOBJ.DISPLAYFN) (FUNCTION ENCAPSULATEDOBJ.IMAGEBOXFN) (FUNCTION ENCAPSULATEDOBJ.PUTFN) GETFN (FUNCTION NIL) (FUNCTION ENCAPSULATEDOBJ.BUTTONEVENTINFN) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL] (SETQ ENCAPSULATEDIMAGEFNS (CONS (CONS GETFN IMAGEFNS) ENCAPSULATEDIMAGEFNS)) (RETURN IMAGEFNS]) ) (RPAQ? ENCAPSULATEDIMAGEFNS NIL) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS ENCAPSULATEDIMAGEFNS) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA IMAGEOBJPROP) ) (DECLARE%: DONTCOPY (FILEMAP (NIL (4781 24310 (COPYINSERT 4791 . 6726) (IMAGEBOX 6728 . 6908) (IMAGEFNSCREATE 6910 . 8248) (IMAGEFNSP 8250 . 8491) (IMAGEOBJCREATE 8493 . 9038) (IMAGEOBJP 9040 . 9281) (IMAGEOBJPROP 9283 . 15175) (\IMAGEUSERPROP 15177 . 15771) (HPRINT.IMAGEOBJ 15773 . 16362) (COPYIMAGEOBJ 16364 . 17597) ( READIMAGEOBJ 17599 . 22956) (WRITEIMAGEOBJ 22958 . 24308)) (24524 33166 ( ENCAPSULATEDOBJ.BUTTONEVENTINFN 24534 . 26317) (ENCAPSULATEDOBJ.PUTFN 26319 . 27434) ( ENCAPSULATEDOBJ.DISPLAYFN 27436 . 29239) (ENCAPSULATEDOBJ.IMAGEBOXFN 29241 . 31417) (ENCAPSULATEDOBJP 31419 . 31727) (ENCAPSULATEDIMAGEFNS 31729 . 33164))))) STOP