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

Merge (rebase) Cleanup-character-IO-interfaces with master (#356)

Browse Source 
* Cleanup  of character IO interface

Committing this branch for further testing.  I know at least that the TTY output stream somehow is defaulting to :XCCS, which is wrong, but I haven't yet found the interface for that.

* Clean out \NSIN etc

No top-level calls to the NS specific functions, just to the generic \OUTCHAR etc.

Updated full.database

* MODERNIZE: added dragging for fixed-menu windows

They can be dragged by their title bars

* UNICODE:  Added Greek to the default set

Also made spelling of default-externalformats consistent with FILEIO

* FASLOAD: EOL conversion in FASL::READ-TEXT

EOL's printed as LF's will be read as EOL

* LLREAD:  Added meta as a CHARACTERSETNAME

meta,a maps to 1,a now.  But slowly propagating this to TEDIT, SEDIT, etc will make it easier to change the coding of meta characters, e.g. as part of a Unicode transition.

* APRINT FILEIO LLREAD: \OUTCHAR now a closed function

Removed the macro

* LLKEY: call CHARCODE.DECODE directory in \KEYACTION1

Minor cleanup, avoid typical user entry and APPLY*

* WHEELSCROLL: re-enable on AFTERMAKESYS/SYSOUT FORMS

Also sets up mappings in the \COMMANDKEYACTIONS, whatever that is

* ABASIC:  NILL and ZERO change from LAMBDA NOBIND to LAMBDA NIL

So that things like Masterscope don't break

* MASTERSCOPE:  Added WHEREIS as last-resort for CONTAINS

Looks at the WHEREIS database, if present, for FNS and FUNCTIONS if it has no other information.  . WHO CONTAINS ANY CALLING FOO works, but not the inverse:  . WHO DOES FUM CONTAIN.  We still need to figure out why the CONTAINS table isn't populated

* POSTSCRIPTSTREAM: use standard \OUTCHAR conventions

Now uses generic \OUTCHAR to get the proper function from the stream (or default)

* Recompile with right EXPORTS.ALL

Some of the macros weren't correct.

* Fix POSTSCRIPTSTREAM

Cleaner separation between external \OUTCHAR and internal BOUT

* POSTSCRIPTSTREAM gets its own external format

* Minor fix

* Compile-time warning about EXPORTS.ALL

* MODERNIZE:  Modern button fn has same args as the original

For Notecards  #343

* Fixed another glitch in the MODERNIZE  arglist thing

\TEDIT.BUTTONEVENTFN actually takes a second STREAM argument.  I don't see where it is ever called with that.  The modernize replacement binds that argument, but it isn't being passed to the original.

* FILEWATCH:  added missing record field

* Update FILEWATCH.LCOM

* Eliminating record/type name conflicts

Mostly just qualifying references, more work to get BIGBITMAP stuff out of ADISPLAY and to eliminate ambiguity of LINE record (now XXLINE in XXGEOM)

* Compile away open calls to \OUTCHAR, add loadups/full.database

Mostly new LCOMS where \OUTCHAR calls were compiled open

* Remove garbage library/XCCS

Old tools for reading wikipedia XCCS tables, sources/XCCS will deal with XCCS external format

* Next step:  Remove open input-character calls, factor XCCS to separate file

XCCS is the default, but can be swapped out (eventually) by setting a few variables, without recompiling everything

* Lots of residual cleanup for XCCS isolation

* Delete old file MACINTERFACE (migrated to MODERNIZE)

* Eliminate straggling NS calls:  LAFITE, READINTERPRESS

* Typo

* READINTERPRESS:  removed CHARSET

* MODERNIZE: Interface to control title-bar response (for Notecards)

* Many changes for external format name consistency

Very close to the end of this

* Put :FORMAT in file info, fix TEDIT plaintext hardcopy

I distributed :FORMAT :XCCS as the default marking, but somehow one of the variables seems to get revert during the loadup.  This is correct, as far as it goes.

* Getting the format in the file-info

This is all very twisty, different variables set in different places.  It now seems to do the right thing, at least for new files.  Marks them with :FORMAT :XCCS.

* Another fileinfo glitch

* CLIPBOARD -UNICODE:  Make UTF8 to UTF-8 to match standards

* MODERNIZE:  fix bug in MODERWINDOW

* External format as MAKEFILE option, LOAD applies the file's format

(MAKEFILE 'XX '((FORMAT :UTF-8)))
  will dump XX as a UTF-8 file.  LOAD will load it back to XCCS internal.

* Compilers respect DEFINE-FILE-INFO format

* MODERNIZE:  little glitch

* Delete old FILEIO.LCOM

* More edge cases of external format thru MAKEFILE, PRETTY, PRETTYFILEINDEX etc.

* FILEBROWSER:  Can SEE UTF-8 Lisp sourcefile

* INSPECT:  Better macro for inspecting readtables

* recompile changed files and do new loadup

Co-authored-by: rmkaplan <ron.kaplan@post.harvard.edu>
This commit is contained in:
Larry Masinter
2021-07-29 17:07:23 -07:00
committed by GitHub
parent 4fac4e3e96
commit 4efe2f93af
159 changed files with 41605 additions and 42552 deletions
Download Patch File Download Diff File Expand all files Collapse all files

BIN
lispusers/CHATEMACS.LCOM
View File

Binary file not shown.

BIN
lispusers/DEFINERPRINT.LCOM
View File

Binary file not shown.

BIN
lispusers/FILEWATCH
View File

Binary file not shown.

BIN
lispusers/FILEWATCH.LCOM
View File

Binary file not shown.

423
lispusers/ISO8859IO
View File

@@ -1,11 +1,11 @@
(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED "24-Apr-2021 17:06:30" 
{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>ISO8859IO.;3 36846
(FILECREATED "23-Jun-2021 17:00:30" 
{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>ISO8859IO.;10 22675
changes to%: (FNS \8859OUTCHARFN \8859INCCODEFN \8859PEEKCCODEFN MAKEISOFORMAT)
changes to%: (FNS MAKEISOFORMAT MAKEIBMFORMAT MAKEMACFORMAT)
previous date%: "24-Apr-2021 17:06:06"
{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>ISO8859IO.;2)
previous date%: "15-Jun-2021 13:53:42"
{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>ISO8859IO.;9)
(* ; "
@@ -15,7 +15,7 @@ Copyright (c) 1995-1997, 1999, 2021 by Xerox Corporation.
(PRETTYCOMPRINT ISO8859IOCOMS)
(RPAQQ ISO8859IOCOMS
(
[
(* ;; "This package defines EXTERNALFORMATS for files that are encoded in either ISO8859/1, the standard IBM extended ascii, or the usual MAC encoding.")
(COMS (* ; "ISO8859/1")
@@ -35,23 +35,10 @@ Copyright (c) 1995-1997, 1999, 2021 by Xerox Corporation.
(P (MAKEMACFORMAT)))
(COMS (* ; "Independent of char encoding")
(FNS \COMMONBACKCHARFN \MAKERECODEMAP \RECODECCODE))
(DECLARE%: EVAL@COMPILE DONTCOPY [P (EVAL (SYSRECLOOK1 'EXTERNALFORMAT]
(* ;; "From FILEIO")
(CONSTANTS (\NORUNCODE 255))
(* ;; "From LLCHAR")
(CONSTANTS (NSCHARSETSHIFT 255))
(* ;; "From LLREAD")
(MACROS \XCCSIN \XCCSPEEK \BACKXCCSCHAR)
(* ;; "From MODARITH")
(MACROS UNFOLD))))
(DECLARE%: EVAL@COMPILE DONTCOPY (P (OR (GETP 'EXPORTS.ALL 'FILE)
(PRINT
"NOTE: ISO8859IO requires EXPORTS.ALL for compilation"
T])
@@ -68,58 +55,36 @@ Copyright (c) 1995-1997, 1999, 2021 by Xerox Corporation.
(\8859OUTCHARFN
[LAMBDA (STREAM CHARCODE)
(DECLARE (GLOBALVARS *XEROXTOISO8859MAP*)) (* ; "Edited 9-Mar-99 16:59 by rmk:")
(* ; "Edited 7-Dec-95 14:34 by ")
(DECLARE (GLOBALVARS *XEROXTOISO8859MAP*)) (* ; "Edited 5-May-2021 16:31 by rmk:")
(* ; "Edited 7-Dec-95 14:34 by ")
(* ; "Edited 7-Dec-95 14:32 by ")
(* ;; "Converts CHARCODE from internal Xerox-rendering to ISO8859 before printing. Unconverted codes are left unchanged (no error). If any remaining codes are out of charset 0, the Xerox run-encoding is used (which means that y-umlaut (code 255 in iso) will confuse any readers).")
(* ;; "Converts CHARCODE from internal encoding to ISO8859 before printing.")
(\FILEOUTCHARFN STREAM (IF (IGREATERP CHARCODE 127)
THEN
(* ;; "Unconverted codes are left unchanged (no error).")
(* ;; "We know that ISO doesn't have floating accents, so only singletons are returned. We also know that it agrees with Xerox on first 128")
(* ;; "If any remaining codes are out of charset 0, the streams external format will be used. ")
(\RECODECCODE CHARCODE *XEROXTOISO8859MAP*)
ELSE CHARCODE])
(* ;; "Calls \PRINTCCODE instead of \OUTCHAR so that recompiling is not needed if the default external format changes.")
(\8859INCCODEFN
[LAMBDA (STREAM COUNTP) (* ; "Edited 9-Mar-99 16:59 by rmk:")
(* ; "Edited 7-Dec-95 15:24 by ")
(* ; "Edited 7-Dec-95 15:19 by ")
(IF COUNTP
THEN
(\PRINTCCODE (IF (IGREATERP CHARCODE 127)
THEN
(* ;; "This is a little goofy. \NSIN passes the COUNTP flag, not the variable. It then takes the COUNT result and subtracts it out. But \XCCSIN is already subtracting from 0, giving a negative count. So we have to reverse the value here. Sigh ")
(* ;; "We know that ISO doesn't have floating accents, so only singletons are returned. We also know that it agrees with Xerox on first 128")
(LET ((COUNT 0))
(CL:VALUES (\RECODECCODE (\XCCSIN STREAM (UNFOLD (ACCESS-CHARSET STREAM)
256)
NIL COUNT)
*ISO8859TOXEROXMAP*)
(IMINUS COUNT)))
ELSE (\RECODECCODE (\XCCSIN STREAM (UNFOLD (ACCESS-CHARSET STREAM)
256))
*ISO8859TOXEROXMAP*])
(\RECODECCODE CHARCODE *XEROXTOISO8859MAP*)
ELSE CHARCODE)
STREAM])
(\8859INCCODEFN
[LAMBDA (STRM BYTECOUNTVAR BYTECOUNTVAL) (* ; "Edited 15-Jun-2021 13:50 by rmk:")
(* ; "Edited 7-Dec-95 15:24 by ")
[LAMBDA (STREAM NOERROR COUNTP) (* ; "Edited 9-Mar-99 16:59 by rmk:")
(* ; "Edited 3-Jan-96 14:21 by ")
(* ; "Edited 7-Dec-95 15:51 by ")
(* ;; "Uses \XCCSPEEK to handle Xerox run-coding")
(* ; "Edited 7-Dec-95 15:19 by ")
(CL:WHEN BYTECOUNTVAR
(SET BYTECOUNTVAR (SUB1 BYTECOUNTVAL)))
(\RECODECCODE (\BIN STRM)
(LET (PCODE (COUNT 0))
(SETQ PCODE (IF COUNTP
THEN (\XCCSPEEK STREAM (UNFOLD (ACCESS-CHARSET STREAM)
256)
NIL NOERROR COUNT)
ELSE (\XCCSPEEK STREAM (UNFOLD (ACCESS-CHARSET STREAM)
256)
NIL NOERROR)))
(IF COUNTP
THEN (CL:VALUES (AND PCODE (\RECODECCODE PCODE *ISO8859TOXEROXMAP*))
COUNT)
ELSE (AND PCODE (\RECODECCODE PCODE *ISO8859TOXEROXMAP*])
*ISO8859TOXEROXMAP*])
(\8859PEEKCCODEFN
[LAMBDA (STRM NOERROR) (* ; "Edited 5-May-2021 17:44 by rmk:")
(* ; "Edited 3-Jan-96 14:21 by ")
@@ -128,9 +93,9 @@ Copyright (c) 1995-1997, 1999, 2021 by Xerox Corporation.
(\RECODECCODE (\PEEKCCODE STRM NOERROR)
*ISO8859TOXEROXMAP*])
)
[LAMBDA NIL (* ; "Edited 24-Apr-2021 17:01 by rmk:")
(* ; "Edited 9-Mar-99 17:19 by rmk:")
(* ; "Edited 7-Dec-95 16:24 by ")
(DECLARE%: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS *XEROXTOISO8859MAP* *ISO8859TOXEROXMAP*)
)
(DEFINEQ
@@ -212,11 +177,12 @@ Copyright (c) 1995-1997, 1999, 2021 by Xerox Corporation.
(61919 249)
(61920 250)
(61921 251)
(\INSTALL.EXTERNALFORMAT :ISO8859/1 (CREATE EXTERNALFORMAT
INCCODEFN _ (FUNCTION \8859INCCODEFN)
PEEKCCODEFN _ (FUNCTION \8859PEEKCCODEFN)
BACKCHARFN _ (FUNCTION \COMMONBACKCHARFN)
FILEOUTCHARFN _ (FUNCTION \8859OUTCHARFN])
(61925 252)
(61931 253)
(252 254)
(61933 255)
(61805 376]
(SETQ *XEROXTOISO8859MAP* (\MAKERECODEMAP XEROXTOISO))
(SETQ *ISO8859TOXEROXMAP* (\MAKERECODEMAP XEROXTOISO T)))
(\INSTALL.EXTERNALFORMAT (CREATE EXTERNALFORMAT
NAME _ :ISO8859/1
@@ -228,55 +194,26 @@ Copyright (c) 1995-1997, 1999, 2021 by Xerox Corporation.
(MAKEISOFORMAT)
[LAMBDA (STREAM CHARCODE) (* ; "Edited 9-Mar-99 16:59 by rmk:")
(* ; "IBM-PC Extended Ascii")
(* ;; "Converts CHARCODE from internal Xerox-rendering to IBM before printing. Unconverted codes are left unchanged (no error). If any remaining codes are out of charset 0, the Xerox run-encoding is used (which means that y-umlaut (code 255 in iso) will confuse any readers).")
(DEFINEQ
(\FILEOUTCHARFN STREAM (IF (IGREATERP CHARCODE 127)
THEN
(\IBMOUTCHARFN
[LAMBDA (STREAM CHARCODE) (* ; "Edited 5-May-2021 16:38 by rmk:")
(\PRINTCCODE (IF (IGREATERP CHARCODE 127)
THEN
(* ;; "We know that IBM doesn't have floating accents, so only singletons are returned. We also know that it agrees with Xerox on first 128")
(\RECODECCODE CHARCODE *XEROXTOIBMMAP*)
ELSE CHARCODE])
(\IBMINCCODEFN
[LAMBDA (STREAM COUNTP) (* ; "Edited 9-Mar-99 16:59 by rmk:")
(* ; "Edited 8-Dec-95 13:23 by ")
(* ;; "Uses \XCCSIN to handle Xerox run-coding")
(* ; "Edited 7-Dec-95 15:19 by ")
(IF COUNTP
THEN (LET ((COUNT 0))
(CL:VALUES (\RECODECCODE (\XCCSIN STREAM (UNFOLD (ACCESS-CHARSET STREAM)
256)
NIL COUNT)
*IBMTOXEROXMAP*)
(IMINUS COUNT)))
ELSE (\RECODECCODE (\XCCSIN STREAM (UNFOLD (ACCESS-CHARSET STREAM)
256))
*IBMTOXEROXMAP*])
(* ;; "We know that IBM doesn't have floating accents, so only singletons are returned. We also know that it agrees with Xerox on first 128")
[LAMBDA (STREAM NOERROR COUNTP) (* ; "Edited 9-Mar-99 16:59 by rmk:")
(* ; "Edited 3-Jan-96 14:23 by ")
(* ; "Edited 8-Dec-95 13:24 by ")
(* ; "Edited 7-Dec-95 15:51 by ")
(* ;; "Uses \XCCSPEEK to handle Xerox run-coding")
(\RECODECCODE CHARCODE *XEROXTOIBMMAP*)
ELSE CHARCODE)
STREAM])
(\IBMINCCODEFN
(LET (PCODE (COUNT 0))
(SETQ PCODE (IF COUNTP
THEN (\XCCSPEEK STREAM (UNFOLD (ACCESS-CHARSET STREAM)
256)
NIL NOERROR COUNT)
ELSE (\XCCSPEEK STREAM (UNFOLD (ACCESS-CHARSET STREAM)
256)
NIL NOERROR)))
(IF COUNTP
THEN (CL:VALUES (AND PCODE (\RECODECCODE PCODE *IBMTOXEROXMAP*))
COUNT)
ELSE (AND PCODE (\RECODECCODE PCODE *IBMTOXEROXMAP*])
[LAMBDA (STRM BYTECOUNTVAR BYTECOUNTVAL) (* ; "Edited 15-Jun-2021 13:50 by rmk:")
(* ; "Edited 8-Dec-95 13:23 by ")
(* ; "Edited 7-Dec-95 15:19 by ")
(CL:WHEN BYTECOUNTVAR
(SET BYTECOUNTVAR (SUB1 BYTECOUNTVAL)))
@@ -285,7 +222,7 @@ Copyright (c) 1995-1997, 1999, 2021 by Xerox Corporation.
(\IBMPEEKCCODEFN
[LAMBDA (STRM NOERROR COUNTP) (* ; "Edited 5-May-2021 17:44 by rmk:")
[LAMBDA NIL (* ; "Edited 9-Mar-99 17:33 by rmk:")
(* ; "Edited 3-Jan-96 14:23 by ")
(* ; "Edited 8-Dec-95 13:24 by ")
(* ; "Edited 7-Dec-95 15:51 by ")
(* ; "Edited 7-Dec-95 15:19 by ")
@@ -375,11 +312,12 @@ Copyright (c) 1995-1997, 1999, 2021 by Xerox Corporation.
(162 155)
(163 156)
(165 157)
(\INSTALL.EXTERNALFORMAT :IBM (CREATE EXTERNALFORMAT
INCCODEFN _ (FUNCTION \IBMINCCODEFN)
PEEKCCODEFN _ (FUNCTION \IBMPEEKCCODEFN)
BACKCHARFN _ (FUNCTION \COMMONBACKCHARFN)
FILEOUTCHARFN _ (FUNCTION \IBMOUTCHARFN])
(167 21)
(171 174)
(176 248)
(177 241)
(178 253)
(181 230)
(182 20)
(183 250)
(187 175)
@@ -391,54 +329,33 @@ Copyright (c) 1995-1997, 1999, 2021 by Xerox Corporation.
(\INSTALL.EXTERNALFORMAT (CREATE EXTERNALFORMAT
NAME _ :IBM
INCCODEFN _ (FUNCTION \IBMINCCODEFN)
[LAMBDA (STREAM CHARCODE) (* ; "Edited 9-Mar-99 16:59 by rmk:")
PEEKCCODEFN _ (FUNCTION \IBMPEEKCCODEFN)
BACKCCODEFN _ (FUNCTION \COMMONBACKCHARFN)
(* ;; "Converts CHARCODE from internal Xerox-rendering to MAC before printing. Unconverted codes are left unchanged (no error). If any remaining codes are out of charset 0, the Xerox run-encoding is used (which means that code 255 will confuse any readers).")
OUTCHARFN _ (FUNCTION \IBMOUTCHARFN])
)
(\FILEOUTCHARFN STREAM (IF (IGREATERP CHARCODE 127)
THEN
(MAKEIBMFORMAT)
(* ;; "We know that MAC doesn't have floating accents, so only singletons are returned. We also know that it agrees with Xerox on first 128")
(\RECODECCODE CHARCODE *XEROXTOMACMAP*)
ELSE CHARCODE])
(* ; "Macintosh")
(\MACINCCODEFN
[LAMBDA (STREAM COUNTP) (* ; "Edited 9-Mar-99 16:59 by rmk:")
(* ; "Edited 8-Dec-95 13:29 by ")
(DEFINEQ
(* ;; "Uses \XCCSIN to handle Xerox run-coding")
(\MACOUTCHARFN
[LAMBDA (STREAM CHARCODE) (* ; "Edited 5-May-2021 16:28 by rmk:")
(IF COUNTP
THEN (LET ((COUNT 0))
(CL:VALUES (\RECODECCODE (\XCCSIN STREAM (UNFOLD (ACCESS-CHARSET STREAM)
256)
NIL COUNT)
*MACTOXEROXMAP*)
(IMINUS COUNT)))
ELSE (\RECODECCODE (\XCCSIN STREAM (UNFOLD (ACCESS-CHARSET STREAM)
256))
*MACTOXEROXMAP*])
(* ;; "Converts CHARCODE from internal encoding to MAC before printing.")
(* ;; "Unconverted codes are left unchanged (no error).")
(* ;; "If any remaining codes are out of charset 0, the streams external format will be used.")
[LAMBDA (STREAM NOERROR COUNTP) (* ; "Edited 9-Mar-99 16:59 by rmk:")
(* ; "Edited 3-Jan-96 14:23 by ")
(* ;; "Calls \PRINTCCODE instead of \OUTCHAR so that recompiling is not needed if the default external format changes.")
(\PRINTCCODE (IF (IGREATERP CHARCODE 127)
(* ;; "Uses \XCCSPEEK to handle Xerox run-coding")
(LET (PCODE (COUNT 0))
(SETQ PCODE (IF COUNTP
THEN (\XCCSPEEK STREAM (UNFOLD (ACCESS-CHARSET STREAM)
256)
NIL NOERROR COUNT)
ELSE (\XCCSPEEK STREAM (UNFOLD (ACCESS-CHARSET STREAM)
256)
NIL NOERROR)))
(IF COUNTP
THEN (CL:VALUES (AND PCODE (\RECODECCODE PCODE *MACTOXEROXMAP*))
COUNT)
ELSE (AND PCODE (\RECODECCODE PCODE *MACTOXEROXMAP*])
THEN
(* ;; "We know that MAC doesn't have floating accents, so only singletons are returned. We also know that it agrees with Xerox on first 128")
(\RECODECCODE CHARCODE *XEROXTOMACMAP*)
@@ -447,8 +364,8 @@ Copyright (c) 1995-1997, 1999, 2021 by Xerox Corporation.
(\MACINCCODEFN
[LAMBDA (STRM BYTECOUNTVAR BYTECOUNTVAL) (* ; "Edited 15-Jun-2021 13:50 by rmk:")
[LAMBDA NIL (* ; "Edited 9-Mar-99 17:32 by rmk:")
(* ; "Edited 7-Dec-95 16:24 by ")
(* ; "Edited 8-Dec-95 13:29 by ")
(CL:WHEN BYTECOUNTVAR
(SET BYTECOUNTVAR (SUB1 BYTECOUNTVAL)))
(\RECODECCODE (\BIN STRM)
*MACTOXEROXMAP*])
@@ -561,11 +478,12 @@ Copyright (c) 1995-1997, 1999, 2021 by Xerox Corporation.
(61346 196)
(61305 197)
(9797 198)
(\INSTALL.EXTERNALFORMAT :MACINTOSH (CREATE EXTERNALFORMAT
INCCODEFN _ (FUNCTION \MACINCCODEFN)
PEEKCCODEFN _ (FUNCTION \MACPEEKCCODEFN)
BACKCHARFN _ (FUNCTION \COMMONBACKCHARFN)
FILEOUTCHARFN _ (FUNCTION \MACOUTCHARFN])
(171 199)
(187 200)
(8516 201)
(32 202)
(61220 208)
(61221 209)
(8574 215)
(47 218)
(164 219)
@@ -576,17 +494,7 @@ Copyright (c) 1995-1997, 1999, 2021 by Xerox Corporation.
(61233 224)
(183 225)
(9138 226)
(\COMMONBACKCHARFN
[LAMBDA (STREAM COUNTP) (* ; "Edited 29-Mar-96 10:55 by rmk")
(* ; "Edited 8-Dec-95 13:26 by ")
(* ;; "Let \BACKXCCSCHAR handle the run-coding. The charset in the stream is the charset byte, unconverted to ISO. This is independent of the particular character translation.")
(IF COUNTP
THEN (LET ((COUNT 0))
(\BACKXCCSCHAR STREAM COUNT)
COUNT)
ELSE (\BACKXCCSCHAR STREAM NIL])
(61224 227)
(61249 228]
(SETQ *XEROXTOMACMAP* (\MAKERECODEMAP XEROXTOMAC))
(SETQ *MACTOXEROXMAP* (\MAKERECODEMAP XEROXTOMAC T))
@@ -622,160 +530,15 @@ Copyright (c) 1995-1997, 1999, 2021 by Xerox Corporation.
(CL:WHEN INVERTED
[SETQ CODEMAP (FOR C IN CODEMAP COLLECT (LIST (CADR C)
(CAR C])
(EVAL (SYSRECLOOK1 'EXTERNALFORMAT))
(DECLARE%: EVAL@COMPILE
(RPAQQ \NORUNCODE 255)
(CONSTANTS (\NORUNCODE 255))
)
(DECLARE%: EVAL@COMPILE
(RPAQQ NSCHARSETSHIFT 255)
(CONSTANTS (NSCHARSETSHIFT 255))
)
(DECLARE%: EVAL@COMPILE
(PUTPROPS \XCCSIN MACRO [(STREAM SHIFTEDCSET SHIFTEDCSETVAR COUNTERVAR)
(* ;;; "returns a 16 bit character code. SHIFTEDCSET is STREAM's char set left shifted 8, SHIFTEDCSETVAR if non-NIL is the variable to set if char set changes. COUNTERVAR if non-NIL is decremented by number of bytes read. Doesn't do EOL conversion -- \INCHAR and \INCCODE do that.")
(LET ((CHAR (\BIN STREAM))
SCSET)
(COND
[(EQ CHAR NSCHARSETSHIFT)
(* ; "Shifting character sets")
[ACCESS-CHARSET STREAM
(SETQ SCSET (COND
((NEQ NSCHARSETSHIFT (SETQ CHAR
(\BIN STREAM)))
(AND 'COUNTERVAR (SETQ COUNTERVAR
(IDIFFERENCE
COUNTERVAR 2)))
CHAR)
((PROGN
(* ;
 "2 shift-bytes means not run-encoded")
(AND 'COUNTERVAR
(SETQ COUNTERVAR
(IDIFFERENCE COUNTERVAR
3)))
(EQ 0 (\BIN STREAM)))
\NORUNCODE)
(T (\NSIN.24BITENCODING.ERROR STREAM]
(SETQ CHAR (\BIN STREAM))
(SETQ SCSET (COND
('SHIFTEDCSETVAR
(* ; "CHARSETVAR=NIL means don't set")
(SETQ SHIFTEDCSETVAR (UNFOLD SCSET
256)))
(T (UNFOLD SCSET 256]
(T (SETQ SCSET SHIFTEDCSET)))
(COND
((EQ SCSET (UNFOLD \NORUNCODE 256))
(* ;
 "just read two bytes and combine them to a 16 bit value")
(AND 'COUNTERVAR (SETQ COUNTERVAR (IDIFFERENCE COUNTERVAR 2
)))
(LOGOR (UNFOLD CHAR 256)
(\BIN STREAM)))
(CHAR (AND 'COUNTERVAR (SETQ COUNTERVAR (IDIFFERENCE
COUNTERVAR 1)
))
(AND CHAR (LOGOR SCSET CHAR])
(PUTPROPS \XCCSPEEK MACRO [(STREAM SHIFTEDCSET SHIFTEDCSETVAR NOERROR COUNTERVAR)
(* ;; "Returns a 16 bit character code. Doesn't do EOL conversion--\INCHAR does that. May actually read the character-set shift, storing the result in the stream. COUNTERVAR, if given, is updated to reflect any such bytes that are actually read")
(PROG ((CHAR (\PEEKBIN STREAM NOERROR))
SCSET)
(COND
((NULL CHAR)
(RETURN NIL))
[(EQ CHAR NSCHARSETSHIFT)
(* ; "CHARSETVAR=NIL means don't set")
(\BIN STREAM) (* ; "Consume the char shift byte")
[ACCESS-CHARSET STREAM
(SETQ SCSET (COND
((NEQ NSCHARSETSHIFT
(SETQ CHAR (\BIN STREAM)))
(* ;
 "Note: no eof error check on this \BIN -- an eof in the middle of a charset shift is an error")
(AND 'COUNTERVAR
(SETQ COUNTERVAR
(IDIFFERENCE COUNTERVAR 2))
)
CHAR)
((PROGN
(* ;
 "2 shift-bytes means not run-encoded")
(AND 'COUNTERVAR
(SETQ COUNTERVAR
(IDIFFERENCE
COUNTERVAR 3)
))
(EQ 0 (\BIN STREAM)))
\NORUNCODE)
(T (\NSIN.24BITENCODING.ERROR
STREAM]
[SETQ SCSET (COND
('SHIFTEDCSETVAR
(* ; "CHARSETVAR=NIL means don't set")
(SETQ SHIFTEDCSETVAR
(UNFOLD SCSET 256)))
(T (UNFOLD SCSET 256]
(COND
((NULL (SETQ CHAR (\PEEKBIN STREAM NOERROR)))
(RETURN NIL]
(T (SETQ SCSET SHIFTEDCSET)))
(RETURN (COND
((EQ SCSET (UNFOLD \NORUNCODE 256))
(* ;; "just peek two bytes and combine them to a 16 bit value. Again, is an error if we hit eof in mid-character")
(\BIN STREAM)
(PROG1 (LOGOR (UNFOLD CHAR 256)
(\PEEKBIN STREAM NOERROR))
(\BACKFILEPTR STREAM)))
(T (LOGOR SHIFTEDCSET CHAR])
(PUTPROPS \BACKXCCSCHAR MACRO [(STREAM SHIFTEDCHARSET COUNTERVAR)
(AND (\BACKFILEPTR STREAM)
(COND
[[COND
(SHIFTEDCHARSET (EQ SHIFTEDCHARSET
(UNFOLD \NORUNCODE 256)))
(T (EQ \NORUNCODE (ACCESS-CHARSET STREAM]
(COND
((\BACKFILEPTR STREAM)
(AND 'COUNTERVAR (add COUNTERVAR 2))
T)
('COUNTERVAR (add COUNTERVAR 1]
('COUNTERVAR (add COUNTERVAR 1])
)
(DECLARE%: EVAL@COMPILE
(PUTPROPS UNFOLD MACRO [X (PROG [(FORM (CAR X))
(DIVISOR (CAR (CONSTANTEXPRESSIONP (CADR X]
(OR (AND DIVISOR (POWEROFTWOP DIVISOR))
(\ILLEGAL.ARG (CADR X)))
(RETURN (LIST 'LLSH FORM (SUB1 (INTEGERLENGTH DIVISOR])
)
(FOR M (MAPARRAY _ (CL:MAKE-ARRAY 256 :INITIAL-ELEMENT NIL))
CSMAP IN CODEMAP UNLESS (EQ (CAR M)
(CADR M))
DO (CL:UNLESS (SETQ CSMAP (CL:SVREF MAPARRAY (LRSH (CAR M)
8)))
(FILEMAP (NIL (2391 5846 (\8859OUTCHARFN 2401 . 3463) (\8859INCCODEFN 3465 . 4657) (\8859PEEKCCODEFN
4659 . 5844)) (5938 9711 (MAKEISOFORMAT 5948 . 9709)) (9771 12858 (\IBMOUTCHARFN 9781 . 10606) (
\IBMINCCODEFN 10608 . 11578) (\IBMPEEKCCODEFN 11580 . 12856)) (12942 16693 (MAKEIBMFORMAT 12952 .
16691)) (16741 19512 (\MACOUTCHARFN 16751 . 17558) (\MACINCCODEFN 17560 . 18431) (\MACPEEKCCODEFN
18433 . 19510)) (19596 24385 (MAKEMACFORMAT 19606 . 24383)) (24452 26736 (\COMMONBACKCHARFN 24462 .
25057) (\MAKERECODEMAP 25059 . 26289) (\RECODECCODE 26291 . 26734)))))
(SETQ CSMAP (CL:MAKE-ARRAY 256 :INITIAL-ELEMENT NIL))
(CL:SETF (CL:SVREF MAPARRAY (LRSH (CAR M)
8))
CSMAP))
(CL:SETF (CL:SVREF CSMAP (LOGAND (CAR M)
255))
(CADR M)) FINALLY (RETURN MAPARRAY])

BIN
lispusers/ISO8859IO.LCOM
View File

Binary file not shown.

466
lispusers/MACINTERFACE
View File

@@ -1,466 +0,0 @@
(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED "22-Feb-2021 14:01:07" 
{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>MACINTERFACE.;78 20371
changes to%: (VARS MACINTERFACECOMS)
previous date%: "22-Feb-2021 12:56:21"
{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>MACINTERFACE.;77)
(PRETTYCOMPRINT MACINTERFACECOMS)
(RPAQQ MACINTERFACECOMS
[
(* ;; "Externals")
(COMS (FNS MACWINDOW MACWINDOW.SETUP UNMACWINDOW MACWINDOW.UNSETUP)
(INITVARS (MACWINDOWMARGIN 25)))
(* ;; "Internals")
[COMS (FNS MACWINDOW.BUTTONEVENTFN MACWINDOW.BUTTONEVENTFN.ANYWHERE NEARTOP NEARESTCORNER
INCORNER.REGION)
(* ;; "Behavior for some known window creators")
(FNS MACINT-ADD-EXEC MACINT-SNAPW)
(FNS TEDIT.MACINTERFACE TEDIT.SELECTALL)
(FNS TOTOPW.MACINTERFACE)
(P (MOVD 'TOTOPW.MACINTERFACE 'TOTOPW.MODERNIZE)
(MOVD 'MACWINDOW 'MODERNWINDOW)
(MOVD 'UNMACWINDOW 'UNMODERNWINDOW))
(DECLARE%: DONTEVAL@LOAD DOCOPY (P (TEDIT.MACINTERFACE)
(* ;; "Inspector")
(MACWINDOW.SETUP '\ITEM.WINDOW.BUTTON.HANDLER)
(* ;; "Commonlisp array inspector. If you move the main window, the little attached window doesn't move. But if you move the attached window, it all works. Needs a special definition. Shaping doesn't work either")
(* (MACWINDOW.SETUP 'ONEDINSPECT.BUTTONEVENTFN))
(MACWINDOW.SETUP 'ICMLARRAY.TITLECOMMANDFN)
(* ;; "Freemenu")
(MACWINDOW.SETUP '\FM.BUTTONEVENTFN)
(* ;; "SEDIT")
(MACWINDOW.SETUP 'SEDIT::BUTTONEVENTFN)
(* ;; "Debugger")
(MACWINDOW.SETUP 'DBG::DEBUGGER-BUTTON-EVENT)
(* ;; "Snap")
(MACWINDOW.SETUP 'SNAPW 'MACINT-SNAPW)
(* ;; "New execs")
(MACWINDOW.SETUP 'ADD-EXEC 'MACINT-ADD-EXEC)
(* ;; "Existing exec of the load")
(MACWINDOW (PROCESSPROP (TTY.PROCESS)
'WINDOW))
(* ;; "Table browser (for filebrowser)")
(MACWINDOW.SETUP 'TB.BUTTONEVENTFN)
(* ;; "Grapher")
(MACWINDOW.SETUP 'APPLYTOSELECTEDNODE)
(* ;; "Promptwindow")
(MACWINDOW PROMPTWINDOW T]
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML)
(LAMA MACINT-ADD-EXEC])
(* ;; "Externals")
(DEFINEQ
(MACWINDOW
[LAMBDA (WINDOW ANYWHERE) (* ; "Edited 23-Jun-2020 16:01 by rmk:")
(* ;; "This can be applied to windows that have been created with an unknown or unmodifiable buttoneventfn.")
(CL:UNLESS (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN)
(WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN (WINDOWPROP WINDOW 'BUTTONEVENTFN))
(WINDOWPROP WINDOW 'BUTTONEVENTFN (IF ANYWHERE
THEN (FUNCTION MACWINDOW.BUTTONEVENTFN.ANYWHERE)
ELSE (FUNCTION MACWINDOW.BUTTONEVENTFN))))
WINDOW])
(MACWINDOW.SETUP
[LAMBDA (ORIGFN MACWINDOWFN ANYWHERE) (* ; "Edited 13-Feb-2021 19:53 by rmk:")
(* ;; "ORIGFN is either a function that creates windows of a given type (e.g. SNAPW or ADD-EXEC) or the known BUTTONEVENTFN of a class of windows.")
(* ;; "Moves ORIGNFN to a new name, prefixed with MACORIG-.")
(* ;; "If MACWINDOWFN is given, then that replaces the original definition of ORIGFN, and presumably knows how to call the renamed ORIGFN under the right circumstances. This is typically the case where ORIGFN is a window creator.")
(* ;; "Otherwise, ORIGFN is taken to be the BUTTONEVENTFN for a class of windows, and its new definition is defaulted to one that maps left-clicks in appropriate areas into Mac window operations. If not in appropriate areas, then the renamed ORIGNFN is called to give the original button behavior.")
(* ;; "If ANYWHERE, moving will happen for any click not in one of the shaping corners.")
(* ;; "The renamed function has arguments in addition to WINDOW: the new name for the original function, if MACWINDOFN is provided, and the value specified here for ANYWHERE.")
(LET [RENAMEDORIG (PKGNAME (CL:PACKAGE-NAME (CL:SYMBOL-PACKAGE ORIGFN]
(* ;; "The renamed version of XCL symbols go into Interlisp, so there is less confusion about accessing it")
(CL:WHEN (STREQUAL PKGNAME "XEROX-COMMON-LISP")
(SETQ PKGNAME "INTERLISP"))
(SETQ RENAMEDORIG (CL:INTERN (CONCAT 'MACORIG- ORIGFN)
PKGNAME))
(MOVD? ORIGFN RENAMEDORIG)
(IF MACWINDOWFN
THEN (MOVD MACWINDOWFN ORIGFN)
ELSE (PUTD ORIGFN `(LAMBDA (WINDOW)
(MACWINDOW.BUTTONEVENTFN WINDOW (FUNCTION ,RENAMEDORIG)
,ANYWHERE])
(UNMACWINDOW
[LAMBDA (WINDOW) (* ; "Edited 7-Dec-2020 17:57 by rmk:")
(* ;; "Restores original window behavior")
(CL:WHEN (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN)
(WINDOWPROP WINDOW 'BUTTONEVENTFN (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN))
(WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN NIL))
WINDOW])
(MACWINDOW.UNSETUP
[LAMBDA (ORIGFN) (* ; "Edited 6-Jul-2020 13:04 by rmk:")
(* ; "Edited 24-Jun-2020 15:09 by rmk:")
(* ;; "Moves the renamed original function back to its original name")
(LET [RENAMEDORIG (PKGNAME (CL:PACKAGE-NAME (CL:SYMBOL-PACKAGE ORIGFN]
(* ;; "The renamed version of XCL symbols go into Interlisp, so there is less confusion about accessing it")
(CL:WHEN (STREQUAL PKGNAME "XEROX-COMMON-LISP")
(SETQ PKGNAME "INTERLISP"))
(SETQ RENAMEDORIG (CL:INTERN (CONCAT 'MACORIG- ORIGFN)
PKGNAME))
(CL:WHEN (GETD RENAMEDORIG)
(MOVD RENAMEDORIG ORIGFN])
)
(RPAQ? MACWINDOWMARGIN 25)
(* ;; "Internals")
(DEFINEQ
(MACWINDOW.BUTTONEVENTFN
[LAMBDA (WINDOW ORIGFUNCTION ANYWHERE) (* ; "Edited 14-Feb-2021 21:51 by rmk:")
(* ; "Edited 24-Jun-2020 20:23 by rmk:")
(* ; "Edited 23-May-2020 08:34 by rmk:")
(* ; "Edited 10-May-2020 03:35 by rmk:")
(* ; "Edited 3-May-2020 21:18 by rmk:")
(IF (AND (MOUSESTATE (ONLY LEFT))
(EQ LASTKEYBOARD 0))
THEN (TOTOPW WINDOW)
(LET [CORNER TOPMARGIN (MAINREGION (WINDOWPROP WINDOW 'REGION))
(ATTACHEDREGION (WINDOWREGION WINDOW 'SHAPEW]
(* ;; "If the window has a TOPMARGIN property, that tells us that it does not have a canonical title but may still have a title-like attached window just above the main window. The TOPMARGIN should be 0 in that case.")
(* ;; "This is particularly the case of FILEBROWSER windows, where the the modified ATTACHEDWINDOWTOTOPFN drives the click here. ")
(SETQ TOPMARGIN (IF (WINDOWPROP WINDOW 'TOPMARGIN)
ELSEIF (WINDOWPROP WINDOW 'TITLE)
THEN (FONTPROP WindowTitleDisplayStream 'HEIGHT)
ELSE MACWINDOWMARGIN))
(SETQ CORNER (INCORNER.REGION MAINREGION TOPMARGIN))
(IF CORNER
THEN
(* ;;
 "The upper corners may be in the title bar, near the side, so test corners before titlebar.")
(* ;; "We are in the corner of the main window, so we are reshaping. But the ghost region should include all of the attached windows, and the starting cursor should be positioned at the corner closest to the selected corner of the main window.")
(* ;; "WINDOWREGION includes the attached windows")
(LET ((LEFT (FETCH LEFT OF ATTACHEDREGION))
(RIGHT (FETCH RIGHT OF ATTACHEDREGION))
(TOP (FETCH TOP OF ATTACHEDREGION))
(BOTTOM (FETCH BOTTOM OF ATTACHEDREGION))
STARTINGREGION)
(* ;; "\CURSORPOSITION moves the mouse to the tracking corner of the ghost region, in screen coordinates, so that the mouse starts out at the tracking corner of the ghost region, even if there are attached windows (as in the filebrowser) that overhang the corner and the initiating click was at the corner of the mainwindow.")
(CL:UNLESS (EQ 'DON'T (WINDOWPROP WINDOW 'RESHAPEFN))
[SETQ STARTINGREGION
(GETREGION NIL NIL NIL NIL NIL
(SELECTQ CORNER
(RIGHTBOTTOM (\CURSORPOSITION RIGHT BOTTOM)
(GETMOUSESTATE)
(LIST LEFT TOP RIGHT BOTTOM))
(LEFTBOTTOM (\CURSORPOSITION LEFT BOTTOM)
(GETMOUSESTATE)
(LIST RIGHT TOP LEFT BOTTOM))
(RIGHTTOP (\CURSORPOSITION RIGHT TOP)
(GETMOUSESTATE)
(LIST LEFT BOTTOM RIGHT TOP))
(LEFTTOP (\CURSORPOSITION LEFT TOP)
(GETMOUSESTATE)
(LIST RIGHT BOTTOM LEFT TOP))
(SHOULDNT])
(SHAPEW WINDOW STARTINGREGION))
T
ELSEIF (OR ANYWHERE (NEARTOP MAINREGION TOPMARGIN))
THEN (NEARESTCORNER ATTACHEDREGION)
(MOVEW WINDOW)
T
ELSEIF [OR ORIGFUNCTION (SETQ ORIGFUNCTION (WINDOWPROP WINDOW
'PREMACBUTTONEVENTFN]
THEN (APPLY* ORIGFUNCTION WINDOW)))
ELSEIF [OR ORIGFUNCTION (SETQ ORIGFUNCTION (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN]
THEN (APPLY* ORIGFUNCTION WINDOW])
(MACWINDOW.BUTTONEVENTFN.ANYWHERE
[LAMBDA (WINDOW) (* ; "Edited 3-Dec-2020 14:24 by rmk:")
(* ; "Edited 24-Jun-2020 13:24 by rmk:")
(* ;; "Move if left-click anywhere, not just titlebar")
(MACWINDOW.BUTTONEVENTFN WINDOW NIL T])
(NEARTOP
[LAMBDA (MAINREGION TOPMARGIN) (* ; "Edited 12-Feb-2021 23:19 by rmk:")
(* ;; "True if the MOUSEY is near the top of MAINREGION. That means in the title bar for titled windows, otherwise a short distance below the top of the window. (Could be in the border?)")
(IGREATERP LASTMOUSEY (IDIFFERENCE (FETCH TOP OF MAINREGION)
TOPMARGIN])
(NEARESTCORNER
[LAMBDA (REGION) (* ; "Edited 14-Feb-2021 21:46 by rmk:")
(* ;;
"Moves the cursor to the corner of REGION that is closest to the current LASTMOUSEX AND LASTMOUSEY")
(\CURSORPOSITION (CL:IF (ILESSP (IDIFFERENCE LASTMOUSEX (FETCH LEFT OF REGION))
(IDIFFERENCE (FETCH RIGHT OF REGION)
LASTMOUSEX))
(FETCH LEFT OF REGION)
(FETCH RIGHT OF REGION))
(CL:IF (ILESSP (IDIFFERENCE LASTMOUSEY (FETCH BOTTOM OF REGION))
(IDIFFERENCE (FETCH TOP OF REGION)
LASTMOUSEY))
(FETCH BOTTOM OF REGION)
(FETCH TOP OF REGION))])
(INCORNER.REGION
[LAMBDA (MAINREGION TOPMARGIN) (* ; "Edited 12-Feb-2021 23:22 by rmk:")
(* ;; "MAINREGION, LASTMOUSEX, LASTMOUSEY in screen coordinates.")
(* ;; "TOPMARGIN is the height of the titlebar for titled windows, otherwise the margin at the top of the window's content that we regard as the top. ")
(IF (ILEQ (IABS (IDIFFERENCE LASTMOUSEX (FETCH LEFT OF MAINREGION)))
MACWINDOWMARGIN)
THEN (IF (NEARTOP MAINREGION TOPMARGIN)
THEN 'LEFTTOP
ELSEIF (ILEQ LASTMOUSEY (IPLUS MACWINDOWMARGIN (FETCH BOTTOM OF
MAINREGION
)))
THEN 'LEFTBOTTOM)
ELSEIF (ILEQ (IABS (IDIFFERENCE LASTMOUSEX (FETCH RIGHT OF MAINREGION)))
MACWINDOWMARGIN)
THEN (IF (NEARTOP MAINREGION TOPMARGIN)
THEN 'RIGHTTOP
ELSEIF (ILEQ LASTMOUSEY (IPLUS MACWINDOWMARGIN (FETCH BOTTOM OF
MAINREGION
)))
THEN 'RIGHTBOTTOM])
)
(* ;; "Behavior for some known window creators")
(DEFINEQ
(MACINT-ADD-EXEC
[LAMBDA U (* ; "Edited 24-Jun-2020 14:23 by rmk:")
(LET [(PROC (APPLY (FUNCTION MACORIG-ADD-EXEC)
(FOR N FROM 1 TO U COLLECT (ARG U N]
(* ;; "For some reason, the window may not be there immediately")
(DISMISS 100)
(MACWINDOW (PROCESSPROP PROC 'WINDOW))
PROC])
(MACINT-SNAPW
[LAMBDA NIL (* ; "Edited 24-Jun-2020 13:19 by rmk:")
(* ;; "No point in shaping a snap window, just move it.;;")
(* ;;
"This changes the creation function (SNAPW), since snap windows otherwise don't have a BUTTONEVENTN")
(LET ((W (MACORIG-SNAPW)))
[WINDOWPROP W 'BUTTONEVENTFN (FUNCTION (LAMBDA (W)
(TOTOPW W)
(MOVEW W]
W])
)
(DEFINEQ
(TEDIT.MACINTERFACE
[LAMBDA NIL (* ; "Edited 22-Feb-2021 12:56 by rmk:")
(CL:WHEN (GETD '\TEDIT.BUTTONEVENTFN)
(MACWINDOW.SETUP '\TEDIT.BUTTONEVENTFN)
(* ;; "All")
(TEDIT.SETFUNCTION (CHARCODE "1,a")
(FUNCTION TEDIT.SELECTALL)
TEDIT.READTABLE)
(TEDIT.SETFUNCTION (CHARCODE "1,A")
(FUNCTION TEDIT.SELECTALL)
TEDIT.READTABLE)
(* ;; "Quit")
(TEDIT.SETFUNCTION (CHARCODE "1,q")
(FUNCTION TEDIT.QUIT)
TEDIT.READTABLE)
(TEDIT.SETFUNCTION (CHARCODE "1,Q")
(FUNCTION TEDIT.QUIT)
TEDIT.READTABLE))])
(TEDIT.SELECTALL
[LAMBDA (STREAM TEXTOBJ SEL) (* ; "Edited 3-May-2020 17:29 by rmk:")
(LET [(TEXTSTREAM (TEXTSTREAM (TTY.PROCESS]
(CL:WHEN TEXTSTREAM
(TEDIT.SETSEL TEXTSTREAM 0 (ADD1 (fetch TEXTLEN of (TEXTOBJ TEXTSTREAM)))
'LEFT))])
)
(DEFINEQ
(TOTOPW.MACINTERFACE
[LAMBDA (WINDOW) (* ; "Edited 13-Feb-2021 23:27 by rmk:")
(* ;; "This replaces the TOTOPW BUTTONEVENTFN on an attached window where the click is then directed to the MAINWINDOW.")
(TOTOPW WINDOW)
(LET ((MAIN (MAINWINDOW WINDOW T)))
(CL:WHEN MAIN
(MACWINDOW.BUTTONEVENTFN MAIN (WINDOWPROP MAIN 'BUTTONEVENTFN)))])
)
(MOVD 'TOTOPW.MACINTERFACE 'TOTOPW.MODERNIZE)
(MOVD 'MACWINDOW 'MODERNWINDOW)
(MOVD 'UNMACWINDOW 'UNMODERNWINDOW)
(DECLARE%: DONTEVAL@LOAD DOCOPY
(TEDIT.MACINTERFACE)
(* ;; "Inspector")
(MACWINDOW.SETUP '\ITEM.WINDOW.BUTTON.HANDLER)
(* ;; "Commonlisp array inspector. If you move the main window, the little attached window doesn't move. But if you move the attached window, it all works. Needs a special definition. Shaping doesn't work either")
(* (MACWINDOW.SETUP
 (QUOTE ONEDINSPECT.BUTTONEVENTFN)))
(MACWINDOW.SETUP 'ICMLARRAY.TITLECOMMANDFN)
(* ;; "Freemenu")
(MACWINDOW.SETUP '\FM.BUTTONEVENTFN)
(* ;; "SEDIT")
(MACWINDOW.SETUP 'SEDIT::BUTTONEVENTFN)
(* ;; "Debugger")
(MACWINDOW.SETUP 'DBG::DEBUGGER-BUTTON-EVENT)
(* ;; "Snap")
(MACWINDOW.SETUP 'SNAPW 'MACINT-SNAPW)
(* ;; "New execs")
(MACWINDOW.SETUP 'ADD-EXEC 'MACINT-ADD-EXEC)
(* ;; "Existing exec of the load")
(MACWINDOW (PROCESSPROP (TTY.PROCESS)
'WINDOW))
(* ;; "Table browser (for filebrowser)")
(MACWINDOW.SETUP 'TB.BUTTONEVENTFN)
(* ;; "Grapher")
(MACWINDOW.SETUP 'APPLYTOSELECTEDNODE)
(* ;; "Promptwindow")
(MACWINDOW PROMPTWINDOW T)
)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA MACINT-ADD-EXEC)
)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (4238 7997 (MACWINDOW 4248 . 4889) (MACWINDOW.SETUP 4891 . 6807) (UNMACWINDOW 6809 .
7188) (MACWINDOW.UNSETUP 7190 . 7995)) (8057 16239 (MACWINDOW.BUTTONEVENTFN 8067 . 13089) (
MACWINDOW.BUTTONEVENTFN.ANYWHERE 13091 . 13456) (NEARTOP 13458 . 13894) (NEARESTCORNER 13896 . 14775)
(INCORNER.REGION 14777 . 16237)) (16297 17274 (MACINT-ADD-EXEC 16307 . 16731) (MACINT-SNAPW 16733 .
17272)) (17275 18358 (TEDIT.MACINTERFACE 17285 . 18027) (TEDIT.SELECTALL 18029 . 18356)) (18359 18799
(TOTOPW.MACINTERFACE 18369 . 18797)))))
STOP

BIN
lispusers/MACINTERFACE.LCOM
View File

Binary file not shown.

52
lispusers/MACINTERFACE.TXT
View File

@@ -1,52 +0,0 @@
MACINTERFACE documentation
Ron Kaplan, June 2020
MACINTERFACE is a symbol Lispusers package that changes the mouse actions on Medley windows so that moving and shaping can be done in a way that approximates the behavior of windows on the Mac desktop.
Thus, for a window that has been created or transformed in this way, you can move the window by left-clicking in the title bar and dragging the window.
The menu behavior for other buttons in the title bar is unchanged.
Similarly, you can reshape a window by clicking near one of its corners and dragging it out.
For bottom corners, "near" means inside the window within MACINTERFACECORNERMARGIN (initially 25) pixels above or to the left/right of the corner.
For top corners, "near" means within the title bar and within the margin from the left/right edges.
(Windows that don't have a title-bar, like Snap windows, can be set up so that moving can happen by clicking anywhere, and shaping at the top is determined by the margin inside the window region.)
When the package is loaded, this behavior is installed for the following kinds of windows:
Tedit
Debugger/break
Sedit
Inspector
Snap
Exec
The function MACWINDOW.SETUP establishes the new behavior for classes of windows:
(MACWINDOW.SETUP ORIGFN MACWINDOWFN ANYWHERE)
ORIGFN is either the name of the BUTTONEVENTFN for a class of windows (e.g. \TEDIT.BUTTONEVENTFN for Tedit windows) or it is a function that creates windows of a particulate kind (e.g. SNAPW or ADD-EXEC).
MACWINDOW.SETUP moves the definition of ORIGFN to the name (PACK* 'MACORIG- ORIGFN), and then provides a new definition for ORIGFN that does the moving or reshaping for clicks in the triggering locations, and otherwise passes control through to the original definition.
If ORIGNFN is a button event function, then MACWINDOWFN should not be specified. In that case a new definition for ORIGFN is constructed to provide the desired windowing behavior.
Otherwise, if ORIGFN is the function that creates windows of a class (e.g. SNAPW), then a MACWINDOWFN should be provided to create such window (by calling (PACK* MACORIG- ORIGFN)). The definition of MACWINDOWFN replaces the original definition of ORIGFN.
If the flag ANYWHERE is non-NIL, especially for windows without a title bar, then the moving behavior is triggered by a click anywhere in the window (except the corners).
Because this works by redefining existing functions, it is important that the MACINTERFACE package be loaded AFTER Tedit and Sedit, if those are not already in the sysout. And it should be called to upgrade the proper functions for other window classes that might later be added (e.g. GRAPHER).
If it is not known or it is inconvenient to systematically upgrade a button function or a window-creation function, the new behavior can be provided after a window has been created, by invoking
(MACWINDOW WINDOW ANYWHERE)
This saves the windows existing BUTTONEVENTFN as a window property PREMACBUTTONEVENTFN, and installs a simple stub function in its place.
Known issue: Clicking at the bottom-right corner of Tedit windows sometimes doesn't catch the new behavior--there seems to be a conflict with Tedit's window-splitting conventions.
A future extension might be to add an X or some circles on the left of the title bar, to implement a close/shrink behaviors.

1
lispusers/MACINTERFACE.~1~
View File

@@ -1 +0,0 @@
(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")

1
lispusers/MACINTERFACE.~32~
View File

File diff suppressed because one or more lines are too long

1
lispusers/MACINTERFACE.~46~
View File

File diff suppressed because one or more lines are too long

1
lispusers/MACINTERFACE.~49~
View File

File diff suppressed because one or more lines are too long

1
lispusers/MACINTERFACE.~6~
View File

@@ -1 +0,0 @@
(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")

150
lispusers/MODERNIZE
View File

@@ -1,11 +1,11 @@
(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED "14-Mar-2021 20:33:34" 
{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>MODERNIZE.;14 20950
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10 FORMAT XCCS)
(FILECREATED " 8-Jul-2021 23:33:42" 
{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>MODERNIZE.;16 23978
changes to%: (FNS MODERNWINDOW.SETUP)
changes to%: (FNS MODERNWINDOW)
previous date%: "14-Mar-2021 18:00:34"
{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>MODERNIZE.;13)
previous date%: " 3-Jul-2021 10:32:03"
{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>MODERNIZE.;15)
(PRETTYCOMPRINT MODERNIZECOMS)
@@ -19,17 +19,20 @@
(* ;; "Internals")
[COMS (FNS MODERNWINDOW.BUTTONEVENTFN MODERNWINDOW.BUTTONEVENTFN.ANYWHERE NEARTOP
NEARESTCORNER INCORNER.REGION)
[COMS (FNS MODERNWINDOW.BUTTONEVENTFN NEARTOP NEARESTCORNER INCORNER.REGION)
(* ;; "Behavior for some known window creators")
(FNS MODERN-ADD-EXEC MODERN-SNAPW TOTOPW.MODERNIZE)
(FNS MODERN-ADD-EXEC MODERN-SNAPW TOTOPW.MODERNIZE MODERN-MENUBUTTONFN)
(* ;; "Add some Meta commands")
(FNS TEDIT.MODERNIZE TEDIT.SELECTALL)
(DECLARE%: DONTEVAL@LOAD DOCOPY (P (TEDIT.MODERNIZE)
(DECLARE%: DONTEVAL@LOAD DOCOPY (P
(* ;; "Tedit")
(MODERNWINDOW.SETUP '\TEDIT.BUTTONEVENTFN)
(TEDIT.MODERNIZE)
(* ;; "Inspector")
@@ -80,7 +83,13 @@
(* ;; "Promptwindow")
(MODERNWINDOW PROMPTWINDOW T]
(MODERNWINDOW PROMPTWINDOW T)
(* ;;
 "Menus: Move only and only with title clicks")
(MODERNWINDOW.SETUP 'MENUBUTTONFN
'MODERN-MENUBUTTONFN]
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML)
(LAMA MODERN-ADD-EXEC])
@@ -92,19 +101,28 @@
(DEFINEQ
(MODERNWINDOW
[LAMBDA (WINDOW ANYWHERE) (* ; "Edited 22-Feb-2021 16:44 by rmk:")
[LAMBDA (WINDOW ANYWHERE TITLEPROPORTION) (* ; "Edited 8-Jul-2021 23:33 by rmk:")
(* ; "Edited 3-Jul-2021 10:31 by rmk:")
(* ; "Edited 24-Jun-2021 14:52 by rmk:")
(* ;; "This can be applied to windows that have been created with an unknown or unmodifiable buttoneventfn.")
(* ;; "This can be applied to windows that have been created with an unknown or unmodifiable buttoneventfn. If the window was previously modernized, we restore its original state first, in case it is called here with different parameters")
(CL:UNLESS (WINDOWPROP WINDOW 'PREMODERN-BUTTONEVENTFN)
(WINDOWPROP WINDOW 'PREMODERN-BUTTONEVENTFN (WINDOWPROP WINDOW 'BUTTONEVENTFN))
(WINDOWPROP WINDOW 'BUTTONEVENTFN (IF ANYWHERE
THEN (FUNCTION MODERNWINDOW.BUTTONEVENTFN.ANYWHERE)
ELSE (FUNCTION MODERNWINDOW.BUTTONEVENTFN))))
(CL:WHEN (AND TITLEPROPORTION (GREATERP TITLEPROPORTION 0.5))
(ERROR "TITLEPROPORTION cannot be greater than .5"))
(CL:WHEN (WINDOWPROP WINDOW 'PREMODERN-BUTTONEVENTFN)
(WINDOWPROP WINDOW 'BUTTONEVENTFN (WINDOWPROP WINDOW 'PREMODERN-BUTTONEVENTFN))
(WINDOWPROP WINDOW 'PREMODERN-BUTTONEVENTFN NIL))
(WINDOWPROP WINDOW 'PREMODERN-BUTTONEVENTFN (WINDOWPROP WINDOW 'BUTTONEVENTFN))
(WINDOWPROP WINDOW 'BUTTONEVENTFN (IF (OR ANYWHERE TITLEPROPORTION)
THEN [FUNCTION (LAMBDA (WINDOW)
(MODERNWINDOW.BUTTONEVENTFN
WINDOW NIL T ,TITLEPROPORTION]
ELSE (FUNCTION MODERNWINDOW.BUTTONEVENTFN)))
WINDOW])
(MODERNWINDOW.SETUP
[LAMBDA (ORIGFN MODERNWINDOWFN ANYWHERE) (* ; "Edited 14-Mar-2021 20:33 by rmk:")
[LAMBDA (ORIGFN MODERNWINDOWFN ANYWHERE TITLEPROPORTION)
(* ; "Edited 24-Jun-2021 14:53 by rmk:")
(* ;; "ORIGFN is either a function that creates windows of a given type (e.g. SNAPW or ADD-EXEC) or the known BUTTONEVENTFN of a class of windows.")
@@ -122,6 +140,11 @@
(* ;; "If ORIGFN is defined, then presumably the file containing ORIGFN (e.g. sketch) was loaded before MODERNIZE (if we are being called on our load), and we can rearrange things. But of ORIGFN is not defined, then there is really nothing to do. The package loader itself should call MODERNWINDOW.SETUP if we are defined when it is loaded. ")
(* ;; "")
(CL:WHEN (AND TITLEPROPORTION (GREATERP TITLEPROPORTION 0.5))
(ERROR "TITLEPROPORTION cannot be greater than .5"))
(MODERNWINDOW.UNSETUP ORIGFN)
[LET [RENAMEDORIG (PKGNAME (CL:PACKAGE-NAME (CL:SYMBOL-PACKAGE ORIGFN]
(* ;; "The renamed version of XCL symbols go into Interlisp, so there is less confusion about accessing it")
@@ -133,10 +156,14 @@
(MOVD? ORIGFN RENAMEDORIG)
(IF MODERNWINDOWFN
THEN (MOVD MODERNWINDOWFN ORIGFN)
ELSE (PUTD ORIGFN `(LAMBDA (WINDOW)
(MODERNWINDOW.BUTTONEVENTFN WINDOW (FUNCTION
,RENAMEDORIG)
,ANYWHERE])])
ELSE (PUTD ORIGFN `(LAMBDA ,(ARGLIST ORIGFN)
(MODERNWINDOW.BUTTONEVENTFN
,(CL:IF (LISTP (ARGLIST ORIGFN))
(CAR (ARGLIST ORIGFN))
(ARGLIST ORIGFN))
(FUNCTION ,RENAMEDORIG)
,ANYWHERE
,TITLEPROPORTION])])
(UNMODERNWINDOW
[LAMBDA (WINDOW) (* ; "Edited 22-Feb-2021 16:44 by rmk:")
@@ -175,7 +202,7 @@
(DEFINEQ
(MODERNWINDOW.BUTTONEVENTFN
[LAMBDA (WINDOW ORIGFUNCTION ANYWHERE) (* ; "Edited 27-Feb-2021 17:57 by rmk:")
[LAMBDA (WINDOW ORIGFUNCTION ANYWHERE TITLEPROPORTION)(* ; "Edited 24-Jun-2021 14:49 by rmk:")
(IF (AND (MOUSESTATE (ONLY LEFT))
(EQ LASTKEYBOARD 0))
THEN (TOTOPW WINDOW)
@@ -231,7 +258,7 @@
WINDOW)
STARTINGREGION))
T
ELSEIF (OR ANYWHERE (NEARTOP MAINREGION TOPMARGIN))
ELSEIF (OR ANYWHERE (NEARTOP MAINREGION TOPMARGIN TITLEPROPORTION))
THEN (NEARESTCORNER ATTACHEDREGION)
(MOVEW (CL:IF (MEMB 'MOVEW (WINDOWPROP WINDOW 'PASSTOMAINCOMS))
(WINDOWPROP WINDOW 'MAINWINDOW)
@@ -243,21 +270,20 @@
ELSEIF [OR ORIGFUNCTION (SETQ ORIGFUNCTION (WINDOWPROP WINDOW 'PREMODERN-BUTTONEVENTFN]
THEN (APPLY* ORIGFUNCTION WINDOW])
(MODERNWINDOW.BUTTONEVENTFN.ANYWHERE
[LAMBDA (WINDOW) (* ; "Edited 22-Feb-2021 16:31 by rmk:")
(* ; "Edited 24-Jun-2020 13:24 by rmk:")
(* ;; "Move if left-click anywhere, not just titlebar")
(MODERNWINDOW.BUTTONEVENTFN WINDOW NIL T])
(NEARTOP
[LAMBDA (MAINREGION TOPMARGIN) (* ; "Edited 12-Feb-2021 23:19 by rmk:")
[LAMBDA (MAINREGION TOPMARGIN TITLEPROPORTION) (* ; "Edited 24-Jun-2021 14:51 by rmk:")
(* ;; "True if the MOUSEY is near the top of MAINREGION. That means in the title bar for titled windows, otherwise a short distance below the top of the window. (Could be in the border?)")
(IGREATERP LASTMOUSEY (IDIFFERENCE (FETCH TOP OF MAINREGION)
TOPMARGIN])
(* ;; "If TITLEPROPORTION is N, then the click must be within that proportion of the window-width from either edge. ")
(AND (IGREATERP LASTMOUSEY (IDIFFERENCE (FETCH TOP OF MAINREGION)
TOPMARGIN))
(OR (NOT TITLEPROPORTION)
(LET ((WIDTH (FETCH WIDTH of MAINREGION))
(LEFT (FETCH LEFT OF MAINREGION)))
(OR (ILESSP LASTMOUSEX (IPLUS LEFT (TIMES WIDTH TITLEPROPORTION)))
(IGREATERP LASTMOUSEX (IPLUS LEFT (TIMES WIDTH (DIFFERENCE 1 TITLEPROPORTION])
(NEARESTCORNER
[LAMBDA (REGION) (* ; "Edited 14-Feb-2021 21:46 by rmk:")
@@ -339,6 +365,23 @@
(LET ((MAIN (MAINWINDOW WINDOW T)))
(CL:WHEN MAIN
(MODERNWINDOW.BUTTONEVENTFN MAIN (WINDOWPROP MAIN 'BUTTONEVENTFN)))])
(MODERN-MENUBUTTONFN
[LAMBDA (WINDOW) (* ; "Edited 23-May-2021 20:37 by rmk:")
(* ;; "Replaces the button fn for a Menu window, allowing title clicks to do the move. Sometimes the title isn't in the window, it's in the menu.")
(LET (MENU)
(IF [AND (MOUSESTATE (ONLY LEFT))
(EQ LASTKEYBOARD 0)
(OR (WINDOWPROP WINDOW 'TITLE)
(AND [NULL (CDR (SETQ MENU (MKLIST (WINDOWPROP WINDOW 'MENU]
(TYPE? MENU (SETQ MENU (CAR MENU)))
(FETCH (MENU TITLE) OF MENU)))
(NEARTOP (WINDOWPROP WINDOW 'REGION)
(FONTPROP WindowTitleDisplayStream 'HEIGHT]
THEN (MOVEW WINDOW)
ELSE (MODERN-ORIG-MENUBUTTONFN WINDOW])
)
@@ -348,25 +391,24 @@
(DEFINEQ
(TEDIT.MODERNIZE
[LAMBDA NIL (* ; "Edited 22-Feb-2021 16:28 by rmk:")
[LAMBDA NIL (* ; "Edited 24-Jun-2021 20:54 by rmk:")
(CL:WHEN (GETD '\TEDIT.BUTTONEVENTFN)
(MODERNWINDOW.SETUP '\TEDIT.BUTTONEVENTFN)
(* ;; "All")
(TEDIT.SETFUNCTION (CHARCODE "1,a")
(TEDIT.SETFUNCTION (CHARCODE "Meta,a")
(FUNCTION TEDIT.SELECTALL)
TEDIT.READTABLE)
(TEDIT.SETFUNCTION (CHARCODE "1,A")
(TEDIT.SETFUNCTION (CHARCODE "Meta,A")
(FUNCTION TEDIT.SELECTALL)
TEDIT.READTABLE)
(* ;; "Quit")
(TEDIT.SETFUNCTION (CHARCODE "1,q")
(TEDIT.SETFUNCTION (CHARCODE "Meta,q")
(FUNCTION TEDIT.QUIT)
TEDIT.READTABLE)
(TEDIT.SETFUNCTION (CHARCODE "1,Q")
(TEDIT.SETFUNCTION (CHARCODE "Meta,Q")
(FUNCTION TEDIT.QUIT)
TEDIT.READTABLE))])
@@ -379,6 +421,12 @@
)
(DECLARE%: DONTEVAL@LOAD DOCOPY
(* ;; "Tedit")
(MODERNWINDOW.SETUP '\TEDIT.BUTTONEVENTFN)
(TEDIT.MODERNIZE)
@@ -456,6 +504,12 @@
(MODERNWINDOW PROMPTWINDOW T)
(* ;; "Menus: Move only and only with title clicks")
(MODERNWINDOW.SETUP 'MENUBUTTONFN 'MODERN-MENUBUTTONFN)
)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
@@ -466,10 +520,10 @@
(ADDTOVAR LAMA MODERN-ADD-EXEC)
)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (4369 8713 (MODERNWINDOW 4379 . 5037) (MODERNWINDOW.SETUP 5039 . 7501) (UNMODERNWINDOW
7503 . 7897) (MODERNWINDOW.UNSETUP 7899 . 8711)) (8778 16791 (MODERNWINDOW.BUTTONEVENTFN 8788 . 13799)
(MODERNWINDOW.BUTTONEVENTFN.ANYWHERE 13801 . 14172) (NEARTOP 14174 . 14610) (NEARESTCORNER 14612 .
15491) (INCORNER.REGION 15493 . 16789)) (16849 18267 (MODERN-ADD-EXEC 16859 . 17290) (MODERN-SNAPW
17292 . 17835) (TOTOPW.MODERNIZE 17837 . 18265)) (18308 19391 (TEDIT.MODERNIZE 18318 . 19060) (
TEDIT.SELECTALL 19062 . 19389)))))
(FILEMAP (NIL (4933 10561 (MODERNWINDOW 4943 . 6398) (MODERNWINDOW.SETUP 6400 . 9349) (UNMODERNWINDOW
9351 . 9745) (MODERNWINDOW.UNSETUP 9747 . 10559)) (10626 18766 (MODERNWINDOW.BUTTONEVENTFN 10636 .
15663) (NEARTOP 15665 . 16585) (NEARESTCORNER 16587 . 17466) (INCORNER.REGION 17468 . 18764)) (18824
21146 (MODERN-ADD-EXEC 18834 . 19265) (MODERN-SNAPW 19267 . 19810) (TOTOPW.MODERNIZE 19812 . 20240) (
MODERN-MENUBUTTONFN 20242 . 21144)) (21187 22227 (TEDIT.MODERNIZE 21197 . 21896) (TEDIT.SELECTALL
21898 . 22225)))))
STOP

BIN
lispusers/MODERNIZE.LCOM
View File

Binary file not shown.

167
lispusers/PRETTYFILEINDEX
View File

@@ -1,13 +1,15 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "28-Jun-99 17:13:51" {DSK}<project>medley3.5>lispusers>PRETTYFILEINDEX.;3 91069
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10 FORMAT XCCS)
(FILECREATED " 9-Jul-2021 21:55:15" 
{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>PRETTYFILEINDEX.;5 93788
changes to%: (FNS PRETTYFILEINDEX PFI.PASS.COMMENT)
changes to%: (FNS PRETTYFILEINDEX PFI.PRINT.FILECREATED)
previous date%: "12-Nov-93 09:53:58" {DSK}<project>medley3.5>lispusers>PRETTYFILEINDEX.;2)
previous date%: " 9-Jul-2021 08:04:40"
{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>PRETTYFILEINDEX.;4)
(* ; "
Copyright (c) 1988, 1992, 1993, 1999 by Xerox Corporation. All rights reserved.
Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation.
")
(PRETTYCOMPRINT PRETTYFILEINDEXCOMS)
@@ -181,7 +183,8 @@ Copyright (c) 1988, 1992, 1993, 1999 by Xerox Corporation. All rights reserved.
(DEFINEQ
(PRETTYFILEINDEX
[LAMBDA (FILENAME PRINTOPTIONS OUTSTREAM DONTINDEX) (* ; "Edited 11-Apr-95 00:02 by rmk:")
[LAMBDA (FILENAME PRINTOPTIONS OUTSTREAM DONTINDEX) (* ; "Edited 9-Jul-2021 21:35 by rmk:")
(* ; "Edited 11-Apr-95 00:02 by rmk:")
(* ; "Edited 11-Jun-92 15:58 by cat")
(* ;; "Makes an indexed file (default is the line printer pseudo-file). The index file will have a number of indices, one for each indexable type. Each type index will list all the items of that type in alphabetical order and the page number of where that item's definition is in the file. The indices will be printed last, so that this can be one-pass.")
@@ -329,6 +332,9 @@ Copyright (c) 1988, 1992, 1993, 1999 by Xerox Corporation. All rights reserved.
(SETQ *PFI-LOCATIONS* :NONE)
else (STREAMPROP *STANDARD-OUTPUT* 'AFTERNEWPAGEFN (FUNCTION PFI.AFTER.NEW.PAGE))
(* ; "Enable header printing")
(* ;; "RMK: NOBIND here seems to be deliberate, it seems somehow to match the NOBIND that appears in PFI.HANDLE.RPAQQ.")
[SETQ *PFI-FILEVARS* `((,(FILECOMS FILENAME) . NOBIND]
(* ; "Says to do something with coms")
[if (NOT (FIXP *PFI-MAX-WASTED-LINES*))
@@ -453,16 +459,107 @@ Copyright (c) 1988, 1992, 1993, 1999 by Xerox Corporation. All rights reserved.
(DEFINEQ
(PFI.PRINT.FILECREATED
(LAMBDA (EXPR ENV) (* ; "Edited 13-Apr-88 11:14 by bvm") (* ;; "Display the FILECREATED expression and environment prettily") (* ;; "Form is (FILECREATED date filename filemaploc changes to: changes previous date: date filename)") (pop EXPR) (CHANGEFONT ITALICFONT) (LET* ((STRINGS (QUOTE ("File created:" "changes to:" "previous date:" "Read Table:" "Package:" "Base:"))) (FONT (DSPFONT)) (STRWIDTHS (for STR in STRINGS collect (STRINGWIDTH STR FONT))) (TABSTOP (+ (DSPLEFTMARGIN) (APPLY (FUNCTION MAX) STRWIDTHS)))) (PFI.PRINT.TO.TAB (pop STRINGS) (pop STRWIDTHS) TABSTOP) (* ; "File created:") (PRINTOUT NIL (pop EXPR) " " .FONT LAMBDAFONT (pop EXPR) T T) (* ; "date and file name") (if (OR (NULL (CAR EXPR)) (FIXP (CAR EXPR))) then (* ; "Skip over filemaploc") (pop EXPR)) (if (EQ (CAR EXPR) (QUOTE changes)) then (* ; "handle %"Changes to:%"") (PFI.PRINT.TO.TAB (pop STRINGS) (pop STRWIDTHS) TABSTOP) (SETQ EXPR (CDDR EXPR)) (PRINTDEF (while (LISTP (CAR EXPR)) collect (pop EXPR)) T NIL T) (TERPRI) (TERPRI) else (pop STRINGS) (pop STRWIDTHS)) (if (EQ (CAR EXPR) (QUOTE previous)) then (* ; "Handle %"Previous date:%"") (PFI.PRINT.TO.TAB (pop STRINGS) (pop STRWIDTHS) TABSTOP) (SETQ EXPR (CDDR EXPR)) (PRINTOUT NIL (pop EXPR) " " (pop EXPR) T T) else (pop STRINGS) (pop STRWIDTHS)) (LET ((SPEC (fetch RESPEC of ENV))) (* ; "Show environment") (PFI.PRINT.TO.TAB (pop STRINGS) (pop STRWIDTHS) TABSTOP) (* ; "Read table") (PFI.PRINT.ENVIRONMENT SPEC :READTABLE) (PFI.PRINT.TO.TAB (pop STRINGS) (pop STRWIDTHS) TABSTOP) (* ; "Package") (PFI.PRINT.ENVIRONMENT SPEC :PACKAGE) (if (NEQ *PRINT-BASE* 10) then (PFI.PRINT.TO.TAB (pop STRINGS) (pop STRWIDTHS) TABSTOP) (PFI.PRINT.ENVIRONMENT SPEC :BASE)))))
)
[LAMBDA (EXPR ENV) (* ; "Edited 9-Jul-2021 07:59 by rmk:")
(* ;; "Display the FILECREATED expression and environment prettily")
(* ;;
 "Form is (FILECREATED date filename filemaploc changes to: changes previous date: date filename)")
(pop EXPR)
(CHANGEFONT ITALICFONT)
(LET* [(STRINGS '("File created:" "changes to:" "previous date:" "Read Table:" "Package:" "Base:"
"Format:"))
(FONT (DSPFONT))
(STRWIDTHS (for STR in STRINGS collect (STRINGWIDTH STR FONT)))
(TABSTOP (+ (DSPLEFTMARGIN)
(APPLY (FUNCTION MAX)
STRWIDTHS]
(PFI.PRINT.TO.TAB (pop STRINGS)
(pop STRWIDTHS)
TABSTOP) (* ; "File created:")
(PRINTOUT NIL (pop EXPR)
" " .FONT LAMBDAFONT (pop EXPR)
T T) (* ; "date and file name")
(if (OR (NULL (CAR EXPR))
(FIXP (CAR EXPR)))
then (* ; "Skip over filemaploc")
(pop EXPR))
(if (EQ (CAR EXPR)
'changes)
then (* ; "handle %"Changes to:%"")
(PFI.PRINT.TO.TAB (pop STRINGS)
(pop STRWIDTHS)
TABSTOP)
(SETQ EXPR (CDDR EXPR))
(PRINTDEF (while (LISTP (CAR EXPR)) collect (pop EXPR))
T NIL T)
(TERPRI)
(TERPRI)
else (pop STRINGS)
(pop STRWIDTHS))
(if (EQ (CAR EXPR)
'previous)
then (* ; "Handle %"Previous date:%"")
(PFI.PRINT.TO.TAB (pop STRINGS)
(pop STRWIDTHS)
TABSTOP)
(SETQ EXPR (CDDR EXPR))
(PRINTOUT NIL (pop EXPR)
" "
(pop EXPR)
T T)
else (pop STRINGS)
(pop STRWIDTHS))
(* ;; "Show environment")
(PFI.PRINT.TO.TAB (pop STRINGS)
(pop STRWIDTHS)
TABSTOP) (* ; "Read table")
(PFI.PRINT.ENVIRONMENT ENV :READTABLE)
(PFI.PRINT.TO.TAB (pop STRINGS)
(pop STRWIDTHS)
TABSTOP) (* ; "Package")
(PFI.PRINT.ENVIRONMENT ENV :PACKAGE)
(if (NEQ *PRINT-BASE* 10)
then (PFI.PRINT.TO.TAB (pop STRINGS)
(pop STRWIDTHS)
TABSTOP)
(PFI.PRINT.ENVIRONMENT ENV :BASE)
ELSE (pop STRINGS))
(PFI.PRINT.TO.TAB (pop STRINGS)
(pop STRWIDTHS)
TABSTOP) (* ; "Format")
(PFI.PRINT.ENVIRONMENT ENV :FORMAT])
(PFI.PRINT.TO.TAB
(LAMBDA (STR WIDTH TABSTOP) (* ; "Edited 29-Mar-88 12:44 by bvm") (* ;; "Print STR of specified WIDTH right-justified to xpos TABSTOP in italic font, leave a couple of spaces, then switch back to defaultfont.") (CHANGEFONT ITALICFONT) (DSPXPOSITION (- TABSTOP WIDTH)) (PRIN3 STR) (RELMOVETO (TIMES 12 (DSPSCALE)) 0) (CHANGEFONT DEFAULTFONT))
)
(PFI.PRINT.ENVIRONMENT
(LAMBDA (SPEC KEYWORD) (* ; "Edited 29-Mar-88 12:46 by bvm") (* ;; "Display the KEYWORD component of a reader environment spec") (LET ((VALUE (LISTGET SPEC KEYWORD))) (if (LISTP VALUE) then (* ; "An expression to create it--show pretty. Use IL package, since that's what they appear in at beginning of file") (LET ((*PACKAGE* *INTERLISP-PACKAGE*)) (PRINTDEF VALUE T T)) else (* ; "Just show the value, sans quotations, etc. The selectq is just in case this environment has no spec, something that shouldn't happen if it came from a define-file-info") (PRIN3 (OR VALUE (SELECTQ KEYWORD (:READTABLE (READTABLEPROP *READTABLE* (QUOTE NAME))) (:PACKAGE (CL:PACKAGE-NAME *PACKAGE*)) (SHOULDNT))))) (TERPRI) (TERPRI)))
)
[LAMBDA (ENV KEYWORD) (* ; "Edited 9-Jul-2021 08:03 by rmk:")
(* ;; "Display the KEYWORD component of a reader environment spec")
(LET [(VALUE (SELECTQ KEYWORD
(:READTABLE (READTABLEPROP (FETCH (READER-ENVIRONMENT REREADTABLE)
OF ENV)
'NAME))
(:PACKAGE (CL:PACKAGE-NAME (FETCH (READER-ENVIRONMENT REPACKAGE)
OF ENV)))
(:BASE (FETCH (READER-ENVIRONMENT REBASE) OF ENV))
(:FORMAT (FETCH (READER-ENVIRONMENT REFORMAT) OF ENV))
(SHOULDNT]
(if (LISTP VALUE)
then (* ; "An expression to create it--show pretty. Use IL package, since that's what they appear in at beginning of file")
(LET ((*PACKAGE* *INTERLISP-PACKAGE*))
(PRINTDEF VALUE T T))
else (* ;
 "Just show the value, sans quotations, etc. ")
(PRIN3 VALUE))
(TERPRI)
(TERPRI])
)
(DEFINEQ
@@ -884,30 +981,30 @@ Copyright (c) 1988, 1992, 1993, 1999 by Xerox Corporation. All rights reserved.
'NILL)
'NON.PFI.PRINT.BITMAP NIL T)
)
(PUTPROPS PRETTYFILEINDEX COPYRIGHT ("Xerox Corporation" 1988 1992 1993 1999))
(PUTPROPS PRETTYFILEINDEX COPYRIGHT ("Xerox Corporation" 1988 1992 1993 1999 2021))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (10096 12331 (PFI.NEW.LISTFILES1 10106 . 10600) (PFI.ENQUEUE 10602 . 11226) (
\PFI.DO.HARDCOPY 11228 . 11814) (MAYBE.PRETTYFILEINDEX 11816 . 12329)) (12332 34987 (PRETTYFILEINDEX
12342 . 26515) (PFI.MAKE.LPT.STREAM 26517 . 29568) (PFI.SETUP.TRANSLATIONS 29570 . 31084) (
PFI.OUTCHARFN 31086 . 33060) (PFI.COLLECT.DEFINERS 33062 . 33874) (PFI.AFTER.NEW.PAGE 33876 . 34985))
(34988 37844 (PFI.PRINT.FILECREATED 34998 . 36730) (PFI.PRINT.TO.TAB 36732 . 37097) (
PFI.PRINT.ENVIRONMENT 37099 . 37842)) (37845 45029 (PFI.PROCESS.FILE 37855 . 39085) (PFI.PASS.COMMENT
39087 . 40057) (PFI.HANDLE.EXPR 40059 . 40726) (PFI.DEFAULT.HANDLER 40728 . 42781) (PFI.PRETTYPRINT
42783 . 43118) (PFI.LINES.REMAINING 43120 . 43447) (PFI.MAYBE.NEW.PAGE 43449 . 43952) (
PFI.ESTIMATE.SIZE 43954 . 44485) (PFI.ESTIMATE.SIZE1 44487 . 45027)) (45066 54553 (PFI.HANDLE.RPAQQ
45076 . 46484) (PFI.HANDLE.DECLARE 46486 . 47425) (PFI.HANDLE.EVAL-WHEN 47427 . 47910) (
PFI.HANDLE.DEFDEFINER 47912 . 49202) (PFI.HANDLE.DEFINEQ 49204 . 49448) (PFI.PRINT.LAMBDA 49450 .
49788) (PFI.PRINT.LAMBDA.BODY 49790 . 50125) (PFI.HANDLE.PUTDEF 50127 . 50624) (PFI.HANDLE.PUTPROPS
50626 . 51241) (PFI.HANDLE./DECLAREDATATYPE 51243 . 51790) (PFI.HANDLE.* 51792 . 53054) (
PFI.PRINT.COMMENTS 53056 . 53956) (PFI.HANDLE.FILEMAP 53958 . 54246) (PFI.HANDLE.PACKAGE 54248 . 54551
)) (54581 55573 (PFI.PREVIEW.DECLARE 54591 . 55253) (PFI.PREVIEW.DEFINEQ 55255 . 55571)) (55609 66597
(PFI.PRINT.INDEX 55619 . 56470) (PFI.CONDENSE.INDEX 56472 . 58279) (PFI.SORT.INDICES 58281 . 59420) (
PFI.COMPUTE.INDEX.SHAPE 59422 . 60886) (PFI.PRINT.INDICES 60888 . 65430) (PFI.CENTER.PRINT 65432 .
66002) (PFI.INDEX.BREAK 66004 . 66462) (PFI.LOOKUP.NAME 66464 . 66595)) (66598 67829 (PFI.ADD.TO.INDEX
66608 . 67118) (PFI.VARNAME 67120 . 67530) (PFI.CONSTANTNAMES 67532 . 67827)) (67864 76177 (
MULTIFILEINDEX 67874 . 68670) (MULTIFILEINDEX1 68672 . 70128) (PFI.PRINT.MULTI.INDEX 70130 . 75233) (
PFI.CHOOSE.BEST 75235 . 75462) (PFI.MERGE.INDICES 75464 . 76175)) (76234 77852 (PFI.MAYBE.SEE.PRETTY
76244 . 77174) (PFI.MAYBE.PP.DEFINITION 77176 . 77850)) (77922 81757 (PFI.PRINT.BITMAP 77932 . 81755))
(84602 87716 (PUTPROPS.PRETTYPRINT 84612 . 86023) (RPAQX.PRETTYPRINT 86025 . 86750) (
COURIERPROGRAM.PRETTYPRINT 86752 . 87452) (MAYBE.PRETTYPRINT.BOLD 87454 . 87714)))))
(FILEMAP (NIL (10148 12383 (PFI.NEW.LISTFILES1 10158 . 10652) (PFI.ENQUEUE 10654 . 11278) (
\PFI.DO.HARDCOPY 11280 . 11866) (MAYBE.PRETTYFILEINDEX 11868 . 12381)) (12384 35298 (PRETTYFILEINDEX
12394 . 26826) (PFI.MAKE.LPT.STREAM 26828 . 29879) (PFI.SETUP.TRANSLATIONS 29881 . 31395) (
PFI.OUTCHARFN 31397 . 33371) (PFI.COLLECT.DEFINERS 33373 . 34185) (PFI.AFTER.NEW.PAGE 34187 . 35296))
(35299 40558 (PFI.PRINT.FILECREATED 35309 . 38825) (PFI.PRINT.TO.TAB 38827 . 39192) (
PFI.PRINT.ENVIRONMENT 39194 . 40556)) (40559 47743 (PFI.PROCESS.FILE 40569 . 41799) (PFI.PASS.COMMENT
41801 . 42771) (PFI.HANDLE.EXPR 42773 . 43440) (PFI.DEFAULT.HANDLER 43442 . 45495) (PFI.PRETTYPRINT
45497 . 45832) (PFI.LINES.REMAINING 45834 . 46161) (PFI.MAYBE.NEW.PAGE 46163 . 46666) (
PFI.ESTIMATE.SIZE 46668 . 47199) (PFI.ESTIMATE.SIZE1 47201 . 47741)) (47780 57267 (PFI.HANDLE.RPAQQ
47790 . 49198) (PFI.HANDLE.DECLARE 49200 . 50139) (PFI.HANDLE.EVAL-WHEN 50141 . 50624) (
PFI.HANDLE.DEFDEFINER 50626 . 51916) (PFI.HANDLE.DEFINEQ 51918 . 52162) (PFI.PRINT.LAMBDA 52164 .
52502) (PFI.PRINT.LAMBDA.BODY 52504 . 52839) (PFI.HANDLE.PUTDEF 52841 . 53338) (PFI.HANDLE.PUTPROPS
53340 . 53955) (PFI.HANDLE./DECLAREDATATYPE 53957 . 54504) (PFI.HANDLE.* 54506 . 55768) (
PFI.PRINT.COMMENTS 55770 . 56670) (PFI.HANDLE.FILEMAP 56672 . 56960) (PFI.HANDLE.PACKAGE 56962 . 57265
)) (57295 58287 (PFI.PREVIEW.DECLARE 57305 . 57967) (PFI.PREVIEW.DEFINEQ 57969 . 58285)) (58323 69311
(PFI.PRINT.INDEX 58333 . 59184) (PFI.CONDENSE.INDEX 59186 . 60993) (PFI.SORT.INDICES 60995 . 62134) (
PFI.COMPUTE.INDEX.SHAPE 62136 . 63600) (PFI.PRINT.INDICES 63602 . 68144) (PFI.CENTER.PRINT 68146 .
68716) (PFI.INDEX.BREAK 68718 . 69176) (PFI.LOOKUP.NAME 69178 . 69309)) (69312 70543 (PFI.ADD.TO.INDEX
69322 . 69832) (PFI.VARNAME 69834 . 70244) (PFI.CONSTANTNAMES 70246 . 70541)) (70578 78891 (
MULTIFILEINDEX 70588 . 71384) (MULTIFILEINDEX1 71386 . 72842) (PFI.PRINT.MULTI.INDEX 72844 . 77947) (
PFI.CHOOSE.BEST 77949 . 78176) (PFI.MERGE.INDICES 78178 . 78889)) (78948 80566 (PFI.MAYBE.SEE.PRETTY
78958 . 79888) (PFI.MAYBE.PP.DEFINITION 79890 . 80564)) (80636 84471 (PFI.PRINT.BITMAP 80646 . 84469))
(87316 90430 (PUTPROPS.PRETTYPRINT 87326 . 88737) (RPAQX.PRETTYPRINT 88739 . 89464) (
COURIERPROGRAM.PRETTYPRINT 89466 . 90166) (MAYBE.PRETTYPRINT.BOLD 90168 . 90428)))))
STOP

BIN
lispusers/PRETTYFILEINDEX.LCOM
View File

Binary file not shown.

94
lispusers/READINTERPRESS
View File

@@ -1,19 +1,30 @@
(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED "25-Mar-88 17:54:27" {ERINYES}<LISPUSERS>MEDLEY>READINTERPRESS.;2 8705
(FILECREATED "22-Jun-2021 10:52:34" 
{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>READINTERPRESS.;4 10412
changes to%: (FNS READINT.IP)
changes to%: (FNS PRINTSEQUENCE)
previous date%: "15-Jul-86 21:58:05" {PHYLUM}<LISPUSERS>LYRIC>READINTERPRESS.;1)
previous date%: "22-Jun-2021 10:35:30"
{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>READINTERPRESS.;3)
(* "
Copyright (c) 1983, 1984, 1985, 1986, 1988 by Xerox Corporation. All rights reserved.
(* ; "
Copyright (c) 1983-1986, 1988, 2021 by Xerox Corporation.
")
(PRETTYCOMPRINT READINTERPRESSCOMS)
(RPAQQ READINTERPRESSCOMS ((* "Utilities for reading Interpress files") (FNS PRINTMASTER) (FNS OPCODE TOKEN FINDNONPRIMNAME FINDOPNAME SHORTINT TOKENFORMAT FINDSEQUENCETYPE PRINTTOKEN PRINTSEQUENCE SEARCHIPLIST READINT.IP SHOWFILE SHOWBYTE) (MACROS BIN.RIP) (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP) INTERPRESS)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA SHORTINT TOKEN))))
)
(RPAQQ READINTERPRESSCOMS
[(* "Utilities for reading Interpress files")
(FNS PRINTMASTER)
(FNS OPCODE TOKEN FINDNONPRIMNAME FINDOPNAME SHORTINT TOKENFORMAT FINDSEQUENCETYPE PRINTTOKEN
PRINTSEQUENCE SEARCHIPLIST READINT.IP SHOWFILE SHOWBYTE)
(MACROS BIN.RIP)
(DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP)
INTERPRESS))
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML)
(LAMA SHORTINT TOKEN])
@@ -59,8 +70,48 @@ Copyright (c) 1983, 1984, 1985, 1986, 1988 by Xerox Corporation. All rights res
)
(PRINTSEQUENCE
(LAMBDA (ISTREAM OUTSTREAM TYPE LENGTH) (* hdj "15-Jul-86 21:43") (SELECTQ TYPE (SEQIDENTIFIER (printout OUTSTREAM 20 "ID: ") (CHARSET ISTREAM 0) (bind (CHARSET _ 0) until (EQ LENGTH 0) do (PRINTCCODE (\NSIN ISTREAM CHARSET CHARSET LENGTH) OUTSTREAM))) (SEQINTEGER (printout OUTSTREAM 20) (for I from 1 to LENGTH do (PRINTTOKEN ISTREAM OUTSTREAM))) (SEQRATIONAL (PROG ((NUM (READINT.IP ISTREAM (LRSH LENGTH 1))) (DENOM (READINT.IP ISTREAM (LRSH LENGTH 1)))) (printout OUTSTREAM 20 NUM "/" DENOM " = " (FQUOTIENT NUM DENOM)))) (SEQSTRING (printout OUTSTREAM 20 "STR[" LENGTH "] = %"") (CHARSET ISTREAM 0) (bind (CHARSET _ 0) until (EQ LENGTH 0) do (PRINTCCODE (\NSIN ISTREAM CHARSET CHARSET LENGTH) OUTSTREAM)) (printout OUTSTREAM (QUOTE %"))) (SEQCOMMENT (for I from 1 to LENGTH first (printout OUTSTREAM 20 "Comment vector of " LENGTH " bytes" 22) do (printout OUTSTREAM |.I4| (BIN ISTREAM)))) (SEQPACKEDPIXELVECTOR (bind YBYTES (I _ 5) (XBITS _ (READINT.IP ISTREAM 2)) (YBITS _ (READINT.IP ISTREAM 2)) first (printout OUTSTREAM 20 "Packed pixel" " vector of " LENGTH " bytes [" XBITS "X" YBITS "]") (SETQ YBYTES (UNFOLD (FOLDHI YBITS BITSPERWORD) BYTESPERWORD)) (* "The number of bytes on a line is always even--gets to a word boundary") while (ILEQ I LENGTH) do (printout OUTSTREAM T 10) (for J from 1 to YBYTES do (printout OUTSTREAM |.I8.-2.T| (BIN ISTREAM)) (add I 1)))) (SEQLARGEVECTOR (for I VAL (BYTESPERELT _ (BIN ISTREAM)) from 2 to LENGTH first (printout OUTSTREAM 20 "Large vector of " BYTESPERELT " bytes per element") do (SETQ VAL (READINT.IP ISTREAM BYTESPERELT)) (printout OUTSTREAM 22 |.I5| I ": " VAL))) (SEQCONTINUED (HELP "Can't handle SEQCONTINUED yet")) (SEQINSERTFILE (HELP "Can't handle SEQINSERTFILE yet")) (SEQCOMPRESSPIXELVECTOR (HELP "Can't handle SEQCOMPRESSPIXELVECTOR yet")) (SHOULDNT)) (TERPRI OUTSTREAM))
)
[LAMBDA (ISTREAM OUTSTREAM TYPE LENGTH) (* ; "Edited 22-Jun-2021 10:52 by rmk:")
(DECLARE (SPECVARS LENGTH)) (* ; "For byte counting")
(SELECTQ TYPE
(SEQIDENTIFIER (printout OUTSTREAM 20 "ID: ")
(until (EQ LENGTH 0) do (PRINTCCODE (\INCCODE ISTREAM 'LENGTH LENGTH)
OUTSTREAM)))
(SEQINTEGER (printout OUTSTREAM 20)
(for I from 1 to LENGTH do (PRINTTOKEN ISTREAM OUTSTREAM)))
(SEQRATIONAL (PROG [(NUM (READINT.IP ISTREAM (LRSH LENGTH 1)))
(DENOM (READINT.IP ISTREAM (LRSH LENGTH 1]
(printout OUTSTREAM 20 NUM "/" DENOM " = " (FQUOTIENT NUM DENOM))))
(SEQSTRING (printout OUTSTREAM 20 "STR[" LENGTH "] = %"")
(until (EQ LENGTH 0) do (PRINTCCODE (\INCCODE ISTREAM 'LENGTH LENGTH)
OUTSTREAM))
(printout OUTSTREAM '%"))
(SEQCOMMENT (for I from 1 to LENGTH
first (printout OUTSTREAM 20 "Comment vector of " LENGTH " bytes" 22)
do (printout OUTSTREAM .I4 (BIN ISTREAM))))
(SEQPACKEDPIXELVECTOR
(bind YBYTES (I _ 5)
(XBITS _ (READINT.IP ISTREAM 2))
(YBITS _ (READINT.IP ISTREAM 2))
first (printout OUTSTREAM 20 "Packed pixel" " vector of " LENGTH " bytes [" XBITS
"X" YBITS "]")
(SETQ YBYTES (UNFOLD (FOLDHI YBITS BITSPERWORD)
BYTESPERWORD)) (*
 "The number of bytes on a line is always even--gets to a word boundary")
while (ILEQ I LENGTH) do (printout OUTSTREAM T 10)
(for J from 1 to YBYTES
do (printout OUTSTREAM .I8.-2.T (BIN ISTREAM))
(add I 1))))
(SEQLARGEVECTOR
(for I VAL (BYTESPERELT _ (BIN ISTREAM)) from 2 to LENGTH
first (printout OUTSTREAM 20 "Large vector of " BYTESPERELT " bytes per element")
do (SETQ VAL (READINT.IP ISTREAM BYTESPERELT))
(printout OUTSTREAM 22 .I5 I ": " VAL)))
(SEQCONTINUED (HELP "Can't handle SEQCONTINUED yet"))
(SEQINSERTFILE (HELP "Can't handle SEQINSERTFILE yet"))
(SEQCOMPRESSPIXELVECTOR
(HELP "Can't handle SEQCOMPRESSPIXELVECTOR yet"))
(SHOULDNT))
(TERPRI OUTSTREAM])
(SEARCHIPLIST
(LAMBDA (CODE IPLIST) (* rmk%: "15-Mar-84 09:15") (for X in IPLIST when (EQ CODE (CADR X)) do (RETURN (CAR X))))
@@ -79,10 +130,21 @@ Copyright (c) 1983, 1984, 1985, 1986, 1988 by Xerox Corporation. All rights res
)
)
(DECLARE%: EVAL@COMPILE
(PUTPROPS BIN.RIP MACRO (ARGS (LET ((ISTREAM (CAR ARGS)) (OSTREAM (CADR ARGS))) (BQUOTE (LET ((C (BIN (\, ISTREAM)))) (COND ((IGREATERP (POSITION (\, OSTREAM)) 15) (printout (\, OSTREAM) 5 "|" 8))) (printout (\, OSTREAM) |.I3| C " ") C)))))
(PUTPROPS BIN.RIP MACRO [ARGS (LET ((ISTREAM (CAR ARGS))
(OSTREAM (CADR ARGS)))
`(LET [(C (BIN ,ISTREAM]
(COND
((IGREATERP (POSITION ,OSTREAM)
15)
(printout ,OSTREAM 5 "|" 8)))
(printout ,OSTREAM .I3 C " ")
C])
)
(DECLARE%: EVAL@COMPILE DONTCOPY
(FILESLOAD (LOADCOMP) INTERPRESS)
(FILESLOAD (LOADCOMP)
INTERPRESS)
)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
@@ -92,10 +154,10 @@ Copyright (c) 1983, 1984, 1985, 1986, 1988 by Xerox Corporation. All rights res
(ADDTOVAR LAMA SHORTINT TOKEN)
)
(PUTPROPS READINTERPRESS COPYRIGHT ("Xerox Corporation" 1983 1984 1985 1986 1988))
(PUTPROPS READINTERPRESS COPYRIGHT ("Xerox Corporation" 1983 1984 1985 1986 1988 2021))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (910 1596 (PRINTMASTER 920 . 1594)) (1597 8114 (OPCODE 1607 . 1732) (TOKEN 1734 . 2306)
(FINDNONPRIMNAME 2308 . 2413) (FINDOPNAME 2415 . 2672) (SHORTINT 2674 . 2867) (TOKENFORMAT 2869 . 3111
) (FINDSEQUENCETYPE 3113 . 3317) (PRINTTOKEN 3319 . 4270) (PRINTSEQUENCE 4272 . 6133) (SEARCHIPLIST
6135 . 6267) (READINT.IP 6269 . 6508) (SHOWFILE 6510 . 7834) (SHOWBYTE 7836 . 8112)))))
(FILEMAP (NIL (1210 1896 (PRINTMASTER 1220 . 1894)) (1897 9430 (OPCODE 1907 . 2032) (TOKEN 2034 . 2606
) (FINDNONPRIMNAME 2608 . 2713) (FINDOPNAME 2715 . 2972) (SHORTINT 2974 . 3167) (TOKENFORMAT 3169 .
3411) (FINDSEQUENCETYPE 3413 . 3617) (PRINTTOKEN 3619 . 4570) (PRINTSEQUENCE 4572 . 7449) (
SEARCHIPLIST 7451 . 7583) (READINT.IP 7585 . 7824) (SHOWFILE 7826 . 9150) (SHOWBYTE 9152 . 9428)))))
STOP

BIN
lispusers/READINTERPRESS.LCOM Normal file
View File

Binary file not shown.

365
lispusers/SEDIT-COMMONLISP
View File

File diff suppressed because one or more lines are too long

178
lispusers/WHEELSCROLL
View File

@@ -1,12 +1,11 @@
(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED "22-Feb-2021 09:47:46" 
{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>WHEELSCROLL.;43 7259
(FILECREATED "11-Jun-2021 12:50:16" 
{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>WHEELSCROLL.;18 10803
changes to%: (VARS WHEELSCROLLCOMS)
(FNS ENABLEWHEELSCROLL)
changes to%: (FNS ENABLEWHEELSCROLL)
previous date%: "21-Feb-2021 09:39:06"
{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>WHEELSCROLL.;42)
previous date%: "11-Jun-2021 11:11:10"
{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>WHEELSCROLL.;14)
(PRETTYCOMPRINT WHEELSCROLLCOMS)
@@ -14,15 +13,21 @@
(RPAQQ WHEELSCROLLCOMS
[(FNS ENABLEWHEELSCROLL WHEELSCROLL WHEELSCROLL.DOIT INSTALL-WHEELSCROLL
LISPINTERRUPTS.WHEELSCROLL)
[VARS (WHEELSCROLLINTERRUPTS '((520 (WHEELSCROLL 'VERTICAL WHEELSCROLLDELTA)
T)
(521 (WHEELSCROLL 'VERTICAL (IMINUS WHEELSCROLLDELTA))
T)
(522 (WHEELSCROLL 'HORIZONTAL (IMINUS WHEELSCROLLDELTA)
T))
(523 (WHEELSCROLL 'HORIZONTAL WHEELSCROLLDELTA T]
(* ;; "These are the highest meta-ctrl characters, they will be unaffected by teh state of ctrl and meta mode keys")
(DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (UP 156)
(DOWN 157)
(LEFT 158)
(RIGHT 159)))
(GLOBALVARS WHEELSCROLLDELTA WHEELSCROLLSETTLETIME \WHEELSCROLLINPROGRESS)
(INITVARS (WHEELSCROLLDELTA 20)
(* ;; "To restore the keyactions for PAD..., if the keyaction table has been reinitialized")
[ADDVARS (AFTERSYSOUTFORMS (AND WHEELSCROLLENABLED (ENABLEWHEELSCROLL T)))
(AFTERMAKESYSFORMS (AND WHEELSCROLLENABLED (ENABLEWHEELSCROLL T]
(INITVARS (WHEELSCROLLENABLED NIL)
(WHEELSCROLLDELTA 20)
(WHEELSCROLLSETTLETIME 50)
(\WHEELSCROLLINPROGRESS NIL))
(DECLARE%: DONTEVAL@LOAD DOCOPY (P (INSTALL-WHEELSCROLL)
@@ -30,19 +35,73 @@
(DEFINEQ
(ENABLEWHEELSCROLL
[LAMBDA (ON) (* ; "Edited 22-Feb-2021 09:47 by rmk:")
[LAMBDA (ON EXCLUDEHORIZONTAL) (* ; "Edited 11-Jun-2021 12:50 by rmk:")
(* ; "Edited 28-May-2021 11:46 by rmk:")
(* ;; "So we can toggle this scrolling, for experimentation.")
(* ;; "So we can toggle this scrolling.")
(IF ON
THEN [KEYACTION 'PAD1 '((520 520) . IGNORE]
[KEYACTION 'PAD2 '((521 521) . IGNORE]
[KEYACTION 'PAD4 '((522 522) . IGNORE]
[KEYACTION 'PAD5 '((523 523) . IGNORE]
ELSE (KEYACTION 'PAD1 '(IGNORE . IGNORE))
(KEYACTION 'PAD2 '(IGNORE . IGNORE))
(KEYACTION 'PAD4 '(IGNORE . IGNORE))
(KEYACTION 'PAD5 '(IGNORE . IGNORE])
THEN (CL:UNLESS (EQP (GETD 'LISPINTERRUPTS)
(GETD 'LISPINTERRUPTS.WHEELSCROLL))
(CL:WHEN (GETD 'LISPINTERRUPTS.WHEELSCROLL)
(* ; "In case of LOADFROM?")
(MOVD? 'LISPINTERRUPTS 'LISPINTERRUPTS.WSORIG)
(MOVD 'LISPINTERRUPTS.WHEELSCROLL 'LISPINTERRUPTS)))
(* ;; "In some situations these other keyactions seem to be installed, hit them all.")
[FOR KAT IN (LIST \CURRENTKEYACTION \COMMANDKEYACTION \DEFAULTKEYACTION)
DO ((FOR K IN [IF EXCLUDEHORIZONTAL
THEN `((PAD1 ,UP)
(PAD2 ,DOWN)
(PAD4 IGNORE)
(PAD5 IGNORE))
ELSE `((PAD1 ,UP)
(PAD2 ,DOWN)
(PAD4 ,LEFT)
(PAD5 ,RIGHT]
DO (KEYACTION (CAR K)
(CONS (CL:IF (EQ (CADR K)
'IGNORE)
'IGNORE
`(,(CADR K)
,(CADR K)))
`IGNORE)
KAT]
(FOR I IN WHEELSCROLLINTERRUPTS
DO (INTERRUPTCHAR (CAR I)
(CADR I)
(CADDR I))
(CL:WHEN (BOUNDP 'TEDIT.READTABLE)
(* ;; "These actions are invoked when the caret is in the Tedit window, because TEDIT disables the interrupts")
(TEDIT.SETFUNCTION (CAR I)
`[LAMBDA NIL
,(CADR I]
TEDIT.READTABLE)))
(SETQ WHEELSCROLLENABLED T)
ELSE (CL:WHEN (EQP (GETD 'LISPINTERRUPTS.WHEELSCROLL)
(GETD 'LISPINTERRUPTS))
(MOVD 'LISPINTERRUPTS.WSORIG 'LISPINTERRUPTS))
(FOR I IN WHEELSCROLLINTERRUPTS DO (INTERRUPTCHAR (CAR I)
NIL)
(CL:WHEN (BOUNDP 'TEDIT.READTABLE)
(* ;; "These actions are invoked when the caret is in the Tedit window, because TEDIT disables the interrupts")
(TEDIT.SETFUNCTION (CAR I)
NIL TEDIT.READTABLE)))
(FOR KAT IN (LIST \CURRENTKEYACTION \COMMANDKEYACTION \DEFAULTKEYACTION)
DO (KEYACTION 'PAD1 '(IGNORE . IGNORE)
KAT)
(KEYACTION 'PAD2 '(IGNORE . IGNORE)
KAT)
(KEYACTION 'PAD4 '(IGNORE . IGNORE)
KAT)
(KEYACTION 'PAD5 '(IGNORE . IGNORE)
KAT))
(SETQ WHEELSCROLLENABLED NIL])
(WHEELSCROLL
[LAMBDA (DIRECTION DELTA) (* ; "Edited 21-Feb-2021 09:38 by rmk:")
@@ -97,21 +156,18 @@
(RESETVAR \WHEELSCROLLINPROGRESS T (SCROLLW WINDOW DX DY)))])
(INSTALL-WHEELSCROLL
[LAMBDA NIL (* ; "Edited 17-Feb-2021 11:53 by rmk:")
(CL:WHEN (GETD 'LISPINTERRUPTS.WHEELSCROLL)
(MOVD? 'LISPINTERRUPTS 'LISPINTERRUPTS.WSORIG)
(MOVD 'LISPINTERRUPTS.WHEELSCROLL 'LISPINTERRUPTS))
(FOR I IN WHEELSCROLLINTERRUPTS DO (INTERRUPTCHAR (CAR I)
(CADR I)
(CADDR I))
(CL:WHEN (BOUNDP 'TEDIT.READTABLE)
[LAMBDA NIL (* ; "Edited 28-May-2021 11:46 by rmk:")
(* ; "Edited 17-Feb-2021 11:53 by rmk:")
(* ;; "These actions are invoked when the caret is in the Tedit window, because TEDIT disables the interrupts")
(* ;; "We want the UP, DOWN...constants to be compiled awsy")
(TEDIT.SETFUNCTION (CAR I)
`[LAMBDA NIL
,(CADR I]
TEDIT.READTABLE))])
(SETQ WHEELSCROLLINTERRUPTS `((,UP (WHEELSCROLL 'VERTICAL WHEELSCROLLDELTA)
T)
(,DOWN (WHEELSCROLL 'VERTICAL (IMINUS WHEELSCROLLDELTA))
T)
(,LEFT (WHEELSCROLL 'HORIZONTAL (IMINUS WHEELSCROLLDELTA)
T))
(,RIGHT (WHEELSCROLL 'HORIZONTAL WHEELSCROLLDELTA T])
(LISPINTERRUPTS.WHEELSCROLL
[LAMBDA NIL (* ; "Edited 17-Feb-2021 11:09 by rmk:")
@@ -121,19 +177,46 @@
(APPEND WHEELSCROLLINTERRUPTS (LISPINTERRUPTS.WSORIG])
)
(RPAQQ WHEELSCROLLINTERRUPTS
((520 (WHEELSCROLL 'VERTICAL WHEELSCROLLDELTA)
T)
(521 (WHEELSCROLL 'VERTICAL (IMINUS WHEELSCROLLDELTA))
T)
(522 (WHEELSCROLL 'HORIZONTAL (IMINUS WHEELSCROLLDELTA)
T))
(523 (WHEELSCROLL 'HORIZONTAL WHEELSCROLLDELTA T))))
(* ;;
"These are the highest meta-ctrl characters, they will be unaffected by teh state of ctrl and meta mode keys"
)
(DECLARE%: EVAL@COMPILE DONTCOPY
(DECLARE%: EVAL@COMPILE
(RPAQQ UP 156)
(RPAQQ DOWN 157)
(RPAQQ LEFT 158)
(RPAQQ RIGHT 159)
(CONSTANTS (UP 156)
(DOWN 157)
(LEFT 158)
(RIGHT 159))
)
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS WHEELSCROLLDELTA WHEELSCROLLSETTLETIME \WHEELSCROLLINPROGRESS)
)
(* ;; "To restore the keyactions for PAD..., if the keyaction table has been reinitialized")
(ADDTOVAR AFTERSYSOUTFORMS (AND WHEELSCROLLENABLED (ENABLEWHEELSCROLL T)))
(ADDTOVAR AFTERMAKESYSFORMS (AND WHEELSCROLLENABLED (ENABLEWHEELSCROLL T)))
(RPAQ? WHEELSCROLLENABLED NIL)
(RPAQ? WHEELSCROLLDELTA 20)
(RPAQ? WHEELSCROLLSETTLETIME 50)
@@ -146,7 +229,6 @@
(ENABLEWHEELSCROLL T)
)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (1432 6591 (ENABLEWHEELSCROLL 1442 . 2071) (WHEELSCROLL 2073 . 4609) (WHEELSCROLL.DOIT
4611 . 5247) (INSTALL-WHEELSCROLL 5249 . 6312) (LISPINTERRUPTS.WHEELSCROLL 6314 . 6589)))))
(FILEMAP (NIL (1575 9814 (ENABLEWHEELSCROLL 1585 . 5542) (WHEELSCROLL 5544 . 8080) (WHEELSCROLL.DOIT
8082 . 8718) (INSTALL-WHEELSCROLL 8720 . 9535) (LISPINTERRUPTS.WHEELSCROLL 9537 . 9812)))))
STOP

BIN
lispusers/WHEELSCROLL.LCOM
View File

Binary file not shown.