Merge branch 'master' into mth49--some-errors-parsing-BDF
This commit is contained in:
Matt Heffron
@@ -1,13 +1,13 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "21-Apr-2024 09:12:04" {WMEDLEY}<library>CLIPBOARD.;18 7248
|
||||
(FILECREATED "25-Sep-2025 15:00:01"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>working-medley>library>CLIPBOARD.;28 8305
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (FNS INSTALL-CLIPBOARD)
|
||||
(VARS CLIPBOARDCOMS)
|
||||
:CHANGES-TO (FNS PUTCLIPBOARD CLIPBOARD-COPY-STREAM)
|
||||
|
||||
:PREVIOUS-DATE " 2-Apr-2024 17:02:09" {WMEDLEY}<library>CLIPBOARD.;17)
|
||||
:PREVIOUS-DATE "21-Apr-2024 09:12:04" {WMEDLEY}<library>CLIPBOARD.;18)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT CLIPBOARDCOMS)
|
||||
@@ -58,12 +58,29 @@
|
||||
(CONCATCODES (BIND C WHILE (SETQ C (READCCODE s)) COLLECT C])
|
||||
|
||||
(PUTCLIPBOARD
|
||||
[LAMBDA (OBJECT PRINTFN) (* ; "Edited 23-Feb-2021 11:32 by rmk:")
|
||||
(* ; "Edited 25-Apr-2018 16:49 by rmk:")
|
||||
(CL:WITH-OPEN-STREAM (s (CLIPBOARD-COPY-STREAM))
|
||||
(IF PRINTFN
|
||||
THEN (APPLY* PRINTFN OBJECT s)
|
||||
ELSE (PRIN3 OBJECT s])
|
||||
[LAMBDA (OBJECT PRINTFN) (* ; "Edited 25-Sep-2025 14:59 by rmk")
|
||||
(* ; "Edited 23-Feb-2021 11:32 by rmk:")
|
||||
(* ; "Edited 25-Apr-2018 16:49 by rmk:")
|
||||
(if (STRPOS "darwin" (UNIX-GETENV "OSTYPE"))
|
||||
then
|
||||
(* ;; "pbpaste doesn't seem to take a file argument.")
|
||||
|
||||
(CL:WITH-OPEN-STREAM (S (CREATE-PROCESS-STREAM "pbcopy"))
|
||||
(CL:IF PRINTFN
|
||||
(APPLY* PRINTFN OBJECT S)
|
||||
(PRIN3 OBJECT S)))
|
||||
else
|
||||
(* ;; "Try to make xclip more reliable by passing a file that already contains the input.")
|
||||
|
||||
(LET ((TEMPFILE (OUTFILEP "{DSK}/tmp/xclip-copy.txt")))
|
||||
(CL:WITH-OPEN-FILE (S TEMPFILE :DIRECTION :OUTPUT :EXTERNAL-FORMAT (
|
||||
SYSTEM-EXTERNALFORMAT
|
||||
))
|
||||
(CL:IF PRINTFN
|
||||
(APPLY* PRINTFN OBJECT S)
|
||||
(PRIN3 OBJECT S)))
|
||||
(ShellCommand (CONCAT "xclip -i -selection clipboard " (UNIX-FILE-NAME TEMPFILE)))
|
||||
(DELFILE TEMPFILE])
|
||||
|
||||
(PASTEFROMCLIPBOARD
|
||||
[LAMBDA NIL (* ; "Edited 15-Feb-2021 23:43 by rmk:")
|
||||
@@ -81,13 +98,12 @@
|
||||
ELSE (BIND C WHILE (SETQ C (GNCCODE STR)) DO (BKSYSCHARCODE C])
|
||||
|
||||
(CLIPBOARD-COPY-STREAM
|
||||
[LAMBDA NIL (* ; "Edited 7-Jul-2022 23:51 by rmk")
|
||||
[LAMBDA NIL (* ; "Edited 24-Sep-2025 14:27 by rmk")
|
||||
(* ; "Edited 7-Jul-2022 23:51 by rmk")
|
||||
(* ; "Edited 23-Feb-2021 22:11 by rmk:")
|
||||
(LET (STRM (OST (UNIX-GETENV "OSTYPE")))
|
||||
(SETQ STRM (CREATE-PROCESS-STREAM (CL:IF (STRPOS "darwin" OST)
|
||||
"pbcopy"
|
||||
"xclip -i -selection clipboard")))
|
||||
STRM])
|
||||
(CREATE-PROCESS-STREAM (CL:IF (STRPOS "darwin" (UNIX-GETENV "OSTYPE"))
|
||||
"pbcopy"
|
||||
"xclip -i -selection clipboard")])
|
||||
|
||||
(CLIPBOARD-PASTE-STREAM
|
||||
[LAMBDA NIL (* ; "Edited 7-Jul-2022 23:51 by rmk")
|
||||
@@ -146,7 +162,7 @@
|
||||
(ADDTOVAR LAMA )
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (1148 5429 (INSTALL-CLIPBOARD 1158 . 2485) (GETCLIPBOARD 2487 . 2861) (PUTCLIPBOARD 2863
|
||||
. 3268) (PASTEFROMCLIPBOARD 3270 . 4188) (CLIPBOARD-COPY-STREAM 4190 . 4705) (CLIPBOARD-PASTE-STREAM
|
||||
4707 . 5427)) (5430 6969 (SEDIT.COPYTOCLIPBOARD 5440 . 6967)))))
|
||||
(FILEMAP (NIL (1167 6486 (INSTALL-CLIPBOARD 1177 . 2504) (GETCLIPBOARD 2506 . 2880) (PUTCLIPBOARD 2882
|
||||
. 4306) (PASTEFROMCLIPBOARD 4308 . 5226) (CLIPBOARD-COPY-STREAM 5228 . 5762) (CLIPBOARD-PASTE-STREAM
|
||||
5764 . 6484)) (6487 8026 (SEDIT.COPYTOCLIPBOARD 6497 . 8024)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,19 +1,17 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "21-May-2024 22:10:45" {DSK}<home>matt>Interlisp>medley>sources>EDITINTERFACE.;2 47745
|
||||
(FILECREATED " 2-Oct-2025 10:43:08"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>working-medley>sources>EDITINTERFACE.;57 49004
|
||||
|
||||
:EDIT-BY "mth"
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (FNS EDITLOADFNS?)
|
||||
:CHANGES-TO (VARS EDITINTERFACECOMS)
|
||||
(FUNCTIONS ED)
|
||||
|
||||
:PREVIOUS-DATE "22-Jun-2022 13:32:08" {DSK}<home>matt>Interlisp>medley>sources>EDITINTERFACE.;1
|
||||
)
|
||||
:PREVIOUS-DATE " 1-Oct-2025 23:20:37"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>working-medley>sources>EDITINTERFACE.;56)
|
||||
|
||||
|
||||
(* ; "
|
||||
Copyright (c) 1986-1988, 1990-1991, 2024 by Venue & Xerox Corporation.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT EDITINTERFACECOMS)
|
||||
|
||||
(RPAQQ EDITINTERFACECOMS
|
||||
@@ -110,10 +108,11 @@ Copyright (c) 1986-1988, 1990-1991, 2024 by Venue & Xerox Corporation.
|
||||
(DEFGLOBALVAR XCL::ED-LAST-INFO NIL
|
||||
"used in ED to stash last call info so (ED NIL) will restart last edit")
|
||||
|
||||
(CL:DEFUN ED (CL::NAME CL::OPTIONS) (* ; "Edited 5-Jul-88 16:03 by woz")
|
||||
|
||||
(* ;;; "Standard Common Lisp editor entry. CLtL say's ED does something reasonable when passed a pathname. We coerce name into something that might be the name of something with an IL:FILES definition, & try to edit that. Then save call info in ED-LAST-INFO, so (ED) will start last edit over again.")
|
||||
|
||||
(CL:DEFUN ED (CL::NAME &OPTIONAL (CL::OPTIONS NIL)) (* ; "Edited 2-Oct-2025 10:42 by rmk")
|
||||
(* ; "Edited 30-Sep-2025 12:49 by rmk")
|
||||
(* ; "Edited 20-Dec-2023 00:06 by rmk")
|
||||
(* ; "Edited 5-Jul-88 16:03 by woz")
|
||||
(CL:SETQ CL::OPTIONS (MKLIST CL::OPTIONS))
|
||||
(CL:UNLESS (CL:LISTP CL::OPTIONS)
|
||||
(CL:SETQ CL::OPTIONS (LIST CL::OPTIONS)))
|
||||
(CL:WHEN (CL:PATHNAMEP CL::NAME)
|
||||
@@ -122,95 +121,128 @@ Copyright (c) 1986-1988, 1990-1991, 2024 by Venue & Xerox Corporation.
|
||||
(CL:PUSHNEW 'FILES CL::OPTIONS))
|
||||
[COND
|
||||
(CL::NAME (CL:SETQ XCL::ED-LAST-INFO (CONS CL::NAME CL::OPTIONS)))
|
||||
(T (CL:WHEN (NULL XCL::ED-LAST-INFO)
|
||||
(T (CL:UNLESS XCL::ED-LAST-INFO
|
||||
(CL:FORMAT T "Sorry, there is no previous edit to restart.")
|
||||
(CL:RETURN-FROM ED NIL))
|
||||
(CL:SETQ CL::NAME (CAR XCL::ED-LAST-INFO))
|
||||
(CL:SETQ CL::OPTIONS (CL:APPEND (CDR XCL::ED-LAST-INFO)
|
||||
CL::OPTIONS]
|
||||
(LET* ((CL::FROM-DISPLAY (OR (EQ CL::OPTIONS T)
|
||||
(CL:MEMBER :DISPLAY CL::OPTIONS)
|
||||
(CL:MEMBER 'DISPLAY CL::OPTIONS)))
|
||||
(CL::GIVEN-TYPES (for X inside CL::OPTIONS when (NEQ X T) bind TYPE
|
||||
when (CL:SETQ TYPE (GETFILEPKGTYPE X 'TYPES T CL::NAME)) collect TYPE))
|
||||
[CL::TYPES-WITH-DEFNS (TYPESOF CL::NAME CL::GIVEN-TYPES NIL
|
||||
(CL:IF (OR (CL:MEMBER :CURRENT CL::OPTIONS)
|
||||
(CL:MEMBER 'CURRENT CL::OPTIONS))
|
||||
'CURRENT
|
||||
'?)
|
||||
#'(LAMBDA (X)
|
||||
(NEQ (GET X 'EDITDEF)
|
||||
'NILL]
|
||||
(CL::POSSIBLE-TYPES (COND
|
||||
([AND (NULL CL::GIVEN-TYPES)
|
||||
(CL:SYMBOLP CL::NAME)
|
||||
(NOT (NULL *ED-OFFERS-PROPERTY-LIST*))
|
||||
(find X on (GETPROPLIST CL::NAME) by (CDDR X)
|
||||
suchthat (NULL (GET (CAR X)
|
||||
'PROPTYPE]
|
||||
(LET*
|
||||
((CL::FROM-DISPLAY (OR (EQ CL::OPTIONS T)
|
||||
(CL:MEMBER :DISPLAY CL::OPTIONS)
|
||||
(CL:MEMBER 'DISPLAY CL::OPTIONS)))
|
||||
(CL::GIVEN-TYPES (for CL::X TYPE inside CL::OPTIONS unless (EQ CL::X T)
|
||||
when (CL:SETQ TYPE (GETFILEPKGTYPE CL::X 'TYPES T CL::NAME)) collect TYPE))
|
||||
[CL::TYPES-WITH-DEFNS (TYPESOF CL::NAME CL::GIVEN-TYPES NIL (CL:IF (OR (CL:MEMBER :CURRENT
|
||||
CL::OPTIONS)
|
||||
(CL:MEMBER 'CURRENT
|
||||
CL::OPTIONS))
|
||||
'CURRENT
|
||||
'?)
|
||||
#'(LAMBDA (X)
|
||||
(NEQ (GET X 'EDITDEF)
|
||||
'NILL]
|
||||
(CL::POSSIBLE-TYPES (COND
|
||||
([AND (NULL CL::GIVEN-TYPES)
|
||||
(CL:SYMBOLP CL::NAME)
|
||||
*ED-OFFERS-PROPERTY-LIST*
|
||||
(find CL::X on (GETPROPLIST CL::NAME) by (CDDR CL::X)
|
||||
suchthat (NULL (GET (CAR CL::X)
|
||||
'PROPTYPE]
|
||||
|
||||
(* ;; "if we're supposed to offer PROPERTY-LIST as an edit type, and this name has a property list with other than system properties on it, then add IL:PROPERTY-LIST to the possible types.")
|
||||
(* ;; "if we're supposed to offer PROPERTY-LIST as an edit type, and this name has a property list with other than system properties on it, then add IL:PROPERTY-LIST to the possible types.")
|
||||
|
||||
(CONS 'PROPERTY-LIST CL::TYPES-WITH-DEFNS))
|
||||
(T CL::TYPES-WITH-DEFNS)))
|
||||
(TYPE))
|
||||
(CL:WHEN (CL:MEMBER 'PROPERTY-LIST CL::OPTIONS)
|
||||
(CONS 'PROPERTY-LIST CL::TYPES-WITH-DEFNS))
|
||||
(T CL::TYPES-WITH-DEFNS)))
|
||||
(TYPE))
|
||||
(CL:WHEN (CL:MEMBER 'PROPERTY-LIST CL::OPTIONS)
|
||||
|
||||
(* ;;
|
||||
"this will allow PROPERTY-LIST to be specified as a fake filepkg type by the user (caller)")
|
||||
(* ;;
|
||||
"this will allow PROPERTY-LIST to be specified as a fake filepkg type by the user (caller)")
|
||||
|
||||
(CL:SETQ CL::POSSIBLE-TYPES '(PROPERTY-LIST)))
|
||||
[CL:SETQ TYPE (if (CL:MEMBER :NEW CL::OPTIONS)
|
||||
then
|
||||
(* ;; "if :NEW then install a blank definition first")
|
||||
(CL:SETQ CL::POSSIBLE-TYPES '(PROPERTY-LIST)))
|
||||
[CL:UNLESS
|
||||
(CL:SETQ
|
||||
TYPE
|
||||
(if (CL:MEMBER :NEW CL::OPTIONS)
|
||||
then
|
||||
(* ;; "if :NEW then install a blank definition first")
|
||||
|
||||
(OR (INSTALL-PROTOTYPE-DEFN CL::NAME (OR CL::TYPES-WITH-DEFNS
|
||||
CL::GIVEN-TYPES)
|
||||
:NEW)
|
||||
(CL:RETURN-FROM ED NIL))
|
||||
elseif (CDR CL::POSSIBLE-TYPES)
|
||||
then
|
||||
(* ;; "Many types were found/given. Ask the user which to use.")
|
||||
(OR (INSTALL-PROTOTYPE-DEFN CL::NAME (OR CL::TYPES-WITH-DEFNS CL::GIVEN-TYPES)
|
||||
:NEW)
|
||||
(CL:RETURN-FROM ED NIL))
|
||||
elseif (CDR CL::POSSIBLE-TYPES)
|
||||
then
|
||||
(* ;; "Many types were found/given. Ask the user which to use.")
|
||||
|
||||
(if CL::FROM-DISPLAY
|
||||
then (OR (MENU (create MENU
|
||||
ITEMS _ CL::POSSIBLE-TYPES
|
||||
TITLE _ (CL:FORMAT NIL
|
||||
"Edit which definition of ~S ?"
|
||||
CL::NAME)))
|
||||
(CL:RETURN-FROM ED NIL))
|
||||
else (ASKUSER NIL (CAR CL::POSSIBLE-TYPES)
|
||||
(CL:FORMAT NIL "Edit which ~A definition of ~S ? "
|
||||
CL::POSSIBLE-TYPES CL::NAME)
|
||||
CL::POSSIBLE-TYPES))
|
||||
elseif (NOT (NULL CL::POSSIBLE-TYPES))
|
||||
then
|
||||
(* ;; "Exactly one type was found.")
|
||||
(if CL::FROM-DISPLAY
|
||||
then (OR (MENU (create MENU
|
||||
ITEMS _ CL::POSSIBLE-TYPES
|
||||
TITLE _ (CL:FORMAT NIL "Edit which definition of ~S ?"
|
||||
CL::NAME)))
|
||||
(CL:RETURN-FROM ED NIL))
|
||||
else (ASKUSER NIL (CAR CL::POSSIBLE-TYPES)
|
||||
(CL:FORMAT NIL "Edit which ~A definition of ~S ? " CL::POSSIBLE-TYPES
|
||||
CL::NAME)
|
||||
CL::POSSIBLE-TYPES))
|
||||
elseif CL::POSSIBLE-TYPES
|
||||
then
|
||||
(* ;; "Exactly one type was found.")
|
||||
|
||||
(if CL::FROM-DISPLAY
|
||||
then (* ; "prepare the prompt window")
|
||||
(TERPRI PROMPTWINDOW))
|
||||
(CL:FORMAT (if CL::FROM-DISPLAY
|
||||
then PROMPTWINDOW
|
||||
else T)
|
||||
"Editing ~A ~A ~S.~%%"
|
||||
(CAR CL::POSSIBLE-TYPES)
|
||||
(CL:IF (EQ (CAR CL::POSSIBLE-TYPES)
|
||||
'PROPERTY-LIST)
|
||||
"of"
|
||||
"definition of")
|
||||
CL::NAME)
|
||||
(CAR CL::POSSIBLE-TYPES)
|
||||
else
|
||||
(* ;; "No types were found. Use the DefDefiner prototyping machinery.")
|
||||
(CL:WHEN CL::FROM-DISPLAY (* ; "prepare the prompt window")
|
||||
(TERPRI PROMPTWINDOW))
|
||||
(CL:FORMAT (CL:IF CL::FROM-DISPLAY
|
||||
PROMPTWINDOW
|
||||
T)
|
||||
"Editing ~A ~A ~S.~%%"
|
||||
(CAR CL::POSSIBLE-TYPES)
|
||||
(CL:IF (EQ (CAR CL::POSSIBLE-TYPES)
|
||||
'PROPERTY-LIST)
|
||||
"of"
|
||||
"definition of")
|
||||
CL::NAME)
|
||||
(CAR CL::POSSIBLE-TYPES)
|
||||
elseif
|
||||
[for CL::N CHOICE CL::NTYPES in (CL:FIND-ALL-SYMBOLS CL::NAME)
|
||||
when (CL:SETQ CL::NTYPES (TYPESOF CL::N CL::GIVEN-TYPES)) collect (CONS CL::N CL::NTYPES)
|
||||
finally
|
||||
(if (CDR $$VAL)
|
||||
then (* ;
|
||||
"More than one name, each with at least one type")
|
||||
[SETQ CHOICE
|
||||
(MENU (create MENU
|
||||
TITLE _ (CONCAT " Edit which definition? ")
|
||||
ITEMS _ (for I in $$VAL
|
||||
join (for TY in (CDR I)
|
||||
collect (LIST (CONCAT (MKSTRING (CAR I)
|
||||
T)
|
||||
" " TY)
|
||||
(LIST I TY]
|
||||
(SETQ CL::NAME (CAR CHOICE))
|
||||
(RETURN (CADR CHOICE))
|
||||
elseif (CDDAR $$VAL)
|
||||
then (* ; "One name with multiple types. ")
|
||||
[SETQ CHOICE (MENU (create MENU
|
||||
TITLE _ (CONCAT "Which definition of "
|
||||
(MKSTRING (CAAR $$VAL)
|
||||
T)
|
||||
" ?")
|
||||
ITEMS _ (for TY in (CDAR $$VAL) collect TY]
|
||||
(CL:SETQ CL::NAME (CAAR $$VAL))
|
||||
(RETURN CHOICE)
|
||||
elseif $$VAL
|
||||
then (CL:SETQ CL::NAME (CAAR $$VAL))
|
||||
(RETURN (CADAR $$VAL]
|
||||
else
|
||||
(* ;; "No types were found. Use the DefDefiner prototyping machinery.")
|
||||
|
||||
(OR (INSTALL-PROTOTYPE-DEFN CL::NAME CL::GIVEN-TYPES)
|
||||
(CL:RETURN-FROM ED NIL]
|
||||
(CL:IF (EQ TYPE 'PROPERTY-LIST)
|
||||
(EDITE (GETPROPLIST CL::NAME)
|
||||
NIL CL::NAME 'PROPLST NIL CL::OPTIONS)
|
||||
(EDITDEF CL::NAME TYPE NIL NIL CL::OPTIONS))
|
||||
(CL:RETURN-FROM ED CL::NAME)))
|
||||
(OR (INSTALL-PROTOTYPE-DEFN CL::NAME CL::GIVEN-TYPES)
|
||||
(CL:RETURN-FROM ED NIL]
|
||||
(CL:IF (EQ TYPE 'PROPERTY-LIST)
|
||||
(EDITE (GETPROPLIST CL::NAME)
|
||||
NIL CL::NAME 'PROPLST NIL CL::OPTIONS)
|
||||
(EDITDEF CL::NAME TYPE NIL NIL CL::OPTIONS))
|
||||
(CL:RETURN-FROM ED CL::NAME)))
|
||||
|
||||
(CL:DEFUN INSTALL-PROTOTYPE-DEFN (NAME &REST ARGS)
|
||||
|
||||
@@ -284,21 +316,22 @@ Copyright (c) 1986-1988, 1990-1991, 2024 by Venue & Xerox Corporation.
|
||||
(DEFINEQ
|
||||
|
||||
(EDITDEF.FNS
|
||||
[LAMBDA (NAME EDITCOMS OPTIONS) (* ; "Edited 20-Nov-87 14:25 by woz")
|
||||
|
||||
[LAMBDA (NAME EDITCOMS OPTIONS) (* ; "Edited 26-Sep-2025 15:23 by rmk")
|
||||
(* ; "Edited 20-Nov-87 14:25 by woz")
|
||||
(PROG (DEF)
|
||||
LP (COND
|
||||
((EXPRP (SETQ DEF (OR (GET NAME 'ADVISED)
|
||||
(GET NAME 'BROKEN)
|
||||
NAME)))
|
||||
(EDITE (if (LITATOM DEF)
|
||||
then (GETD DEF)
|
||||
else DEF)
|
||||
then (GETD DEF)
|
||||
else DEF)
|
||||
EDITCOMS NAME 'FNS NIL OPTIONS)
|
||||
(RETURN NAME))
|
||||
([EXPRP (SETQ DEF (GETPROP NAME 'EXPR]
|
||||
|
||||
(* ;;
|
||||
"woz: don't use edit type PROP anymore. Let putdef for fns worry about where the definition goes.")
|
||||
"woz: don't use edit type PROP anymore. Let putdef for fns worry about where the definition goes.")
|
||||
|
||||
(EDITE DEF EDITCOMS NAME 'FNS NIL OPTIONS)
|
||||
(RETURN NAME))
|
||||
@@ -308,7 +341,7 @@ Copyright (c) 1986-1988, 1990-1991, 2024 by Venue & Xerox Corporation.
|
||||
(* ;; "Used to call EDITFERROR to check for MACROS definition or install dummy FNS defintion. FNS can no longer be coerced to MACROS, and the new prototype stuff handles the other case. So if we're here, it's because EDITFB failed to find the definition, and thus NAME is not editable.")
|
||||
|
||||
(CL:FORMAT *ERROR-OUTPUT* "Could not find fns definition for ~a." NAME)
|
||||
(ERROR "Could not find fns definition for " NAME T])
|
||||
(RETURN])
|
||||
|
||||
(EDITF
|
||||
[NLAMBDA EDITFX (* ; "Edited 11-Jun-90 15:44 by jds")
|
||||
@@ -952,13 +985,12 @@ Copyright (c) 1986-1988, 1990-1991, 2024 by Venue & Xerox Corporation.
|
||||
|
||||
(ADDTOVAR LAMA )
|
||||
)
|
||||
(PUTPROPS EDITINTERFACE COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 1991 2024))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (4081 10380 (ED 4081 . 10380)) (10382 14358 (INSTALL-PROTOTYPE-DEFN 10382 . 14358)) (
|
||||
14359 31218 (EDITDEF.FNS 14369 . 15705) (EDITF 15707 . 16587) (EDITFB 16589 . 17437) (EDITFNS 17439 .
|
||||
18759) (EDITLOADFNS? 18761 . 22637) (EDITMODE 22639 . 24649) (EDITP 24651 . 25162) (EDITV 25164 .
|
||||
25803) (DC 25805 . 26486) (DF 26488 . 27530) (DP 27532 . 28616) (DV 28618 . 29190) (EDITPROP 29192 .
|
||||
29411) (EF 29413 . 29742) (EP 29744 . 29927) (EV 29929 . 30108) (EDITE 30110 . 30988) (EDITL 30990 .
|
||||
31216)) (31568 46885 (NEW/EDITDATE 31578 . 31800) (FIXEDITDATE 31802 . 40409) (EDITDATE? 40411 . 43439
|
||||
) (EDITDATE 43441 . 44888) (SETINITIALS 44890 . 46883)))))
|
||||
(FILEMAP (NIL (4073 11670 (ED 4073 . 11670)) (11672 15648 (INSTALL-PROTOTYPE-DEFN 11672 . 15648)) (
|
||||
15649 32572 (EDITDEF.FNS 15659 . 17059) (EDITF 17061 . 17941) (EDITFB 17943 . 18791) (EDITFNS 18793 .
|
||||
20113) (EDITLOADFNS? 20115 . 23991) (EDITMODE 23993 . 26003) (EDITP 26005 . 26516) (EDITV 26518 .
|
||||
27157) (DC 27159 . 27840) (DF 27842 . 28884) (DP 28886 . 29970) (DV 29972 . 30544) (EDITPROP 30546 .
|
||||
30765) (EF 30767 . 31096) (EP 31098 . 31281) (EV 31283 . 31462) (EDITE 31464 . 32342) (EDITL 32344 .
|
||||
32570)) (32922 48239 (NEW/EDITDATE 32932 . 33154) (FIXEDITDATE 33156 . 41763) (EDITDATE? 41765 . 44793
|
||||
) (EDITDATE 44795 . 46242) (SETINITIALS 46244 . 48237)))))
|
||||
STOP
|
||||
|
||||
BIN
sources/EDITINTERFACE.DFASL
Normal file
BIN
sources/EDITINTERFACE.DFASL
Normal file
Binary file not shown.
Binary file not shown.
@@ -1,12 +1,14 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "18-Jan-2024 10:40:56" {WMEDLEY}<sources>MACHINEINDEPENDENT.;38 117576
|
||||
(FILECREATED "29-Sep-2025 12:51:06"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>working-medley>sources>MACHINEINDEPENDENT.;39 119579
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (FNS LISPSOURCEFILEP)
|
||||
:CHANGES-TO (VARS MACHINEINDEPENDENTCOMS)
|
||||
|
||||
:PREVIOUS-DATE "20-Jul-2022 19:55:30" {WMEDLEY}<sources>MACHINEINDEPENDENT.;36)
|
||||
:PREVIOUS-DATE "18-Jan-2024 10:40:56"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>working-medley>sources>MACHINEINDEPENDENT.;38)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT MACHINEINDEPENDENTCOMS)
|
||||
@@ -28,10 +30,10 @@
|
||||
(INITVARS (OK.TO.MODIFY.FNS))
|
||||
[COMS (* ;
|
||||
"FILEDATE, for finding out the creation date of source files, from the compiled files.")
|
||||
(FNS FILEDATE COMPILEFILETYPE)
|
||||
|
||||
(* ;; "FASL isn't loaded when MACHINEINDEPENDENT is, so we have to fake the FASL checker for now. It's defined in FASLOAD.")
|
||||
|
||||
(FNS FILEDATE)
|
||||
(P (MOVD? 'NILL 'FASL-FILEDATE]
|
||||
(P (MOVD? 'CL:FMAKUNBOUND 'UNDOABLY-FMAKUNBOUND))
|
||||
(* ;
|
||||
@@ -1348,13 +1350,6 @@ WRITEFILE OF ")
|
||||
|
||||
(* ; "FILEDATE, for finding out the creation date of source files, from the compiled files.")
|
||||
|
||||
|
||||
|
||||
|
||||
(* ;;
|
||||
"FASL isn't loaded when MACHINEINDEPENDENT is, so we have to fake the FASL checker for now. It's defined in FASLOAD."
|
||||
)
|
||||
|
||||
(DEFINEQ
|
||||
|
||||
(FILEDATE
|
||||
@@ -1403,8 +1398,45 @@ WRITEFILE OF ")
|
||||
(COND
|
||||
(OLDPTR (SETFILEPTR STREAM OLDPTR)))
|
||||
(RETURN VALUE)))])
|
||||
|
||||
(COMPILEFILETYPE
|
||||
[LAMBDA (CFILE) (* ; "Edited 29-Sep-2025 12:26 by rmk")
|
||||
|
||||
(* ;; "Returns the type of compiler used to compile the compiled-file CFILE: CL:COMPILE-FILE IL:FAKE-COMPILE-FILE IL:BCOMP")
|
||||
|
||||
(CL:WHEN CFILE
|
||||
[CAR (NLSETQ
|
||||
(RESETLST
|
||||
[LET (STREAM COMPILER)
|
||||
[if (SETQ STREAM (\GETSTREAM CFILE 'INPUT T))
|
||||
then [RESETSAVE NIL `(PROGN (SETFILEPTR ,STREAM ,(GETFILEPTR STREAM]
|
||||
else (* ;
|
||||
"OPENSTREAM used instead of INFILEP to allow for error correction.")
|
||||
(RESETSAVE (SETQ STREAM (OPENSTREAM CFILE 'INPUT))
|
||||
`(PROGN (CLOSEF? OLDVALUE]
|
||||
(CL:WHEN (RANDACCESSP STREAM)
|
||||
(SETFILEPTR STREAM 0)
|
||||
[if (FASL-FILEDATE STREAM T)
|
||||
then (* ; " A Dfasl file")
|
||||
'CL:COMPILE-FILE
|
||||
else (SETFILEPTR STREAM 0) (* ; "Any other filetype")
|
||||
(CL:MULTIPLE-VALUE-BIND (ENV FORM)
|
||||
(\PARSE-FILE-HEADER STREAM 'RETURN)
|
||||
(CL:WHEN (LISTP FORM)
|
||||
(* ;
|
||||
"First expression is for compiled file")
|
||||
(SELECTQ (MKATOM (CADDDR (CDR FORM)))
|
||||
(COMPILE-FILEd 'FAKE-COMPILE-FILE)
|
||||
'BCOMPL))])])])])
|
||||
)
|
||||
|
||||
|
||||
|
||||
(* ;;
|
||||
"FASL isn't loaded when MACHINEINDEPENDENT is, so we have to fake the FASL checker for now. It's defined in FASLOAD."
|
||||
)
|
||||
|
||||
|
||||
(MOVD? 'NILL 'FASL-FILEDATE)
|
||||
|
||||
(MOVD? 'CL:FMAKUNBOUND 'UNDOABLY-FMAKUNBOUND)
|
||||
@@ -2463,23 +2495,23 @@ This has little hope of working any more.")
|
||||
(LOCALVARS . T)
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (12537 25962 (LOAD? 12547 . 14398) (FILESLOAD 14400 . 14689) (DOFILESLOAD 14691 . 22317)
|
||||
(FINDFILE-WITH-EXTENSIONS 22319 . 25518) (READ-FILECREATED 25520 . 25960)) (26079 31400 (DMPHASH
|
||||
26089 . 27683) (HASHOVERFLOW 27685 . 31398)) (32156 64264 (BKBUFS 32166 . 33285) (CHANGENAME 33287 .
|
||||
33548) (CHNGNM 33550 . 35398) (CLBUFS 35400 . 36673) (DEFINE 36675 . 37399) (FNS.PUTDEF 37401 . 40816)
|
||||
(EQMEMB 40818 . 41000) (EQUALN 41002 . 41831) (FNCHECK 41833 . 43840) (FNTYP1 43842 . 43939) (LCSKIP
|
||||
43941 . 44785) (MAPRINT 44787 . 45733) (MKLIST 45735 . 45885) (NAMEFIELD 45887 . 47412) (NLIST 47414
|
||||
. 47749) (PRINTBELLS 47751 . 47877) (PROMPTCHAR 47879 . 49769) (RAISEP 49771 . 50032) (READFILE 50034
|
||||
. 52378) (READLINE 52380 . 57820) (REMPROPLIST 57822 . 58710) (RESETBUFS 58712 . 59162) (TAB 59164 .
|
||||
59760) (UNSAVED1 59762 . 60867) (WRITEFILE 60869 . 62611) (CLOSE-AND-MAYBE-DELETE 62613 . 62957) (
|
||||
UNSAFE.TO.MODIFY 62959 . 64262)) (66619 69563 (FILEDATE 66629 . 69561)) (69793 96996 (FILEMAP 69803 .
|
||||
70273) (\PARSE-FILE-HEADER 70275 . 74090) (GET-ENVIRONMENT-AND-FILEMAP 74092 . 76319) (
|
||||
LOOKUP-ENVIRONMENT-AND-FILEMAP 76321 . 78512) (GET-FILEMAP-FROM-FILECREATED 78514 . 79338) (
|
||||
\FILEMAP-HASHOVERFLOW 79340 . 84004) (FLUSHFILEMAPS 84006 . 84629) (LISPSOURCEFILEP 84631 . 86023) (
|
||||
LISPFILETYPE 86025 . 89274) (GETFILEMAP 89276 . 89695) (PUTFILEMAP 89697 . 91888) (UPDATEFILEMAP 91890
|
||||
. 96994)) (97662 101248 (LVLPRINT 97672 . 97845) (LVLPRIN1 97847 . 98029) (LVLPRIN2 98031 . 98263) (
|
||||
LVLPRIN 98265 . 99279) (LVLPRIN0 99281 . 101246)) (101282 106199 (FLUSHRIGHT 101292 . 102107) (
|
||||
PRINTPARA 102109 . 103207) (PRINTPARA1 103209 . 106197)) (106235 108520 (SUBLIS 106245 . 106853) (
|
||||
SUBPAIR 106855 . 108083) (DSUBLIS 108085 . 108518)) (108543 109143 (CONSTANTOK 108553 . 109141)) (
|
||||
110896 111601 (NLAMBDA.ARGS 110906 . 111599)))))
|
||||
(FILEMAP (NIL (12643 26068 (LOAD? 12653 . 14504) (FILESLOAD 14506 . 14795) (DOFILESLOAD 14797 . 22423)
|
||||
(FINDFILE-WITH-EXTENSIONS 22425 . 25624) (READ-FILECREATED 25626 . 26066)) (26185 31506 (DMPHASH
|
||||
26195 . 27789) (HASHOVERFLOW 27791 . 31504)) (32262 64370 (BKBUFS 32272 . 33391) (CHANGENAME 33393 .
|
||||
33654) (CHNGNM 33656 . 35504) (CLBUFS 35506 . 36779) (DEFINE 36781 . 37505) (FNS.PUTDEF 37507 . 40922)
|
||||
(EQMEMB 40924 . 41106) (EQUALN 41108 . 41937) (FNCHECK 41939 . 43946) (FNTYP1 43948 . 44045) (LCSKIP
|
||||
44047 . 44891) (MAPRINT 44893 . 45839) (MKLIST 45841 . 45991) (NAMEFIELD 45993 . 47518) (NLIST 47520
|
||||
. 47855) (PRINTBELLS 47857 . 47983) (PROMPTCHAR 47985 . 49875) (RAISEP 49877 . 50138) (READFILE 50140
|
||||
. 52484) (READLINE 52486 . 57926) (REMPROPLIST 57928 . 58816) (RESETBUFS 58818 . 59268) (TAB 59270 .
|
||||
59866) (UNSAVED1 59868 . 60973) (WRITEFILE 60975 . 62717) (CLOSE-AND-MAYBE-DELETE 62719 . 63063) (
|
||||
UNSAFE.TO.MODIFY 63065 . 64368)) (66589 71430 (FILEDATE 66599 . 69531) (COMPILEFILETYPE 69533 . 71428)
|
||||
) (71796 98999 (FILEMAP 71806 . 72276) (\PARSE-FILE-HEADER 72278 . 76093) (GET-ENVIRONMENT-AND-FILEMAP
|
||||
76095 . 78322) (LOOKUP-ENVIRONMENT-AND-FILEMAP 78324 . 80515) (GET-FILEMAP-FROM-FILECREATED 80517 .
|
||||
81341) (\FILEMAP-HASHOVERFLOW 81343 . 86007) (FLUSHFILEMAPS 86009 . 86632) (LISPSOURCEFILEP 86634 .
|
||||
88026) (LISPFILETYPE 88028 . 91277) (GETFILEMAP 91279 . 91698) (PUTFILEMAP 91700 . 93891) (
|
||||
UPDATEFILEMAP 93893 . 98997)) (99665 103251 (LVLPRINT 99675 . 99848) (LVLPRIN1 99850 . 100032) (
|
||||
LVLPRIN2 100034 . 100266) (LVLPRIN 100268 . 101282) (LVLPRIN0 101284 . 103249)) (103285 108202 (
|
||||
FLUSHRIGHT 103295 . 104110) (PRINTPARA 104112 . 105210) (PRINTPARA1 105212 . 108200)) (108238 110523 (
|
||||
SUBLIS 108248 . 108856) (SUBPAIR 108858 . 110086) (DSUBLIS 110088 . 110521)) (110546 111146 (
|
||||
CONSTANTOK 110556 . 111144)) (112899 113604 (NLAMBDA.ARGS 112909 . 113602)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
132
sources/MENU
132
sources/MENU
@@ -1,13 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "14-Jul-2025 22:35:12" {DSK}<Users>kaplan>Local>medley3.5>working-medley>sources>MENU.;3 101431
|
||||
(FILECREATED " 2-Oct-2025 17:53:41" {SOURCES}MENU.;2 102104
|
||||
|
||||
:EDIT-BY rmk
|
||||
:EDIT-BY "mth"
|
||||
|
||||
:CHANGES-TO (FNS MENUTITLEFONT UPDATE/MENU/IMAGE)
|
||||
:CHANGES-TO (FNS ADDMENU CHECK/MENU/IMAGE UPDATE/MENU/IMAGE MENU)
|
||||
|
||||
:PREVIOUS-DATE "16-Jul-99 15:51:36"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>working-medley>sources>MENU.;1)
|
||||
:PREVIOUS-DATE "14-Jul-2025 22:35:12" {SOURCES}MENU.;1)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT MENUCOMS)
|
||||
@@ -92,12 +91,16 @@
|
||||
(T 0] finally (RETURN ANSWER])
|
||||
|
||||
(MENU
|
||||
[LAMBDA (MENU POSITION RELEASECONTROLFLG NESTEDFLG)(* ; "Edited 21-Jun-88 19:00 by jds")
|
||||
[LAMBDA (MENU POSITION RELEASECONTROLFLG NESTEDFLG) (* ; "Edited 2-Oct-2025 17:49 by mth")
|
||||
(* ; "Edited 21-Jun-88 19:00 by jds")
|
||||
(DECLARE (LOCALVARS . T))
|
||||
|
||||
(* ;; "puts a menu on the screen and waits for the user to select one of the items")
|
||||
|
||||
(\DTEST MENU 'MENU)
|
||||
(COND
|
||||
((NOT (LISTP (fetch (MENU ITEMS) of MENU)))
|
||||
(ERROR 'MENU "ITEMS list is empty")))
|
||||
(PROG (IMAGE SELVAL DSP) (* ; "make sure the image is a window")
|
||||
[SETQ IMAGE (COND
|
||||
((NOT (EQ POSITION 'INPLACE))
|
||||
@@ -119,18 +122,18 @@
|
||||
(RETURN NIL))
|
||||
(GETMOUSESTATE)
|
||||
(* ;
|
||||
"if mouse state is up, then someone came into the window with the mouse down. Ignore it.")
|
||||
"if mouse state is up, then someone came into the window with the mouse down. Ignore it.")
|
||||
(OR (MOUSESTATE (OR LEFT RIGHT MIDDLE))
|
||||
(GO LP))
|
||||
(* ;
|
||||
"MVAL will be NIL only if the user clicked up outside the window")
|
||||
(OR (SETQ MVAL (MENU.HANDLER MENU DSP NIL
|
||||
T NESTEDFLG))
|
||||
"MVAL will be NIL only if the user clicked up outside the window")
|
||||
(OR (SETQ MVAL (MENU.HANDLER MENU DSP NIL T
|
||||
NESTEDFLG))
|
||||
(GO LP))
|
||||
(RETURN MVAL)))
|
||||
(T (MENU.HANDLER MENU DSP T T NESTEDFLG))))]
|
||||
(* ;
|
||||
"evaluate menu form after image has been taken down.")
|
||||
"evaluate menu form after image has been taken down.")
|
||||
(RETURN (COND
|
||||
(NESTEDFLG SELVAL)
|
||||
(SELVAL (DOSELECTEDITEM MENU (CAR SELVAL)
|
||||
@@ -159,24 +162,28 @@
|
||||
(T (DSPFONT NIL (fetch (SCREEN SCTITLEDS) of SCREEN])
|
||||
|
||||
(ADDMENU
|
||||
[LAMBDA (ADDEDMENU W POSITION DONTOPENFLG) (* kbr%: "24-Jan-86 18:00")
|
||||
[LAMBDA (ADDEDMENU W POSITION DONTOPENFLG) (* ; "Edited 2-Oct-2025 17:51 by mth")
|
||||
(* kbr%: "24-Jan-86 18:00")
|
||||
|
||||
(* adds a menu to a window. If W is not given, it is created;
|
||||
sized a necessary.)
|
||||
sized a necessary.)
|
||||
|
||||
(OR (TYPENAMEP ADDEDMENU 'MENU)
|
||||
(\ILLEGAL.ARG ADDEDMENU))
|
||||
(COND
|
||||
((NOT (LISTP (fetch (MENU ITEMS) of ADDEDMENU)))
|
||||
(ERROR 'ADDEDMENU "ITEMS list is empty")))
|
||||
(PROG (IMAGEWIDTH IMAGEHEIGHT SCREEN)
|
||||
(SETQ IMAGEWIDTH (fetch (MENU IMAGEWIDTH) of ADDEDMENU))
|
||||
(SETQ IMAGEHEIGHT (fetch (MENU IMAGEHEIGHT) of ADDEDMENU))
|
||||
(* put menu at POSITION if argument,
|
||||
otherwise its stored position,
|
||||
otherwise at cursorposition)
|
||||
otherwise its stored position,
|
||||
otherwise at cursorposition)
|
||||
[COND
|
||||
((POSITIONP POSITION))
|
||||
((SETQ POSITION (fetch (MENU MENUPOSITION) of ADDEDMENU)))
|
||||
(W (* if a window is given, put it in
|
||||
the lower left corner.)
|
||||
(W (* if a window is given, put it in the
|
||||
lower left corner.)
|
||||
(SETQ POSITION (create POSITION
|
||||
XCOORD _ 0
|
||||
YCOORD _ 0)))
|
||||
@@ -187,20 +194,20 @@
|
||||
((WINDOWP W)
|
||||
|
||||
(* adding to an existing window. To avoid partial images when window is partly
|
||||
off the screen, this case could close window then blt to save region then
|
||||
reopen window.)
|
||||
off the screen, this case could close window then blt to save region then reopen
|
||||
window.)
|
||||
(* locate menu grid in MENU.)
|
||||
(replace (REGION LEFT) of (fetch (MENU MENUGRID) of ADDEDMENU)
|
||||
with (IPLUS (fetch (POSITION XCOORD) of POSITION)
|
||||
(fetch (MENU MENUOUTLINESIZE) of ADDEDMENU)))
|
||||
(fetch (MENU MENUOUTLINESIZE) of ADDEDMENU)))
|
||||
(replace (REGION BOTTOM) of (fetch (MENU MENUGRID) of ADDEDMENU)
|
||||
with (IPLUS (fetch (POSITION YCOORD) of POSITION)
|
||||
(fetch (MENU MENUOUTLINESIZE) of ADDEDMENU)))
|
||||
(fetch (MENU MENUOUTLINESIZE) of ADDEDMENU)))
|
||||
(* Blt image into Window.)
|
||||
(BLTMENUIMAGE ADDEDMENU (WINDOWPROP W 'DSP)
|
||||
DONTOPENFLG))
|
||||
(T (* have to create new window.
|
||||
Put position at Origin.)
|
||||
Put position at Origin.)
|
||||
(SETQ SCREEN (COND
|
||||
((type? SCREEN W)
|
||||
W)
|
||||
@@ -221,29 +228,27 @@
|
||||
(OR DONTOPENFLG (OPENW W]
|
||||
|
||||
(* put MENUBUTTONFN in CURSORINFN so it will get called if button is down and
|
||||
moves into W.)
|
||||
moves into W.)
|
||||
|
||||
(WINDOWPROP W 'CURSORINFN (FUNCTION MENUBUTTONFN)) (* Set ButtonEventFn to activate
|
||||
menu selection.)
|
||||
(WINDOWPROP W 'CURSORINFN (FUNCTION MENUBUTTONFN)) (* Set ButtonEventFn to activate menu
|
||||
selection.)
|
||||
(WINDOWPROP W 'BUTTONEVENTFN (FUNCTION MENUBUTTONFN))
|
||||
(WINDOWPROP W 'CURSORMOVEDFN (FUNCTION MENUBUTTONFN))
|
||||
(* put ADDEDMENU on USERDATA so
|
||||
MENUBUTTONFN can get at it.)
|
||||
MENUBUTTONFN can get at it.)
|
||||
(WINDOWADDPROP W 'MENU ADDEDMENU)
|
||||
(WINDOWADDPROP W 'REPAINTFN (FUNCTION MENUREPAINTFN))
|
||||
[COND
|
||||
((NULL (fetch (MENU WHENSELECTEDFN) of ADDEDMENU))
|
||||
|
||||
(* make the default selection function call EVAL.AS.PROCESS instead of EVAL so
|
||||
it won't tie up background.)
|
||||
(* make the default selection function call EVAL.AS.PROCESS instead of EVAL so it
|
||||
won't tie up background.)
|
||||
|
||||
(replace (MENU WHENSELECTEDFN) of ADDEDMENU with (FUNCTION
|
||||
BACKGROUNDWHENSELECTEDFN
|
||||
]
|
||||
(replace (MENU WHENSELECTEDFN) of ADDEDMENU with (FUNCTION BACKGROUNDWHENSELECTEDFN]
|
||||
[COND
|
||||
((NOT (SUBREGIONP (DSPCLIPPINGREGION NIL W)
|
||||
(MENUREGION ADDEDMENU))) (* if the menu didn't fit, make it
|
||||
scrollable.)
|
||||
(MENUREGION ADDEDMENU))) (* if the menu didn't fit, make it
|
||||
scrollable.)
|
||||
(WINDOWPROP W 'SCROLLFN (FUNCTION SCROLLBYREPAINTFN))
|
||||
(EXTENDEXTENT W (MENUREGION ADDEDMENU]
|
||||
(RETURN W])
|
||||
@@ -748,14 +753,18 @@
|
||||
MENU ITEM])
|
||||
|
||||
(CHECK/MENU/IMAGE
|
||||
[LAMBDA (MENU MAKEWINDOWFLG SCREEN) (* kbr%: " 5-Sep-85 20:31")
|
||||
[LAMBDA (MENU MAKEWINDOWFLG SCREEN) (* ; "Edited 2-Oct-2025 17:50 by mth")
|
||||
(* kbr%: " 5-Sep-85 20:31")
|
||||
|
||||
(* returns menus image, creating one if necessary.
|
||||
The image field will be a WINDOW for popup menus.)
|
||||
The image field will be a WINDOW for popup menus.)
|
||||
|
||||
(PROG (IMAGE DSP WINDOW)
|
||||
(OR (type? MENU MENU)
|
||||
(\ILLEGAL.ARG MENU))
|
||||
(COND
|
||||
((NOT (LISTP (fetch (MENU ITEMS) of MENU)))
|
||||
(ERROR 'MENU "ITEMS list is empty")))
|
||||
(SETQ IMAGE (fetch (MENU IMAGE) of MENU))
|
||||
[OR SCREEN (SETQ SCREEN (COND
|
||||
((type? WINDOW IMAGE)
|
||||
@@ -765,7 +774,7 @@
|
||||
((OR (NULL IMAGE)
|
||||
(NOT (EQ (fetch (WINDOW SCREEN) of IMAGE)
|
||||
SCREEN))) (* Switched screens.
|
||||
*)
|
||||
*)
|
||||
(UPDATE/MENU/IMAGE MENU SCREEN)
|
||||
(SETQ IMAGE (fetch (MENU IMAGE) of MENU]
|
||||
(COND
|
||||
@@ -774,9 +783,8 @@
|
||||
(UPDATEWFROMIMAGE IMAGE))
|
||||
(T (SETQ IMAGE (CREATEWFROMIMAGE IMAGE SCREEN))
|
||||
(replace (MENU IMAGE) of MENU with IMAGE)))
|
||||
(SETQ DSP (fetch (WINDOW DSP) of IMAGE))
|
||||
(* set the offset in the display
|
||||
stream to agree with the region.)
|
||||
(SETQ DSP (fetch (WINDOW DSP) of IMAGE)) (* set the offset in the display
|
||||
stream to agree with the region.)
|
||||
(DSPXOFFSET (fetch (WINDOW WBORDER) of IMAGE)
|
||||
DSP)
|
||||
(DSPYOFFSET (fetch (WINDOW WBORDER) of IMAGE)
|
||||
@@ -796,7 +804,8 @@
|
||||
(PROMPTPRINT (CADR ITEM])
|
||||
|
||||
(UPDATE/MENU/IMAGE
|
||||
[LAMBDA (MNU SCREEN) (* ; "Edited 14-Jul-2025 22:34 by rmk")
|
||||
[LAMBDA (MNU SCREEN) (* ; "Edited 2-Oct-2025 17:49 by mth")
|
||||
(* ; "Edited 14-Jul-2025 22:34 by rmk")
|
||||
(* ; "Edited 16-Jul-99 15:51 by rmk:")
|
||||
(* ; "Edited 10-Dec-93 16:01 by sybalsky")
|
||||
(* ;
|
||||
@@ -811,6 +820,9 @@
|
||||
(SETQ SCREEN (fetch (WINDOW SCREEN) of (fetch (MENU IMAGE) of MNU]
|
||||
(T (SETQ SCREEN LASTSCREEN]
|
||||
(SETQ MENUITEMS (fetch (MENU ITEMS) of MNU))
|
||||
(COND
|
||||
((NOT (LISTP MENUITEMS))
|
||||
(ERROR 'MENU "ITEMS list is empty")))
|
||||
(SETQ CENTER? (fetch (MENU CENTERFLG) of MNU)) (* ; "check the font.")
|
||||
(COND
|
||||
[(FONTP (SETQ FONT (AND (fetch (MENU MENUFONT) of MNU)
|
||||
@@ -1710,24 +1722,24 @@
|
||||
(MENU 42 POINTER))
|
||||
'44)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (2583 86884 (MAXMENUITEMHEIGHT 2593 . 3530) (MAXMENUITEMWIDTH 3532 . 5231) (MENU 5233 .
|
||||
8130) (MENUTITLEFONT 8132 . 9572) (ADDMENU 9574 . 15012) (DELETEMENU 15014 . 16495) (MENUREGION 16497
|
||||
. 17357) (BLTMENUIMAGE 17359 . 19387) (ERASEMENUIMAGE 19389 . 20311) (DEFAULTMENUHELDFN 20313 . 20603
|
||||
) (DEFAULTWHENSELECTEDFN 20605 . 21016) (BACKGROUNDWHENSELECTEDFN 21018 . 21453) (GETMENUITEM 21455 .
|
||||
22044) (MENUBUTTONFN 22046 . 22677) (MENU.HANDLER 22679 . 40781) (DOSELECTEDITEM 40783 . 41208) (
|
||||
SHOWSHADEDITEMS 41210 . 42627) (\AddShade 42629 . 43821) (\DelShade 43823 . 44094) (\FDECODE/BUTTON
|
||||
44096 . 44483) (MENUITEMREGION 44485 . 47220) (\MENUITEMLABEL 47222 . 47568) (\MENUSUBITEMS 47570 .
|
||||
47808) (CHECK/MENU/IMAGE 47810 . 49816) (PPROMPT2 49818 . 50207) (UPDATE/MENU/IMAGE 50209 . 65643) (
|
||||
\MAKE.ITEMS.VERT.ORDER 65645 . 67172) (\SHOWMENULABEL 67174 . 71101) (\POSITION.MENU.IMAGE 71103 .
|
||||
73958) (\SMASHMENUIMAGEONRESET 73960 . 74308) (CLOSE.PROCESS.MENU 74310 . 74492) (DEFAULTSUBITEMFN
|
||||
74494 . 75214) (GETMENUPROP 75216 . 75408) (PUTMENUPROP 75410 . 75783) (WAKE.MY.PROCESS 75785 . 75968)
|
||||
(\INVERTITEM 75970 . 76426) (\MENU.ITEM.SELECT 76428 . 77991) (\MENU.ITEM.DESELECT 77993 . 78695) (
|
||||
\ItemNumber 78697 . 79264) (\BOXITEM 79266 . 80813) (NESTED.SUBMENU 80815 . 83533) (NESTED.SUBMENU.POS
|
||||
83535 . 86506) (WFROMMENU 86508 . 86882)) (88093 88513 (MENUREPAINTFN 88103 . 88511)) (88548 91597 (
|
||||
MAXSTRINGWIDTH 88558 . 88801) (CENTEREDPRIN1 88803 . 89240) (CENTERPRINTINREGION 89242 . 89771) (
|
||||
CENTERPRINTINAREA 89773 . 91230) (STRICTLY/BETWEEN 91232 . 91595)) (91631 97573 (UNREADITEM 91641 .
|
||||
91963) (TYPEINMENU 91965 . 92166) (SHADEITEM 92168 . 93912) (RESHADEITEM 93914 . 95007) (
|
||||
MOST/VISIBLE/OPERATION 95009 . 95280) (%#BITSON 95282 . 96000) (BUTTONPANEL 96002 . 96794) (
|
||||
BUTTONPANEL/SELECTION/FN 96796 . 97348) (GETSELECTEDITEMS 97350 . 97571)) (97889 98430 (MENUDESELECT
|
||||
97899 . 98116) (MENUSELECT 98118 . 98428)))))
|
||||
(FILEMAP (NIL (2504 87557 (MAXMENUITEMHEIGHT 2514 . 3451) (MAXMENUITEMWIDTH 3453 . 5152) (MENU 5154 .
|
||||
8294) (MENUTITLEFONT 8296 . 9736) (ADDMENU 9738 . 15275) (DELETEMENU 15277 . 16758) (MENUREGION 16760
|
||||
. 17620) (BLTMENUIMAGE 17622 . 19650) (ERASEMENUIMAGE 19652 . 20574) (DEFAULTMENUHELDFN 20576 . 20866
|
||||
) (DEFAULTWHENSELECTEDFN 20868 . 21279) (BACKGROUNDWHENSELECTEDFN 21281 . 21716) (GETMENUITEM 21718 .
|
||||
22307) (MENUBUTTONFN 22309 . 22940) (MENU.HANDLER 22942 . 41044) (DOSELECTEDITEM 41046 . 41471) (
|
||||
SHOWSHADEDITEMS 41473 . 42890) (\AddShade 42892 . 44084) (\DelShade 44086 . 44357) (\FDECODE/BUTTON
|
||||
44359 . 44746) (MENUITEMREGION 44748 . 47483) (\MENUITEMLABEL 47485 . 47831) (\MENUSUBITEMS 47833 .
|
||||
48071) (CHECK/MENU/IMAGE 48073 . 50274) (PPROMPT2 50276 . 50665) (UPDATE/MENU/IMAGE 50667 . 66316) (
|
||||
\MAKE.ITEMS.VERT.ORDER 66318 . 67845) (\SHOWMENULABEL 67847 . 71774) (\POSITION.MENU.IMAGE 71776 .
|
||||
74631) (\SMASHMENUIMAGEONRESET 74633 . 74981) (CLOSE.PROCESS.MENU 74983 . 75165) (DEFAULTSUBITEMFN
|
||||
75167 . 75887) (GETMENUPROP 75889 . 76081) (PUTMENUPROP 76083 . 76456) (WAKE.MY.PROCESS 76458 . 76641)
|
||||
(\INVERTITEM 76643 . 77099) (\MENU.ITEM.SELECT 77101 . 78664) (\MENU.ITEM.DESELECT 78666 . 79368) (
|
||||
\ItemNumber 79370 . 79937) (\BOXITEM 79939 . 81486) (NESTED.SUBMENU 81488 . 84206) (NESTED.SUBMENU.POS
|
||||
84208 . 87179) (WFROMMENU 87181 . 87555)) (88766 89186 (MENUREPAINTFN 88776 . 89184)) (89221 92270 (
|
||||
MAXSTRINGWIDTH 89231 . 89474) (CENTEREDPRIN1 89476 . 89913) (CENTERPRINTINREGION 89915 . 90444) (
|
||||
CENTERPRINTINAREA 90446 . 91903) (STRICTLY/BETWEEN 91905 . 92268)) (92304 98246 (UNREADITEM 92314 .
|
||||
92636) (TYPEINMENU 92638 . 92839) (SHADEITEM 92841 . 94585) (RESHADEITEM 94587 . 95680) (
|
||||
MOST/VISIBLE/OPERATION 95682 . 95953) (%#BITSON 95955 . 96673) (BUTTONPANEL 96675 . 97467) (
|
||||
BUTTONPANEL/SELECTION/FN 97469 . 98021) (GETSELECTEDITEMS 98023 . 98244)) (98562 99103 (MENUDESELECT
|
||||
98572 . 98789) (MENUSELECT 98791 . 99101)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
Reference in New Issue
Block a user