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

Merge branch 'master' into Externalformat-collected-in-a-separate-file

Browse Source
This commit is contained in:
rmkaplan
2021-10-01 23:13:12 -07:00
parent 09fec6ac56 84bf09394e
commit cbfdfd6dab
37 changed files with 11661 additions and 1443 deletions
Download Patch File Download Diff File Expand all files Collapse all files

12
library/SYSEDIT
View File

@@ -1,9 +1,9 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "30-Aug-2021 16:04:42" {DSK}<home>larry>medley>library>SYSEDIT.;3 1146 (FILECREATED "28-Sep-2021 10:16:44" {DSK}<home>larry>medley>library>SYSEDIT.;3 1307
changes to%: (VARS SYSEDITCOMS) changes to%: (VARS SYSEDITCOMS)
previous date%: " 6-Aug-2021 07:35:16" {DSK}<home>larry>medley>library>SYSEDIT.;1) previous date%: "24-Sep-2021 20:52:26" {DSK}<home>larry>medley>library>SYSEDIT.;2)
(* ; " (* ; "
@@ -19,7 +19,9 @@ Copyright (c) 1984, 1987, 1990, 2021 by Venue & Xerox Corporation.
(GLOBALVARFLG T) (GLOBALVARFLG T)
(CLISPIFTRANFLG T) (CLISPIFTRANFLG T)
(CROSSCOMPILING 'ASK) (CROSSCOMPILING 'ASK)
(DFNFLG 'PROP)) (DFNFLG 'PROP)
(*REPLACE-OLD-EDIT-DATES* NIL)
(COPYRIGHTFLG 'PRESERVE))
(P (RESETVARS ((CROSSCOMPILING T)) (P (RESETVARS ((CROSSCOMPILING T))
(LOAD? 'EXPORTS.ALL]) (LOAD? 'EXPORTS.ALL])
@@ -37,6 +39,10 @@ Copyright (c) 1984, 1987, 1990, 2021 by Venue & Xerox Corporation.
(RPAQQ DFNFLG PROP) (RPAQQ DFNFLG PROP)
(RPAQQ *REPLACE-OLD-EDIT-DATES* NIL)
(RPAQQ COPYRIGHTFLG PRESERVE)
(RESETVARS ((CROSSCOMPILING T)) (RESETVARS ((CROSSCOMPILING T))
(LOAD? 'EXPORTS.ALL)) (LOAD? 'EXPORTS.ALL))
(PUTPROPS SYSEDIT COPYRIGHT ("Venue & Xerox Corporation" 1984 1987 1990 2021)) (PUTPROPS SYSEDIT COPYRIGHT ("Venue & Xerox Corporation" 1984 1987 1990 2021))

58
library/TEDIT
View File

@@ -1,10 +1,12 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "19-Sep-2021 17:08:56" {DSK}<Users>kaplan>Local>medley3.5>git-medley>library>TEDIT.;2 141945
changes to%: (VARS TEDITCOMS) (FILECREATED "29-Sep-2021 22:16:28" 
{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>TEDIT.;11 142247
previous date%: "19-Apr-2018 12:22:03" changes to%: (FNS TEDIT-SEE)
{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>TEDIT.;1)
previous date%: "19-Sep-2021 17:08:56"
{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>TEDIT.;5)
(* ; " (* ; "
@@ -328,12 +330,14 @@ Copyright (c) 1983-1993, 1995, 1999, 2018, 2021 by Venue & Xerox Corporation.
(RETURN PROC]) (RETURN PROC])
(TEDIT-SEE (TEDIT-SEE
[LAMBDA (FILE WINDOW) (* ; "Edited 19-Sep-2021 09:40 by rmk:") [LAMBDA (FILE WINDOW FORMAT) (* ; "Edited 29-Sep-2021 22:16 by rmk:")
(* ; "Edited 27-Feb-2021 20:07 by rmk:") (* ; "Edited 27-Feb-2021 20:07 by rmk:")
(* ; "Edited 1-Feb-88 19:00 by bvm:") (* ; "Edited 1-Feb-88 19:00 by bvm:")
(* ;; "See FILE in a scrollable READONLY TEDIT window. If FILE is a LISP source file, copy first to a temporary NODIRCORE image file that interpretes the fontchange characters rather than showing black boxes.") (* ;; "See FILE in a scrollable READONLY TEDIT window. If FILE is a LISP source file, copy first to a temporary NODIRCORE image file that interpretes the fontchange characters rather than showing black boxes.")
(* ;; "FORMAT for text files defaults to :UTF-8 if present, otherwise *DEFAULT-EXTERNALFORMAT*")
(CL:WITH-OPEN-FILE (STREAM FILE :DIRECTION :INPUT) (CL:WITH-OPEN-FILE (STREAM FILE :DIRECTION :INPUT)
(LET ((SEESTREAM STREAM) (LET ((SEESTREAM STREAM)
ENV TSTREAM) ENV TSTREAM)
@@ -346,18 +350,20 @@ Copyright (c) 1983-1993, 1995, 1999, 2018, 2021 by Venue & Xerox Corporation.
(* ;; "Lisp source file") (* ;; "Lisp source file")
(\EXTERNALFORMAT STREAM ENV) (SETFILEINFO STREAM 'FORMAT ENV)
(SETQ SEESTREAM (OPENTEXTSTREAM)) (SETQ SEESTREAM (OPENTEXTSTREAM))
(COPY.TEXT.TO.IMAGE STREAM SEESTREAM) (COPY.TEXT.TO.IMAGE STREAM SEESTREAM)
ELSE ELSE
(* ;; "Not a Lisp source file and not a Tedit file. If it is not random access, we copy it so we can scroll around.") (* ;; "Not a Lisp source file and not a Tedit file. If it is not random access, we copy it so we can scroll around.")
(* ;; "Maybe there is a conventional way of finding out the external format of a plain-text stream (an EMACS header?), here we nudge towards :UTF-8 (if it exists).")
(SETFILEINFO STREAM 'FORMAT (OR FORMAT (FIND-FORMAT :UTF-8)
*DEFAULT-EXTERNALFORMAT*))
(CL:UNLESS (RANDACCESSP STREAM) (CL:UNLESS (RANDACCESSP STREAM)
[SETQ SEESTREAM (OPENSTREAM '{NODIRCORE} 'BOTH 'NEW (SETQ SEESTREAM (OPENSTREAM '{NODIRCORE} 'BOTH 'NEW))
`([TYPE ,(GETFILEINFO STREAM 'TYPE] (COPYCHARS STREAM SEESTREAM)))
(FORMAT ,(\EXTERNALFORMAT STREAM]
(COPYBYTES STREAM SEESTREAM)))
[SETQ TSTREAM (TEXTSTREAM (TEDIT SEESTREAM WINDOW NIL '(READONLY T] [SETQ TSTREAM (TEXTSTREAM (TEDIT SEESTREAM WINDOW NIL '(READONLY T]
(WINDOWPROP (WFROMDS TSTREAM) (WINDOWPROP (WFROMDS TSTREAM)
'TITLE 'TITLE
@@ -2229,7 +2235,7 @@ Copyright (c) 1983-1993, 1995, 1999, 2018, 2021 by Venue & Xerox Corporation.
(* ; "TEDIT Support information") (* ; "TEDIT Support information")
(RPAQQ TEDITSYSTEMDATE "19-Sep-2021 17:08:56") (RPAQQ TEDITSYSTEMDATE "29-Sep-2021 22:16:28")
(RPAQ TEDITSUPPORT "TEditSupport.PA") (RPAQ TEDITSUPPORT "TEditSupport.PA")
(DEFINEQ (DEFINEQ
@@ -2255,19 +2261,19 @@ Copyright (c) 1983-1993, 1995, 1999, 2018, 2021 by Venue & Xerox Corporation.
(PUTPROPS TEDIT COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1989 1990 1991 (PUTPROPS TEDIT COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1989 1990 1991
1992 1993 1995 1999 2018 2021)) 1992 1993 1995 1999 2018 2021))
(DECLARE%: DONTCOPY (DECLARE%: DONTCOPY
(FILEMAP (NIL (4327 117111 (\TEDIT2 4337 . 7088) (COERCETEXTOBJ 7090 . 15866) (TEDIT 15868 . 20837) ( (FILEMAP (NIL (4329 117413 (\TEDIT2 4339 . 7090) (COERCETEXTOBJ 7092 . 15868) (TEDIT 15870 . 20839) (
TEDIT-SEE 20839 . 22787) (TEDIT.CHARWIDTH 22789 . 24813) (TEDIT.COPY 24815 . 33251) (TEDIT.DELETE TEDIT-SEE 20841 . 23089) (TEDIT.CHARWIDTH 23091 . 25115) (TEDIT.COPY 25117 . 33553) (TEDIT.DELETE
33253 . 33943) (TEDIT.DO.BLUEPENDINGDELETE 33945 . 37012) (TEDIT.INSERT 37014 . 42544) (TEDIT.KILL 33555 . 34245) (TEDIT.DO.BLUEPENDINGDELETE 34247 . 37314) (TEDIT.INSERT 37316 . 42846) (TEDIT.KILL
42546 . 44103) (TEDIT.MAPLINES 44105 . 45504) (TEDIT.MAPPIECES 45506 . 46462) (TEDIT.MOVE 46464 . 42848 . 44405) (TEDIT.MAPLINES 44407 . 45806) (TEDIT.MAPPIECES 45808 . 46764) (TEDIT.MOVE 46766 .
56248) (TEDIT.QUIT 56250 . 58250) (TEDIT.STRINGWIDTH 58252 . 58923) (TEDIT.\INSERT 58925 . 60950) ( 56550) (TEDIT.QUIT 56552 . 58552) (TEDIT.STRINGWIDTH 58554 . 59225) (TEDIT.\INSERT 59227 . 61252) (
TEXTOBJ 60952 . 62077) (TEXTSTREAM 62079 . 63694) (\TEDIT.INCLUDE 63696 . 67596) (\TEDIT.INSERT.PIECES TEXTOBJ 61254 . 62379) (TEXTSTREAM 62381 . 63996) (\TEDIT.INCLUDE 63998 . 67898) (\TEDIT.INSERT.PIECES
67598 . 77513) (\TEDIT.MOVE.PIECEMAPFN 77515 . 79594) (\TEDIT.OBJECT.SHOWSEL 79596 . 83225) ( 67900 . 77815) (\TEDIT.MOVE.PIECEMAPFN 77817 . 79896) (\TEDIT.OBJECT.SHOWSEL 79898 . 83527) (
\TEDIT.RESTARTFN 83227 . 85222) (\TEDIT.CHARDELETE 85224 . 89186) (\TEDIT.COPY.PIECEMAPFN 89188 . \TEDIT.RESTARTFN 83529 . 85524) (\TEDIT.CHARDELETE 85526 . 89488) (\TEDIT.COPY.PIECEMAPFN 89490 .
92413) (\TEDIT.DELETE 92415 . 99933) (\TEDIT.DIFFUSE.PARALOOKS 99935 . 102699) (\TEDIT.FOREIGN.COPY? 92715) (\TEDIT.DELETE 92717 . 100235) (\TEDIT.DIFFUSE.PARALOOKS 100237 . 103001) (\TEDIT.FOREIGN.COPY?
102701 . 106428) (\TEDIT.QUIT 106430 . 109576) (\TEDIT.WORDDELETE 109578 . 114411) (\TEDIT1 114413 . 103003 . 106730) (\TEDIT.QUIT 106732 . 109878) (\TEDIT.WORDDELETE 109880 . 114713) (\TEDIT1 114715 .
117109)) (117225 117341 (\CREATE.TEDIT.RESTART.MENU 117235 . 117339)) (117440 121129 (PLCHAIN 117450 117411)) (117527 117643 (\CREATE.TEDIT.RESTART.MENU 117537 . 117641)) (117742 121431 (PLCHAIN 117752
. 117724) (PRINTLINE 117726 . 120490) (SEEFILE 120492 . 121127)) (121170 140813 (TEDIT.INSERT.OBJECT . 118026) (PRINTLINE 118028 . 120792) (SEEFILE 120794 . 121429)) (121472 141115 (TEDIT.INSERT.OBJECT
121180 . 130257) (TEDIT.EDIT.OBJECT 130259 . 132515) (TEDIT.FIND.OBJECT 132517 . 133410) ( 121482 . 130559) (TEDIT.EDIT.OBJECT 130561 . 132817) (TEDIT.FIND.OBJECT 132819 . 133712) (
TEDIT.FIND.OBJECT.SUBTREE 133412 . 134218) (TEDIT.PUT.OBJECT 134220 . 135879) (TEDIT.GET.OBJECT 135881 TEDIT.FIND.OBJECT.SUBTREE 133714 . 134520) (TEDIT.PUT.OBJECT 134522 . 136181) (TEDIT.GET.OBJECT 136183
. 139080) (TEDIT.OBJECT.CHANGED 139082 . 140811)) (141091 141454 (MAKETEDITFORM 141101 . 141452))))) . 139382) (TEDIT.OBJECT.CHANGED 139384 . 141113)) (141393 141756 (MAKETEDITFORM 141403 . 141754)))))
STOP STOP

BIN
library/TEDIT.LCOM
View File

Binary file not shown.

421
library/TEDITSCREEN
View File

@@ -1,13 +1,12 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "21-Sep-2021 12:53:40" 
{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>TEDITSCREEN.;4 214736
changes to%: (MACROS MI-TEDIT.BLTCHAR) (FILECREATED "29-Sep-2021 22:03:57" 
(VARS TEDITSCREENCOMS) {DSK}<Users>kaplan>Local>medley3.5>git-medley>library>TEDITSCREEN.;8 214517
(FNS \MAIKO.DISPLAYLINE \DISPLAYLINE)
previous date%: "30-Apr-2021 14:42:15" changes to%: (FNS \DISPLAYLINE)
{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>TEDITSCREEN.;1)
previous date%: "21-Sep-2021 12:53:40"
{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>TEDITSCREEN.;7)
(* ; " (* ; "
@@ -1094,247 +1093,245 @@ Copyright (c) 1983-1994, 2021 by Venue & Xerox Corporation.
(DEFINEQ (DEFINEQ
(\DISPLAYLINE (\DISPLAYLINE
[LAMBDA (TEXTOBJ LINE WINDOW) (* ; "Edited 21-Sep-2021 12:47 by rmk:") [LAMBDA (TEXTOBJ LINE WINDOW) (* ; "Edited 28-Sep-2021 15:00 by rmk:")
(* ;; "Display the line of text LINE in the edit window where it belongs.") (* ;; "Display the line of text LINE in the edit window where it belongs.")
(PROG ((CH 0) (* ;; "Validate the incoming arguments so ffetch can be used consistently for all their field extractions.")
(CHLIST (fetch (THISLINE CHARS) of (fetch (TEXTOBJ THISLINE) of TEXTOBJ)))
(WLIST (fetch (THISLINE WIDTHS) of (fetch (TEXTOBJ THISLINE) of TEXTOBJ))) (\DTEST TEXTOBJ 'TEXTOBJ)
(LOOKS (fetch (THISLINE LOOKS) of (fetch (TEXTOBJ THISLINE) of TEXTOBJ))) (\DTEST LINE 'LINEDESCRIPTOR)
(WINDOWDS (WINDOWPROP (OR WINDOW (CAR (fetch (TEXTOBJ \WINDOW) of TEXTOBJ))) (LET ((LOOKS (ffetch (THISLINE LOOKS) of (ffetch (TEXTOBJ THISLINE) of TEXTOBJ)))
'DSP)) (WINDOWDS (WINDOWPROP (OR WINDOW (CAR (ffetch (TEXTOBJ \WINDOW) of TEXTOBJ)))
(TEXTLEN (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ)) 'DSP))
(THISLINE (fetch (TEXTOBJ THISLINE) of TEXTOBJ)) (THISLINE (\DTEST (ffetch (TEXTOBJ THISLINE) of TEXTOBJ)
(TERMSA (fetch (TEXTOBJ TXTTERMSA) of TEXTOBJ)) 'THISLINE))
(STREAM (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ)) (OLDCACHE (fetch (LINECACHE LCBITMAP) of (ffetch (TEXTOBJ DISPLAYCACHE)
(OLDCACHE (fetch LCBITMAP of (fetch (TEXTOBJ DISPLAYCACHE) of TEXTOBJ))) of TEXTOBJ)))
(DS (fetch (TEXTOBJ DISPLAYCACHEDS) of TEXTOBJ)) (DS (ffetch (TEXTOBJ DISPLAYCACHEDS) of TEXTOBJ))
(HCPYDS (fetch (TEXTOBJ DISPLAYHCPYDS) of TEXTOBJ)) (HCPYDS (ffetch (TEXTOBJ DISPLAYHCPYDS) of TEXTOBJ))
(HARDCOPYMODE (fetch (FMTSPEC FMTHARDCOPY) of (fetch (LINEDESCRIPTOR LFMTSPEC) (HARDCOPYMODE (fetch (FMTSPEC FMTHARDCOPY) of (ffetch (LINEDESCRIPTOR LFMTSPEC)
of LINE))) of LINE)))
LOOKSTARTX CACHE \PCHARSLEFT \PSTRING \PFILE FONT OFONT OLOOKS XOFFSET CLIPLEFT CLIPRIGHT CACHE OFONT OLOOKS XOFFSET CLIPLEFT CLIPRIGHT DISPLAYDATA DDPILOTBBT DDWIDTHCACHE
DISPLAYDATA DDPILOTBBT DDWIDTHCACHE DDOFFSETCACHE CURY LHEIGHT SCALE) DDOFFSETCACHE CURY LHEIGHT SCALE)
[SETQ LHEIGHT (COND [SETQ LHEIGHT (COND
((fetch (LINEDESCRIPTOR PREVLINE) of LINE) ((ffetch (LINEDESCRIPTOR PREVLINE) of LINE)
(* ; (* ;
 "So if theres a base-to-base measure, we clear everything right.")  "So if theres a base-to-base measure, we clear everything right.")
(IMAX (IDIFFERENCE (fetch (LINEDESCRIPTOR YBOT) (IMAX (IDIFFERENCE (ffetch (LINEDESCRIPTOR YBOT)
of (fetch (LINEDESCRIPTOR PREVLINE) of (ffetch (LINEDESCRIPTOR PREVLINE)
of LINE)) of LINE))
(fetch (LINEDESCRIPTOR YBOT) of LINE)) (ffetch (LINEDESCRIPTOR YBOT) of LINE))
(fetch (LINEDESCRIPTOR LHEIGHT) of LINE))) (ffetch (LINEDESCRIPTOR LHEIGHT) of LINE)))
(T (fetch (LINEDESCRIPTOR LHEIGHT) of LINE] (T (ffetch (LINEDESCRIPTOR LHEIGHT) of LINE]
(COND (SETQ SCALE (COND
(HARDCOPYMODE (* ; (HARDCOPYMODE (* ;
 "This is a hardcopy-mode line. Scale things.")  "This is a hardcopy-mode line. Scale things.")
(* ; "(SETQ DS HCPYDS)") (DSPSCALE NIL HCPYDS))
(SETQ SCALE (DSPSCALE NIL HCPYDS))) (T 1)))
(T (SETQ SCALE 1))) (SETQ CACHE (\TEDIT.LINECACHE (ffetch (TEXTOBJ DISPLAYCACHE) of TEXTOBJ)
(SETQ CACHE (\TEDIT.LINECACHE (fetch (TEXTOBJ DISPLAYCACHE) of TEXTOBJ) (COND
(COND (HARDCOPYMODE (FIXR (FQUOTIENT (ffetch (LINEDESCRIPTOR RIGHTMARGIN
(HARDCOPYMODE (FIXR (FQUOTIENT (fetch (LINEDESCRIPTOR RIGHTMARGIN
) of LINE) ) of LINE)
SCALE))) SCALE)))
(T (fetch (LINEDESCRIPTOR RIGHTMARGIN) of LINE))) (T (ffetch (LINEDESCRIPTOR RIGHTMARGIN) of LINE)))
LHEIGHT)) LHEIGHT))
(COND (COND
((NEQ CACHE OLDCACHE) (* ; ((NEQ CACHE OLDCACHE) (* ;
 "We changed the bitmaps because this line was bigger--update the displaystream, too")  "We changed the bitmaps because this line was bigger--update the displaystream, too")
(DSPDESTINATION CACHE DS) (DSPDESTINATION CACHE DS)
(DSPCLIPPINGREGION (create REGION (DSPCLIPPINGREGION (create REGION
LEFT _ 0 LEFT _ 0
BOTTOM _ 0 BOTTOM _ 0
WIDTH _ (fetch BITMAPWIDTH of CACHE) WIDTH _ (fetch BITMAPWIDTH of CACHE)
HEIGHT _ (fetch BITMAPHEIGHT of CACHE)) HEIGHT _ (fetch BITMAPHEIGHT of CACHE))
DS))) DS)))
(BITBLT NIL 0 0 CACHE 0 0 NIL NIL 'TEXTURE 'REPLACE WHITESHADE) (BITBLT NIL 0 0 CACHE 0 0 NIL NIL 'TEXTURE 'REPLACE WHITESHADE)
(* ; "Clear the line cache") (* ; "Clear the line cache")
(COND [COND
(HARDCOPYMODE (* ; ((AND (NOT (ZEROP (fetch (LINEDESCRIPTOR CHAR1) of LINE)))
 "This is a hardcopy-mode line. Scale things.") (ILEQ (ffetch (LINEDESCRIPTOR CHAR1) of LINE)
(* ; "(SETQ DS HCPYDS)") (ffetch (TEXTOBJ TEXTLEN) of TEXTOBJ))
(SETQ SCALE (DSPSCALE NIL HCPYDS))) (IGEQ (ffetch (LINEDESCRIPTOR YBOT) of LINE)
(T (SETQ SCALE 1))) (ffetch (TEXTOBJ WBOTTOM) of TEXTOBJ)))
[COND
((AND (NOT (ZEROP (fetch (LINEDESCRIPTOR CHAR1) of LINE)))
(ILEQ (fetch (LINEDESCRIPTOR CHAR1) of LINE)
TEXTLEN)
(IGEQ (fetch (LINEDESCRIPTOR YBOT) of LINE)
(fetch (TEXTOBJ WBOTTOM) of TEXTOBJ)))
(* ;; "Only display the line of it contains text (CHAR1 > 0), appears before the end of the test, and is on-screen.") (* ;; "Only display the line of it contains text (CHAR1 > 0), appears before the end of the test, and is on-screen.")
(COND (COND
((NEQ (fetch (THISLINE DESC) of THISLINE) ((NEQ (fetch (THISLINE DESC) of THISLINE)
LINE) (* ; LINE) (* ;
 "No image cache -- re-format and display")  "No image cache -- re-format and display")
(\FORMATLINE TEXTOBJ NIL (fetch (LINEDESCRIPTOR CHAR1) of LINE) (\FORMATLINE TEXTOBJ NIL (ffetch (LINEDESCRIPTOR CHAR1) of LINE)
LINE))) LINE)))
(MOVETO (fetch (LINEDESCRIPTOR LEFTMARGIN) of LINE) (MOVETO (ffetch (LINEDESCRIPTOR LEFTMARGIN) of LINE)
(fetch (LINEDESCRIPTOR DESCENT) of LINE) (ffetch (LINEDESCRIPTOR DESCENT) of LINE)
DS) DS)
(SETQ DISPLAYDATA (fetch (STREAM IMAGEDATA) of DS)) (SETQ DISPLAYDATA (fetch (STREAM IMAGEDATA) of DS))
(SETQ DDPILOTBBT (ffetch DDPILOTBBT of DISPLAYDATA)) (SETQ DDPILOTBBT (ffetch DDPILOTBBT of DISPLAYDATA))
(SETQ XOFFSET (fetch DDXOFFSET of DISPLAYDATA)) (SETQ XOFFSET (fetch DDXOFFSET of DISPLAYDATA))
(* ;; "The X position of the left edge of the window, since \TEDIT.BLTCHAR works on the screen bitmap itself.") (* ;; "The X position of the left edge of the window, since \TEDIT.BLTCHAR works on the screen bitmap itself.")
(SETQ CLIPLEFT (fetch DDClippingLeft of DISPLAYDATA)) (SETQ CLIPLEFT (fetch DDClippingLeft of DISPLAYDATA))
(* ; (* ;
 "The left and right edges of the clipping region for the text display window.")  "The left and right edges of the clipping region for the text display window.")
(SETQ CLIPRIGHT (fetch DDClippingRight of DISPLAYDATA)) (SETQ CLIPRIGHT (fetch DDClippingRight of DISPLAYDATA))
(SETQ OFONT (DSPFONT (fetch CLFONT of (SETQ OLOOKS (\EDITELT LOOKS 0))) (SETQ OFONT (DSPFONT (fetch CLFONT of (SETQ OLOOKS (\EDITELT LOOKS 0)))
DS)) (* ; "The starting font") DS)) (* ; "The starting font")
(SETQ DDWIDTHCACHE (ffetch DDWIDTHSCACHE of DISPLAYDATA)) (SETQ DDWIDTHCACHE (ffetch DDWIDTHSCACHE of DISPLAYDATA))
(* ; (* ;
 "Cache the character-image widths")  "Cache the character-image widths")
(SETQ DDOFFSETCACHE (ffetch DDOFFSETSCACHE of DISPLAYDATA)) (SETQ DDOFFSETCACHE (ffetch DDOFFSETSCACHE of DISPLAYDATA))
(* ; (* ;
 "And the offset-into-strike-bitmap array")  "And the offset-into-strike-bitmap array")
(SETQ LOOKSTARTX (fetch (LINEDESCRIPTOR LEFTMARGIN) of LINE))
(* ; (* ;
 "Starting X position for the current-looks text.")  "LOOKSTARTX: Starting X position for the current-looks text.")
(AND (fetch CLOFFSET of OLOOKS) (AND (fetch CLOFFSET of OLOOKS)
(RELMOVETO 0 (FIXR (FTIMES SCALE (fetch CLOFFSET of OLOOKS))) (RELMOVETO 0 (FIXR (FTIMES SCALE (fetch CLOFFSET of OLOOKS)))
DS)) (* ; DS)) (* ;
 "Any sub- or superscripting at start of line")  "Any sub- or superscripting at start of line")
(bind (LOOKNO _ 1) (bind (LOOKNO _ 1)
DX DX CH (CHLIST _ (fetch (THISLINE CHARS) of (ffetch (TEXTOBJ THISLINE)
(TX _ (IPLUS XOFFSET (fetch (LINEDESCRIPTOR LEFTMARGIN) of LINE))) of TEXTOBJ)))
for I from 0 to (fetch (THISLINE LEN) of THISLINE) (WLIST _ (fetch (THISLINE WIDTHS) of (ffetch (TEXTOBJ THISLINE)
do of TEXTOBJ)))
(TX _ (IPLUS XOFFSET (ffetch (LINEDESCRIPTOR LEFTMARGIN) of LINE)))
(TERMSA _ (ffetch (TEXTOBJ TXTTERMSA) of TEXTOBJ))
(LOOKSTARTX _ (ffetch (LINEDESCRIPTOR LEFTMARGIN) of LINE)) for
I
from 0 to (ffetch (THISLINE LEN) of THISLINE)
do
(* ;; "Display the line character by character") (* ;; "Display the line character by character")
(SETQ CH (\EDITELT CHLIST I)) (* ; (SETQ CH (\EDITELT CHLIST I)) (* ;
 "Grab the character (or IMAGEOBJ) to display")  "Grab the character (or IMAGEOBJ) to display")
(SETQ DX (\EDITELT WLIST I)) (* ; "And its width") (SETQ DX (\EDITELT WLIST I)) (* ; "And its width")
[SELECTC CH [SELECTC CH
(LMInvisibleRun (* ; (LMInvisibleRun (* ;
 "An INVISIBLE run -- skip it, and skip over the char count")  "An INVISIBLE run -- skip it, and skip over the char count")
(add LOOKNO 1)) (add LOOKNO 1))
(LMLooksChange (* ; "A LOOKS change") (LMLooksChange (* ; "A LOOKS change")
(replace DDXPOSITION of DISPLAYDATA (replace DDXPOSITION of DISPLAYDATA
with (IDIFFERENCE TX XOFFSET)) with (IDIFFERENCE TX XOFFSET))
(* ; (* ;
 "Make the displaystream reflect our current X position")  "Make the displaystream reflect our current X position")
(TEDIT.MODIFYLOOKS LINE LOOKSTARTX DS OLOOKS (TEDIT.MODIFYLOOKS LINE LOOKSTARTX DS OLOOKS
(fetch (LINEDESCRIPTOR DESCENT) of LINE)) (ffetch (LINEDESCRIPTOR DESCENT) of LINE))
(* ; (* ;
 "Make any necessary changes to the preceding characters (underline, strike-out &c)")  "Make any necessary changes to the preceding characters (underline, strike-out &c)")
(DSPFONT (fetch CLFONT of (SETQ OLOOKS (DSPFONT (fetch CLFONT of (SETQ OLOOKS
(\EDITELT LOOKS LOOKNO)) (\EDITELT LOOKS LOOKNO)))
) DS) (* ; "Set the new font")
DS) (* ; "Set the new font") (add LOOKNO 1) (* ; "Grab the next set of char looks")
(add LOOKNO 1) (* ; "Grab the next set of char looks") (AND (fetch CLOFFSET of OLOOKS)
(AND (fetch CLOFFSET of OLOOKS) (RELMOVETO 0 (fetch CLOFFSET of OLOOKS)
(RELMOVETO 0 (fetch CLOFFSET of OLOOKS) DS)) (* ; "Account for super/subscripting")
DS)) (* ; "Account for super/subscripting") (SETQ LOOKSTARTX (IDIFFERENCE TX XOFFSET))
(SETQ LOOKSTARTX (IDIFFERENCE TX XOFFSET))
(* ; (* ;
 "Remember the starting Xpos for possible later underlining &c")  "Remember the starting Xpos for possible later underlining &c")
) )
((CHARCODE (TAB %#^I)) (* ; ((CHARCODE (TAB %#^I)) (* ;
 "TAB: use the width from the cache to decide the right formatting.")  "TAB: use the width from the cache to decide the right formatting.")
[COND [COND
((OR (IEQP CH (CHARCODE %#^I)) ((OR (IEQP CH (CHARCODE %#^I))
(fetch CLLEADER of OLOOKS) (fetch CLLEADER of OLOOKS)
(EQ (fetch CLUSERINFO of OLOOKS) (EQ (fetch CLUSERINFO of OLOOKS)
'DOTTEDLEADER)) 'DOTTEDLEADER))
(LET* [[LEADERFONT (COND (LET* [[LEADERFONT (COND
(HARDCOPYMODE (FONTCOPY (fetch CLFONT (HARDCOPYMODE (FONTCOPY (fetch CLFONT
of OLOOKS) of OLOOKS)
'DEVICE HCPYDS)) 'DEVICE HCPYDS))
(T (fetch CLFONT of OLOOKS] (T (fetch CLFONT of OLOOKS]
(DOTWIDTH (CHARWIDTH (CHARCODE %.) (DOTWIDTH (CHARWIDTH (CHARCODE %.)
LEADERFONT)) LEADERFONT))
(TTX (IPLUS TX DOTWIDTH (IDIFFERENCE DOTWIDTH (TTX (IPLUS TX DOTWIDTH (IDIFFERENCE DOTWIDTH
(IREMAINDER TX DOTWIDTH] (IREMAINDER TX DOTWIDTH]
(while (ILEQ TTX (IPLUS TX DX)) (while (ILEQ TTX (IPLUS TX DX))
do (COND do (COND
(HARDCOPYMODE (HARDCOPYMODE (MI-TEDIT.BLTCHAR
(MI-TEDIT.BLTCHAR (CHARCODE %.) (CHARCODE %.)
DS DS
(FIXR (FQUOTIENT (IDIFFERENCE TTX (FIXR (FQUOTIENT (IDIFFERENCE
DOTWIDTH) TTX DOTWIDTH)
SCALE)) SCALE))
DISPLAYDATA DDPILOTBBT CLIPRIGHT)) DISPLAYDATA DDPILOTBBT CLIPRIGHT
((OR TERMSA HARDCOPYMODE) ))
((OR TERMSA HARDCOPYMODE)
(* ; (* ;
 "Using special instrns from TERMSA")  "Using special instrns from TERMSA")
(\DSPPRINTCHAR DS (CHARCODE %.))) (\DSPPRINTCHAR DS (CHARCODE %.)))
(T (* ; "Native charcodes") (T (* ; "Native charcodes")
(MI-TEDIT.BLTCHAR (CHARCODE %.) (MI-TEDIT.BLTCHAR (CHARCODE %.)
DS DS
(IDIFFERENCE TTX DOTWIDTH) (IDIFFERENCE TTX DOTWIDTH)
DISPLAYDATA DDPILOTBBT CLIPRIGHT))) DISPLAYDATA DDPILOTBBT CLIPRIGHT)))
(add TTX DOTWIDTH]) (add TTX DOTWIDTH])
((CHARCODE (EOL LF CR)) (* ; "It's a CR") ((CHARCODE (EOL LF CR)) (* ; "It's a CR")
NIL) NIL)
(NIL (* ; "NIL signifies a character we've suppressed as part of line formatting (e.g., a discretionary hyphen we didn't use to break the line). Show it as a thin black line.") (NIL (* ; "NIL signifies a character we've suppressed as part of line formatting (e.g., a discretionary hyphen we didn't use to break the line). Show it as a thin black line.")
(BLTSHADE BLACKSHADE DS TX 0 1 100 'PAINT)) (BLTSHADE BLACKSHADE DS TX 0 1 100 'PAINT))
(COND (COND
[(SMALLP CH) (* ; [(SMALLP CH) (* ;
 "Normal character -- just display it.")  "Normal character -- just display it.")
(COND (COND
(HARDCOPYMODE (MI-TEDIT.BLTCHAR CH DS (FIXR (FQUOTIENT TX SCALE)) (HARDCOPYMODE (MI-TEDIT.BLTCHAR CH DS (FIXR (FQUOTIENT TX SCALE))
DISPLAYDATA DDPILOTBBT CLIPRIGHT)) DISPLAYDATA DDPILOTBBT CLIPRIGHT))
((OR TERMSA HARDCOPYMODE) (* ; ((OR TERMSA HARDCOPYMODE) (* ;
 "Using special instrns from TERMSA")  "Using special instrns from TERMSA")
(\DSPPRINTCHAR DS CH)) (\DSPPRINTCHAR DS CH))
(T (* ; "Native charcodes") (T (* ; "Native charcodes")
(MI-TEDIT.BLTCHAR CH DS TX DISPLAYDATA DDPILOTBBT CLIPRIGHT] (MI-TEDIT.BLTCHAR CH DS TX DISPLAYDATA DDPILOTBBT CLIPRIGHT]
(T (* ; "CH is an object.") (T (* ; "CH is an object.")
(MOVETO (IDIFFERENCE (FIXR (FQUOTIENT TX SCALE)) (MOVETO (IDIFFERENCE (FIXR (FQUOTIENT TX SCALE))
XOFFSET) XOFFSET)
(SETQ CURY (DSPYPOSITION NIL DS)) (SETQ CURY (DSPYPOSITION NIL DS))
DS) (* ; DS) (* ;
 "Go to the base line, left edge of the image region.")  "Go to the base line, left edge of the image region.")
(APPLY* (IMAGEOBJPROP CH 'DISPLAYFN) (APPLY* (IMAGEOBJPROP CH 'DISPLAYFN)
CH DS 'DISPLAY (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ CH DS 'DISPLAY (ffetch (TEXTOBJ STREAMHINT) of TEXTOBJ
)) ))
(* ; (* ;
 "Tell him to display himself here.")  "Tell him to display himself here.")
(DSPFONT (fetch CLFONT of OLOOKS) (DSPFONT (fetch CLFONT of OLOOKS)
DS) DS)
(MOVETO (IDIFFERENCE (FIXR (FQUOTIENT TX SCALE)) (MOVETO (IDIFFERENCE (FIXR (FQUOTIENT TX SCALE))
XOFFSET) XOFFSET)
CURY DS) (* ; CURY DS) (* ;
 "Move to after the object's image")  "Move to after the object's image")
] ]
(add TX DX) (* ; "Update our X position") (add TX DX) (* ; "Update our X position")
finally (replace DDXPOSITION of DISPLAYDATA finally (replace DDXPOSITION of DISPLAYDATA
with (IDIFFERENCE (FIXR (FQUOTIENT TX SCALE)) with (IDIFFERENCE (FIXR (FQUOTIENT TX SCALE))
XOFFSET)) (* ; XOFFSET)) (* ;
 "Make any necessary looks mods to the last run of characters")  "Make any necessary looks mods to the last run of characters")
(TEDIT.MODIFYLOOKS LINE LOOKSTARTX DS OLOOKS (fetch (LINEDESCRIPTOR (TEDIT.MODIFYLOOKS LINE LOOKSTARTX DS OLOOKS (ffetch (LINEDESCRIPTOR
DESCENT) DESCENT)
of LINE] of LINE]
(BITBLT CACHE 0 0 WINDOWDS 0 (fetch (LINEDESCRIPTOR YBOT) of LINE) (BITBLT CACHE 0 0 WINDOWDS 0 (ffetch (LINEDESCRIPTOR YBOT) of LINE)
(fetch (TEXTOBJ WRIGHT) of TEXTOBJ) (ffetch (TEXTOBJ WRIGHT) of TEXTOBJ)
LHEIGHT LHEIGHT
'INPUT 'INPUT
'REPLACE) (* ; 'REPLACE) (* ;
 "Paint the cached image on the screen (this lessens flicker during update)")  "Paint the cached image on the screen (this lessens flicker during update)")
(COND (COND
((fetch (FMTSPEC FMTREVISED) of (fetch (LINEDESCRIPTOR LFMTSPEC) ((fetch (FMTSPEC FMTREVISED) of (ffetch (LINEDESCRIPTOR LFMTSPEC)
of LINE)) of LINE))
(* ; (* ;
 "This paragraph has been revised, so mark it.")  "This paragraph has been revised, so mark it.")
(\TEDIT.MARK.REVISION TEXTOBJ (fetch (LINEDESCRIPTOR LFMTSPEC) of LINE) (\TEDIT.MARK.REVISION TEXTOBJ (ffetch (LINEDESCRIPTOR LFMTSPEC) of LINE)
WINDOWDS LINE))) WINDOWDS LINE)))
(SELECTQ (fetch (LINEDESCRIPTOR LMARK) of LINE) (SELECTQ (ffetch (LINEDESCRIPTOR LMARK) of LINE)
(GREY (* ; (GREY (* ;
 "This line has some property that isn't visible to the user. Tell him to be careful")  "This line has some property that isn't visible to the user. Tell him to be careful")
(BITBLT NIL 0 0 WINDOWDS 0 (fetch (LINEDESCRIPTOR YBASE) of LINE) (BITBLT NIL 0 0 WINDOWDS 0 (ffetch (LINEDESCRIPTOR YBASE) of LINE)
6 6 'TEXTURE 'PAINT 42405)) 6 6 'TEXTURE 'PAINT 42405))
(SOLID (* ; (SOLID (* ;
 "This line has some property that isn't visible to the user. Tell him to be careful")  "This line has some property that isn't visible to the user. Tell him to be careful")
(BITBLT NIL 0 0 WINDOWDS 0 (fetch (LINEDESCRIPTOR YBASE) of LINE) (BITBLT NIL 0 0 WINDOWDS 0 (ffetch (LINEDESCRIPTOR YBASE) of LINE)
6 6 'TEXTURE 'PAINT BLACKSHADE)) 6 6 'TEXTURE 'PAINT BLACKSHADE))
(BITBLT NIL 0 0 WINDOWDS 0 (fetch (LINEDESCRIPTOR YBASE) of LINE) (BITBLT NIL 0 0 WINDOWDS 0 (ffetch (LINEDESCRIPTOR YBASE) of LINE)
6 6 'TEXTURE 'REPLACE WHITESHADE]) 6 6 'TEXTURE 'REPLACE WHITESHADE])
(\TEDIT.LINECACHE (\TEDIT.LINECACHE
(LAMBDA (CACHE WIDTH HEIGHT) (* jds "21-Apr-84 00:52") (LAMBDA (CACHE WIDTH HEIGHT) (* jds "21-Apr-84 00:52")
@@ -2991,16 +2988,16 @@ Copyright (c) 1983-1994, 2021 by Venue & Xerox Corporation.
(PUTPROPS TEDITSCREEN COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1989 1990 (PUTPROPS TEDITSCREEN COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1989 1990
1991 1992 1993 1994 2021)) 1991 1992 1993 1994 2021))
(DECLARE%: DONTCOPY (DECLARE%: DONTCOPY
(FILEMAP (NIL (2874 76866 (\FORMATLINE 2884 . 56612) (\TEDIT.NSCHAR.RUN 56614 . 63431) ( (FILEMAP (NIL (2767 76759 (\FORMATLINE 2777 . 56505) (\TEDIT.NSCHAR.RUN 56507 . 63324) (
\TEDIT.PURGE.SPACES 63433 . 63891) (\DOFORMATTING 63893 . 76864)) (76867 98847 (\DISPLAYLINE 76877 . \TEDIT.PURGE.SPACES 63326 . 63784) (\DOFORMATTING 63786 . 76757)) (76760 98628 (\DISPLAYLINE 76770 .
94847) (\TEDIT.LINECACHE 94849 . 95600) (\TEDIT.CREATE.LINECACHE 95602 . 96346) (\TEDIT.BLTCHAR 96348 94628) (\TEDIT.LINECACHE 94630 . 95381) (\TEDIT.CREATE.LINECACHE 95383 . 96127) (\TEDIT.BLTCHAR 96129
. 98845)) (99561 214016 (TEDIT.CR.UPDATESCREEN 99571 . 100822) (TEDIT.DELETELINE 100824 . 101858) ( . 98626)) (99342 213797 (TEDIT.CR.UPDATESCREEN 99352 . 100603) (TEDIT.DELETELINE 100605 . 101639) (
TEDIT.INSERT.DISPLAYTEXT 101860 . 117099) (TEDIT.INSERT.UPDATESCREEN 117101 . 123853) ( TEDIT.INSERT.DISPLAYTEXT 101641 . 116880) (TEDIT.INSERT.UPDATESCREEN 116882 . 123634) (
TEDIT.UPDATE.SCREEN 123855 . 125073) (\BACKFORMAT 125075 . 129386) (\FILLWINDOW 129388 . 144492) ( TEDIT.UPDATE.SCREEN 123636 . 124854) (\BACKFORMAT 124856 . 129167) (\FILLWINDOW 129169 . 144273) (
\FIXDLINES 144494 . 151731) (\FIXILINES 151733 . 159708) (\SHOWTEXT 159710 . 162966) ( \FIXDLINES 144275 . 151512) (\FIXILINES 151514 . 159489) (\SHOWTEXT 159491 . 162747) (
\TEDIT.ADJUST.LINES 162968 . 170435) (\TEDIT.CLEAR.SCREEN.BELOW.LINE 170437 . 171167) ( \TEDIT.ADJUST.LINES 162749 . 170216) (\TEDIT.CLEAR.SCREEN.BELOW.LINE 170218 . 170948) (
\TEDIT.CLOSEUPLINES 171169 . 179685) (\TEDIT.COPY.LINEDESCRIPTOR 179687 . 185253) ( \TEDIT.CLOSEUPLINES 170950 . 179466) (\TEDIT.COPY.LINEDESCRIPTOR 179468 . 185034) (
\TEDIT.FIXCHANGEDLINE 185255 . 196434) (\TEDIT.FIXCHANGEDPART 196436 . 208863) (\TEDIT.INSERTLINE \TEDIT.FIXCHANGEDLINE 185036 . 196215) (\TEDIT.FIXCHANGEDPART 196217 . 208644) (\TEDIT.INSERTLINE
208865 . 209685) (\TEDIT.LINE.LIST 209687 . 210013) (\TEDIT.MARK.LINES.DIRTY 210015 . 211701) ( 208646 . 209466) (\TEDIT.LINE.LIST 209468 . 209794) (\TEDIT.MARK.LINES.DIRTY 209796 . 211482) (
\TEDIT.NEXT.LINE.BOTTOM 211703 . 214014))))) \TEDIT.NEXT.LINE.BOTTOM 211484 . 213795)))))
STOP STOP

BIN
library/TEDITSCREEN.LCOM
View File

Binary file not shown.

417
library/UNICODE
View File

@@ -1,18 +1,16 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "21-Aug-2021 13:13:04"  (FILECREATED "30-Sep-2021 16:03:18" 
{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>UNICODE.;193 64903 {DSK}<Users>kaplan>Local>medley3.5>git-medley>library>UNICODE.;194 64783
changes to%: (FNS MAKE-UNICODE-TRANSLATION-TABLES) previous date%: "21-Aug-2021 13:13:04"
{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>UNICODE.;193)
previous date%: " 8-Aug-2021 13:10:17"
{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>UNICODE.;192)
(PRETTYCOMPRINT UNICODECOMS) (PRETTYCOMPRINT UNICODECOMS)
(RPAQQ UNICODECOMS (RPAQQ UNICODECOMS
[(COMS [(COMS
(* ;; "External formats") (* ;; "External formats")
(FNS UTF8.OUTCHARFN UTF8.INCCODEFN UTF8.PEEKCCODEFN \UTF8.BACKCCODEFN) (FNS UTF8.OUTCHARFN UTF8.INCCODEFN UTF8.PEEKCCODEFN \UTF8.BACKCCODEFN)
(FNS UTF16BE.OUTCHARFN UTF16BE.INCCODEFN UTF16BE.PEEKCCODEFN \UTF16.BACKCCODEFN) (FNS UTF16BE.OUTCHARFN UTF16BE.INCCODEFN UTF16BE.PEEKCCODEFN \UTF16.BACKCCODEFN)
@@ -25,14 +23,14 @@
(DECLARE%: EVAL@COMPILE DONTCOPY (MACROS UNICODE.TRANSLATE)) (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS UNICODE.TRANSLATE))
(FNS XTOUCODE UTOXCODE)) (FNS XTOUCODE UTOXCODE))
[COMS [COMS
(* ;; "Unicode mapping files") (* ;; "Unicode mapping files")
(FNS READ-UNICODE-MAPPING-FILENAMES READ-UNICODE-MAPPING WRITE-UNICODE-MAPPING (FNS READ-UNICODE-MAPPING-FILENAMES READ-UNICODE-MAPPING WRITE-UNICODE-MAPPING
WRITE-UNICODE-INCLUDED WRITE-UNICODE-MAPPING-HEADER WRITE-UNICODE-MAPPING-FILENAME WRITE-UNICODE-INCLUDED WRITE-UNICODE-MAPPING-HEADER WRITE-UNICODE-MAPPING-FILENAME
) )
(VARS XCCS-SET-NAMES) (VARS XCCS-SET-NAMES)
(* ;; "Automate dumping of a documentation prefix") (* ;; "Automate dumping of a documentation prefix")
[DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (MISSINGCODE (CL:PARSE-INTEGER "FFFE" [DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (MISSINGCODE (CL:PARSE-INTEGER "FFFE"
:RADIX 16)) :RADIX 16))
@@ -43,7 +41,7 @@
(P (PUSHNEW UNICODEDIRECTORIES (PACK* (UNIX-GETENV "MEDLEYDIR") (P (PUSHNEW UNICODEDIRECTORIES (PACK* (UNIX-GETENV "MEDLEYDIR")
'/unicode/xerox/] '/unicode/xerox/]
(COMS (COMS
(* ;; "Set up translation tables for UTF8 and UTFBE external formats") (* ;; "Set up translation tables for UTF8 and UTFBE external formats")
(FNS MAKE-UNICODE-TRANSLATION-TABLES) (FNS MAKE-UNICODE-TRANSLATION-TABLES)
[INITVARS (DEFAULT-XCCS-CHARSETS '(LATIN SYMBOLS1 SYMBOLS2 EXTENDED-LATIN FORMS [INITVARS (DEFAULT-XCCS-CHARSETS '(LATIN SYMBOLS1 SYMBOLS2 EXTENDED-LATIN FORMS
@@ -63,7 +61,7 @@
"NOTE: UNICODE requires EXPORTS.ALL for compilation" "NOTE: UNICODE requires EXPORTS.ALL for compilation"
T))) T)))
(* ;; "These control the layout of the translation tables. Since many of the upper panels are sparse, doing it per-panel (128) seems more space-efficient, and residual alists can be shorter") (* ;; "These control the layout of the translation tables. Since many of the upper panels are sparse, doing it per-panel (128) seems more space-efficient, and residual alists can be shorter")
(CONSTANTS (TRANSLATION-SEGMENT-SIZE 128) (CONSTANTS (TRANSLATION-SEGMENT-SIZE 128)
(MAX-ALIST-LENGTH 10) (MAX-ALIST-LENGTH 10)
@@ -78,13 +76,13 @@
(DEFINEQ (DEFINEQ
(UTF8.OUTCHARFN (UTF8.OUTCHARFN
[LAMBDA (STREAM CHARCODE RAW) (* ; "Edited 8-Aug-2021 13:02 by rmk:") [LAMBDA (STREAM CHARCODE RAW) (* ; "Edited 8-Aug-2021 13:02 by rmk:")
(* ; "Edited 17-Aug-2020 08:45 by rmk:") (* ; "Edited 17-Aug-2020 08:45 by rmk:")
(* ; "Edited 30-Jan-2020 23:08 by rmk:") (* ; "Edited 30-Jan-2020 23:08 by rmk:")
(* ;; "Perhaps the translation table should already do the mapping for EOL to LF, but that seems to be a separate property of the stream. Also, CRLF=2 bytes.") (* ;; "Perhaps the translation table should already do the mapping for EOL to LF, but that seems to be a separate property of the stream. Also, CRLF=2 bytes.")
(* ;; "Print UTF8 sequence for CHARCODE. Do not do XCCS to Unicode translation if RAW.") (* ;; "Print UTF8 sequence for CHARCODE. Do not do XCCS to Unicode translation if RAW.")
(IF (EQ CHARCODE (CHARCODE EOL)) (IF (EQ CHARCODE (CHARCODE EOL))
THEN (FREPLACE (STREAM CHARPOSITION) OF STREAM WITH 0) THEN (FREPLACE (STREAM CHARPOSITION) OF STREAM WITH 0)
@@ -97,13 +95,13 @@
DO (IF (ILESSP C 128) DO (IF (ILESSP C 128)
THEN (\BOUT STREAM C) THEN (\BOUT STREAM C)
ELSEIF (ILESSP C 2048) ELSEIF (ILESSP C 2048)
THEN (* ; "x800") THEN (* ; "x800")
(\BOUT STREAM (LOGOR (LLSH 3 6) (\BOUT STREAM (LOGOR (LLSH 3 6)
(LRSH C 6))) (LRSH C 6)))
(\BOUT STREAM (LOGOR (LLSH 2 6) (\BOUT STREAM (LOGOR (LLSH 2 6)
(LOADBYTE C 0 6))) (LOADBYTE C 0 6)))
ELSEIF (ILESSP C 65536) ELSEIF (ILESSP C 65536)
THEN (* ; "x10000") THEN (* ; "x10000")
(\BOUT STREAM (LOGOR (LLSH 7 5) (\BOUT STREAM (LOGOR (LLSH 7 5)
(LRSH C 12))) (LRSH C 12)))
(\BOUT STREAM (LOGOR (LLSH 2 6) (\BOUT STREAM (LOGOR (LLSH 2 6)
@@ -111,7 +109,7 @@
(\BOUT STREAM (LOGOR (LLSH 2 6) (\BOUT STREAM (LOGOR (LLSH 2 6)
(LOADBYTE C 0 6))) (LOADBYTE C 0 6)))
ELSEIF (ILESSP C 2097152) ELSEIF (ILESSP C 2097152)
THEN (* ; "x200000") THEN (* ; "x200000")
(\BOUT STREAM (LOGOR (LLSH 15 4) (\BOUT STREAM (LOGOR (LLSH 15 4)
(LRSH C 18))) (LRSH C 18)))
(\BOUT STREAM (LOGOR (LLSH 2 6) (\BOUT STREAM (LOGOR (LLSH 2 6)
@@ -123,29 +121,29 @@
ELSE (ERROR "CHARCODE too big for UTF8" C]) ELSE (ERROR "CHARCODE too big for UTF8" C])
(UTF8.INCCODEFN (UTF8.INCCODEFN
[LAMBDA (STREAM COUNTP RAW) (* ; "Edited 6-Aug-2021 16:02 by rmk:") [LAMBDA (STREAM COUNTP RAW) (* ; "Edited 6-Aug-2021 16:02 by rmk:")
(* ; "Edited 6-Aug-2020 17:13 by rmk:") (* ; "Edited 6-Aug-2020 17:13 by rmk:")
(* ;; "Do not do UNICODE to XCSS translation if RAW.") (* ;; "Do not do UNICODE to XCSS translation if RAW.")
(* ;; "Test for smallp because the stream's End-of-file operation may suppress the error") (* ;; "Test for smallp because the stream's End-of-file operation may suppress the error")
(DECLARE (USEDFREE *BYTECOUNTER*)) (DECLARE (USEDFREE *BYTECOUNTER*))
(LET (BYTE1 BYTE2 BYTE3 BYTE4 CODE (COUNT 1)) (LET (BYTE1 BYTE2 BYTE3 BYTE4 CODE (COUNT 1))
(SETQ BYTE1 (\BIN STREAM)) (SETQ BYTE1 (\BIN STREAM))
(* ;; "Distinguish on header bytes (modulo peculiar EOF behavior--the caller will get whatever ended up in BYTE1") (* ;; "Distinguish on header bytes (modulo peculiar EOF behavior--the caller will get whatever ended up in BYTE1")
(CL:WHEN (SMALLP BYTE1) (CL:WHEN (SMALLP BYTE1)
[SETQ CODE (IF (ILESSP BYTE1 128) [SETQ CODE (IF (ILESSP BYTE1 128)
THEN THEN
(* ;; (* ;;
 "Test first: Ascii is the common case. EOL requires its own translation")  "Test first: Ascii is the common case. EOL requires its own translation")
(SELCHARQ BYTE1 (SELCHARQ BYTE1
(CR (SELECTC (FETCH (STREAM EOLCONVENTION) OF STREAM) (CR (SELECTC (FETCH (STREAM EOLCONVENTION) OF STREAM)
(CR.EOLC (* ; "Also eq BYTE1") (CR.EOLC (* ; "Also eq BYTE1")
(CHARCODE EOL)) (CHARCODE EOL))
(CRLF.EOLC (IF (EQ (CHARCODE LF) (CRLF.EOLC (IF (EQ (CHARCODE LF)
(\PEEKBIN STREAM T)) (\PEEKBIN STREAM T))
@@ -160,7 +158,7 @@
BYTE1)) BYTE1))
BYTE1) BYTE1)
ELSEIF (IGEQ BYTE1 (LLSH 15 4)) ELSEIF (IGEQ BYTE1 (LLSH 15 4))
THEN (* ; "4 bytes") THEN (* ; "4 bytes")
(SETQ BYTE2 (\BIN STREAM)) (SETQ BYTE2 (\BIN STREAM))
(CL:WHEN (OR (NOT (SMALLP BYTE2)) (CL:WHEN (OR (NOT (SMALLP BYTE2))
(ILESSP BYTE2 128)) (ILESSP BYTE2 128))
@@ -182,7 +180,7 @@
6) 6)
(LOADBYTE BYTE4 0 6)) (LOADBYTE BYTE4 0 6))
ELSEIF (IGEQ BYTE1 (LLSH 7 5)) ELSEIF (IGEQ BYTE1 (LLSH 7 5))
THEN (* ; "3 bytes") THEN (* ; "3 bytes")
(SETQ BYTE2 (\BIN STREAM)) (SETQ BYTE2 (\BIN STREAM))
(CL:WHEN (OR (NOT (SMALLP BYTE2)) (CL:WHEN (OR (NOT (SMALLP BYTE2))
(ILESSP BYTE2 128)) (ILESSP BYTE2 128))
@@ -197,7 +195,7 @@
(LLSH (LOADBYTE BYTE2 0 6) (LLSH (LOADBYTE BYTE2 0 6)
6) 6)
(LOADBYTE BYTE3 0 6)) (LOADBYTE BYTE3 0 6))
ELSE (* ; "Must be 2 bytes") ELSE (* ; "Must be 2 bytes")
(SETQ COUNT 2) (SETQ COUNT 2)
(SETQ BYTE2 (\BIN STREAM)) (SETQ BYTE2 (\BIN STREAM))
(CL:WHEN (OR (NOT (SMALLP BYTE2)) (CL:WHEN (OR (NOT (SMALLP BYTE2))
@@ -211,12 +209,97 @@
(CL:WHEN COUNTP (SETQ *BYTECOUNTER* COUNT)) (CL:WHEN COUNTP (SETQ *BYTECOUNTER* COUNT))
CODE]) CODE])
(UTF8.PEEKCCODEFN (UTF8.PEEKCCODEFN
[LAMBDA (STREAM NOERROR RAW) (* ; "Edited 14-Jun-2021 22:53 by rmk:")
(* ;; "Modeled this after \EUCPEEK on LLREAD. In the multi-byte (non-ASCII) case, backs the file pointer to the beginning by the proper number of \BACKFILEPTRs, and returns a count of 0. Returns NIL if NOERROR and either invalid UTF8 or end of file.")
(* ;; "Could be that the caller takes care of backing up the file position if the number of binned-bytes is returned.")
(* ;; "Do not do UNICODE to XCCS translation if RAW")
(PROG (BYTE1 BYTE2 BYTE3 BYTE4 CODE)
(SETQ BYTE1 (\PEEKBIN STREAM NOERROR))
(* ;; "Distinguish on header bytex")
(CL:UNLESS BYTE1 (RETURN NIL))
[IF (ILESSP BYTE1 128)
THEN
(* ;;
 "Test first: Ascii is the common case. No need to back up, since we peeked.")
(SETQ CODE BYTE1)
ELSEIF (IGEQ BYTE1 (LLSH 15 4))
THEN (* ; "4 bytes")
(\BIN STREAM)
(CL:UNLESS (AND (SETQ BYTE2 (\PEEKBIN STREAM NOERROR))
(IGEQ BYTE2 128))
(\BACKFILEPTR STREAM)
(OR NOERROR (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2)))
(RETURN CODE))
(\BIN STREAM)
(CL:UNLESS (AND (SETQ BYTE3 (\PEEKBIN STREAM NOERROR))
(IGEQ BYTE3 128))
(\BACKFILEPTR STREAM)
(\BACKFILEPTR STREAM)
(OR NOERROR (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3)))
(RETURN CODE))
(\BIN STREAM)
(SETQ BYTE4 (\PEEKBIN STREAM NOERROR)) (* ;
 "PEEK the last, no need to back it up")
(\BACKFILEPTR STREAM)
(\BACKFILEPTR STREAM)
(\BACKFILEPTR STREAM)
(IF (AND BYTE4 (IGEQ BYTE4 128))
THEN (SETQ CODE (LOGOR (LLSH (LOADBYTE BYTE1 0 3)
18)
(LLSH (LOADBYTE BYTE2 0 6)
12)
(LLSH (LOADBYTE BYTE3 0 6)
6)
(LOADBYTE BYTE4 0 6)))
ELSEIF NOERROR
ELSE (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3 BYTE4)))
ELSEIF (IGEQ BYTE1 (LLSH 7 5))
THEN (* ; "3 bytes")
(\BIN STREAM)
(CL:UNLESS (AND (SETQ BYTE2 (\PEEKBIN STREAM NOERROR))
(IGEQ BYTE2 128))
(\BACKFILEPTR STREAM)
(OR NOERROR (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2)))
(RETURN CODE))
(\BIN STREAM)
(SETQ BYTE3 (\PEEKBIN STREAM NOERROR))
(\BACKFILEPTR STREAM)
(\BACKFILEPTR STREAM)
(IF (AND BYTE3 (IGEQ BYTE3 128))
THEN (SETQ CODE (LOGOR (LLSH (LOADBYTE BYTE1 0 4)
12)
(LLSH (LOADBYTE BYTE2 0 6)
6)
(LOADBYTE BYTE3 0 6)))
ELSEIF NOERROR
ELSE (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3)))
ELSE (* ; "Must be 2 bytes")
(\BIN STREAM)
(SETQ BYTE2 (\PEEKBIN STREAM NOERROR))
(\BACKFILEPTR STREAM)
(IF (AND BYTE2 (IGEQ BYTE2 128))
THEN (SETQ CODE (LOGOR (LLSH (LOADBYTE BYTE1 0 5)
6)
(LOADBYTE BYTE2 0 6)))
ELSEIF NOERROR
ELSE (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2]
(CL:WHEN (AND CODE (NOT RAW))
(SETQ CODE (UNICODE.TRANSLATE CODE *UNICODETOXCCS*)))
(RETURN CODE])
(\UTF8.BACKCCODEFN (\UTF8.BACKCCODEFN
(* ;; "Modeled this after \EUCPEEK on LLREAD. In the multi-byte (non-ASCII) case, backs the file pointer to the beginning by the proper number of \BACKFILEPTRs, and returns a count of 0. Returns NIL if NOERROR and either invalid UTF8 or end of file.") [LAMBDA (STREAM COUNTP) (* ; "Edited 6-Aug-2021 16:04 by rmk:")
(* ;; "Could be that the caller takes care of backing up the file position if the number of binned-bytes is returned.") (* ;; "\BACKFILEPTR is NIL at beginning of FILE, just return COUNT")
(DECLARE (USEDFREE *BYTECOUNTER*)) (DECLARE (USEDFREE *BYTECOUNTER*))
(BIND (C _ 0) WHILE (CL:WHEN (\BACKFILEPTR STREAM) (BIND (C _ 0) WHILE (CL:WHEN (\BACKFILEPTR STREAM)
@@ -228,12 +311,12 @@
(DEFINEQ (DEFINEQ
(UTF16BE.OUTCHARFN (UTF16BE.OUTCHARFN
[LAMBDA (STREAM CHARCODE RAW) (* ; "Edited 8-Aug-2021 13:09 by rmk:")
(* ;; (* ; "Edited 30-Jan-2020 23:08 by rmk:")
(* ;; "PRINT UTF16 sequence for CHARCODE. Do not do XCCS to UNICODE translation if RAW.")
ELSEIF (IGEQ BYTE1 (LLSH 15 4)) (* ;; "Not sure about EOL conversion if truly %"raw%"")
(IF (EQ CHARCODE (CHARCODE EOL)) (IF (EQ CHARCODE (CHARCODE EOL))
THEN (FREPLACE (STREAM CHARPOSITION) OF STREAM WITH 0) THEN (FREPLACE (STREAM CHARPOSITION) OF STREAM WITH 0)
@@ -245,10 +328,10 @@
DO (\WOUT STREAM C]) DO (\WOUT STREAM C])
(UTF16BE.INCCODEFN (UTF16BE.INCCODEFN
(\BACKFILEPTR STREAM) [LAMBDA (STREAM COUNTP RAW) (* ; "Edited 6-Aug-2021 16:05 by rmk:")
(RETURN CODE)) (* ;;
(\BIN STREAM)  "Do not do UNICODE to XCCS translation if RAW. Test for SMALLPin case of funky EOF behavior")
(DECLARE (USEDFREE *BYTECOUNTER*)) (DECLARE (USEDFREE *BYTECOUNTER*))
(LET (CODE BYTE1 BYTE2 COUNT) (LET (CODE BYTE1 BYTE2 COUNT)
@@ -264,14 +347,37 @@
CODE CODE
ELSE (ERROR "ODD NUMBER OF BYTES IN UTF16 FILE" STREAM]) ELSE (ERROR "ODD NUMBER OF BYTES IN UTF16 FILE" STREAM])
ELSEIF (IGEQ BYTE1 (LLSH 7 5)) (UTF16BE.PEEKCCODEFN
[LAMBDA (STREAM NOERROR RAW) (* ; "Edited 14-Jun-2021 22:58 by rmk:")
(* ;; "Could be that the caller takes care of backing up the file position if the number of binned-bytes is returned.")
(* ;; "Do not do UNICODE to XCCS translation if RAW")
(LET (BYTE1 BYTE2 CODE)
(SETQ BYTE1 (\PEEKBIN STREAM NOERROR))
(IF BYTE1
THEN (\BIN STREAM)
(SETQ BYTE2 (\PEEKBIN STREAM NOERROR))
(\BACKFILEPTR STREAM)
(IF BYTE2
THEN (SETQ CODE (LOGOR (LLSH BYTE1 8)
BYTE2))
(CL:IF RAW
CODE
(UNICODE.TRANSLATE CODE *UNICODETOXCCS*))
ELSEIF NOERROR
THEN NIL)
ELSEIF NOERROR
THEN NIL
ELSE (ERROR "INVALID UTF16 CHARACTER" (LIST BYTE1 BYTE2])
(\UTF16.BACKCCODEFN (\UTF16.BACKCCODEFN
(CL:UNLESS (AND (SETQ BYTE2 (\PEEKBIN STREAM NOERROR)) [LAMBDA (STREAM COUNTP) (* ; "Edited 6-Aug-2021 16:07 by rmk:")
(\BACKFILEPTR STREAM) (* ;; "\BACKFILEPTR is NIL at beginning of FILE, do nothing.")
(RETURN CODE)) (* ;; "Common for big-ending and little-ending")
(DECLARE (USEDFREE *BYTECOUNTER*)) (DECLARE (USEDFREE *BYTECOUNTER*))
(CL:WHEN (\BACKFILEPTR STREAM) (CL:WHEN (\BACKFILEPTR STREAM)
@@ -285,11 +391,11 @@
(DEFINEQ (DEFINEQ
(MAKE-UNICODE-FORMATS (MAKE-UNICODE-FORMATS
(\BIN STREAM) [LAMBDA (EXTERNALEOL) (* ; "Edited 6-Aug-2021 16:08 by rmk:")
(\BACKFILEPTR STREAM) (* ;; "RAW formats do not do XCCS/Unicode translation, just deal with the byte encoding.")
THEN (SETQ CODE (LOGOR (LLSH (LOADBYTE BYTE1 0 5) (* ;; "The EXTERNALEOL specifies the EOLCONVENTION of the stream, particularly to produce output files with the desired convention. On input the macro \CHECKEOLC (LLREAD) coerces only that coding to the internal EOL, which is a mistake.")
(MAKE-EXTERNALFORMAT :UTF-8 (FUNCTION UTF8.INCCODEFN) (MAKE-EXTERNALFORMAT :UTF-8 (FUNCTION UTF8.INCCODEFN)
(FUNCTION UTF8.PEEKCCODEFN) (FUNCTION UTF8.PEEKCCODEFN)
@@ -325,11 +431,11 @@
(DEFINEQ (DEFINEQ
(UNICODE.UNMAPPED (UNICODE.UNMAPPED
CHARCODE [LAMBDA (CODE TRANSLATION-TABLE) (* ; "Edited 11-Aug-2020 20:23 by rmk:")
DO (\WOUT STREAM C]) (* ;; "This is the slow fall-out when UNICODE.TRANSLATE determines that CODED has no fast mapping in TRANSLATION-TABLE.")
(UTF16BE.INCCODEFN (* ;; "We return an existing entry in the hash array of the table. If CODE has not previously been seen, we allocate a new code in the forward unmapped hasharray and put the inverse in the backward array.")
(LET ((FORWARD (CL:SVREF TRANSLATION-TABLE N-TRANSLATION-SEGMENTS)) (LET ((FORWARD (CL:SVREF TRANSLATION-TABLE N-TRANSLATION-SEGMENTS))
INVERSE NEXTCODE) INVERSE NEXTCODE)
@@ -349,9 +455,9 @@
(DEFINEQ (DEFINEQ
(XCCS-UTF8-AFTER-OPEN (XCCS-UTF8-AFTER-OPEN
(UTF16BE.PEEKCCODEFN [LAMBDA (STREAM ACCESS PARAMETERS) (* ; "Edited 13-Aug-2020 11:54 by rmk:")
(* ;; "If added to STREAM-AFTER-OPEN-FNS, causes mapping files to be opened as UTF8.")
(CL:WHEN (AND (STRPOS "XCCS-" (U-CASE (FULLNAME STREAM))) (CL:WHEN (AND (STRPOS "XCCS-" (U-CASE (FULLNAME STREAM)))
[EQ 'TXT (U-CASE (FILENAMEFIELD (FULLNAME STREAM) [EQ 'TXT (U-CASE (FILENAMEFIELD (FULLNAME STREAM)
@@ -379,11 +485,11 @@
(DEFINEQ (DEFINEQ
(XTOUCODE (XTOUCODE
(* ;; "Common for big-ending and little-ending") [LAMBDA (XCCSCODE) (* ; "Edited 9-Aug-2020 09:04 by rmk:")
(UNICODE.TRANSLATE XCCSCODE *XCCSTOUNICODE*]) (UNICODE.TRANSLATE XCCSCODE *XCCSTOUNICODE*])
(UTOXCODE (UTOXCODE
(IF (\BACKFILEPTR STREAM) [LAMBDA (UNICODE) (* ; "Edited 9-Aug-2020 09:04 by rmk:")
(UNICODE.TRANSLATE UNICODE *UNICODETOXCCS*]) (UNICODE.TRANSLATE UNICODE *UNICODETOXCCS*])
) )
@@ -394,9 +500,8 @@
(DEFINEQ (DEFINEQ
(READ-UNICODE-MAPPING-FILENAMES (READ-UNICODE-MAPPING-FILENAMES
[LAMBDA (FILESPEC) (* ; "Edited 5-Aug-2020 15:59 by kaplan")
(* ;; "RAW formats do not do XCCS/Unicode translation, just deal with the byte encoding.") (* ; "Edited 4-Aug-2020 17:31 by rmk:")
(FOR F X CSI INSIDE FILESPEC (FOR F X CSI INSIDE FILESPEC
COLLECT (IF (FINDFILE (PACKFILENAME 'BODY F 'EXTENSION 'TXT) COLLECT (IF (FINDFILE (PACKFILENAME 'BODY F 'EXTENSION 'TXT)
T UNICODEDIRECTORIES) T UNICODEDIRECTORIES)
@@ -412,24 +517,24 @@
ELSE F]) ELSE F])
(READ-UNICODE-MAPPING (READ-UNICODE-MAPPING
(MAKE-EXTERNALFORMAT :UTF-16BE (FUNCTION UTF16BE.INCCODEFN) [LAMBDA (FILESPEC NOPRINT NOERROR) (* ; "Edited 3-Jul-2021 13:37 by rmk:")
(FUNCTION \UTF16.BACKCCODEFN) (* ;; "Combines the char-mapping tables from FILES coded in the Uncode-CDROM format. Comments prefixed by # and")
NIL EXTERNALEOL) (* ;; " Column 1: Input hex code in the format 0xXXXX")
(UTF16BE.INCCODEFN STREAM COUNTP T] (* ;; " Column 2: Corresponding Unicode code-sequence in the format")
(UTF16BE.PEEKCCODEFN STREAM NOERROR T] (* ;; " 0xXXXX ... 0xYYYY")
[FUNCTION (LAMBDA (STREAM CHARCODE) (* ;;
(UTF16BE.OUTCHARFN STREAM CHARCODE T]  " Column 3: (after #) Character name in some mapping files, utf-8 character")
) (* ;; " for XCCS mapping files")
(MAKE-UNICODE-FORMATS EXTERNALEOL) (* ;; "")
(ADDTOVAR *DEFAULT-EXTERNALFORMATS* (UNIX :UTF-8)) (* ;; "Result is a list of (fromcode tocode1 ... tocoden) integer lists (almost always with only a single tocode")
(FOR FILE [SEPBITTABLE _ (MAKEBITTABLE (CHARCODE (TAB SPACE] IN ( (FOR FILE [SEPBITTABLE _ (MAKEBITTABLE (CHARCODE (TAB SPACE] IN (
 READ-UNICODE-MAPPING-FILENAMES  READ-UNICODE-MAPPING-FILENAMES
@@ -461,18 +566,18 @@
(NTHCHARCODE LINE START]) (NTHCHARCODE LINE START])
(WRITE-UNICODE-MAPPING (WRITE-UNICODE-MAPPING
(CL:WHEN (AND (STRPOS "XCCS-" (U-CASE (FULLNAME STREAM))) [LAMBDA (MAPPING INCLUDECHARSETS FILE EMPTYOK) (* ; "Edited 16-Aug-2020 16:56 by rmk:")
'EXTENSION] (* ;; "Writes a symbol unicode mapping file. Mapping is a list of (XCCS-code Unicode) pairs, which may contain codes in multiple character sets.")
(STREAMPROP STREAM 'EXTERNALFORMAT :UTF8))]) (* ;; "If FILE is NIL, it defaults to a name XCCS- followed by the octal character sets in the mapping, in the unicode/XEROX directory.")
(DECLARE%: EVAL@COMPILE DONTCOPY (* ;; "The output lines are of the form x0XXX<tab>x0UUUU<tab># Unicode-char")
(* ;;
(PUTPROPS UNICODE.TRANSLATE MACRO [OPENLAMBDA (CODE TRANSLATION-TABLE)  "If INCLUDECHARSETS=T then the mappings are split up into separate per-character set files.")
TRANSLATION-SHIFT (* ;; "Otherwise, all and only mappings included in thos charsets are included in a single output file--an implicit subset.")
(IF (AND (EQ INCLUDECHARSETS T) (IF (AND (EQ INCLUDECHARSETS T)
(NULL FILE)) (NULL FILE))
@@ -513,15 +618,15 @@
" # " " # "
(SELECTC FIRSTRIGHTC (SELECTC FIRSTRIGHTC
(UNDEFINEDCODE (UNDEFINEDCODE
(CADR CSI)) (* ;; "FFFF")
"UNDEFINED") "UNDEFINED")
(MISSINGCODE (MISSINGCODE
ELSE F]) (* ;; "FFFE")
"MISSING") "MISSING")
(IF (ILESSP FIRSTRIGHTC 32) (IF (ILESSP FIRSTRIGHTC 32)
THEN (* ; "Control chars")
[CONCAT "^" (CHARACTER (IPLUS FIRSTRIGHTC [CONCAT "^" (CHARACTER (IPLUS FIRSTRIGHTC
(CHARCODE @] (CHARCODE @]
ELSE (CHARACTER FIRSTRIGHTC))) ELSE (CHARACTER FIRSTRIGHTC)))
@@ -535,13 +640,13 @@
NIL]) NIL])
(WRITE-UNICODE-INCLUDED (WRITE-UNICODE-INCLUDED
(* ;; "") [LAMBDA (MAPPING INCLUDECHARSETS) (* ; "Edited 4-Aug-2020 17:47 by rmk:")
(* ;; "Result is a list of (fromcode tocode1 ... tocoden) integer lists (almost always with only a single tocode") (* ;; "CSETINFO is a list of (num string name) for each included character set.")
(LET (CHARSETS CSETINFO RANGES ICSETS IMAPPING) (LET (CHARSETS CSETINFO RANGES ICSETS IMAPPING)
FILESPEC) (* ;; "Normalize the INCLUDECHARSETS, then reduce MAPPING to the included mappings")
[SETQ ICSETS (FOR C POS KNOWN INSIDE (OR INCLUDECHARSETS (FOR CSI IN [SETQ ICSETS (FOR C POS KNOWN INSIDE (OR INCLUDECHARSETS (FOR CSI IN
XCCS-SET-NAMES XCCS-SET-NAMES
@@ -569,13 +674,13 @@
ICSETS)) ICSETS))
COLLECT COLLECT
[LAMBDA (MAPPING INCLUDECHARSETS FILE EMPTYOK) (* ; "Edited 16-Aug-2020 16:56 by rmk:") (* ;; "The attested subset of INCLUDED")
(CL:UNLESS (MEMB CSI CSETINFO) (CL:UNLESS (MEMB CSI CSETINFO)
(PUSH CSETINFO CSI)) (PUSH CSETINFO CSI))
M)) M))
(* ;; "The output lines are of the form x0XXX<tab>x0UUUU<tab># Unicode-char") (* ;; "Sort as numbers, not octal strings, then group into consecutive ranges")
(SETQ CSETINFO (SORT CSETINFO T)) (SETQ CSETINFO (SORT CSETINFO T))
[SETQ RANGES (FOR CTAIL C START END ON (FOR CSI IN CSETINFO [SETQ RANGES (FOR CTAIL C START END ON (FOR CSI IN CSETINFO
@@ -587,7 +692,7 @@
COLLECT (SETQ CTAIL (CDR CTAIL)) COLLECT (SETQ CTAIL (CDR CTAIL))
(SETQ END (CAR CTAIL] (SETQ END (CAR CTAIL]
MAPPING (* ;; "Split out groups of less than 3. But if a range exhaustively covers a known subset (like JIS), replace by the name")
[SETQ RANGES (FOR R STR KNOWN LAST IN RANGES [SETQ RANGES (FOR R STR KNOWN LAST IN RANGES
JOIN (SETQ LAST (CAR (LAST R))) JOIN (SETQ LAST (CAR (LAST R)))
@@ -607,9 +712,9 @@
(CL:VALUES IMAPPING CSETINFO RANGES]) (CL:VALUES IMAPPING CSETINFO RANGES])
(WRITE-UNICODE-MAPPING-HEADER (WRITE-UNICODE-MAPPING-HEADER
(CL:UNLESS (EQ CSET (LRSH LEFTC 8)) [LAMBDA (STREAM CSETINFO RANGES) (* ; "Edited 4-Aug-2020 17:38 by rmk:")
(SETQ CSI (ASSOC CSET CSETINFO)) (* ;; "Writes the standard per-file header information")
(FOR LINE IN UNICODE-MAPPING-HEADER (FOR LINE IN UNICODE-MAPPING-HEADER
DO (PRINTOUT STREAM "#" 2) DO (PRINTOUT STREAM "#" 2)
@@ -620,7 +725,7 @@
THEN (PRINTOUT STREAM "s:" -4) THEN (PRINTOUT STREAM "s:" -4)
(FOR R IN RANGES DO (PRINTOUT STREAM R " ")) (FOR R IN RANGES DO (PRINTOUT STREAM R " "))
(TERPRI STREAM) (TERPRI STREAM)
(UNDEFINEDCODE ELSE (* ; "Singleton")
(PRINTOUT STREAM ": " -4 (CADAR CSETINFO) (PRINTOUT STREAM ": " -4 (CADAR CSETINFO)
" " " "
(CADDAR CSETINFO))) (CADDAR CSETINFO)))
@@ -632,7 +737,7 @@
(TERPRI STREAM]) (TERPRI STREAM])
(WRITE-UNICODE-MAPPING-FILENAME (WRITE-UNICODE-MAPPING-FILENAME
ELSE (CHARACTER FIRSTRIGHTC))) [LAMBDA (FILE CSETINFO RANGES) (* ; "Edited 4-Aug-2020 19:34 by rmk:")
(PACKFILENAME 'BODY [OR FILE (CONCATLIST (PACKFILENAME 'BODY [OR FILE (CONCATLIST
(CONS 'XCCS- (IF (CDR CSETINFO) (CONS 'XCCS- (IF (CDR CSETINFO)
THEN (FOR RTAIL R ON RANGES THEN (FOR RTAIL R ON RANGES
@@ -736,53 +841,53 @@
(DEFINEQ (DEFINEQ
(MAKE-UNICODE-TRANSLATION-TABLES (MAKE-UNICODE-TRANSLATION-TABLES
(PRINTOUT STREAM LINE T))) [LAMBDA (MAPPING LTORVAR RTOLVAR) (* ; "Edited 21-Aug-2021 13:12 by rmk:")
(TERPRI STREAM]) (* ; "Edited 17-Aug-2020 08:46 by rmk:")
(WRITE-UNICODE-MAPPING-FILENAME (* ;; "MAPPING is the list of numeric code correspondence pairs constructed by applying READ-UNICODE-MAPPING to a Unicode mapping file.")
(PACKFILENAME 'BODY [OR FILE (CONCATLIST (* ;; "This produces two recoding arrays, one maps left-side codes into right-side codes (e.g. XCCS or ISO8859-1 to Unicode), for printing, the other maps right-side (Unicode) codes to corresponding right-side codes (e.g. XCCS).")
THEN (FOR RTAIL R ON RANGES (* ;; "")
(SETQ R (* ;; "We assume that the left-to-right mapping into Unicode is functional, so that each left code maps to a unique right (Unicode) code, because Unicode is presumably the most refined coding scheme. But several Unicode codes may map to the same left code, for logically different codes that happen to have the same glyphs. In that case the heuristic is to map each %"from%" code to the lowest of the possible %"to%" codes. This means that round-trip reading/writing or writing/reading from one or both starting points may not always be lossless.")
(LIST (CAR R) (* ;; " ")
(CDR R)) (* ;; " Each recoding array has 256 elements, one for each possible high-order byte of a character code. An array entry is either NIL, a 256-array of codes indexed by low-order bytes, or an alist of (lower-order-bytes . codes). The latter is used to save space for sparsely populated character sets.")
(CL:IF (CDR RTAIL) (* ;; "")
R) (* ;; "The element 256 of each array contains a hash table for characters that might be encountered in XCCS memory or Unicode files for which there is no mapping. Element 257 contains the corresponding inverse unmapped hash-array, so that UNICODE.TRANSLATE can update them consistently.")
"=" (* ;; "")
'DIRECTORY (* ;; "UNICODE.TRANSLATE assigns an unmapped Unicode character to a %"not used%" XCCS code position (from 5,0 to 40,FF, leaving other low not-used sets for other internal uses (TEDIT?).")
'EXTENSION (* ;; "")
) (* ;;
 "An unmapped XCCS character is assigned a code in the %"private use%" code blocks 0xE000-F8FF")
(("0" LATIN) (* ;; "")
("42" SYMBOLS2) (* ;; "For the convenience of not having to deal with the multiple values, if LTORVAR or RTOLVAR are given, they are set to the constructed arrays before return.")
("44" HIRAGANA) (* ;; "")
(LET ((LTORARRAY (CL:MAKE-ARRAY (IPLUS 2 N-TRANSLATION-SEGMENTS) (LET ((LTORARRAY (CL:MAKE-ARRAY (IPLUS 2 N-TRANSLATION-SEGMENTS)
:INITIAL-ELEMENT NIL)) :INITIAL-ELEMENT NIL))
(RTOLARRAY (CL:MAKE-ARRAY (IPLUS 2 N-TRANSLATION-SEGMENTS) (RTOLARRAY (CL:MAKE-ARRAY (IPLUS 2 N-TRANSLATION-SEGMENTS)
:INITIAL-ELEMENT NIL))) :INITIAL-ELEMENT NIL)))
("341" HEBREW) (* ;; "The left-to-right direction (into Unicode). We start by distributing the mappings into alists in arrays indexed by the higher-order (charaset set byte). The second loop converts long alists into arrays.")
[FOR M LEFTC RBASE RCODES IN MAPPING EACHTIME (SETQ RCODES (CDR M)) [FOR M LEFTC RBASE RCODES IN MAPPING EACHTIME (SETQ RCODES (CDR M))
(SETQ RBASE (CAR RCODES)) (SETQ RBASE (CAR RCODES))
UNLESS (IGEQ RBASE MISSINGCODE) DO (SETQ LEFTC (CAR M)) UNLESS (IGEQ RBASE MISSINGCODE) DO (SETQ LEFTC (CAR M))
("360" LIGATURES) (* ;;
("361" ACCENTED-LATIN)  "(CDR RCODES) contains combiners on the base")
(CL:PUSH (CONS (LOGAND LEFTC TRANSLATION-MASK) (CL:PUSH (CONS (LOGAND LEFTC TRANSLATION-MASK)
(CL:IF (CDR RCODES) (CL:IF (CDR RCODES)
@@ -796,7 +901,7 @@
MAX-ALIST-LENGTH) MAX-ALIST-LENGTH)
DO DO
(* ;; "Leave it alone if the alist is short")
(SETQ CSA (CL:MAKE-ARRAY TRANSLATION-SEGMENT-SIZE :INITIAL-ELEMENT NIL)) (SETQ CSA (CL:MAKE-ARRAY TRANSLATION-SEGMENT-SIZE :INITIAL-ELEMENT NIL))
(FOR P IN (CL:SVREF LTORARRAY I) (FOR P IN (CL:SVREF LTORARRAY I)
@@ -806,17 +911,17 @@
(CL:SETF (CL:SVREF LTORARRAY I) (CL:SETF (CL:SVREF LTORARRAY I)
CSA)) CSA))
DATE " Author: Ron Kaplan <Ron.Kaplan@post.harvard.edu>" "" (* ;; "")
"XC1-3-3-0, 1987) into Unicode 3.0. standard codes. That is the version of" (* ;; "Now the right-to-left direction (from Unicode). Here we have to detect and compensate for ambiguity.")
(FOR M LEFTC RBASE RCOMBINERS PREV IN MAPPING EACHTIME (SETQ RBASE (CADR M)) (FOR M LEFTC RBASE RCOMBINERS PREV IN MAPPING EACHTIME (SETQ RBASE (CADR M))
(SETQ RCOMBINERS (CDDR M)) (SETQ RCOMBINERS (CDDR M))
UNLESS (OR (IGEQ RBASE MISSINGCODE) UNLESS (OR (IGEQ RBASE MISSINGCODE)
RCOMBINERS) DO RCOMBINERS) DO
" Unicode character itself (since the Unicode character names" (* ;;
" are not available)"  "Have we already seen an explicit mapping from right to left?")
(SETQ LEFTC (CAR M)) (SETQ LEFTC (CAR M))
[SETQ PREV (ASSOC (LOGAND RBASE TRANSLATION-MASK) [SETQ PREV (ASSOC (LOGAND RBASE TRANSLATION-MASK)
@@ -838,7 +943,7 @@
MAX-ALIST-LENGTH) MAX-ALIST-LENGTH)
DO DO
(* ;; "Long list, make an array")
(SETQ CSA (CL:MAKE-ARRAY TRANSLATION-SEGMENT-SIZE :INITIAL-ELEMENT NIL)) (SETQ CSA (CL:MAKE-ARRAY TRANSLATION-SEGMENT-SIZE :INITIAL-ELEMENT NIL))
(FOR P IN (CL:SVREF RTOLARRAY I) (FOR P IN (CL:SVREF RTOLARRAY I)
@@ -848,9 +953,9 @@
(CL:SETF (CL:SVREF RTOLARRAY I) (CL:SETF (CL:SVREF RTOLARRAY I)
CSA)) CSA))
(* ;; "")
(* ;; "Allocate the hash arrays for future out-of-map codes. We we have to keep track of the next available and last possible codes, as well as the first available, for error checking.")
(CL:SETF (CL:SVREF LTORARRAY N-TRANSLATION-SEGMENTS) (CL:SETF (CL:SVREF LTORARRAY N-TRANSLATION-SEGMENTS)
(LIST (HASHARRAY 10) (LIST (HASHARRAY 10)
@@ -863,14 +968,14 @@
(CHARCODE.DECODE "U+F8FF") (CHARCODE.DECODE "U+F8FF")
(CHARCODE.DECODE "U+E000"))) (CHARCODE.DECODE "U+E000")))
(* ;; "") (* ;; "Now put in the inverse unmapped hash arrays")
(CL:SETF (CL:SVREF LTORARRAY (ADD1 N-TRANSLATION-SEGMENTS)) (CL:SETF (CL:SVREF LTORARRAY (ADD1 N-TRANSLATION-SEGMENTS))
(CL:SVREF RTOLARRAY N-TRANSLATION-SEGMENTS)) (CL:SVREF RTOLARRAY N-TRANSLATION-SEGMENTS))
(CL:SETF (CL:SVREF RTOLARRAY (ADD1 N-TRANSLATION-SEGMENTS)) (CL:SETF (CL:SVREF RTOLARRAY (ADD1 N-TRANSLATION-SEGMENTS))
(CL:SVREF LTORARRAY N-TRANSLATION-SEGMENTS)) (CL:SVREF LTORARRAY N-TRANSLATION-SEGMENTS))
 "An unmapped XCCS character is assigned a code in the %"private use%" code blocks 0xE000-F8FF") (* ;; "")
(CL:WHEN LTORVAR (SETATOMVAL LTORVAR LTORARRAY)) (CL:WHEN LTORVAR (SETATOMVAL LTORVAR LTORARRAY))
(CL:WHEN RTOLVAR (SETATOMVAL RTOLVAR RTOLARRAY)) (CL:WHEN RTOLVAR (SETATOMVAL RTOLVAR RTOLARRAY))
@@ -892,11 +997,11 @@
(DEFINEQ (DEFINEQ
(HEXSTRING (HEXSTRING
(CL:PUSH (CONS (LOGAND LEFTC TRANSLATION-MASK) [LAMBDA (N WIDTH) (* ; "Edited 23-Jul-2020 08:28 by rmk:")
(CL:IF (CDR RCODES) (* ; "Edited 20-Dec-93 17:51 by rmk:")
RBASE)) (* ;;
(CL:SVREF LTORARRAY (LRSH LEFTC  "Converts positive numbers to Hex strings, padding on the right with 0 up to WIDTH if given.")
(CL:UNLESS (FIXP N) (CL:UNLESS (FIXP N)
(SETQ N (CHARCODE.DECODE N))) (SETQ N (CHARCODE.DECODE N)))
@@ -915,21 +1020,21 @@
STR]) STR])
(UTF8HEXSTRING (UTF8HEXSTRING
[LAMBDA (CHARCODE) (* ; "Edited 10-Aug-2020 08:33 by rmk:")
(* ;; "Utility to produces the UTF8 hexstring representing CODE")
(HEXSTRING (IF (ILESSP CHARCODE 128) (HEXSTRING (IF (ILESSP CHARCODE 128)
THEN CHARCODE THEN CHARCODE
ELSEIF (ILESSP CHARCODE 2048) ELSEIF (ILESSP CHARCODE 2048)
THEN (* ; "x800")
(LOGOR (LLSH (LOGOR (LLSH 3 6) (LOGOR (LLSH (LOGOR (LLSH 3 6)
(LRSH CHARCODE 6)) (LRSH CHARCODE 6))
8) 8)
(LOGOR (LLSH 2 6) (LOGOR (LLSH 2 6)
(LOADBYTE CHARCODE 0 6))) (LOADBYTE CHARCODE 0 6)))
ELSEIF (ILESSP CHARCODE 65536) ELSEIF (ILESSP CHARCODE 65536)
TRANSLATION-SHIFT THEN (* ; "x10000")
(LOGOR (LLSH (LOGOR (LLSH 7 5) (LOGOR (LLSH (LOGOR (LLSH 7 5)
(LRSH CHARCODE 12)) (LRSH CHARCODE 12))
16) 16)
@@ -939,7 +1044,7 @@
(LOGOR (LLSH 2 6) (LOGOR (LLSH 2 6)
(LOADBYTE CHARCODE 0 6))) (LOADBYTE CHARCODE 0 6)))
ELSEIF (ILESSP CHARCODE 2097152) ELSEIF (ILESSP CHARCODE 2097152)
LEFTC) THEN (* ; "x200000")
(LOGOR (LLSH (LOGOR (LLSH 15 4) (LOGOR (LLSH (LOGOR (LLSH 15 4)
(LRSH CHARCODE 18)) (LRSH CHARCODE 18))
24) 24)
@@ -954,27 +1059,27 @@
ELSE (ERROR "CHARCODE too big for UTF8" CHARCODE]) ELSE (ERROR "CHARCODE too big for UTF8" CHARCODE])
(NUTF8CODEBYTES (NUTF8CODEBYTES
CSA)) [LAMBDA (N) (* ; "Edited 10-Aug-2020 12:35 by rmk:")
(* ;; "") (* ;; "Returns the number of bytes needed to encode N in UTF8, ")
(IF (ILESSP N 128) (IF (ILESSP N 128)
THEN 1 THEN 1
ELSEIF (ILESSP N 2048) ELSEIF (ILESSP N 2048)
(LIST (HASHARRAY 10) THEN (* ; "x800")
4 4
ELSEIF (ILESSP N 65536) ELSEIF (ILESSP N 65536)
(CHARCODE.DECODE "5,0"))) THEN (* ; "x10000")
3 3
ELSEIF (ILESSP N 2097152) ELSEIF (ILESSP N 2097152)
(CHARCODE.DECODE "U+E000") THEN (* ; "x200000")
2 2
ELSE (SHOULDNT]) ELSE (SHOULDNT])
(NUTF8STRINGBYTES (NUTF8STRINGBYTES
[LAMBDA (STRING RAWFLG) (* ; "Edited 10-Aug-2020 09:06 by rmk:")
(CL:SVREF RTOLARRAY N-TRANSLATION-SEGMENTS)) (* ;; "Returns the number of bytes it would take to represent STRING in UTF8, assuming it is an XCCS string unless RAWFLG. ")
(FOR I C FROM 1 WHILE (SETQ C (NTHCHARCODE STRING I)) (FOR I C FROM 1 WHILE (SETQ C (NTHCHARCODE STRING I))
SUM (NUTF8CODEBYTES (CL:IF RAWFLG SUM (NUTF8CODEBYTES (CL:IF RAWFLG
@@ -982,11 +1087,11 @@
(XTOUCODE C))]) (XTOUCODE C))])
(XTOUSTRING (XTOUSTRING
(LIST LTORARRAY RTOLARRAY]) [LAMBDA (XCCSSTRING RAWFLG) (* ; "Edited 10-Aug-2020 21:42 by rmk:")
(* ;; "Produces a string that contains the UTF8 bytes that represent the characters in XCCSSTRING. Applies the XCCSTOUNICODE translation unless RAWFLG. ")
ACCENTED-LATIN GREEK)) (* ;; "The resulting string will not be readable inside Medley.")
(LET [(USTR (ALLOCSTRING (NUTF8STRINGBYTES XCCSSTRING RAWFLG] (LET [(USTR (ALLOCSTRING (NUTF8STRINGBYTES XCCSSTRING RAWFLG]
(FOR I CHARCODE (SINDEX _ 0) FROM 1 WHILE (SETQ CHARCODE (NTHCHARCODE XCCSSTRING (FOR I CHARCODE (SINDEX _ 0) FROM 1 WHILE (SETQ CHARCODE (NTHCHARCODE XCCSSTRING
@@ -997,7 +1102,7 @@
THEN (RPLCHARCODE USTR (ADD SINDEX 1) THEN (RPLCHARCODE USTR (ADD SINDEX 1)
CHARCODE) CHARCODE)
ELSEIF (ILESSP CHARCODE 2048) ELSEIF (ILESSP CHARCODE 2048)
(DEFINEQ THEN (* ; "x800")
(RPLCHARCODE USTR (ADD SINDEX 1) (RPLCHARCODE USTR (ADD SINDEX 1)
(LOGOR (LLSH 3 6) (LOGOR (LLSH 3 6)
(LRSH CHARCODE 6))) (LRSH CHARCODE 6)))
@@ -1005,7 +1110,7 @@
(LOGOR (LLSH 2 6) (LOGOR (LLSH 2 6)
(LOADBYTE CHARCODE 0 6))) (LOADBYTE CHARCODE 0 6)))
ELSEIF (ILESSP CHARCODE 65536) ELSEIF (ILESSP CHARCODE 65536)
THEN (* ; "x10000")
(RPLCHARCODE USTR (ADD SINDEX 1) (RPLCHARCODE USTR (ADD SINDEX 1)
(LOGOR (LLSH 7 5) (LOGOR (LLSH 7 5)
(LRSH CHARCODE 12))) (LRSH CHARCODE 12)))
@@ -1016,7 +1121,7 @@
(LOGOR (LLSH 2 6) (LOGOR (LLSH 2 6)
(LOADBYTE CHARCODE 0 6))) (LOADBYTE CHARCODE 0 6)))
ELSEIF (ILESSP CHARCODE 2097152) ELSEIF (ILESSP CHARCODE 2097152)
THEN (+ CHAR (CHARCODE 0)) THEN (* ; "x200000")
(RPLCHARCODE USTR (ADD SINDEX 1) (RPLCHARCODE USTR (ADD SINDEX 1)
(LOGOR (LLSH 15 4) (LOGOR (LLSH 15 4)
(LRSH CHARCODE 18))) (LRSH CHARCODE 18)))
@@ -1033,9 +1138,9 @@
USTR]) USTR])
(XCCSSTRING (XCCSSTRING
8) [LAMBDA (CODE) (* ; "Edited 13-Aug-2020 12:16 by rmk:")
(LOADBYTE CHARCODE 0 6))) (* ;; "Returns XCCS character representation of string %"cset,char%"")
(CL:UNLESS (FIXP CODE) (CL:UNLESS (FIXP CODE)
(SETQ CODE (CHCON1 CODE))) (SETQ CODE (CHCON1 CODE)))
@@ -1046,14 +1151,14 @@
(DEFINEQ (DEFINEQ
(SHOWCHARS (SHOWCHARS
ELSEIF (ILESSP CHARCODE 2097152) [LAMBDA (FROMCHAR TOCHAR FONT) (* ; "Edited 1-Aug-2020 09:27 by rmk:")
(RESETFORM (DSPFONT (OR FONT '(CLASSIC 12)) (RESETFORM (DSPFONT (OR FONT '(CLASSIC 12))
T) T)
(CL:WHEN (AND (SMALLP FROMCHAR) (CL:WHEN (AND (SMALLP FROMCHAR)
(NOT TOCHAR)) (NOT TOCHAR))
(LOADBYTE CHARCODE 12 6)) (* ;;
16)  "If a small number, assume it's an octal (in decimal) character set, no need for string quotes")
(SETQ TOCHAR (CONCAT FROMCHAR "," 376)) (SETQ TOCHAR (CONCAT FROMCHAR "," 376))
(SETQ FROMCHAR (CONCAT FROMCHAR "," 41))) (SETQ FROMCHAR (CONCAT FROMCHAR "," 41)))
@@ -1100,15 +1205,15 @@
) )
) )
(DECLARE%: DONTCOPY (DECLARE%: DONTCOPY
(SETQ CHARCODE (XTOUCODE CHARCODE))) (FILEMAP (NIL (4046 17726 (UTF8.OUTCHARFN 4056 . 6887) (UTF8.INCCODEFN 6889 . 12379) (UTF8.PEEKCCODEFN
(IF (ILESSP CHARCODE 128) 12381 . 17155) (\UTF8.BACKCCODEFN 17157 . 17724)) (17727 21053 (UTF16BE.OUTCHARFN 17737 . 18561) (
THEN (RPLCHARCODE USTR (ADD SINDEX 1) UTF16BE.INCCODEFN 18563 . 19462) (UTF16BE.PEEKCCODEFN 19464 . 20535) (\UTF16.BACKCCODEFN 20537 . 21051
CHARCODE) )) (21083 22891 (MAKE-UNICODE-FORMATS 21093 . 22889)) (22988 24294 (UNICODE.UNMAPPED 22998 . 24292)) (
ELSEIF (ILESSP CHARCODE 2048) 24295 24831 (XCCS-UTF8-AFTER-OPEN 24305 . 24829)) (25901 26250 (XTOUCODE 25911 . 26079) (UTOXCODE
THEN (* ; "x800") 26081 . 26248)) (26290 42412 (READ-UNICODE-MAPPING-FILENAMES 26300 . 27401) (READ-UNICODE-MAPPING
(RPLCHARCODE USTR (ADD SINDEX 1) 27403 . 30701) (WRITE-UNICODE-MAPPING 30703 . 34920) (WRITE-UNICODE-INCLUDED 34922 . 39644) (
(LOGOR (LLSH 3 6) WRITE-UNICODE-MAPPING-HEADER 39646 . 40878) (WRITE-UNICODE-MAPPING-FILENAME 40880 . 42410)) (45749
(LRSH CHARCODE 6))) 54228 (MAKE-UNICODE-TRANSLATION-TABLES 45759 . 54226)) (54649 62553 (HEXSTRING 54659 . 55820) (
(RPLCHARCODE USTR (ADD SINDEX 1) UTF8HEXSTRING 55822 . 58027) (NUTF8CODEBYTES 58029 . 58692) (NUTF8STRINGBYTES 58694 . 59175) (
(LOGOR (LLSH 2 6) XTOUSTRING 59177 . 62188) (XCCSSTRING 62190 . 62551)) (62554 64023 (SHOWCHARS 62564 . 64021)))))
STOP STOP

BIN
library/UNICODE.LCOM
View File

Binary file not shown.

235
library/UNIXMAIL
View File

File diff suppressed because one or more lines are too long

BIN
library/UNIXMAIL.DFASL
View File

Binary file not shown.

54
library/UNIXTELNET
View File

@@ -1,18 +1,27 @@
(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "16-Feb-90 17:00:31" "{piglet/n}<piglet>vanmelle>lispusers>UNIXTELNET;11" 3551 (FILECREATED "30-Sep-2021 19:23:57" {DSK}<Users>briggs>Projects>medley>library>UNIXTELNET.;2 3970
changes to%: (VARS UNIXTELNETCOMS) (FNS UNIX-TCPCHAT.INIT UNIX-TCPCHAT.OPEN UNIX-TCPCHAT.HOST.FILTER UNIX-TCPCHAT.GET.LOGIN) changes to%: (FNS UNIX-TCPCHAT.OPEN)
previous date%: "30-Jan-90 17:47:34" "{piglet/n}<piglet>vanmelle>lispusers>UNIXTELNET;7") previous date%: "16-Feb-90 17:00:31" {DSK}<Users>briggs>Projects>medley>library>UNIXTELNET.;1
)
(* " (* ; "
Copyright (c) 1989, 1990 by Xerox Corporation. All rights reserved. Copyright (c) 1989-1990 by Xerox Corporation.
") ")
(PRETTYCOMPRINT UNIXTELNETCOMS) (PRETTYCOMPRINT UNIXTELNETCOMS)
(RPAQQ UNIXTELNETCOMS ((FNS UNIX-TCPCHAT.HOST.FILTER UNIX-TCPCHAT.OPEN UNIX-TCPCHAT.GET.LOGIN UNIX-TCPCHAT.INIT) (INITVARS (CHAT.LOGINS) (CHAT.LOGINS.MENU)) (GLOBALVARS CHAT.LOGINS CHAT.LOGINS.MENU) (DECLARE%: DONTEVAL@LOAD DOCOPY (FILES (SYSLOAD) UNIXCHAT) (ADDVARS (AROUNDEXITFNS UNIX-TCPCHAT.INIT)) (P (UNIX-TCPCHAT.INIT))))) (RPAQQ UNIXTELNETCOMS
[(FNS UNIX-TCPCHAT.HOST.FILTER UNIX-TCPCHAT.OPEN UNIX-TCPCHAT.GET.LOGIN UNIX-TCPCHAT.INIT)
(INITVARS (CHAT.LOGINS)
(CHAT.LOGINS.MENU))
(GLOBALVARS CHAT.LOGINS CHAT.LOGINS.MENU)
(DECLARE%: DONTEVAL@LOAD DOCOPY (FILES (SYSLOAD)
UNIXCHAT)
(ADDVARS (AROUNDEXITFNS UNIX-TCPCHAT.INIT))
(P (UNIX-TCPCHAT.INIT])
(DEFINEQ (DEFINEQ
(UNIX-TCPCHAT.HOST.FILTER (UNIX-TCPCHAT.HOST.FILTER
@@ -20,8 +29,20 @@ Copyright (c) 1989, 1990 by Xerox Corporation. All rights reserved.
) )
(UNIX-TCPCHAT.OPEN (UNIX-TCPCHAT.OPEN
(LAMBDA (HOST TERMTYPE LOGOPTION) (* ; "Edited 14-Feb-90 18:36 by bvm") (* ;; "For use on Maiko: chat to HOST by using rlogin in a shell window.") (LET (NAME STR) (if (AND (OR (NEQ LOGOPTION (QUOTE NONE)) (SETQ NAME (UNIX-TCPCHAT.GET.LOGIN HOST))) (SETQ STR (CREATE-SHELL-STREAM TERMTYPE (CL:FORMAT NIL "exec rlogin ~@[-l ~A ~]~A" NAME HOST)))) then (STREAMPROP STR (QUOTE SENDSCREENPARAMS) (FUNCTION UNIX.SENDSCREENPARAMS)) (STREAMPROP STR (QUOTE SETDISPLAYTYPE) (FUNCTION UNIX.SETDISPLAYTYPE)) (LIST STR STR (QUOTE LOGOPTION) (QUOTE NONE))))) [LAMBDA (HOST TERMTYPE LOGOPTION) (* ;
)  "Edited 30-Sep-2021 19:23 by briggs")
(* ; "Edited 14-Feb-90 18:36 by bvm")
(* ;; "For use on Maiko: chat to HOST by using ssh in a shell window.")
(LET (NAME STR)
(if [AND (OR (NEQ LOGOPTION 'NONE)
(SETQ NAME (UNIX-TCPCHAT.GET.LOGIN HOST)))
(SETQ STR (CREATE-SHELL-STREAM TERMTYPE (CL:FORMAT NIL "exec ssh ~@[-l ~A ~]~A"
NAME HOST]
then (STREAMPROP STR 'SENDSCREENPARAMS (FUNCTION UNIX.SENDSCREENPARAMS))
(STREAMPROP STR 'SETDISPLAYTYPE (FUNCTION UNIX.SETDISPLAYTYPE))
(LIST STR STR 'LOGOPTION 'NONE])
(UNIX-TCPCHAT.GET.LOGIN (UNIX-TCPCHAT.GET.LOGIN
(LAMBDA (HOST) (* ; "Edited 15-Feb-90 11:28 by bvm") (LET (NAME) (if (OR (NULL CHAT.LOGINS) (EQ (SETQ NAME (MENU (OR CHAT.LOGINS.MENU (SETQ CHAT.LOGINS.MENU (create MENU ITEMS _ (APPEND CHAT.LOGINS (QUOTE (("**other**" T "Prompts for a name to login as")))) CENTERFLG _ T TITLE _ "Log in as:"))))) T)) then (* ; "Prompt for a name") (if (SETQ NAME (CHAT.PROMPT.FOR.INPUT (CL:FORMAT NIL "Log in to ~A as user: " HOST) NIL 16)) then (SETQ CHAT.LOGINS (SORT (CONS NAME CHAT.LOGINS) (FUNCTION UALPHORDER))) (SETQ CHAT.LOGINS.MENU NIL))) NAME)) (LAMBDA (HOST) (* ; "Edited 15-Feb-90 11:28 by bvm") (LET (NAME) (if (OR (NULL CHAT.LOGINS) (EQ (SETQ NAME (MENU (OR CHAT.LOGINS.MENU (SETQ CHAT.LOGINS.MENU (create MENU ITEMS _ (APPEND CHAT.LOGINS (QUOTE (("**other**" T "Prompts for a name to login as")))) CENTERFLG _ T TITLE _ "Log in as:"))))) T)) then (* ; "Prompt for a name") (if (SETQ NAME (CHAT.PROMPT.FOR.INPUT (CL:FORMAT NIL "Log in to ~A as user: " HOST) NIL 16)) then (SETQ CHAT.LOGINS (SORT (CONS NAME CHAT.LOGINS) (FUNCTION UALPHORDER))) (SETQ CHAT.LOGINS.MENU NIL))) NAME))
@@ -32,25 +53,26 @@ Copyright (c) 1989, 1990 by Xerox Corporation. All rights reserved.
) )
) )
(RPAQ? CHAT.LOGINS) (RPAQ? CHAT.LOGINS )
(RPAQ? CHAT.LOGINS.MENU) (RPAQ? CHAT.LOGINS.MENU )
(DECLARE%: DOEVAL@COMPILE DONTCOPY (DECLARE%: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS CHAT.LOGINS CHAT.LOGINS.MENU) (GLOBALVARS CHAT.LOGINS CHAT.LOGINS.MENU)
) )
(DECLARE%: DONTEVAL@LOAD DOCOPY (DECLARE%: DONTEVAL@LOAD DOCOPY
(FILESLOAD (SYSLOAD) UNIXCHAT) (FILESLOAD (SYSLOAD)
UNIXCHAT)
(ADDTOVAR AROUNDEXITFNS UNIX-TCPCHAT.INIT) (ADDTOVAR AROUNDEXITFNS UNIX-TCPCHAT.INIT)
(UNIX-TCPCHAT.INIT) (UNIX-TCPCHAT.INIT)
) )
(PUTPROPS UNIXTELNET COPYRIGHT ("Xerox Corporation" 1989 1990)) (PUTPROPS UNIXTELNET COPYRIGHT ("Xerox Corporation" 1989 1990))
(DECLARE%: DONTCOPY (DECLARE%: DONTCOPY
(FILEMAP (NIL (836 3203 (UNIX-TCPCHAT.HOST.FILTER 846 . 1353) (UNIX-TCPCHAT.OPEN 1355 . 1924) ( (FILEMAP (NIL (872 3597 (UNIX-TCPCHAT.HOST.FILTER 882 . 1389) (UNIX-TCPCHAT.OPEN 1391 . 2318) (
UNIX-TCPCHAT.GET.LOGIN 1926 . 2495) (UNIX-TCPCHAT.INIT 2497 . 3201))))) UNIX-TCPCHAT.GET.LOGIN 2320 . 2889) (UNIX-TCPCHAT.INIT 2891 . 3595)))))
STOP STOP

BIN
library/UNIXTELNET.LCOM
View File

Binary file not shown.

86
library/VTCHAT
View File

@@ -1,40 +1,37 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "20-Jan-93 15:06:01" {DSK}<python>lde>lispcore>library>VTCHAT.;2 21782 (FILECREATED "30-Sep-2021 17:41:51" {DSK}<Users>briggs>Projects>medley>library>VTCHAT.;4 21924
changes to%: (RECORDS VT100SAVE VT100.STATE) changes to%: (FNS VTCHAT.STATUS)
previous date%: "13-Jun-90 01:22:35" {DSK}<python>lde>lispcore>library>VTCHAT.;1) previous date%: "20-Jan-93 15:06:01" {DSK}<Users>briggs>Projects>medley>library>VTCHAT.;3)
(* ; " (* ; "
Copyright (c) 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1993 by Venue & Xerox Corporation. All rights reserved. Copyright (c) 1983-1988, 1990, 1993 by Venue & Xerox Corporation.
") ")
(PRETTYCOMPRINT VTCHATCOMS) (PRETTYCOMPRINT VTCHATCOMS)
(RPAQQ VTCHATCOMS [ (RPAQQ VTCHATCOMS
(* ;; "VT100 emulator") [
(* ;; "VT100 emulator")
(FNS VTCHAT.STATE VTCHAT.HANDLECHARACTER VTCHAT.SEQUENCE VTCHAT.DOCOMMAND) (FNS VTCHAT.STATE VTCHAT.HANDLECHARACTER VTCHAT.SEQUENCE VTCHAT.DOCOMMAND)
(FNS VTCHAT.ADDRESS VTCHAT.REVERSE.INDEX VTCHAT.ATTRIBUTES VTCHAT.DECLFONT (FNS VTCHAT.ADDRESS VTCHAT.REVERSE.INDEX VTCHAT.ATTRIBUTES VTCHAT.DECLFONT VTCHAT.CLEARMODES
VTCHAT.CLEARMODES VTCHAT.SAVE VTCHAT.RESTORE VTCHAT.SETMODE VTCHAT.SAVE VTCHAT.RESTORE VTCHAT.SETMODE VTCHAT.SETMARGINS VTCHAT.REPORT VTCHAT.STATUS)
VTCHAT.SETMARGINS VTCHAT.REPORT VTCHAT.STATUS) (INITVARS (VTCHAT.DEBUGGING.FLG)
(INITVARS (VTCHAT.DEBUGGING.FLG) (VTCHAT.TERM.IDENTITY.STRING "[?1;0c"))
(VTCHAT.TERM.IDENTITY.STRING "[?1;0c")) (GLOBALVARS VTCHAT.DEBUGGING.FLG CHATFONT GRAPHICSFONT VTCHAT.TERM.IDENTITY.STRING)
(GLOBALVARS VTCHAT.DEBUGGING.FLG CHATFONT GRAPHICSFONT (ADDVARS (CHAT.DRIVERTYPES (VT100 VTCHAT.HANDLECHARACTER VTCHAT.STATE)))
VTCHAT.TERM.IDENTITY.STRING) (DECLARE%: EVAL@COMPILE DONTCOPY (LOCALVARS . T)
(ADDVARS (CHAT.DRIVERTYPES (VT100 VTCHAT.HANDLECHARACTER VTCHAT.STATE))) (FILES (LOADCOMP)
(DECLARE%: EVAL@COMPILE DONTCOPY (LOCALVARS . T) CHATDECLS)
(FILES (LOADCOMP) (RECORDS VT100SAVE VT100.STATE))
CHATDECLS) (INITRECORDS VT100.STATE)
(RECORDS VT100SAVE VT100.STATE)) (SYSRECORDS VT100.STATE)
(INITRECORDS VT100.STATE) (DECLARE%: DONTEVAL@LOAD DOCOPY (FILES (SYSLOAD)
(SYSRECORDS VT100.STATE) VT100KP)
(DECLARE%: DONTEVAL@LOAD DOCOPY (FILES (SYSLOAD) (ADDVARS (CHAT.DISPLAYTYPES ("Replace this string with NIL to prefer vt100" NIL VT100])
VT100KP)
(ADDVARS (CHAT.DISPLAYTYPES (
"Replace this string with NIL to prefer vt100"
NIL VT100])
@@ -101,8 +98,29 @@ Copyright (c) 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1993 by Venue & Xerox Co
) )
(VTCHAT.STATUS (VTCHAT.STATUS
(LAMBDA (CHAT.STATE VT100.STATE TYPE) (* ; "Edited 18-Dec-86 15:16 by amd") (* ;; "Returns VT100 status info") (LET ((OUTSTREAM (ffetch (CHAT.STATE OUTSTREAM) of (\DTEST CHAT.STATE (QUOTE CHAT.STATE))))) (SELECTQ TYPE (5 (* ; "Host wants device status") (PRIN1 "" OUTSTREAM)) (6 (* ; "Host wants cursor coords") (BOUT OUTSTREAM (CHARCODE ESC)) (BOUT OUTSTREAM (CHARCODE %[)) (BOUT OUTSTREAM (MKSTRING (ADD1 (IQUOTIENT (ffetch (CHAT.STATE YPOS) of CHAT.STATE) (ffetch (CHAT.STATE FONTHEIGHT) of CHAT.STATE))))) (BOUT OUTSTREAM (CHARCODE ;)) (BOUT OUTSTREAM (MKSTRING (ADD1 (IQUOTIENT (ffetch (CHAT.STATE XPOS) of CHAT.STATE) (ffetch (CHAT.STATE FONTWIDTH) of CHAT.STATE))))) (BOUT OUTSTREAM (CHARCODE R))) NIL) (FORCEOUTPUT OUTSTREAM))) [LAMBDA (CHAT.STATE VT100.STATE TYPE) (* ;
)  "Edited 30-Sep-2021 17:30 by briggs")
(* ; "Edited 18-Dec-86 15:16 by amd")
(* ;; "Returns VT100 status info")
(LET [(OUTSTREAM (ffetch (CHAT.STATE OUTSTREAM) of (\DTEST CHAT.STATE 'CHAT.STATE]
(SELECTQ TYPE
(5 (* ; "Host wants device status")
(PRIN1 "" OUTSTREAM))
(6 (* ; "Host wants cursor coords")
(BOUT OUTSTREAM (CHARCODE ESC))
(BOUT OUTSTREAM (CHARCODE %[))
(PRIN1 (ADD1 (IQUOTIENT (ffetch (CHAT.STATE YPOS) of CHAT.STATE)
(ffetch (CHAT.STATE FONTHEIGHT) of CHAT.STATE)))
OUTSTREAM)
(BOUT OUTSTREAM (CHARCODE ;))
(PRIN1 (ADD1 (IQUOTIENT (ffetch (CHAT.STATE XPOS) of CHAT.STATE)
(ffetch (CHAT.STATE FONTWIDTH) of CHAT.STATE)))
OUTSTREAM)
(BOUT OUTSTREAM (CHARCODE R)))
NIL)
(FORCEOUTPUT OUTSTREAM])
) )
(RPAQ? VTCHAT.DEBUGGING.FLG ) (RPAQ? VTCHAT.DEBUGGING.FLG )
@@ -236,10 +254,10 @@ Copyright (c) 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1993 by Venue & Xerox Co
) )
(PUTPROPS VTCHAT COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1990 1993)) (PUTPROPS VTCHAT COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1990 1993))
(DECLARE%: DONTCOPY (DECLARE%: DONTCOPY
(FILEMAP (NIL (1995 10061 (VTCHAT.STATE 2005 . 2515) (VTCHAT.HANDLECHARACTER 2517 . 5091) ( (FILEMAP (NIL (1532 9598 (VTCHAT.STATE 1542 . 2052) (VTCHAT.HANDLECHARACTER 2054 . 4628) (
VTCHAT.SEQUENCE 5093 . 6636) (VTCHAT.DOCOMMAND 6638 . 10059)) (10062 16968 (VTCHAT.ADDRESS 10072 . VTCHAT.SEQUENCE 4630 . 6173) (VTCHAT.DOCOMMAND 6175 . 9596)) (9599 17110 (VTCHAT.ADDRESS 9609 . 10127)
10590) (VTCHAT.REVERSE.INDEX 10592 . 11161) (VTCHAT.ATTRIBUTES 11163 . 11549) (VTCHAT.DECLFONT 11551 (VTCHAT.REVERSE.INDEX 10129 . 10698) (VTCHAT.ATTRIBUTES 10700 . 11086) (VTCHAT.DECLFONT 11088 . 11357
. 11820) (VTCHAT.CLEARMODES 11822 . 12325) (VTCHAT.SAVE 12327 . 13066) (VTCHAT.RESTORE 13068 . 13775) ) (VTCHAT.CLEARMODES 11359 . 11862) (VTCHAT.SAVE 11864 . 12603) (VTCHAT.RESTORE 12605 . 13312) (
(VTCHAT.SETMODE 13777 . 14849) (VTCHAT.SETMARGINS 14851 . 15442) (VTCHAT.REPORT 15444 . 16204) ( VTCHAT.SETMODE 13314 . 14386) (VTCHAT.SETMARGINS 14388 . 14979) (VTCHAT.REPORT 14981 . 15741) (
VTCHAT.STATUS 16206 . 16966))))) VTCHAT.STATUS 15743 . 17108)))))
STOP STOP

BIN
library/VTCHAT.LCOM
View File

Binary file not shown.

89
library/lafite/LAFITE
View File

@@ -1,12 +1,11 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "24-Jun-2021 19:17:01"  (FILECREATED "30-Sep-2021 22:59:08" 
{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>lafite>LAFITE.;4 71992 {DSK}<Users>kaplan>Local>medley3.5>git-medley>library>lafite>LAFITE.;5 71956
changes to%: (FNS \LAFITE.EOF) changes to%: (FILES LAFITEDECLS)
(FILES LAFITEDECLS)
previous date%: "22-Aug-94 13:00:22" previous date%: "24-Jun-2021 19:17:01"
{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>lafite>LAFITE.;2) {DSK}<Users>kaplan>Local>medley3.5>git-medley>library>lafite>LAFITE.;4)
(* ; " (* ; "
@@ -75,19 +74,19 @@ Copyright (c) 1982-1989, 1993-1994, 2021 by Xerox Corporation and Bolt Beranek a
(LAFITE.PERSONAL.VARS LAFITEDEFAULTHOST&DIR LAFITE.SIGNATURE)) (LAFITE.PERSONAL.VARS LAFITEDEFAULTHOST&DIR LAFITE.SIGNATURE))
(FNS LAFITE.AROUNDEXIT \LAFITE.MARK.FOLDERS.OBSOLETE \LAFITE.CHECK.FOLDERS (FNS LAFITE.AROUNDEXIT \LAFITE.MARK.FOLDERS.OBSOLETE \LAFITE.CHECK.FOLDERS
\LAFITE.ASSURE.FOLDER.READY \LAFITE.AFTERLOGIN)) \LAFITE.ASSURE.FOLDER.READY \LAFITE.AFTERLOGIN))
(COMS (* ; "misc utilities") (COMS (* ; "misc utilities")
(FNS LA.RESETSHADE LA.MENU.ITEM NTHMESSAGE \LAFITE.MAKE.MSGARRAY (FNS LA.RESETSHADE LA.MENU.ITEM NTHMESSAGE \LAFITE.MAKE.MSGARRAY
\LAFITE.ADDMESSAGES.TO.ARRAY \MAILFOLDER.DEFPRINT \LAFITEMSG.DEFPRINT \LAFITE.ADDMESSAGES.TO.ARRAY \MAILFOLDER.DEFPRINT \LAFITEMSG.DEFPRINT
LA.POSITION.FROM.REGION MAILFOLDERBUSY) LA.POSITION.FROM.REGION MAILFOLDERBUSY)
(CURSORS LA.CROSSCURSOR) (CURSORS LA.CROSSCURSOR)
(* ; "Low level file functions") (* ; "Low level file functions")
(FNS TOCFILENAME DELETEMAILFOLDER \LAFITE.OPEN.FOLDER \LAFITE.REPORT.FILE.WONT.OPEN (FNS TOCFILENAME DELETEMAILFOLDER \LAFITE.OPEN.FOLDER \LAFITE.REPORT.FILE.WONT.OPEN
\LAFITE.FOLDER.CHANGED \LAFITE.REBROWSE.FOLDER \LAFITE.FOLDER.CHANGED.MENU \LAFITE.FOLDER.CHANGED \LAFITE.REBROWSE.FOLDER \LAFITE.FOLDER.CHANGED.MENU
\LAFITE.SET.FOLDER.STREAM \LAFITE.OPENSTREAM \LAFITE.CREATE.MENU \LAFITE.EOF \LAFITE.SET.FOLDER.STREAM \LAFITE.OPENSTREAM \LAFITE.CREATE.MENU \LAFITE.EOF
\LAFITE.CLOSE.FOLDER) \LAFITE.CLOSE.FOLDER)
(FNS \LAFITE.DESCRIBE.FOLDER)) (FNS \LAFITE.DESCRIBE.FOLDER))
(COMS (* ; (COMS (* ;
 "Make is easy to load new versions of Lafite")  "Make is easy to load new versions of Lafite")
(FNS LOAD-LAFITE) (FNS LOAD-LAFITE)
(VARS LAFITEFILES)) (VARS LAFITEFILES))
[DECLARE%: DOEVAL@COMPILE DONTCOPY (FILES (SOURCE) [DECLARE%: DOEVAL@COMPILE DONTCOPY (FILES (SOURCE)
@@ -102,14 +101,14 @@ Copyright (c) 1982-1989, 1993-1994, 2021 by Xerox Corporation and Bolt Beranek a
(FILES LAFITEBROWSE LAFITECOMMANDS LAFITEFOLDERS LAFITESEND LAFITEMAIL (FILES LAFITEBROWSE LAFITECOMMANDS LAFITEFOLDERS LAFITESEND LAFITEMAIL
LAFITESORT TEDIT LAFITETEDIT LAFITEFIND ATTACHEDWINDOW MAILSCAVENGE) LAFITESORT TEDIT LAFITETEDIT LAFITEFIND ATTACHEDWINDOW MAILSCAVENGE)
(P * (PROGN LAFITE.PROCLAMATIONS)) (P * (PROGN LAFITE.PROCLAMATIONS))
(* ; (* ;
 "Proclaim user interface variables. Value is on LAFITEDECLS")  "Proclaim user interface variables. Value is on LAFITEDECLS")
(P (\LAFITE.GLOBAL.INIT) (P (\LAFITE.GLOBAL.INIT)
(COND ((EQ MAKESYSNAME :LYRIC) (COND ((EQ MAKESYSNAME :LYRIC)
(FILESLOAD (SYSLOAD) (FILESLOAD (SYSLOAD)
NSCHARPATCH) NSCHARPATCH)
(* ; (* ;
 "Patch to horrid Lyric NS chars bug")  "Patch to horrid Lyric NS chars bug")
(MOVD? 'PROMPTFORWORD 'TTYINPROMPTFORWORD NIL T] (MOVD? 'PROMPTFORWORD 'TTYINPROMPTFORWORD NIL T]
(DECLARE%: DOEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (DECLARE%: DOEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML) (NLAML)
@@ -117,7 +116,7 @@ Copyright (c) 1982-1989, 1993-1994, 2021 by Xerox Corporation and Bolt Beranek a
(RPAQQ LAFITEVERSION# 10) (RPAQQ LAFITEVERSION# 10)
(RPAQQ LAFITESYSTEMDATE "24-Jun-2021 19:17:01") (RPAQQ LAFITESYSTEMDATE "30-Sep-2021 22:59:08")
(DEFINEQ (DEFINEQ
(LAFITE (LAFITE
@@ -277,8 +276,8 @@ Mode affects SendMail only; mail is still retrieved in all modes.~]" (if \LAFITE
DEFAULTFONT) DEFAULTFONT)
(CHARWIDTH (CHARCODE "W") (CHARWIDTH (CHARCODE "W")
DEFAULTFONT)) DEFAULTFONT))
(* ; (* ;
 "Yes, user has not changed default to a variable width font")  "Yes, user has not changed default to a variable width font")
DEFAULTFONT) DEFAULTFONT)
(T (FONTCREATE '(GACHA 10] (T (FONTCREATE '(GACHA 10]
(LAFITEHARDCOPYFONT LAFITEDISPLAYFONT) (LAFITEHARDCOPYFONT LAFITEDISPLAYFONT)
@@ -317,8 +316,8 @@ Mode affects SendMail only; mail is still retrieved in all modes.~]" (if \LAFITE
DEFAULTFONT) DEFAULTFONT)
(CHARWIDTH (CHARCODE "W") (CHARWIDTH (CHARCODE "W")
DEFAULTFONT)) DEFAULTFONT))
(* ; (* ;
 "Yes, user has not changed default to a variable width font")  "Yes, user has not changed default to a variable width font")
DEFAULTFONT) DEFAULTFONT)
(T (FONTCREATE '(GACHA 10]) (T (FONTCREATE '(GACHA 10])
@@ -864,8 +863,8 @@ Mode affects SendMail only; mail is still retrieved in all modes.~]" (if \LAFITE
(COND (COND
((EQ MAKESYSNAME :LYRIC) ((EQ MAKESYSNAME :LYRIC)
(FILESLOAD (SYSLOAD) (FILESLOAD (SYSLOAD)
NSCHARPATCH) (* ; NSCHARPATCH) (* ;
 "Patch to horrid Lyric NS chars bug")  "Patch to horrid Lyric NS chars bug")
(MOVD? 'PROMPTFORWORD 'TTYINPROMPTFORWORD NIL T))) (MOVD? 'PROMPTFORWORD 'TTYINPROMPTFORWORD NIL T)))
) )
(DECLARE%: DOEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (DECLARE%: DOEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
@@ -879,28 +878,28 @@ Mode affects SendMail only; mail is still retrieved in all modes.~]" (if \LAFITE
(PUTPROPS LAFITE COPYRIGHT ("Xerox Corporation and Bolt Beranek and Newman Inc." 1982 1983 1984 1985 (PUTPROPS LAFITE COPYRIGHT ("Xerox Corporation and Bolt Beranek and Newman Inc." 1982 1983 1984 1985
1986 1987 1988 1989 1993 1994 2021)) 1986 1987 1988 1989 1993 1994 2021))
(DECLARE%: DONTCOPY (DECLARE%: DONTCOPY
(FILEMAP (NIL (7140 22186 (LAFITE 7150 . 8461) (LAFITE.ON.FROM.BACKGROUND 8463 . 8834) (\LAFITE.OFF (FILEMAP (NIL (7104 22150 (LAFITE 7114 . 8425) (LAFITE.ON.FROM.BACKGROUND 8427 . 8798) (\LAFITE.OFF
8836 . 9220) (\LAFITE.START.PROC 9222 . 10998) (LAFITE.COMPUTE.CACHED.VARS 11000 . 13702) ( 8800 . 9184) (\LAFITE.START.PROC 9186 . 10962) (LAFITE.COMPUTE.CACHED.VARS 10964 . 13666) (
\LAFITE.PROCESS 13704 . 14070) (\LAFITE.START.ABORT 14072 . 14264) (\LAFITE.QUIT 14266 . 14508) ( \LAFITE.PROCESS 13668 . 14034) (\LAFITE.START.ABORT 14036 . 14228) (\LAFITE.QUIT 14230 . 14472) (
\LAFITE.RESTART 14510 . 14643) (\LAFITE.SUBQUIT 14645 . 15943) (\LAFITE.QUIT.PROC 15945 . 18681) ( \LAFITE.RESTART 14474 . 14607) (\LAFITE.SUBQUIT 14609 . 15907) (\LAFITE.QUIT.PROC 15909 . 18645) (
\LAFITEDEFAULTHOST&DIR 18683 . 19493) (LAFITEDEFAULTHOST&DIR 19495 . 19665) (MAKELAFITECOMMANDWINDOW \LAFITEDEFAULTHOST&DIR 18647 . 19457) (LAFITEDEFAULTHOST&DIR 19459 . 19629) (MAKELAFITECOMMANDWINDOW
19667 . 21306) (EXTRACTMENUCOMMAND 21308 . 21556) (DOMAINLAFITECOMMAND 21558 . 21707) ( 19631 . 21270) (EXTRACTMENUCOMMAND 21272 . 21520) (DOMAINLAFITECOMMAND 21522 . 21671) (
LAFITE.TOGGLE.SERVER.TRACE 21709 . 22184)) (22261 25229 (LAFITEMODE 22271 . 22751) (\LAFITE.INFER.MODE LAFITE.TOGGLE.SERVER.TRACE 21673 . 22148)) (22225 25193 (LAFITEMODE 22235 . 22715) (\LAFITE.INFER.MODE
22753 . 23106) (\LAFITE.SHOW.MODE 23108 . 23345) (\LAFITE.MODE.TITLE 23347 . 23632) ( 22717 . 23070) (\LAFITE.SHOW.MODE 23072 . 23309) (\LAFITE.MODE.TITLE 23311 . 23596) (
LAFITE.SHOW.MODE.P 23634 . 23875) (LAFITE.ALL.MODES.P 23877 . 24220) (SET.LAFITE.MODE.INTERACTIVELY LAFITE.SHOW.MODE.P 23598 . 23839) (LAFITE.ALL.MODES.P 23841 . 24184) (SET.LAFITE.MODE.INTERACTIVELY
24222 . 24804) (\LAFITE.COMPUTE.MODE.COMMANDS 24806 . 25227)) (26079 27835 (\LAFITE.LOGIN 26089 . 24186 . 24768) (\LAFITE.COMPUTE.MODE.COMMANDS 24770 . 25191)) (26043 27799 (\LAFITE.LOGIN 26053 .
26471) (\LAFITE.LOGIN.NORESTART 26473 . 26579) (LAFITE.PROMPT.FOR.LOGIN 26581 . 27600) ( 26435) (\LAFITE.LOGIN.NORESTART 26437 . 26543) (LAFITE.PROMPT.FOR.LOGIN 26545 . 27564) (
\LAFITE.REAUTHENTICATE 27602 . 27833)) (35346 38788 (LAFITE.AROUNDEXIT 35356 . 35894) ( \LAFITE.REAUTHENTICATE 27566 . 27797)) (35310 38752 (LAFITE.AROUNDEXIT 35320 . 35858) (
\LAFITE.MARK.FOLDERS.OBSOLETE 35896 . 36812) (\LAFITE.CHECK.FOLDERS 36814 . 37213) ( \LAFITE.MARK.FOLDERS.OBSOLETE 35860 . 36776) (\LAFITE.CHECK.FOLDERS 36778 . 37177) (
\LAFITE.ASSURE.FOLDER.READY 37215 . 37625) (\LAFITE.AFTERLOGIN 37627 . 38786)) (38820 41758 ( \LAFITE.ASSURE.FOLDER.READY 37179 . 37589) (\LAFITE.AFTERLOGIN 37591 . 38750)) (38784 41722 (
LA.RESETSHADE 38830 . 39208) (LA.MENU.ITEM 39210 . 39628) (NTHMESSAGE 39630 . 39713) ( LA.RESETSHADE 38794 . 39172) (LA.MENU.ITEM 39174 . 39592) (NTHMESSAGE 39594 . 39677) (
\LAFITE.MAKE.MSGARRAY 39715 . 40145) (\LAFITE.ADDMESSAGES.TO.ARRAY 40147 . 40728) ( \LAFITE.MAKE.MSGARRAY 39679 . 40109) (\LAFITE.ADDMESSAGES.TO.ARRAY 40111 . 40692) (
\MAILFOLDER.DEFPRINT 40730 . 40977) (\LAFITEMSG.DEFPRINT 40979 . 41141) (LA.POSITION.FROM.REGION 41143 \MAILFOLDER.DEFPRINT 40694 . 40941) (\LAFITEMSG.DEFPRINT 40943 . 41105) (LA.POSITION.FROM.REGION 41107
. 41620) (MAILFOLDERBUSY 41622 . 41756)) (41936 58324 (TOCFILENAME 41946 . 42377) (DELETEMAILFOLDER . 41584) (MAILFOLDERBUSY 41586 . 41720)) (41900 58288 (TOCFILENAME 41910 . 42341) (DELETEMAILFOLDER
42379 . 42899) (\LAFITE.OPEN.FOLDER 42901 . 47516) (\LAFITE.REPORT.FILE.WONT.OPEN 47518 . 48242) ( 42343 . 42863) (\LAFITE.OPEN.FOLDER 42865 . 47480) (\LAFITE.REPORT.FILE.WONT.OPEN 47482 . 48206) (
\LAFITE.FOLDER.CHANGED 48244 . 50648) (\LAFITE.REBROWSE.FOLDER 50650 . 53615) ( \LAFITE.FOLDER.CHANGED 48208 . 50612) (\LAFITE.REBROWSE.FOLDER 50614 . 53579) (
\LAFITE.FOLDER.CHANGED.MENU 53617 . 54540) (\LAFITE.SET.FOLDER.STREAM 54542 . 55236) ( \LAFITE.FOLDER.CHANGED.MENU 53581 . 54504) (\LAFITE.SET.FOLDER.STREAM 54506 . 55200) (
\LAFITE.OPENSTREAM 55238 . 55777) (\LAFITE.CREATE.MENU 55779 . 56132) (\LAFITE.EOF 56134 . 57476) ( \LAFITE.OPENSTREAM 55202 . 55741) (\LAFITE.CREATE.MENU 55743 . 56096) (\LAFITE.EOF 56098 . 57440) (
\LAFITE.CLOSE.FOLDER 57478 . 58322)) (58325 58909 (\LAFITE.DESCRIBE.FOLDER 58335 . 58907)) (58970 \LAFITE.CLOSE.FOLDER 57442 . 58286)) (58289 58873 (\LAFITE.DESCRIBE.FOLDER 58299 . 58871)) (58934
60076 (LOAD-LAFITE 58980 . 60074)) (67787 69064 (\LAFITE.GLOBAL.INIT 67797 . 69062))))) 60040 (LOAD-LAFITE 58944 . 60038)) (67751 69028 (\LAFITE.GLOBAL.INIT 67761 . 69026)))))
STOP STOP

BIN
library/lafite/LAFITE.LCOM
View File

Binary file not shown.

2468
library/lafite/LAFITEBROWSE
View File

File diff suppressed because one or more lines are too long

BIN
library/lafite/LAFITEBROWSE.LCOM
View File

Binary file not shown.

2730
library/lafite/LAFITECOMMANDS
View File

File diff suppressed because one or more lines are too long

BIN
library/lafite/LAFITECOMMANDS.LCOM
View File

Binary file not shown.

138
library/lafite/LAFITEFIND
View File

@@ -1,47 +1,45 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED " 3-Jun-92 10:10:41" {DSK}<usr>local>users>welch>lisp>lafite>LAFITEFIND.;2 15951 (FILECREATED "30-Sep-2021 23:01:05" 
{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>lafite>LAFITEFIND.;2 14882
previous date%: "15-Jun-90 16:06:40" {DSK}<usr>local>users>welch>lisp>lafite>LAFITEFIND.;1) changes to%: (FILES LAFITEDECLS)
previous date%: " 3-Jun-92 10:10:41"
{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>lafite>LAFITEFIND.;1)
(* ; " (* ; "
Copyright (c) 1984, 1985, 1986, 1987, 1988, 1990, 1992 by Venue & Xerox Corporation. All rights reserved. Copyright (c) 1984-1988, 1990, 1992, 2021 by Venue & Xerox Corporation.
") ")
(PRETTYCOMPRINT LAFITEFINDCOMS) (PRETTYCOMPRINT LAFITEFINDCOMS)
(RPAQQ LAFITEFINDCOMS ((FNS \LAFITE.FIND \LAFITE.FIND.RELATED \LAFITE.FIND.RELATED.BACKWARD (RPAQQ LAFITEFINDCOMS
\LAFITE.GO.TO.FIRST \LAFITE.GO.TO.INTERACTIVE \LAFITE.GO.TO.LAST ((FNS \LAFITE.FIND \LAFITE.FIND.RELATED \LAFITE.FIND.RELATED.BACKWARD \LAFITE.GO.TO.FIRST
\LAFITE.FIND.AGAIN \LAFITE.FIND.PROMPT \LAFITE.DO.FIND \LAFITE.GO.TO.INTERACTIVE \LAFITE.GO.TO.LAST \LAFITE.FIND.AGAIN \LAFITE.FIND.PROMPT
\LAFITE.FIND.START) \LAFITE.DO.FIND \LAFITE.FIND.START)
(DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS SEARCHSTATE) (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS SEARCHSTATE)
(GLOBALVARS LAFITEFINDAREAMENUITEMS LAFITEFINDTYPEMENUITEMS (GLOBALVARS LAFITEFINDAREAMENUITEMS LAFITEFINDTYPEMENUITEMS LAFITEFINDTYPEMENU
LAFITEFINDTYPEMENU LAFITEFINDAREAMENU LAFITEEXTRAMENU LAFITEFINDAREAMENU LAFITEEXTRAMENU LAFITEEXTRAMENUFLG \LAFITE.LAST.SEARCH)
LAFITEEXTRAMENUFLG \LAFITE.LAST.SEARCH) (FILES (SOURCE)
(FILES (SOURCE) LAFITEDECLS)
LAFITEDECLS) (LOCALVARS . T))
(LOCALVARS . T)) (INITVARS LAFITEFINDTYPEMENU LAFITEFINDAREAMENU)
(INITVARS LAFITEFINDTYPEMENU LAFITEFINDAREAMENU) (VARS LAFITEFINDAREAMENUITEMS LAFITEFINDTYPEMENUITEMS)
(VARS LAFITEFINDAREAMENUITEMS LAFITEFINDTYPEMENUITEMS) (ADDVARS [LAFITEEXTRAMENUITEMS ("Find" '\LAFITE.FIND "Search mail for something")
(ADDVARS [LAFITEEXTRAMENUITEMS ("Find" '\LAFITE.FIND ["Find Related" '\LAFITE.FIND.RELATED
"Search mail for something") "Find all messages from here on in reply to this message"
["Find Related" '\LAFITE.FIND.RELATED (SUBITEMS ("Find Related Forward" '\LAFITE.FIND.RELATED)
"Find all messages from here on in reply to this message" ("Find Related Backward" '\LAFITE.FIND.RELATED.BACKWARD]
(SUBITEMS ("Find Related Forward" ("Find Again" '\LAFITE.FIND.AGAIN "Repeat previous search")
'\LAFITE.FIND.RELATED) ("Go to #" '\LAFITE.GO.TO.INTERACTIVE
("Find Related Backward" "Scroll to and select a specific message by number."
'\LAFITE.FIND.RELATED.BACKWARD] (SUBITEMS ("Go to First" '\LAFITE.GO.TO.FIRST
("Find Again" '\LAFITE.FIND.AGAIN "Repeat previous search" "Scroll to and select first message.")
) ("Go to Last" '\LAFITE.GO.TO.LAST
("Go to #" '\LAFITE.GO.TO.INTERACTIVE "Scroll to and select last message."]
"Scroll to and select a specific message by number." (LAFITEMENUVARS LAFITEFINDTYPEMENU LAFITEFINDAREAMENU))
(SUBITEMS ("Go to First" '\LAFITE.GO.TO.FIRST (VARS (\LAFITE.LAST.SEARCH))))
"Scroll to and select first message."
)
("Go to Last" '\LAFITE.GO.TO.LAST
"Scroll to and select last message."]
(LAFITEMENUVARS LAFITEFINDTYPEMENU LAFITEFINDAREAMENU))
(VARS (\LAFITE.LAST.SEARCH))))
(DEFINEQ (DEFINEQ
(\LAFITE.FIND (\LAFITE.FIND
@@ -147,45 +145,47 @@ Copyright (c) 1984, 1985, 1986, 1987, 1988, 1990, 1992 by Venue & Xerox Corporat
(RPAQ? LAFITEFINDAREAMENU NIL) (RPAQ? LAFITEFINDAREAMENU NIL)
(RPAQQ LAFITEFINDAREAMENUITEMS ((From 'From "Search From: field for string (or To: if from self)" (RPAQQ LAFITEFINDAREAMENUITEMS
) ((From 'From "Search From: field for string (or To: if from self)")
(Subject 'Subject "Search Subject: field for string") (Subject 'Subject "Search Subject: field for string")
(Body 'Body "Search message bodies for string") (Body 'Body "Search message bodies for string")
(Mark 'Mark "Search for messages with specified mark character") (Mark 'Mark "Search for messages with specified mark character")
(Related 'Related (Related 'Related "Search for a message with same Subject, modulo Re:")))
"Search for a message with same Subject, modulo Re:")))
(RPAQQ LAFITEFINDTYPEMENUITEMS (("Find Next One" '(FORWARD ONE) (RPAQQ LAFITEFINDTYPEMENUITEMS
"Search forward from selected message") (("Find Next One" '(FORWARD ONE)
("Find Next All" '(FORWARD ALL) "Search forward from selected message")
"Search forward from selected message") ("Find Next All" '(FORWARD ALL)
("Find Previous One" '(BACKWARD ONE) "Search forward from selected message")
"Search backward from selected message") ("Find Previous One" '(BACKWARD ONE)
("Find Previous All" '(BACKWARD ALL) "Search backward from selected message")
"Search backward from selected message"))) ("Find Previous All" '(BACKWARD ALL)
"Search backward from selected message")))
(ADDTOVAR LAFITEEXTRAMENUITEMS ("Find" '\LAFITE.FIND "Search mail for something") (ADDTOVAR LAFITEEXTRAMENUITEMS
["Find Related" '\LAFITE.FIND.RELATED ("Find" '\LAFITE.FIND "Search mail for something")
"Find all messages from here on in reply to this message" ["Find Related" '\LAFITE.FIND.RELATED
(SUBITEMS ("Find Related Forward" '\LAFITE.FIND.RELATED) "Find all messages from here on in reply to this message" (SUBITEMS
("Find Related Backward" ("Find Related Forward"
'\LAFITE.FIND.RELATED.BACKWARD] '\LAFITE.FIND.RELATED)
("Find Again" '\LAFITE.FIND.AGAIN "Repeat previous search") ("Find Related Backward"
("Go to #" '\LAFITE.GO.TO.INTERACTIVE
"Scroll to and select a specific message by number." '
(SUBITEMS ("Go to First" '\LAFITE.GO.TO.FIRST \LAFITE.FIND.RELATED.BACKWARD
"Scroll to and select first message.") ]
("Go to Last" '\LAFITE.GO.TO.LAST ("Find Again" '\LAFITE.FIND.AGAIN "Repeat previous search")
"Scroll to and select last message.")))) ("Go to #" '\LAFITE.GO.TO.INTERACTIVE "Scroll to and select a specific message by number."
(SUBITEMS ("Go to First" '\LAFITE.GO.TO.FIRST "Scroll to and select first message.")
("Go to Last" '\LAFITE.GO.TO.LAST "Scroll to and select last message."))))
(ADDTOVAR LAFITEMENUVARS LAFITEFINDTYPEMENU LAFITEFINDAREAMENU) (ADDTOVAR LAFITEMENUVARS LAFITEFINDTYPEMENU LAFITEFINDAREAMENU)
(RPAQQ \LAFITE.LAST.SEARCH NIL) (RPAQQ \LAFITE.LAST.SEARCH NIL)
(PUTPROPS LAFITEFIND COPYRIGHT ("Venue & Xerox Corporation" 1984 1985 1986 1987 1988 1990 1992)) (PUTPROPS LAFITEFIND COPYRIGHT ("Venue & Xerox Corporation" 1984 1985 1986 1987 1988 1990 1992 2021))
(DECLARE%: DONTCOPY (DECLARE%: DONTCOPY
(FILEMAP (NIL (3089 12861 (\LAFITE.FIND 3099 . 4131) (\LAFITE.FIND.RELATED 4133 . 4798) ( (FILEMAP (NIL (2309 12081 (\LAFITE.FIND 2319 . 3351) (\LAFITE.FIND.RELATED 3353 . 4018) (
\LAFITE.FIND.RELATED.BACKWARD 4800 . 4936) (\LAFITE.GO.TO.FIRST 4938 . 5105) ( \LAFITE.FIND.RELATED.BACKWARD 4020 . 4156) (\LAFITE.GO.TO.FIRST 4158 . 4325) (
\LAFITE.GO.TO.INTERACTIVE 5107 . 5719) (\LAFITE.GO.TO.LAST 5721 . 5929) (\LAFITE.FIND.AGAIN 5931 . \LAFITE.GO.TO.INTERACTIVE 4327 . 4939) (\LAFITE.GO.TO.LAST 4941 . 5149) (\LAFITE.FIND.AGAIN 5151 .
6513) (\LAFITE.FIND.PROMPT 6515 . 8637) (\LAFITE.DO.FIND 8639 . 11790) (\LAFITE.FIND.START 11792 . 5733) (\LAFITE.FIND.PROMPT 5735 . 7857) (\LAFITE.DO.FIND 7859 . 11010) (\LAFITE.FIND.START 11012 .
12859))))) 12079)))))
STOP STOP

BIN
library/lafite/LAFITEFIND.LCOM
View File

Binary file not shown.

1994
library/lafite/LAFITEMAIL
View File

File diff suppressed because one or more lines are too long

BIN
library/lafite/LAFITEMAIL.LCOM
View File

Binary file not shown.

1906
library/lafite/LAFITESEND
View File

File diff suppressed because one or more lines are too long

BIN
library/lafite/LAFITESEND.LCOM
View File

Binary file not shown.

353
library/lafite/LAFITESORT
View File

@@ -1,19 +1,334 @@
(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED " 7-Feb-95 13:10:22" {DSK}<lispcore>lafite>parc-94>LAFITESORT.;2 12117 (FILECREATED "30-Sep-2021 22:58:58" 
{DSK}<USERS>KAPLAN>LOCAL>MEDLEY3.5>GIT-MEDLEY>LIBRARY>LAFITE>LAFITESORT.;1 19675
changes to%: (VARS LAFITESORTCOMS)
previous date%: " 7-Feb-95 13:10:22"
previous date%: " 7-Oct-89 14:07:49" {DSK}<lispcore>lafite>parc-94>LAFITESORT.;1) {DSK}<USERS>KAPLAN>LOCAL>MEDLEY3.5>GIT-MEDLEY>LIBRARY>LAFITE>LAFITESORT.;1)
(* ; " (* ; "
Copyright (c) 1989, 1995 by Xerox Corporation. All rights reserved. Copyright (c) 1989, 1995, 2021 by Xerox Corporation.
") ")
(PRETTYCOMPRINT LAFITESORTCOMS) (PRETTYCOMPRINT LAFITESORTCOMS)
(RPAQQ LAFITESORTCOMS (RPAQQ LAFITESORTCOMS
[(DECLARE%: EVAL@COMPILE DONTCOPY (FILES (SOURCE) [(DECLARE%: EVAL@COMPILE DONTCOPY (FILES (SOURCE)
LAFITEDECLS)) LAFITEDECLS))
(FNS LAFITE.ASSURE.DATE.FIELDS LAFITE.PARSE.DATE.FIELD LAFITE.PARSE.DATE.FIELD.ONLY (FNS LAFITE.ASSURE.DATE.FIELDS LAFITE.PARSE.DATE.FIELD LAFITE.PARSE.DATE.FIELD.ONLY
LAFITE.SORT.BY.DATE LAFITE.SORT.MESSAGES LAFITEMSG.DATE.ORDER LAFITE.SORT.BY.DATE LAFITE.SORT.MESSAGES LAFITEMSG.DATE.ORDER
\LAFITE.SORT.BY.DATE.INTERACTIVE \LAFITE.SORT.BY.DATE.REGION)
[APPENDVARS (LAFITEEXTRAMENUITEMS ("Sort by Date" '\LAFITE.SORT.BY.DATE.INTERACTIVE
"Sort all the messages in this folder by their Date: fields."
(SUBITEMS ("Sort Entire Folder"
'\LAFITE.SORT.BY.DATE.INTERACTIVE
"Sort all the messages in this folder by their Date: fields."
)
("Sort Selected Range"
'\LAFITE.SORT.BY.DATE.REGION
"Sort only the messages between the first and last selected messages."
]
(COMS (* ; "Date hax")
(FNS GDATE1-6)
(DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS \4YearsDays)
(GLOBALVARS \TimeZoneComp \DayLightSavings])
(DECLARE%: EVAL@COMPILE DONTCOPY
(FILESLOAD (SOURCE)
LAFITEDECLS)
)
(DEFINEQ
(LAFITE.ASSURE.DATE.FIELDS
[LAMBDA (FOLDER FIRST# LAST#) (* ; "Edited 5-May-89 15:46 by bvm")
(* ;; "Assure that messages FIRST# thru LAST# have IDATE fields. FIRST# & LAST# default.")
(for I from (OR FIRST# 1) to (OR LAST# (fetch (MAILFOLDER %#OFMESSAGES)
of FOLDER))
bind (STREAM _ (\LAFITE.OPEN.FOLDER FOLDER 'INPUT :ABORT))
(MESSAGES _ (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of FOLDER))
(FAILURECNT _ 0)
(MISSING _ 0)
MSG ID PREV DATEFAILURE DATEFETCHED BABBLED
do [if (fetch (LAFITEMSG DATEFETCHED?) of (SETQ MSG (NTHMESSAGE MESSAGES I)))
then (* ; "Ok")
(if (NOT (fetch (LAFITEMSG DATEKNOWN?) of MSG))
then (add FAILURECNT 1))
else (if (NOT BABBLED)
then (* ; "Tell user what's taking so long")
(LAB.PROMPTPRINT FOLDER "Collecting dates... ")
(SETQ BABBLED T))
(if (FIXP (SETQ ID (LAFITE.PARSE.HEADER STREAM \LAPARSE.DATEFIELD
(fetch (LAFITEMSG START) of MSG)
(fetch (LAFITEMSG END) of MSG)
T)))
then (replace (LAFITEMSG IDATE) of MSG with ID)
(replace (LAFITEMSG DATEKNOWN?) of MSG with T)
(replace (LAFITEMSG DATEFETCHED?) of MSG with T)
(replace (LAFITEMSG DATE) of MSG with NIL)
(* ;
 "So it will be regenerated in canonical form")
(OR DATEFETCHED (SETQ DATEFETCHED I))
else (replace (LAFITEMSG DATEKNOWN?) of MSG with NIL)
(if LAFITEDEBUGFLG
then (LAB.FORMAT FOLDER
" ~:[Date missing for~;Could not parse date of~] msg ~D. "
ID I))
(add FAILURECNT 1)
(if (NULL ID)
then (add MISSING 1))
(if [AND (> I 1)
(fetch (LAFITEMSG DATEFETCHED?)
of (SETQ PREV (NTHMESSAGE MESSAGES (SUB1 I]
then (* ;
 "Guess that message i has date just after i-1")
(replace (LAFITEMSG IDATE) of MSG
with (ADD1 (fetch (LAFITEMSG IDATE) of PREV)))
(replace (LAFITEMSG DATEFETCHED?) of MSG with
T)
else (SETQ DATEFAILURE I]
finally (if (AND DATEFETCHED (< DATEFETCHED (fetch (MAILFOLDER TOCLASTMESSAGE#)
of FOLDER)))
then (* ;
 "Assure that the toc will be rewritten at least this far back so that we save the dates.")
(replace (MAILFOLDER TOCLASTMESSAGE#) of FOLDER with
DATEFETCHED
))
(COND
([AND DATEFAILURE (NOT (for I from (ADD1 (OR FIRST# 1))
to (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER)
when (fetch (LAFITEMSG DATEFETCHED?)
of (SETQ MSG (NTHMESSAGE MESSAGES I)))
do (* ; "Got a date later on")
(SETQ ID (fetch (LAFITEMSG IDATE) of MSG))
(for J from DATEFAILURE
to (OR FIRST# 1) by -1
do (* ;
 "Store guess dates for first message(s)")
(replace (LAFITEMSG IDATE)
of (SETQ MSG (NTHMESSAGE MESSAGES J))
with (add ID -1))
(replace (LAFITEMSG DATEFETCHED?)
of MSG with T))
(RETURN T]
(LAB.PROMPTPRINT FOLDER "Could not parse dates of ANY messages in this file."))
((> FAILURECNT 0)
(LAB.FORMAT FOLDER (if (< MISSING FAILURECNT)
then
" Note: Could not parse date field of ~D of these messages."
else " Note: Missing date field for ~D of these messages.")
FAILURECNT])
(LAFITE.PARSE.DATE.FIELD
[LAMBDA (STREAM) (* ; "Edited 5-May-89 12:52 by bvm")
(LET* ((DATESTR (LAFITE.READ.TO.EOL STREAM))
(ID (IDATE DATESTR)))
(if [AND ID (> ID (CONSTANT (IDATE "1-jan-70 1200"]
then (* ; "Plausible date. Test is for those silly senders who didn't get the date set and have messages reading %"31-dec-00 ...%"")
ID
else (CONCAT (OR (SUBSTRING DATESTR 1 6 DATESTR)
DATESTR)
"?"])
(LAFITE.PARSE.DATE.FIELD.ONLY
[LAMBDA (STREAM)
(DECLARE (USEDFREE PARSERESULT)) (* ; "Edited 26-Apr-89 14:35 by bvm")
(SETQ PARSERESULT (LAFITE.PARSE.DATE.FIELD STREAM])
(LAFITE.SORT.BY.DATE
[LAMBDA (FOLDER FIRST# LAST#) (* ; "Edited 26-Apr-89 15:32 by bvm")
(WITH.MONITOR (fetch (MAILFOLDER FOLDERLOCK) of FOLDER)
(LAFITE.ASSURE.DATE.FIELDS FOLDER FIRST# LAST#)
(LAFITE.SORT.MESSAGES FOLDER (FUNCTION LAFITEMSG.DATE.ORDER)
FIRST# LAST#))])
(LAFITE.SORT.MESSAGES
[LAMBDA (FOLDER COMPAREFN FIRST# LAST#) (* ; "Edited 7-Oct-89 14:03 by bvm")
(WITH.MONITOR (fetch (MAILFOLDER FOLDERLOCK) of FOLDER)
(OR FIRST# (SETQ FIRST# 1))
(OR LAST# (SETQ LAST# (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER)))
(LAB.PROMPTPRINT FOLDER "Sorting... ")
(LET* ((MESSAGES (fetch (MAILFOLDER MESSAGEDESCRIPTORS) of FOLDER))
(SORTED (CL:STABLE-SORT (for I from FIRST# to LAST#
collect (NTHMESSAGE MESSAGES I))
COMPAREFN)))
(while (AND SORTED (EQ (fetch (LAFITEMSG %#) of (CAR SORTED))
FIRST#)) do (* ;
 "Skip over the initial prefix of in-order messages")
(add FIRST# 1)
(SETQ SORTED (CDR SORTED)))
(if (NULL SORTED)
then (LAB.PROMPTPRINT FOLDER "already in order")
else (replace (MAILFOLDER FOLDEROUTOFORDER) of FOLDER with T)
(if (< FIRST# (fetch (MAILFOLDER FIRSTCHANGEDMESSAGE) of FOLDER))
then (replace (MAILFOLDER FIRSTCHANGEDMESSAGE) of FOLDER
with FIRST#))
(UNINTERRUPTABLY
(for MSG in SORTED as I from FIRST#
do (replace (LAFITEMSG %#) of MSG with I)
(SETA MESSAGES I MSG)))
[LET ((FIRSTSEL (fetch (MAILFOLDER FIRSTSELECTEDMESSAGE) of FOLDER))
(LASTSEL (fetch (MAILFOLDER LASTSELECTEDMESSAGE) of FOLDER)))
(if (>= LASTSEL FIRSTSEL)
then (if (AND (>= FIRSTSEL FIRST#)
(<= FIRSTSEL LAST#))
then (* ;
 "Start of selection was inside here, have to recompute its number")
(replace (MAILFOLDER FIRSTSELECTEDMESSAGE)
of FOLDER with (LAB.FIND.SELECTED.MSG
FOLDER FIRST# LAST#)))
(if (AND (>= LASTSEL FIRST#)
(<= LASTSEL LAST#))
then (* ;
 "End of selection was inside here, have to recompute its number")
(replace (MAILFOLDER LASTSELECTEDMESSAGE)
of FOLDER with (LAB.REV.FIND.SELECTED.MSG
FOLDER FIRST# LAST#]
(LAB.DISPLAYLINES FOLDER FIRST# LAST# NIL T)
(LAB.PROMPTPRINT FOLDER "done"))))])
(LAFITEMSG.DATE.ORDER
[LAMBDA (X Y) (* ; "Edited 26-Apr-89 14:53 by bvm")
(* ;; "True if msg X has older date than msg Y. Since date field is stored as an unboxed 32-bit integer, we open code %"<%" here to avoid boxing.")
(LET [(HIDIFF (- (LOGXOR (fetch (LAFITEMSG IDATEHI) of X)
32768)
(LOGXOR (fetch (LAFITEMSG IDATEHI) of Y)
32768]
(* ;; "HIDIFF is unsigned difference of high words")
(OR (< HIDIFF 0)
(AND (EQ HIDIFF 0)
(< (fetch (LAFITEMSG IDATELO) of X)
(fetch (LAFITEMSG IDATELO) of Y])
(\LAFITE.SORT.BY.DATE.INTERACTIVE
[LAMBDA (FOLDER FIRST# LAST#) (* ; "Edited 3-May-89 18:38 by bvm")
(if (LAB.MOUSECONFIRM FOLDER "Click LEFT to confirm sorting ~D messages by date"
(if LAST#
then (ADD1 (- LAST# FIRST#))
else (fetch (MAILFOLDER %#OFMESSAGES) of FOLDER)))
then (\LAFITE.PROCESS `(,(FUNCTION LAFITE.SORT.BY.DATE)
',FOLDER
',FIRST#
',LAST#)
"LafiteSort"])
(\LAFITE.SORT.BY.DATE.REGION
[LAMBDA (FOLDER) (* ; "Edited 28-Apr-89 16:23 by bvm")
(LET ((FIRST# (fetch (MAILFOLDER FIRSTSELECTEDMESSAGE) of FOLDER))
(LAST# (fetch (MAILFOLDER LASTSELECTEDMESSAGE) of FOLDER)))
(if (> LAST# FIRST#)
then (\LAFITE.SORT.BY.DATE.INTERACTIVE FOLDER FIRST# LAST#)
else (LAB.FORMAT FOLDER "There is ~:[no~;only one~] message selected."
(EQ LAST# FIRST#])
)
(APPENDTOVAR LAFITEEXTRAMENUITEMS ("Sort by Date" '\LAFITE.SORT.BY.DATE.INTERACTIVE
"Sort all the messages in this folder by their Date: fields."
(SUBITEMS ("Sort Entire Folder"
'\LAFITE.SORT.BY.DATE.INTERACTIVE
"Sort all the messages in this folder by their Date: fields."
)
("Sort Selected Range"
'\LAFITE.SORT.BY.DATE.REGION
"Sort only the messages between the first and last selected messages."
))))
(* ; "Date hax")
(DEFINEQ
(GDATE1-6
[LAMBDA (D) (* ; "Edited 26-Apr-89 15:24 by bvm")
(* ;; "Return a string containing the day and month given in internal date D.")
(* ;; "This is an optimization by source code simplification of (SUBSTRING (GDATE IDT) 1 6)")
(PROG ((CHECKDLS \DayLightSavings)
[DQ (IQUOTIENT (LRSH (LISP.TO.ALTO.DATE D)
1)
(CONSTANT (IQUOTIENT (TIMES 60 60)
2]
HR DAY4 YDAY WDAY YEAR4 TOTALDAYS DLS) (* ;
 "DQ is number of hours since day 0, getting us past the sign bit problem.")
(* ;; "Now we can adjust to the current time zone. Since this might cause DQ to go negative, first add in 4 years worth of hours, making the base date be Jan 1, 1897")
(SETQ HR (IREMAINDER (SETQ DQ (- (+ DQ (CONSTANT (ITIMES 24 \4YearsDays)))
\TimeZoneComp))
24))
(SETQ TOTALDAYS (IQUOTIENT DQ 24))
DTLOOP
(SETQ DAY4 (IREMAINDER TOTALDAYS \4YearsDays)) (* ;
 "DAY4 = number of days since last leap year day 0")
[SETQ DAY4 (+ DAY4 (CDR (\DTSCAN DAY4 '((789 . 3)
(424 . 2)
(59 . 1)
(0 . 0] (* ;
 "pretend every year is a leap year, adding one for days after Feb 28")
(SETQ YEAR4 (IQUOTIENT TOTALDAYS \4YearsDays)) (* ;
 "YEAR4 = number of years til that last leap year / 4")
(SETQ YDAY (IREMAINDER DAY4 366)) (* ;
 "YDAY is the ordinal day in the year (jan 1 = zero)")
(SETQ WDAY (IREMAINDER (+ TOTALDAYS 3)
7))
[COND
((AND CHECKDLS (SETQ DLS (\ISDST? YDAY HR WDAY)))
(* ;; "This date is during daylight savings, so add 1 hour. Third arg is day of the week, which we determine by taking days mod 7 plus offset. Monday = zero in this scheme. Jan 1 1897 was actually a Friday (not Thursday=3), but we're cheating--1900 was not a leap year")
(COND
((> (SETQ HR (ADD1 HR))
23)
(* ;; "overflowed into the next day. This case is too hard (we might have overflowed the month, for example), so just go back and recompute")
(SETQ TOTALDAYS (ADD1 TOTALDAYS))
(SETQ HR 0)
(SETQ CHECKDLS NIL)
(GO DTLOOP]
(RETURN (LET* [[MONTH (\DTSCAN YDAY '((335 . "Dec")
(305 . "Nov")
(274 . "Oct")
(244 . "Sep")
(213 . "Aug")
(182 . "Jul")
(152 . "Jun")
(121 . "May")
(91 . "Apr")
(60 . "Mar")
(31 . "Feb")
(0 . "Jan"]
[DAY (ADD1 (- YDAY (CAR MONTH]
(RESULT (CONCAT " " (CDR MONTH]
(\RPLRIGHT RESULT 2 DAY 1)
RESULT])
)
(DECLARE%: EVAL@COMPILE DONTCOPY
(DECLARE%: EVAL@COMPILE
(RPAQQ \4YearsDays 1461)
(CONSTANTS \4YearsDays)
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS \TimeZoneComp \DayLightSavings)
)
)
(PUTPROPS LAFITESORT COPYRIGHT ("Xerox Corporation" 1989 1995 2021))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (2020 14676 (LAFITE.ASSURE.DATE.FIELDS 2030 . 8127) (LAFITE.PARSE.DATE.FIELD 8129 . 8766
) (LAFITE.PARSE.DATE.FIELD.ONLY 8768 . 8983) (LAFITE.SORT.BY.DATE 8985 . 9345) (LAFITE.SORT.MESSAGES
9347 . 12737) (LAFITEMSG.DATE.ORDER 12739 . 13487) (\LAFITE.SORT.BY.DATE.INTERACTIVE 13489 . 14133) (
\LAFITE.SORT.BY.DATE.REGION 14135 . 14674)) (15566 19381 (GDATE1-6 15576 . 19379)))))
STOP

BIN
library/lafite/LAFITESORT.LCOM
View File

Binary file not shown.

32
library/lafite/LAFITETEDIT
View File

@@ -1,14 +1,18 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "20-May-92 11:28:47" {DSK}<project>medley2.0>library>lafitetedit.;7 12308 (FILECREATED "30-Sep-2021 23:07:55" 
{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>lafite>LAFITETEDIT.;3 12516
changes to%: (FNS TEDIT.ASSURE.NO.BACKING.FILE) changes to%: (VARS LAFITETEDITCOMS)
(VARS LAFITETEDITCOMS) (FNS LA.ADJUST.FORMATTING LA.SKIP.LOOKS.LIST LA.DETACH.TEDIT LA.TEDIT.INCLUDE
LA.WINDOW.FROM.TEXTSTREAM TEDIT.ASSURE.NO.BACKING.FILE)
(FILES LAFITEDECLS)
previous date%: "29-Apr-92 13:30:23" {DSK}<project>medley2.0>library>lafitetedit.;5) previous date%: "30-Sep-2021 22:59:28"
{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>lafite>LAFITETEDIT.;2)
(* ; " (* ; "
Copyright (c) 1988, 1990, 1992 by Xerox Corporation. All rights reserved. Copyright (c) 1988, 1990, 1992, 2021 by Xerox Corporation.
") ")
(PRETTYCOMPRINT LAFITETEDITCOMS) (PRETTYCOMPRINT LAFITETEDITCOMS)
@@ -21,10 +25,10 @@ Copyright (c) 1988, 1990, 1992 by Xerox Corporation. All rights reserved.
LA.WINDOW.FROM.TEXTSTREAM TEDIT.ASSURE.NO.BACKING.FILE) LA.WINDOW.FROM.TEXTSTREAM TEDIT.ASSURE.NO.BACKING.FILE)
(DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE DONTCOPY
(* ;; "Need TEDIT internal declarations for LA.ADJUST.FORMATTING. Can't just do (FILES (SOURCE) TEDITDECLS), because there is a compiled version that is already loaded that isn't enough.") (* ;; "Need TEDIT internal declarations for LA.ADJUST.FORMATTING. Can't just do (FILES (SOURCE) TEDITDCL), because there is a compiled version that is already loaded that isn't enough.")
(P (CL:UNLESS (GET 'TEDITDECLS 'FILE) (P (CL:UNLESS (GET 'TEDITDCL 'FILE)
(FILESLOAD TEDITDECLS))) (FILESLOAD TEDITDCL)))
(FILES (SOURCE) (FILES (SOURCE)
LAFITEDECLS) LAFITEDECLS)
(GLOBALVARS *TEDIT-FILE-READTABLE*) (GLOBALVARS *TEDIT-FILE-READTABLE*)
@@ -181,8 +185,8 @@ Copyright (c) 1988, 1990, 1992 by Xerox Corporation. All rights reserved.
) )
(DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE DONTCOPY
(CL:UNLESS (GET 'TEDITDECLS 'FILE) (CL:UNLESS (GET 'TEDITDCL 'FILE)
(FILESLOAD TEDITDECLS)) (FILESLOAD TEDITDCL))
(FILESLOAD (SOURCE) (FILESLOAD (SOURCE)
@@ -198,9 +202,9 @@ Copyright (c) 1988, 1990, 1992 by Xerox Corporation. All rights reserved.
(LOCALVARS . T) (LOCALVARS . T)
) )
) )
(PUTPROPS LAFITETEDIT COPYRIGHT ("Xerox Corporation" 1988 1990 1992)) (PUTPROPS LAFITETEDIT COPYRIGHT ("Xerox Corporation" 1988 1990 1992 2021))
(DECLARE%: DONTCOPY (DECLARE%: DONTCOPY
(FILEMAP (NIL (1342 11940 (LA.ADJUST.FORMATTING 1352 . 7488) (LA.SKIP.LOOKS.LIST 7490 . 8064) ( (FILEMAP (NIL (1549 12147 (LA.ADJUST.FORMATTING 1559 . 7695) (LA.SKIP.LOOKS.LIST 7697 . 8271) (
LA.DETACH.TEDIT 8066 . 8431) (LA.TEDIT.INCLUDE 8433 . 8922) (LA.WINDOW.FROM.TEXTSTREAM 8924 . 9370) ( LA.DETACH.TEDIT 8273 . 8638) (LA.TEDIT.INCLUDE 8640 . 9129) (LA.WINDOW.FROM.TEXTSTREAM 9131 . 9577) (
TEDIT.ASSURE.NO.BACKING.FILE 9372 . 11938))))) TEDIT.ASSURE.NO.BACKING.FILE 9579 . 12145)))))
STOP STOP

BIN
library/lafite/LAFITETEDIT.LCOM
View File

Binary file not shown.

665
library/lafite/MAILSCAVENGE
View File

File diff suppressed because one or more lines are too long

BIN
library/lafite/MAILSCAVENGE.LCOM
View File

Binary file not shown.

0
internal/library/mailscavenge.tedit → library/lafite/MAILSCAVENGE.TEDIT
View File

1390
library/lafite/UNIXMAIL Normal file
View File

File diff suppressed because it is too large Load Diff

BIN
library/lafite/UNIXMAIL.DFASL Normal file
View File

Binary file not shown.

0
library/UNIXMAIL.TEDIT → library/lafite/UNIXMAIL.TEDIT
View File

56
sources/PRINTFN
View File

@@ -1,8 +1,11 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10 FORMAT XCCS) (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED " 8-Aug-2021 15:15:00" 
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>PRINTFN.;18 13138
previous date%: " 8-Aug-2021 14:52:38" (FILECREATED "28-Sep-2021 23:52:49" 
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>PRINTFN.;24 13993
changes to%: (FNS PRINTFNDEF PFCOPYBYTES)
previous date%: " 8-Aug-2021 15:15:00"
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>PRINTFN.;17) {DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>PRINTFN.;17)
@@ -109,7 +112,7 @@ Copyright (c) 1986-1987, 1990, 1999, 2018, 2021 by Venue & Xerox Corporation.
(T (printout TOFILE FN " not found on " LOC "." T]) (T (printout TOFILE FN " not found on " LOC "." T])
(PRINTFNDEF (PRINTFNDEF
[LAMBDA (SRCFIL DSTFIL START END TYPE) (* bvm%: " 9-Sep-86 15:54") [LAMBDA (SRCFIL DSTFIL START END TYPE) (* ; "Edited 28-Sep-2021 23:52 by rmk:")
(RESETLST (RESETLST
(PROG (TEM) (PROG (TEM)
[COND [COND
@@ -128,10 +131,15 @@ Copyright (c) 1986-1987, 1990, 1999, 2018, 2021 by Venue & Xerox Corporation.
DSTFIL T) DSTFIL T)
(PRIN1 "} (PRIN1 "}
" DSTFIL)) " DSTFIL))
(* ;; "RMK: Originally the last test was (EQ TYPE 'MAC). I think this was a typo for MAP, since that argument is set to MAP in FINDFNDEF. If the typo is fixed, we would end up in the COPYBYTES clause, which we don't generally want. So changed it also to a NEQ.")
(* ;; "PFDEFAULT is passed as the TYPE argument on the call from COPYALLBYTES, basically to force COPYBYTES and not do the format and font translations. It defaults to NIL, not COPYBYTES. I don't understand what this is trying to control. Note that the last argument of PFCOPYBYTES (PFDEFAULT here) is ignored.")
(COND (COND
((OR (NOT (DISPLAYP DSTFIL)) ((OR (NOT (DISPLAYP DSTFIL))
(EQ PFDEFAULT 'COPYBYTES) (EQ PFDEFAULT 'COPYBYTES)
(EQ TYPE 'MAC)) (NEQ TYPE 'MAP))
(COPYBYTES SRCFIL DSTFIL START END)) (COPYBYTES SRCFIL DSTFIL START END))
(T (PFCOPYBYTES SRCFIL DSTFIL START END PFDEFAULT))) (T (PFCOPYBYTES SRCFIL DSTFIL START END PFDEFAULT)))
(TERPRI DSTFIL))]) (TERPRI DSTFIL))])
@@ -160,21 +168,23 @@ Copyright (c) 1986-1987, 1990, 1999, 2018, 2021 by Venue & Xerox Corporation.
(T FULL]) (T FULL])
(PFCOPYBYTES (PFCOPYBYTES
[LAMBDA (SRCFIL DSTFIL START END FLG) (* ; "Edited 8-Aug-2021 14:51 by rmk:") [LAMBDA (SRCFIL DSTFIL START END FLG) (* ; "Edited 28-Sep-2021 23:35 by rmk:")
(* ; "Edited 24-Mar-93 14:16 by rmk:") (* ; "Edited 24-Mar-93 14:16 by rmk:")
(* lmm "28-Sep-86 14:38") (* lmm "28-Sep-86 14:38")
(* ;; " copy from SRCFIL to DSTFIL, paying attention to font changes. Other stuff about truncating lines gone away. Interprets all possible EOL conventions as EOL. Has to call \INCHAR-\INCCODE macros in order to keep track of character count--READDCODE doesn't do that.") (* ;; "RMK: What does FLG do? It isn't referenced. It seems to be passed as the value of PFDEFAULT from PRINTFNDEF, and that variable is initialized to NIL. Remove both, eventually?")
(* ;; "If END is NIL and START is given, then START is the number of characters to copy from the current file position. Otherwise, copy to the end of the file.") (* ;; " copy from SRCFIL to DSTFIL, paying attention to font changes. Other stuff about truncating lines gone away. Interprets all possible EOL conventions as EOL. Has to call \INCHAR-\INCCODE macros in order to keep track of character count--READDCODE doesn't do that.")
(* ;; "If END is NIL and START is given, then START is the number of characters to copy from the current file position. Otherwise, copy to the end of the file.")
(DECLARE (GLOBALVARS CHANGECHAR COMMENTFLG **COMMENT**FLG)) (DECLARE (GLOBALVARS CHANGECHAR COMMENTFLG **COMMENT**FLG))
(RESETLST (RESETLST
(PROG ((SSTRM (\INSTREAMARG SRCFIL)) (PROG ((SSTRM (\INSTREAMARG SRCFIL))
(DSTRM (\OUTSTREAMARG DSTFIL)) (DSTRM (\OUTSTREAMARG DSTFIL))
FONTARRAY CHARCODE %#CHARS MAXFONT) FONTARRAY CHARCODE %#CHARS MAXFONT)
(DECLARE (SPECVARS . T)) (* ; (DECLARE (SPECVARS . T)) (* ;
 "In particular, #CHARS must be a specvar for \INCCODE")  "In particular, #CHARS must be a specvar for \INCCODE")
(COND (COND
((IMAGESTREAMP DSTRM) ((IMAGESTREAMP DSTRM)
(SETQ FONTARRAY (FONTMAPARRAY)) (SETQ FONTARRAY (FONTMAPARRAY))
@@ -187,7 +197,7 @@ Copyright (c) 1986-1987, 1990, 1999, 2018, 2021 by Venue & Xerox Corporation.
[SETQ %#CHARS (COND [SETQ %#CHARS (COND
(END (SETFILEPTR SSTRM START) (END (SETFILEPTR SSTRM START)
(* ;; "Doesn't call \SETFILEPTR cause START has to be checked") (* ;; "Doesn't call \SETFILEPTR cause START has to be checked")
(IDIFFERENCE (COND (IDIFFERENCE (COND
((EQ END -1) ((EQ END -1)
@@ -195,26 +205,26 @@ Copyright (c) 1986-1987, 1990, 1999, 2018, 2021 by Venue & Xerox Corporation.
(T END)) (T END))
START)) START))
(START) (START)
(T (* ; (T (* ;
 "Copy everything from here to the end-of-file")  "Copy everything from here to the end-of-file")
(SETQ START (GETFILEPTR SSTRM)) (SETQ START (GETFILEPTR SSTRM))
(IDIFFERENCE (GETEOFPTR SSTRM) (IDIFFERENCE (GETEOFPTR SSTRM)
(GETFILEPTR SSTRM] (GETFILEPTR SSTRM]
(COND (COND
((ILEQ %#CHARS 0) ((ILEQ %#CHARS 0)
(RETURN T))) (* ; "Nothing to do") (RETURN T))) (* ; "Nothing to do")
LP (COND LP (COND
((ILEQ %#CHARS 0) ((ILEQ %#CHARS 0)
(CL:WHEN (AND (EQ START 0) (CL:WHEN (AND (EQ START 0)
(EOFP SSTRM)) (* ; "We copied the whole file") (EOFP SSTRM)) (* ; "We copied the whole file")
(TERPRI DSTRM)) (TERPRI DSTRM))
(RETURN T))) (RETURN T)))
(SETQ CHARCODE (\INCCODE.EOLC SSTRM ANY.EOLC '%#CHARS %#CHARS)) (SETQ CHARCODE (\INCCODE.EOLC SSTRM ANY.EOLC '%#CHARS %#CHARS))
(IF (EQ CHARCODE (CONSTANT (CHARCODE.DECODE FONTESCAPECHAR))) (IF (EQ CHARCODE (CONSTANT (CHARCODE.DECODE FONTESCAPECHAR)))
THEN THEN
(* ;; (* ;;
 "No EOL check on font character, otherwise we would be limited to 9 fonts")  "No EOL check on font character, otherwise we would be limited to 9 fonts")
(SETQ CHARCODE (\INCCODE SSTRM '%#CHARS %#CHARS)) (SETQ CHARCODE (\INCCODE SSTRM '%#CHARS %#CHARS))
(CL:WHEN (AND (IGEQ MAXFONT CHARCODE) (CL:WHEN (AND (IGEQ MAXFONT CHARCODE)
@@ -257,7 +267,7 @@ Copyright (c) 1986-1987, 1990, 1999, 2018, 2021 by Venue & Xerox Corporation.
(COND (COND
((AND WIDTH (IGREATERP (add HPOS WIDTH) ((AND WIDTH (IGREATERP (add HPOS WIDTH)
RMAR)) RMAR))
(* past RIGHT margin, force eol) (* past RIGHT margin, force eol)
(TERPRI DSTRM) (TERPRI DSTRM)
(SETQ HPOS WIDTH))) (SETQ HPOS WIDTH)))
(\OUTCHAR DSTRM CC] (\OUTCHAR DSTRM CC]
@@ -285,7 +295,7 @@ Copyright (c) 1986-1987, 1990, 1999, 2018, 2021 by Venue & Xerox Corporation.
) )
(PUTPROPS PRINTFN COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990 1999 2018 2021)) (PUTPROPS PRINTFN COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990 1999 2018 2021))
(DECLARE%: DONTCOPY (DECLARE%: DONTCOPY
(FILEMAP (NIL (1097 11016 (PF 1107 . 3802) (PF* 3804 . 4098) (PMORE 4100 . 4419) (PRINTFN 4421 . 5012) (FILEMAP (NIL (1134 11871 (PF 1144 . 3839) (PF* 3841 . 4135) (PMORE 4137 . 4456) (PRINTFN 4458 . 5049)
(PRINTFNDEF 5014 . 6131) (FINDFNDEF 6133 . 7157) (PFCOPYBYTES 7159 . 10766) (DISPLAYP 10768 . 11014)) (PRINTFNDEF 5051 . 6790) (FINDFNDEF 6792 . 7816) (PFCOPYBYTES 7818 . 11621) (DISPLAYP 11623 . 11869))
))) )))
STOP STOP

BIN
sources/PRINTFN.LCOM
View File

Binary file not shown.