github.com/Interlisp.medley
1
0
Fork 0
mirror of synced 2026-01-25 20:06:44 +00:00
Code Issues Projects Releases Wiki Activity

Merge pull request #513 from Interlisp/LAFITE-CR-to-LF

Browse Source 
Lafite cr to lf
This commit is contained in:
Larry Masinter
2021-10-01 18:57:53 -07:00
committed by GitHub
parent a92bce555f 625a5a839c
commit 84bf09394e
32 changed files with 11562 additions and 1390 deletions
Download Patch File Download Diff File Expand all files Collapse all files

58
library/TEDIT
View File

@@ -1,10 +1,12 @@
(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"
{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>TEDIT.;1)
changes to%: (FNS TEDIT-SEE)
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])
(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 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.")
(* ;; "FORMAT for text files defaults to :UTF-8 if present, otherwise *DEFAULT-EXTERNALFORMAT*")
(CL:WITH-OPEN-FILE (STREAM FILE :DIRECTION :INPUT)
(LET ((SEESTREAM STREAM)
ENV TSTREAM)
@@ -346,18 +350,20 @@ Copyright (c) 1983-1993, 1995, 1999, 2018, 2021 by Venue & Xerox Corporation.
(* ;; "Lisp source file")
(\EXTERNALFORMAT STREAM ENV)
(SETFILEINFO STREAM 'FORMAT ENV)
(SETQ SEESTREAM (OPENTEXTSTREAM))
(COPY.TEXT.TO.IMAGE STREAM SEESTREAM)
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.")
(* ;; "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)
[SETQ SEESTREAM (OPENSTREAM '{NODIRCORE} 'BOTH 'NEW
`([TYPE ,(GETFILEINFO STREAM 'TYPE]
(FORMAT ,(\EXTERNALFORMAT STREAM]
(COPYBYTES STREAM SEESTREAM)))
(SETQ SEESTREAM (OPENSTREAM '{NODIRCORE} 'BOTH 'NEW))
(COPYCHARS STREAM SEESTREAM)))
[SETQ TSTREAM (TEXTSTREAM (TEDIT SEESTREAM WINDOW NIL '(READONLY T]
(WINDOWPROP (WFROMDS TSTREAM)
'TITLE
@@ -2229,7 +2235,7 @@ Copyright (c) 1983-1993, 1995, 1999, 2018, 2021 by Venue & Xerox Corporation.
(* ; "TEDIT Support information")
(RPAQQ TEDITSYSTEMDATE "19-Sep-2021 17:08:56")
(RPAQQ TEDITSYSTEMDATE "29-Sep-2021 22:16:28")
(RPAQ TEDITSUPPORT "TEditSupport.PA")
(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
1992 1993 1995 1999 2018 2021))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (4327 117111 (\TEDIT2 4337 . 7088) (COERCETEXTOBJ 7090 . 15866) (TEDIT 15868 . 20837) (
TEDIT-SEE 20839 . 22787) (TEDIT.CHARWIDTH 22789 . 24813) (TEDIT.COPY 24815 . 33251) (TEDIT.DELETE
33253 . 33943) (TEDIT.DO.BLUEPENDINGDELETE 33945 . 37012) (TEDIT.INSERT 37014 . 42544) (TEDIT.KILL
42546 . 44103) (TEDIT.MAPLINES 44105 . 45504) (TEDIT.MAPPIECES 45506 . 46462) (TEDIT.MOVE 46464 .
56248) (TEDIT.QUIT 56250 . 58250) (TEDIT.STRINGWIDTH 58252 . 58923) (TEDIT.\INSERT 58925 . 60950) (
TEXTOBJ 60952 . 62077) (TEXTSTREAM 62079 . 63694) (\TEDIT.INCLUDE 63696 . 67596) (\TEDIT.INSERT.PIECES
67598 . 77513) (\TEDIT.MOVE.PIECEMAPFN 77515 . 79594) (\TEDIT.OBJECT.SHOWSEL 79596 . 83225) (
\TEDIT.RESTARTFN 83227 . 85222) (\TEDIT.CHARDELETE 85224 . 89186) (\TEDIT.COPY.PIECEMAPFN 89188 .
92413) (\TEDIT.DELETE 92415 . 99933) (\TEDIT.DIFFUSE.PARALOOKS 99935 . 102699) (\TEDIT.FOREIGN.COPY?
102701 . 106428) (\TEDIT.QUIT 106430 . 109576) (\TEDIT.WORDDELETE 109578 . 114411) (\TEDIT1 114413 .
117109)) (117225 117341 (\CREATE.TEDIT.RESTART.MENU 117235 . 117339)) (117440 121129 (PLCHAIN 117450
. 117724) (PRINTLINE 117726 . 120490) (SEEFILE 120492 . 121127)) (121170 140813 (TEDIT.INSERT.OBJECT
121180 . 130257) (TEDIT.EDIT.OBJECT 130259 . 132515) (TEDIT.FIND.OBJECT 132517 . 133410) (
TEDIT.FIND.OBJECT.SUBTREE 133412 . 134218) (TEDIT.PUT.OBJECT 134220 . 135879) (TEDIT.GET.OBJECT 135881
. 139080) (TEDIT.OBJECT.CHANGED 139082 . 140811)) (141091 141454 (MAKETEDITFORM 141101 . 141452)))))
(FILEMAP (NIL (4329 117413 (\TEDIT2 4339 . 7090) (COERCETEXTOBJ 7092 . 15868) (TEDIT 15870 . 20839) (
TEDIT-SEE 20841 . 23089) (TEDIT.CHARWIDTH 23091 . 25115) (TEDIT.COPY 25117 . 33553) (TEDIT.DELETE
33555 . 34245) (TEDIT.DO.BLUEPENDINGDELETE 34247 . 37314) (TEDIT.INSERT 37316 . 42846) (TEDIT.KILL
42848 . 44405) (TEDIT.MAPLINES 44407 . 45806) (TEDIT.MAPPIECES 45808 . 46764) (TEDIT.MOVE 46766 .
56550) (TEDIT.QUIT 56552 . 58552) (TEDIT.STRINGWIDTH 58554 . 59225) (TEDIT.\INSERT 59227 . 61252) (
TEXTOBJ 61254 . 62379) (TEXTSTREAM 62381 . 63996) (\TEDIT.INCLUDE 63998 . 67898) (\TEDIT.INSERT.PIECES
67900 . 77815) (\TEDIT.MOVE.PIECEMAPFN 77817 . 79896) (\TEDIT.OBJECT.SHOWSEL 79898 . 83527) (
\TEDIT.RESTARTFN 83529 . 85524) (\TEDIT.CHARDELETE 85526 . 89488) (\TEDIT.COPY.PIECEMAPFN 89490 .
92715) (\TEDIT.DELETE 92717 . 100235) (\TEDIT.DIFFUSE.PARALOOKS 100237 . 103001) (\TEDIT.FOREIGN.COPY?
103003 . 106730) (\TEDIT.QUIT 106732 . 109878) (\TEDIT.WORDDELETE 109880 . 114713) (\TEDIT1 114715 .
117411)) (117527 117643 (\CREATE.TEDIT.RESTART.MENU 117537 . 117641)) (117742 121431 (PLCHAIN 117752
. 118026) (PRINTLINE 118028 . 120792) (SEEFILE 120794 . 121429)) (121472 141115 (TEDIT.INSERT.OBJECT
121482 . 130559) (TEDIT.EDIT.OBJECT 130561 . 132817) (TEDIT.FIND.OBJECT 132819 . 133712) (
TEDIT.FIND.OBJECT.SUBTREE 133714 . 134520) (TEDIT.PUT.OBJECT 134522 . 136181) (TEDIT.GET.OBJECT 136183
. 139382) (TEDIT.OBJECT.CHANGED 139384 . 141113)) (141393 141756 (MAKETEDITFORM 141403 . 141754)))))
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)
(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)
(VARS TEDITSCREENCOMS)
(FNS \MAIKO.DISPLAYLINE \DISPLAYLINE)
(FILECREATED "29-Sep-2021 22:03:57" 
{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>TEDITSCREEN.;8 214517
previous date%: "30-Apr-2021 14:42:15"
{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>TEDITSCREEN.;1)
changes to%: (FNS \DISPLAYLINE)
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
(\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.")
(PROG ((CH 0)
(CHLIST (fetch (THISLINE CHARS) of (fetch (TEXTOBJ THISLINE) of TEXTOBJ)))
(WLIST (fetch (THISLINE WIDTHS) of (fetch (TEXTOBJ THISLINE) of TEXTOBJ)))
(LOOKS (fetch (THISLINE LOOKS) of (fetch (TEXTOBJ THISLINE) of TEXTOBJ)))
(WINDOWDS (WINDOWPROP (OR WINDOW (CAR (fetch (TEXTOBJ \WINDOW) of TEXTOBJ)))
'DSP))
(TEXTLEN (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ))
(THISLINE (fetch (TEXTOBJ THISLINE) of TEXTOBJ))
(TERMSA (fetch (TEXTOBJ TXTTERMSA) of TEXTOBJ))
(STREAM (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ))
(OLDCACHE (fetch LCBITMAP of (fetch (TEXTOBJ DISPLAYCACHE) of TEXTOBJ)))
(DS (fetch (TEXTOBJ DISPLAYCACHEDS) of TEXTOBJ))
(HCPYDS (fetch (TEXTOBJ DISPLAYHCPYDS) of TEXTOBJ))
(HARDCOPYMODE (fetch (FMTSPEC FMTHARDCOPY) of (fetch (LINEDESCRIPTOR LFMTSPEC)
of LINE)))
LOOKSTARTX CACHE \PCHARSLEFT \PSTRING \PFILE FONT OFONT OLOOKS XOFFSET CLIPLEFT CLIPRIGHT
DISPLAYDATA DDPILOTBBT DDWIDTHCACHE DDOFFSETCACHE CURY LHEIGHT SCALE)
[SETQ LHEIGHT (COND
((fetch (LINEDESCRIPTOR PREVLINE) of LINE)
(* ;; "Validate the incoming arguments so ffetch can be used consistently for all their field extractions.")
(\DTEST TEXTOBJ 'TEXTOBJ)
(\DTEST LINE 'LINEDESCRIPTOR)
(LET ((LOOKS (ffetch (THISLINE LOOKS) of (ffetch (TEXTOBJ THISLINE) of TEXTOBJ)))
(WINDOWDS (WINDOWPROP (OR WINDOW (CAR (ffetch (TEXTOBJ \WINDOW) of TEXTOBJ)))
'DSP))
(THISLINE (\DTEST (ffetch (TEXTOBJ THISLINE) of TEXTOBJ)
'THISLINE))
(OLDCACHE (fetch (LINECACHE LCBITMAP) of (ffetch (TEXTOBJ DISPLAYCACHE)
of TEXTOBJ)))
(DS (ffetch (TEXTOBJ DISPLAYCACHEDS) of TEXTOBJ))
(HCPYDS (ffetch (TEXTOBJ DISPLAYHCPYDS) of TEXTOBJ))
(HARDCOPYMODE (fetch (FMTSPEC FMTHARDCOPY) of (ffetch (LINEDESCRIPTOR LFMTSPEC)
of LINE)))
CACHE OFONT OLOOKS XOFFSET CLIPLEFT CLIPRIGHT DISPLAYDATA DDPILOTBBT DDWIDTHCACHE
DDOFFSETCACHE CURY LHEIGHT SCALE)
[SETQ LHEIGHT (COND
((ffetch (LINEDESCRIPTOR PREVLINE) of LINE)
(* ;
 "So if theres a base-to-base measure, we clear everything right.")
(IMAX (IDIFFERENCE (fetch (LINEDESCRIPTOR YBOT)
of (fetch (LINEDESCRIPTOR PREVLINE)
of LINE))
(fetch (LINEDESCRIPTOR YBOT) of LINE))
(fetch (LINEDESCRIPTOR LHEIGHT) of LINE)))
(T (fetch (LINEDESCRIPTOR LHEIGHT) of LINE]
(COND
(HARDCOPYMODE (* ;
(IMAX (IDIFFERENCE (ffetch (LINEDESCRIPTOR YBOT)
of (ffetch (LINEDESCRIPTOR PREVLINE)
of LINE))
(ffetch (LINEDESCRIPTOR YBOT) of LINE))
(ffetch (LINEDESCRIPTOR LHEIGHT) of LINE)))
(T (ffetch (LINEDESCRIPTOR LHEIGHT) of LINE]
(SETQ SCALE (COND
(HARDCOPYMODE (* ;
 "This is a hardcopy-mode line. Scale things.")
(* ; "(SETQ DS HCPYDS)")
(SETQ SCALE (DSPSCALE NIL HCPYDS)))
(T (SETQ SCALE 1)))
(SETQ CACHE (\TEDIT.LINECACHE (fetch (TEXTOBJ DISPLAYCACHE) of TEXTOBJ)
(COND
(HARDCOPYMODE (FIXR (FQUOTIENT (fetch (LINEDESCRIPTOR RIGHTMARGIN
(DSPSCALE NIL HCPYDS))
(T 1)))
(SETQ CACHE (\TEDIT.LINECACHE (ffetch (TEXTOBJ DISPLAYCACHE) of TEXTOBJ)
(COND
(HARDCOPYMODE (FIXR (FQUOTIENT (ffetch (LINEDESCRIPTOR RIGHTMARGIN
) of LINE)
SCALE)))
(T (fetch (LINEDESCRIPTOR RIGHTMARGIN) of LINE)))
LHEIGHT))
(COND
((NEQ CACHE OLDCACHE) (* ;
SCALE)))
(T (ffetch (LINEDESCRIPTOR RIGHTMARGIN) of LINE)))
LHEIGHT))
(COND
((NEQ CACHE OLDCACHE) (* ;
 "We changed the bitmaps because this line was bigger--update the displaystream, too")
(DSPDESTINATION CACHE DS)
(DSPCLIPPINGREGION (create REGION
LEFT _ 0
BOTTOM _ 0
WIDTH _ (fetch BITMAPWIDTH of CACHE)
HEIGHT _ (fetch BITMAPHEIGHT of CACHE))
DS)))
(BITBLT NIL 0 0 CACHE 0 0 NIL NIL 'TEXTURE 'REPLACE WHITESHADE)
(DSPDESTINATION CACHE DS)
(DSPCLIPPINGREGION (create REGION
LEFT _ 0
BOTTOM _ 0
WIDTH _ (fetch BITMAPWIDTH of CACHE)
HEIGHT _ (fetch BITMAPHEIGHT of CACHE))
DS)))
(BITBLT NIL 0 0 CACHE 0 0 NIL NIL 'TEXTURE 'REPLACE WHITESHADE)
(* ; "Clear the line cache")
(COND
(HARDCOPYMODE (* ;
 "This is a hardcopy-mode line. Scale things.")
(* ; "(SETQ DS HCPYDS)")
(SETQ SCALE (DSPSCALE NIL HCPYDS)))
(T (SETQ SCALE 1)))
[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)))
[COND
((AND (NOT (ZEROP (fetch (LINEDESCRIPTOR CHAR1) of LINE)))
(ILEQ (ffetch (LINEDESCRIPTOR CHAR1) of LINE)
(ffetch (TEXTOBJ TEXTLEN) of TEXTOBJ))
(IGEQ (ffetch (LINEDESCRIPTOR YBOT) of LINE)
(ffetch (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
((NEQ (fetch (THISLINE DESC) of THISLINE)
LINE) (* ;
(COND
((NEQ (fetch (THISLINE DESC) of THISLINE)
LINE) (* ;
 "No image cache -- re-format and display")
(\FORMATLINE TEXTOBJ NIL (fetch (LINEDESCRIPTOR CHAR1) of LINE)
LINE)))
(MOVETO (fetch (LINEDESCRIPTOR LEFTMARGIN) of LINE)
(fetch (LINEDESCRIPTOR DESCENT) of LINE)
DS)
(SETQ DISPLAYDATA (fetch (STREAM IMAGEDATA) of DS))
(SETQ DDPILOTBBT (ffetch DDPILOTBBT of DISPLAYDATA))
(SETQ XOFFSET (fetch DDXOFFSET of DISPLAYDATA))
(\FORMATLINE TEXTOBJ NIL (ffetch (LINEDESCRIPTOR CHAR1) of LINE)
LINE)))
(MOVETO (ffetch (LINEDESCRIPTOR LEFTMARGIN) of LINE)
(ffetch (LINEDESCRIPTOR DESCENT) of LINE)
DS)
(SETQ DISPLAYDATA (fetch (STREAM IMAGEDATA) of DS))
(SETQ DDPILOTBBT (ffetch DDPILOTBBT 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.")
(SETQ CLIPRIGHT (fetch DDClippingRight of DISPLAYDATA))
(SETQ OFONT (DSPFONT (fetch CLFONT of (SETQ OLOOKS (\EDITELT LOOKS 0)))
DS)) (* ; "The starting font")
(SETQ DDWIDTHCACHE (ffetch DDWIDTHSCACHE of DISPLAYDATA))
(SETQ CLIPRIGHT (fetch DDClippingRight of DISPLAYDATA))
(SETQ OFONT (DSPFONT (fetch CLFONT of (SETQ OLOOKS (\EDITELT LOOKS 0)))
DS)) (* ; "The starting font")
(SETQ DDWIDTHCACHE (ffetch DDWIDTHSCACHE of DISPLAYDATA))
(* ;
 "Cache the character-image widths")
(SETQ DDOFFSETCACHE (ffetch DDOFFSETSCACHE of DISPLAYDATA))
(SETQ DDOFFSETCACHE (ffetch DDOFFSETSCACHE of DISPLAYDATA))
(* ;
 "And the offset-into-strike-bitmap array")
(SETQ LOOKSTARTX (fetch (LINEDESCRIPTOR LEFTMARGIN) of LINE))
(* ;
 "Starting X position for the current-looks text.")
(AND (fetch CLOFFSET of OLOOKS)
(RELMOVETO 0 (FIXR (FTIMES SCALE (fetch CLOFFSET of OLOOKS)))
DS)) (* ;
 "LOOKSTARTX: Starting X position for the current-looks text.")
(AND (fetch CLOFFSET of OLOOKS)
(RELMOVETO 0 (FIXR (FTIMES SCALE (fetch CLOFFSET of OLOOKS)))
DS)) (* ;
 "Any sub- or superscripting at start of line")
(bind (LOOKNO _ 1)
DX
(TX _ (IPLUS XOFFSET (fetch (LINEDESCRIPTOR LEFTMARGIN) of LINE)))
for I from 0 to (fetch (THISLINE LEN) of THISLINE)
do
(bind (LOOKNO _ 1)
DX CH (CHLIST _ (fetch (THISLINE CHARS) of (ffetch (TEXTOBJ THISLINE)
of TEXTOBJ)))
(WLIST _ (fetch (THISLINE WIDTHS) of (ffetch (TEXTOBJ THISLINE)
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")
(SETQ DX (\EDITELT WLIST I)) (* ; "And its width")
[SELECTC CH
(LMInvisibleRun (* ;
(SETQ DX (\EDITELT WLIST I)) (* ; "And its width")
[SELECTC CH
(LMInvisibleRun (* ;
 "An INVISIBLE run -- skip it, and skip over the char count")
(add LOOKNO 1))
(LMLooksChange (* ; "A LOOKS change")
(replace DDXPOSITION of DISPLAYDATA
with (IDIFFERENCE TX XOFFSET))
(add LOOKNO 1))
(LMLooksChange (* ; "A LOOKS change")
(replace DDXPOSITION of DISPLAYDATA
with (IDIFFERENCE TX XOFFSET))
(* ;
 "Make the displaystream reflect our current X position")
(TEDIT.MODIFYLOOKS LINE LOOKSTARTX DS OLOOKS
(fetch (LINEDESCRIPTOR DESCENT) of LINE))
(TEDIT.MODIFYLOOKS LINE LOOKSTARTX DS OLOOKS
(ffetch (LINEDESCRIPTOR DESCENT) of LINE))
(* ;
 "Make any necessary changes to the preceding characters (underline, strike-out &c)")
(DSPFONT (fetch CLFONT of (SETQ OLOOKS
(\EDITELT LOOKS LOOKNO))
)
DS) (* ; "Set the new font")
(add LOOKNO 1) (* ; "Grab the next set of char looks")
(AND (fetch CLOFFSET of OLOOKS)
(RELMOVETO 0 (fetch CLOFFSET of OLOOKS)
DS)) (* ; "Account for super/subscripting")
(SETQ LOOKSTARTX (IDIFFERENCE TX XOFFSET))
(DSPFONT (fetch CLFONT of (SETQ OLOOKS
(\EDITELT LOOKS LOOKNO)))
DS) (* ; "Set the new font")
(add LOOKNO 1) (* ; "Grab the next set of char looks")
(AND (fetch CLOFFSET of OLOOKS)
(RELMOVETO 0 (fetch CLOFFSET of OLOOKS)
DS)) (* ; "Account for super/subscripting")
(SETQ LOOKSTARTX (IDIFFERENCE TX XOFFSET))
(* ;
 "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.")
[COND
((OR (IEQP CH (CHARCODE %#^I))
(fetch CLLEADER of OLOOKS)
(EQ (fetch CLUSERINFO of OLOOKS)
'DOTTEDLEADER))
(LET* [[LEADERFONT (COND
(HARDCOPYMODE (FONTCOPY (fetch CLFONT
of OLOOKS)
'DEVICE HCPYDS))
(T (fetch CLFONT of OLOOKS]
(DOTWIDTH (CHARWIDTH (CHARCODE %.)
LEADERFONT))
(TTX (IPLUS TX DOTWIDTH (IDIFFERENCE DOTWIDTH
(IREMAINDER TX DOTWIDTH]
(while (ILEQ TTX (IPLUS TX DX))
do (COND
(HARDCOPYMODE
(MI-TEDIT.BLTCHAR (CHARCODE %.)
DS
(FIXR (FQUOTIENT (IDIFFERENCE TTX
DOTWIDTH)
SCALE))
DISPLAYDATA DDPILOTBBT CLIPRIGHT))
((OR TERMSA HARDCOPYMODE)
[COND
((OR (IEQP CH (CHARCODE %#^I))
(fetch CLLEADER of OLOOKS)
(EQ (fetch CLUSERINFO of OLOOKS)
'DOTTEDLEADER))
(LET* [[LEADERFONT (COND
(HARDCOPYMODE (FONTCOPY (fetch CLFONT
of OLOOKS)
'DEVICE HCPYDS))
(T (fetch CLFONT of OLOOKS]
(DOTWIDTH (CHARWIDTH (CHARCODE %.)
LEADERFONT))
(TTX (IPLUS TX DOTWIDTH (IDIFFERENCE DOTWIDTH
(IREMAINDER TX DOTWIDTH]
(while (ILEQ TTX (IPLUS TX DX))
do (COND
(HARDCOPYMODE (MI-TEDIT.BLTCHAR
(CHARCODE %.)
DS
(FIXR (FQUOTIENT (IDIFFERENCE
TTX DOTWIDTH)
SCALE))
DISPLAYDATA DDPILOTBBT CLIPRIGHT
))
((OR TERMSA HARDCOPYMODE)
(* ;
 "Using special instrns from TERMSA")
(\DSPPRINTCHAR DS (CHARCODE %.)))
(T (* ; "Native charcodes")
(MI-TEDIT.BLTCHAR (CHARCODE %.)
DS
(IDIFFERENCE TTX DOTWIDTH)
DISPLAYDATA DDPILOTBBT CLIPRIGHT)))
(add TTX DOTWIDTH])
((CHARCODE (EOL LF CR)) (* ; "It's a CR")
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.")
(BLTSHADE BLACKSHADE DS TX 0 1 100 'PAINT))
(COND
[(SMALLP CH) (* ;
(\DSPPRINTCHAR DS (CHARCODE %.)))
(T (* ; "Native charcodes")
(MI-TEDIT.BLTCHAR (CHARCODE %.)
DS
(IDIFFERENCE TTX DOTWIDTH)
DISPLAYDATA DDPILOTBBT CLIPRIGHT)))
(add TTX DOTWIDTH])
((CHARCODE (EOL LF CR)) (* ; "It's a CR")
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.")
(BLTSHADE BLACKSHADE DS TX 0 1 100 'PAINT))
(COND
[(SMALLP CH) (* ;
 "Normal character -- just display it.")
(COND
(HARDCOPYMODE (MI-TEDIT.BLTCHAR CH DS (FIXR (FQUOTIENT TX SCALE))
DISPLAYDATA DDPILOTBBT CLIPRIGHT))
((OR TERMSA HARDCOPYMODE) (* ;
(COND
(HARDCOPYMODE (MI-TEDIT.BLTCHAR CH DS (FIXR (FQUOTIENT TX SCALE))
DISPLAYDATA DDPILOTBBT CLIPRIGHT))
((OR TERMSA HARDCOPYMODE) (* ;
 "Using special instrns from TERMSA")
(\DSPPRINTCHAR DS CH))
(T (* ; "Native charcodes")
(MI-TEDIT.BLTCHAR CH DS TX DISPLAYDATA DDPILOTBBT CLIPRIGHT]
(T (* ; "CH is an object.")
(MOVETO (IDIFFERENCE (FIXR (FQUOTIENT TX SCALE))
XOFFSET)
(SETQ CURY (DSPYPOSITION NIL DS))
DS) (* ;
(\DSPPRINTCHAR DS CH))
(T (* ; "Native charcodes")
(MI-TEDIT.BLTCHAR CH DS TX DISPLAYDATA DDPILOTBBT CLIPRIGHT]
(T (* ; "CH is an object.")
(MOVETO (IDIFFERENCE (FIXR (FQUOTIENT TX SCALE))
XOFFSET)
(SETQ CURY (DSPYPOSITION NIL DS))
DS) (* ;
 "Go to the base line, left edge of the image region.")
(APPLY* (IMAGEOBJPROP CH 'DISPLAYFN)
CH DS 'DISPLAY (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ
))
(APPLY* (IMAGEOBJPROP CH 'DISPLAYFN)
CH DS 'DISPLAY (ffetch (TEXTOBJ STREAMHINT) of TEXTOBJ
))
(* ;
 "Tell him to display himself here.")
(DSPFONT (fetch CLFONT of OLOOKS)
DS)
(MOVETO (IDIFFERENCE (FIXR (FQUOTIENT TX SCALE))
XOFFSET)
CURY DS) (* ;
(DSPFONT (fetch CLFONT of OLOOKS)
DS)
(MOVETO (IDIFFERENCE (FIXR (FQUOTIENT TX SCALE))
XOFFSET)
CURY DS) (* ;
 "Move to after the object's image")
]
(add TX DX) (* ; "Update our X position")
finally (replace DDXPOSITION of DISPLAYDATA
with (IDIFFERENCE (FIXR (FQUOTIENT TX SCALE))
XOFFSET)) (* ;
]
(add TX DX) (* ; "Update our X position")
finally (replace DDXPOSITION of DISPLAYDATA
with (IDIFFERENCE (FIXR (FQUOTIENT TX SCALE))
XOFFSET)) (* ;
 "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)
of LINE]
(BITBLT CACHE 0 0 WINDOWDS 0 (fetch (LINEDESCRIPTOR YBOT) of LINE)
(fetch (TEXTOBJ WRIGHT) of TEXTOBJ)
LHEIGHT
'INPUT
'REPLACE) (* ;
of LINE]
(BITBLT CACHE 0 0 WINDOWDS 0 (ffetch (LINEDESCRIPTOR YBOT) of LINE)
(ffetch (TEXTOBJ WRIGHT) of TEXTOBJ)
LHEIGHT
'INPUT
'REPLACE) (* ;
 "Paint the cached image on the screen (this lessens flicker during update)")
(COND
((fetch (FMTSPEC FMTREVISED) of (fetch (LINEDESCRIPTOR LFMTSPEC)
of LINE))
(COND
((fetch (FMTSPEC FMTREVISED) of (ffetch (LINEDESCRIPTOR LFMTSPEC)
of LINE))
(* ;
 "This paragraph has been revised, so mark it.")
(\TEDIT.MARK.REVISION TEXTOBJ (fetch (LINEDESCRIPTOR LFMTSPEC) of LINE)
WINDOWDS LINE)))
(SELECTQ (fetch (LINEDESCRIPTOR LMARK) of LINE)
(GREY (* ;
(\TEDIT.MARK.REVISION TEXTOBJ (ffetch (LINEDESCRIPTOR LFMTSPEC) of LINE)
WINDOWDS LINE)))
(SELECTQ (ffetch (LINEDESCRIPTOR LMARK) of LINE)
(GREY (* ;
 "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)
6 6 'TEXTURE 'PAINT 42405))
(SOLID (* ;
(BITBLT NIL 0 0 WINDOWDS 0 (ffetch (LINEDESCRIPTOR YBASE) of LINE)
6 6 'TEXTURE 'PAINT 42405))
(SOLID (* ;
 "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)
6 6 'TEXTURE 'PAINT BLACKSHADE))
(BITBLT NIL 0 0 WINDOWDS 0 (fetch (LINEDESCRIPTOR YBASE) of LINE)
6 6 'TEXTURE 'REPLACE WHITESHADE])
(BITBLT NIL 0 0 WINDOWDS 0 (ffetch (LINEDESCRIPTOR YBASE) of LINE)
6 6 'TEXTURE 'PAINT BLACKSHADE))
(BITBLT NIL 0 0 WINDOWDS 0 (ffetch (LINEDESCRIPTOR YBASE) of LINE)
6 6 'TEXTURE 'REPLACE WHITESHADE])
(\TEDIT.LINECACHE
(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
1991 1992 1993 1994 2021))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (2874 76866 (\FORMATLINE 2884 . 56612) (\TEDIT.NSCHAR.RUN 56614 . 63431) (
\TEDIT.PURGE.SPACES 63433 . 63891) (\DOFORMATTING 63893 . 76864)) (76867 98847 (\DISPLAYLINE 76877 .
94847) (\TEDIT.LINECACHE 94849 . 95600) (\TEDIT.CREATE.LINECACHE 95602 . 96346) (\TEDIT.BLTCHAR 96348
. 98845)) (99561 214016 (TEDIT.CR.UPDATESCREEN 99571 . 100822) (TEDIT.DELETELINE 100824 . 101858) (
TEDIT.INSERT.DISPLAYTEXT 101860 . 117099) (TEDIT.INSERT.UPDATESCREEN 117101 . 123853) (
TEDIT.UPDATE.SCREEN 123855 . 125073) (\BACKFORMAT 125075 . 129386) (\FILLWINDOW 129388 . 144492) (
\FIXDLINES 144494 . 151731) (\FIXILINES 151733 . 159708) (\SHOWTEXT 159710 . 162966) (
\TEDIT.ADJUST.LINES 162968 . 170435) (\TEDIT.CLEAR.SCREEN.BELOW.LINE 170437 . 171167) (
\TEDIT.CLOSEUPLINES 171169 . 179685) (\TEDIT.COPY.LINEDESCRIPTOR 179687 . 185253) (
\TEDIT.FIXCHANGEDLINE 185255 . 196434) (\TEDIT.FIXCHANGEDPART 196436 . 208863) (\TEDIT.INSERTLINE
208865 . 209685) (\TEDIT.LINE.LIST 209687 . 210013) (\TEDIT.MARK.LINES.DIRTY 210015 . 211701) (
\TEDIT.NEXT.LINE.BOTTOM 211703 . 214014)))))
(FILEMAP (NIL (2767 76759 (\FORMATLINE 2777 . 56505) (\TEDIT.NSCHAR.RUN 56507 . 63324) (
\TEDIT.PURGE.SPACES 63326 . 63784) (\DOFORMATTING 63786 . 76757)) (76760 98628 (\DISPLAYLINE 76770 .
94628) (\TEDIT.LINECACHE 94630 . 95381) (\TEDIT.CREATE.LINECACHE 95383 . 96127) (\TEDIT.BLTCHAR 96129
. 98626)) (99342 213797 (TEDIT.CR.UPDATESCREEN 99352 . 100603) (TEDIT.DELETELINE 100605 . 101639) (
TEDIT.INSERT.DISPLAYTEXT 101641 . 116880) (TEDIT.INSERT.UPDATESCREEN 116882 . 123634) (
TEDIT.UPDATE.SCREEN 123636 . 124854) (\BACKFORMAT 124856 . 129167) (\FILLWINDOW 129169 . 144273) (
\FIXDLINES 144275 . 151512) (\FIXILINES 151514 . 159489) (\SHOWTEXT 159491 . 162747) (
\TEDIT.ADJUST.LINES 162749 . 170216) (\TEDIT.CLEAR.SCREEN.BELOW.LINE 170218 . 170948) (
\TEDIT.CLOSEUPLINES 170950 . 179466) (\TEDIT.COPY.LINEDESCRIPTOR 179468 . 185034) (
\TEDIT.FIXCHANGEDLINE 185036 . 196215) (\TEDIT.FIXCHANGEDPART 196217 . 208644) (\TEDIT.INSERTLINE
208646 . 209466) (\TEDIT.LINE.LIST 209468 . 209794) (\TEDIT.MARK.LINES.DIRTY 209796 . 211482) (
\TEDIT.NEXT.LINE.BOTTOM 211484 . 213795)))))
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)
(FILECREATED "21-Aug-2021 13:13:04" 
{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>UNICODE.;193 64903
(FILECREATED "30-Sep-2021 16:03:18" 
{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>UNICODE.;194 64783
changes to%: (FNS MAKE-UNICODE-TRANSLATION-TABLES)
previous date%: " 8-Aug-2021 13:10:17"
{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>UNICODE.;192)
previous date%: "21-Aug-2021 13:13:04"
{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>UNICODE.;193)
(PRETTYCOMPRINT UNICODECOMS)
(RPAQQ UNICODECOMS
[(COMS
(* ;; "External formats")
(* ;; "External formats")
(FNS UTF8.OUTCHARFN UTF8.INCCODEFN UTF8.PEEKCCODEFN \UTF8.BACKCCODEFN)
(FNS UTF16BE.OUTCHARFN UTF16BE.INCCODEFN UTF16BE.PEEKCCODEFN \UTF16.BACKCCODEFN)
@@ -25,14 +23,14 @@
(DECLARE%: EVAL@COMPILE DONTCOPY (MACROS UNICODE.TRANSLATE))
(FNS XTOUCODE UTOXCODE))
[COMS
(* ;; "Unicode mapping files")
(* ;; "Unicode mapping files")
(FNS READ-UNICODE-MAPPING-FILENAMES READ-UNICODE-MAPPING WRITE-UNICODE-MAPPING
WRITE-UNICODE-INCLUDED WRITE-UNICODE-MAPPING-HEADER WRITE-UNICODE-MAPPING-FILENAME
)
(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"
:RADIX 16))
@@ -43,7 +41,7 @@
(P (PUSHNEW UNICODEDIRECTORIES (PACK* (UNIX-GETENV "MEDLEYDIR")
'/unicode/xerox/]
(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)
[INITVARS (DEFAULT-XCCS-CHARSETS '(LATIN SYMBOLS1 SYMBOLS2 EXTENDED-LATIN FORMS
@@ -63,7 +61,7 @@
"NOTE: UNICODE requires EXPORTS.ALL for compilation"
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)
(MAX-ALIST-LENGTH 10)
@@ -78,13 +76,13 @@
(DEFINEQ
(UTF8.OUTCHARFN
[LAMBDA (STREAM CHARCODE RAW) (* ; "Edited 8-Aug-2021 13:02 by rmk:")
(* ; "Edited 17-Aug-2020 08:45 by rmk:")
(* ; "Edited 30-Jan-2020 23:08 by rmk:")
[LAMBDA (STREAM CHARCODE RAW) (* ; "Edited 8-Aug-2021 13:02 by rmk:")
(* ; "Edited 17-Aug-2020 08:45 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))
THEN (FREPLACE (STREAM CHARPOSITION) OF STREAM WITH 0)
@@ -97,13 +95,13 @@
DO (IF (ILESSP C 128)
THEN (\BOUT STREAM C)
ELSEIF (ILESSP C 2048)
THEN (* ; "x800")
THEN (* ; "x800")
(\BOUT STREAM (LOGOR (LLSH 3 6)
(LRSH C 6)))
(\BOUT STREAM (LOGOR (LLSH 2 6)
(LOADBYTE C 0 6)))
ELSEIF (ILESSP C 65536)
THEN (* ; "x10000")
THEN (* ; "x10000")
(\BOUT STREAM (LOGOR (LLSH 7 5)
(LRSH C 12)))
(\BOUT STREAM (LOGOR (LLSH 2 6)
@@ -111,7 +109,7 @@
(\BOUT STREAM (LOGOR (LLSH 2 6)
(LOADBYTE C 0 6)))
ELSEIF (ILESSP C 2097152)
THEN (* ; "x200000")
THEN (* ; "x200000")
(\BOUT STREAM (LOGOR (LLSH 15 4)
(LRSH C 18)))
(\BOUT STREAM (LOGOR (LLSH 2 6)
@@ -123,29 +121,29 @@
ELSE (ERROR "CHARCODE too big for UTF8" C])
(UTF8.INCCODEFN
[LAMBDA (STREAM COUNTP RAW) (* ; "Edited 6-Aug-2021 16:02 by rmk:")
(* ; "Edited 6-Aug-2020 17:13 by rmk:")
[LAMBDA (STREAM COUNTP RAW) (* ; "Edited 6-Aug-2021 16:02 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*))
(LET (BYTE1 BYTE2 BYTE3 BYTE4 CODE (COUNT 1))
(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)
[SETQ CODE (IF (ILESSP BYTE1 128)
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
(CR (SELECTC (FETCH (STREAM EOLCONVENTION) OF STREAM)
(CR.EOLC (* ; "Also eq BYTE1")
(CR.EOLC (* ; "Also eq BYTE1")
(CHARCODE EOL))
(CRLF.EOLC (IF (EQ (CHARCODE LF)
(\PEEKBIN STREAM T))
@@ -160,7 +158,7 @@
BYTE1))
BYTE1)
ELSEIF (IGEQ BYTE1 (LLSH 15 4))
THEN (* ; "4 bytes")
THEN (* ; "4 bytes")
(SETQ BYTE2 (\BIN STREAM))
(CL:WHEN (OR (NOT (SMALLP BYTE2))
(ILESSP BYTE2 128))
@@ -182,7 +180,7 @@
6)
(LOADBYTE BYTE4 0 6))
ELSEIF (IGEQ BYTE1 (LLSH 7 5))
THEN (* ; "3 bytes")
THEN (* ; "3 bytes")
(SETQ BYTE2 (\BIN STREAM))
(CL:WHEN (OR (NOT (SMALLP BYTE2))
(ILESSP BYTE2 128))
@@ -197,7 +195,7 @@
(LLSH (LOADBYTE BYTE2 0 6)
6)
(LOADBYTE BYTE3 0 6))
ELSE (* ; "Must be 2 bytes")
ELSE (* ; "Must be 2 bytes")
(SETQ COUNT 2)
(SETQ BYTE2 (\BIN STREAM))
(CL:WHEN (OR (NOT (SMALLP BYTE2))
@@ -211,12 +209,97 @@
(CL:WHEN COUNTP (SETQ *BYTECOUNTER* COUNT))
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
(* ;; "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*))
(BIND (C _ 0) WHILE (CL:WHEN (\BACKFILEPTR STREAM)
@@ -228,12 +311,12 @@
(DEFINEQ
(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))
THEN (FREPLACE (STREAM CHARPOSITION) OF STREAM WITH 0)
@@ -245,10 +328,10 @@
DO (\WOUT STREAM C])
(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*))
(LET (CODE BYTE1 BYTE2 COUNT)
@@ -264,14 +347,37 @@
CODE
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
(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*))
(CL:WHEN (\BACKFILEPTR STREAM)
@@ -285,11 +391,11 @@
(DEFINEQ
(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)
(FUNCTION UTF8.PEEKCCODEFN)
@@ -325,11 +431,11 @@
(DEFINEQ
(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))
INVERSE NEXTCODE)
@@ -349,9 +455,9 @@
(DEFINEQ
(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)))
[EQ 'TXT (U-CASE (FILENAMEFIELD (FULLNAME STREAM)
@@ -379,11 +485,11 @@
(DEFINEQ
(XTOUCODE
(* ;; "Common for big-ending and little-ending")
[LAMBDA (XCCSCODE) (* ; "Edited 9-Aug-2020 09:04 by rmk:")
(UNICODE.TRANSLATE XCCSCODE *XCCSTOUNICODE*])
(UTOXCODE
(IF (\BACKFILEPTR STREAM)
[LAMBDA (UNICODE) (* ; "Edited 9-Aug-2020 09:04 by rmk:")
(UNICODE.TRANSLATE UNICODE *UNICODETOXCCS*])
)
@@ -394,9 +500,8 @@
(DEFINEQ
(READ-UNICODE-MAPPING-FILENAMES
(* ;; "RAW formats do not do XCCS/Unicode translation, just deal with the byte encoding.")
[LAMBDA (FILESPEC) (* ; "Edited 5-Aug-2020 15:59 by kaplan")
(* ; "Edited 4-Aug-2020 17:31 by rmk:")
(FOR F X CSI INSIDE FILESPEC
COLLECT (IF (FINDFILE (PACKFILENAME 'BODY F 'EXTENSION 'TXT)
T UNICODEDIRECTORIES)
@@ -412,24 +517,24 @@
ELSE F])
(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 (
 READ-UNICODE-MAPPING-FILENAMES
@@ -461,18 +566,18 @@
(NTHCHARCODE LINE START])
(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)
(NULL FILE))
@@ -513,15 +618,15 @@
" # "
(SELECTC FIRSTRIGHTC
(UNDEFINEDCODE
(CADR CSI))
(* ;; "FFFF")
"UNDEFINED")
(MISSINGCODE
ELSE F])
(* ;; "FFFE")
"MISSING")
(IF (ILESSP FIRSTRIGHTC 32)
THEN (* ; "Control chars")
[CONCAT "^" (CHARACTER (IPLUS FIRSTRIGHTC
(CHARCODE @]
ELSE (CHARACTER FIRSTRIGHTC)))
@@ -535,13 +640,13 @@
NIL])
(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)
FILESPEC)
(* ;; "Normalize the INCLUDECHARSETS, then reduce MAPPING to the included mappings")
[SETQ ICSETS (FOR C POS KNOWN INSIDE (OR INCLUDECHARSETS (FOR CSI IN
XCCS-SET-NAMES
@@ -569,13 +674,13 @@
ICSETS))
COLLECT
[LAMBDA (MAPPING INCLUDECHARSETS FILE EMPTYOK) (* ; "Edited 16-Aug-2020 16:56 by rmk:")
(* ;; "The attested subset of INCLUDED")
(CL:UNLESS (MEMB CSI CSETINFO)
(PUSH CSETINFO CSI))
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 RANGES (FOR CTAIL C START END ON (FOR CSI IN CSETINFO
@@ -587,7 +692,7 @@
COLLECT (SETQ CTAIL (CDR 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
JOIN (SETQ LAST (CAR (LAST R)))
@@ -607,9 +712,9 @@
(CL:VALUES IMAPPING CSETINFO RANGES])
(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
DO (PRINTOUT STREAM "#" 2)
@@ -620,7 +725,7 @@
THEN (PRINTOUT STREAM "s:" -4)
(FOR R IN RANGES DO (PRINTOUT STREAM R " "))
(TERPRI STREAM)
(UNDEFINEDCODE
ELSE (* ; "Singleton")
(PRINTOUT STREAM ": " -4 (CADAR CSETINFO)
" "
(CADDAR CSETINFO)))
@@ -632,7 +737,7 @@
(TERPRI STREAM])
(WRITE-UNICODE-MAPPING-FILENAME
ELSE (CHARACTER FIRSTRIGHTC)))
[LAMBDA (FILE CSETINFO RANGES) (* ; "Edited 4-Aug-2020 19:34 by rmk:")
(PACKFILENAME 'BODY [OR FILE (CONCATLIST
(CONS 'XCCS- (IF (CDR CSETINFO)
THEN (FOR RTAIL R ON RANGES
@@ -736,53 +841,53 @@
(DEFINEQ
(MAKE-UNICODE-TRANSLATION-TABLES
(PRINTOUT STREAM LINE T)))
(TERPRI STREAM])
[LAMBDA (MAPPING LTORVAR RTOLVAR) (* ; "Edited 21-Aug-2021 13:12 by rmk:")
(* ; "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)
:INITIAL-ELEMENT NIL))
(RTOLARRAY (CL:MAKE-ARRAY (IPLUS 2 N-TRANSLATION-SEGMENTS)
: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))
(SETQ RBASE (CAR RCODES))
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:IF (CDR RCODES)
@@ -796,7 +901,7 @@
MAX-ALIST-LENGTH)
DO
(* ;; "Leave it alone if the alist is short")
(SETQ CSA (CL:MAKE-ARRAY TRANSLATION-SEGMENT-SIZE :INITIAL-ELEMENT NIL))
(FOR P IN (CL:SVREF LTORARRAY I)
@@ -806,17 +911,17 @@
(CL:SETF (CL:SVREF LTORARRAY I)
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))
(SETQ RCOMBINERS (CDDR M))
UNLESS (OR (IGEQ RBASE MISSINGCODE)
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 PREV (ASSOC (LOGAND RBASE TRANSLATION-MASK)
@@ -838,7 +943,7 @@
MAX-ALIST-LENGTH)
DO
(* ;; "Long list, make an array")
(SETQ CSA (CL:MAKE-ARRAY TRANSLATION-SEGMENT-SIZE :INITIAL-ELEMENT NIL))
(FOR P IN (CL:SVREF RTOLARRAY I)
@@ -848,9 +953,9 @@
(CL:SETF (CL:SVREF RTOLARRAY I)
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)
(LIST (HASHARRAY 10)
@@ -863,14 +968,14 @@
(CHARCODE.DECODE "U+F8FF")
(CHARCODE.DECODE "U+E000")))
(* ;; "")
(* ;; "Now put in the inverse unmapped hash arrays")
(CL:SETF (CL:SVREF LTORARRAY (ADD1 N-TRANSLATION-SEGMENTS))
(CL:SVREF RTOLARRAY N-TRANSLATION-SEGMENTS))
(CL:SETF (CL:SVREF RTOLARRAY (ADD1 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 RTOLVAR (SETATOMVAL RTOLVAR RTOLARRAY))
@@ -892,11 +997,11 @@
(DEFINEQ
(HEXSTRING
(CL:PUSH (CONS (LOGAND LEFTC TRANSLATION-MASK)
(CL:IF (CDR RCODES)
[LAMBDA (N WIDTH) (* ; "Edited 23-Jul-2020 08:28 by rmk:")
(* ; "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)
(SETQ N (CHARCODE.DECODE N)))
@@ -915,21 +1020,21 @@
STR])
(UTF8HEXSTRING
[LAMBDA (CHARCODE) (* ; "Edited 10-Aug-2020 08:33 by rmk:")
(* ;; "Utility to produces the UTF8 hexstring representing CODE")
(HEXSTRING (IF (ILESSP CHARCODE 128)
THEN CHARCODE
ELSEIF (ILESSP CHARCODE 2048)
THEN (* ; "x800")
(LOGOR (LLSH (LOGOR (LLSH 3 6)
(LRSH CHARCODE 6))
8)
(LOGOR (LLSH 2 6)
(LOADBYTE CHARCODE 0 6)))
ELSEIF (ILESSP CHARCODE 65536)
TRANSLATION-SHIFT
THEN (* ; "x10000")
(LOGOR (LLSH (LOGOR (LLSH 7 5)
(LRSH CHARCODE 12))
16)
@@ -939,7 +1044,7 @@
(LOGOR (LLSH 2 6)
(LOADBYTE CHARCODE 0 6)))
ELSEIF (ILESSP CHARCODE 2097152)
LEFTC)
THEN (* ; "x200000")
(LOGOR (LLSH (LOGOR (LLSH 15 4)
(LRSH CHARCODE 18))
24)
@@ -954,27 +1059,27 @@
ELSE (ERROR "CHARCODE too big for UTF8" CHARCODE])
(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)
THEN 1
ELSEIF (ILESSP N 2048)
(LIST (HASHARRAY 10)
THEN (* ; "x800")
4
ELSEIF (ILESSP N 65536)
(CHARCODE.DECODE "5,0")))
THEN (* ; "x10000")
3
ELSEIF (ILESSP N 2097152)
(CHARCODE.DECODE "U+E000")
THEN (* ; "x200000")
2
ELSE (SHOULDNT])
(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))
SUM (NUTF8CODEBYTES (CL:IF RAWFLG
@@ -982,11 +1087,11 @@
(XTOUCODE C))])
(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]
(FOR I CHARCODE (SINDEX _ 0) FROM 1 WHILE (SETQ CHARCODE (NTHCHARCODE XCCSSTRING
@@ -997,7 +1102,7 @@
THEN (RPLCHARCODE USTR (ADD SINDEX 1)
CHARCODE)
ELSEIF (ILESSP CHARCODE 2048)
(DEFINEQ
THEN (* ; "x800")
(RPLCHARCODE USTR (ADD SINDEX 1)
(LOGOR (LLSH 3 6)
(LRSH CHARCODE 6)))
@@ -1005,7 +1110,7 @@
(LOGOR (LLSH 2 6)
(LOADBYTE CHARCODE 0 6)))
ELSEIF (ILESSP CHARCODE 65536)
THEN (* ; "x10000")
(RPLCHARCODE USTR (ADD SINDEX 1)
(LOGOR (LLSH 7 5)
(LRSH CHARCODE 12)))
@@ -1016,7 +1121,7 @@
(LOGOR (LLSH 2 6)
(LOADBYTE CHARCODE 0 6)))
ELSEIF (ILESSP CHARCODE 2097152)
THEN (+ CHAR (CHARCODE 0))
THEN (* ; "x200000")
(RPLCHARCODE USTR (ADD SINDEX 1)
(LOGOR (LLSH 15 4)
(LRSH CHARCODE 18)))
@@ -1033,9 +1138,9 @@
USTR])
(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)
(SETQ CODE (CHCON1 CODE)))
@@ -1046,14 +1151,14 @@
(DEFINEQ
(SHOWCHARS
ELSEIF (ILESSP CHARCODE 2097152)
[LAMBDA (FROMCHAR TOCHAR FONT) (* ; "Edited 1-Aug-2020 09:27 by rmk:")
(RESETFORM (DSPFONT (OR FONT '(CLASSIC 12))
T)
(CL:WHEN (AND (SMALLP FROMCHAR)
(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 FROMCHAR (CONCAT FROMCHAR "," 41)))
@@ -1100,15 +1205,15 @@
)
)
(DECLARE%: DONTCOPY
(SETQ CHARCODE (XTOUCODE CHARCODE)))
(IF (ILESSP CHARCODE 128)
THEN (RPLCHARCODE USTR (ADD SINDEX 1)
CHARCODE)
ELSEIF (ILESSP CHARCODE 2048)
THEN (* ; "x800")
(RPLCHARCODE USTR (ADD SINDEX 1)
(LOGOR (LLSH 3 6)
(LRSH CHARCODE 6)))
(RPLCHARCODE USTR (ADD SINDEX 1)
(LOGOR (LLSH 2 6)
(FILEMAP (NIL (4046 17726 (UTF8.OUTCHARFN 4056 . 6887) (UTF8.INCCODEFN 6889 . 12379) (UTF8.PEEKCCODEFN
12381 . 17155) (\UTF8.BACKCCODEFN 17157 . 17724)) (17727 21053 (UTF16BE.OUTCHARFN 17737 . 18561) (
UTF16BE.INCCODEFN 18563 . 19462) (UTF16BE.PEEKCCODEFN 19464 . 20535) (\UTF16.BACKCCODEFN 20537 . 21051
)) (21083 22891 (MAKE-UNICODE-FORMATS 21093 . 22889)) (22988 24294 (UNICODE.UNMAPPED 22998 . 24292)) (
24295 24831 (XCCS-UTF8-AFTER-OPEN 24305 . 24829)) (25901 26250 (XTOUCODE 25911 . 26079) (UTOXCODE
26081 . 26248)) (26290 42412 (READ-UNICODE-MAPPING-FILENAMES 26300 . 27401) (READ-UNICODE-MAPPING
27403 . 30701) (WRITE-UNICODE-MAPPING 30703 . 34920) (WRITE-UNICODE-INCLUDED 34922 . 39644) (
WRITE-UNICODE-MAPPING-HEADER 39646 . 40878) (WRITE-UNICODE-MAPPING-FILENAME 40880 . 42410)) (45749
54228 (MAKE-UNICODE-TRANSLATION-TABLES 45759 . 54226)) (54649 62553 (HEXSTRING 54659 . 55820) (
UTF8HEXSTRING 55822 . 58027) (NUTF8CODEBYTES 58029 . 58692) (NUTF8STRINGBYTES 58694 . 59175) (
XTOUSTRING 59177 . 62188) (XCCSSTRING 62190 . 62551)) (62554 64023 (SHOWCHARS 62564 . 64021)))))
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.

89
library/lafite/LAFITE
View File

@@ -1,12 +1,11 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "24-Jun-2021 19:17:01" 
{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>lafite>LAFITE.;4 71992
(FILECREATED "30-Sep-2021 22:59:08" 
{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>lafite>LAFITE.;5 71956
changes to%: (FNS \LAFITE.EOF)
(FILES LAFITEDECLS)
changes to%: (FILES LAFITEDECLS)
previous date%: "22-Aug-94 13:00:22"
{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>lafite>LAFITE.;2)
previous date%: "24-Jun-2021 19:17:01"
{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))
(FNS LAFITE.AROUNDEXIT \LAFITE.MARK.FOLDERS.OBSOLETE \LAFITE.CHECK.FOLDERS
\LAFITE.ASSURE.FOLDER.READY \LAFITE.AFTERLOGIN))
(COMS (* ; "misc utilities")
(COMS (* ; "misc utilities")
(FNS LA.RESETSHADE LA.MENU.ITEM NTHMESSAGE \LAFITE.MAKE.MSGARRAY
\LAFITE.ADDMESSAGES.TO.ARRAY \MAILFOLDER.DEFPRINT \LAFITEMSG.DEFPRINT
LA.POSITION.FROM.REGION MAILFOLDERBUSY)
(CURSORS LA.CROSSCURSOR)
(* ; "Low level file functions")
(* ; "Low level file functions")
(FNS TOCFILENAME DELETEMAILFOLDER \LAFITE.OPEN.FOLDER \LAFITE.REPORT.FILE.WONT.OPEN
\LAFITE.FOLDER.CHANGED \LAFITE.REBROWSE.FOLDER \LAFITE.FOLDER.CHANGED.MENU
\LAFITE.SET.FOLDER.STREAM \LAFITE.OPENSTREAM \LAFITE.CREATE.MENU \LAFITE.EOF
\LAFITE.CLOSE.FOLDER)
(FNS \LAFITE.DESCRIBE.FOLDER))
(COMS (* ;
 "Make is easy to load new versions of Lafite")
(COMS (* ;
 "Make is easy to load new versions of Lafite")
(FNS LOAD-LAFITE)
(VARS LAFITEFILES))
[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
LAFITESORT TEDIT LAFITETEDIT LAFITEFIND ATTACHEDWINDOW MAILSCAVENGE)
(P * (PROGN LAFITE.PROCLAMATIONS))
(* ;
 "Proclaim user interface variables. Value is on LAFITEDECLS")
(* ;
 "Proclaim user interface variables. Value is on LAFITEDECLS")
(P (\LAFITE.GLOBAL.INIT)
(COND ((EQ MAKESYSNAME :LYRIC)
(FILESLOAD (SYSLOAD)
NSCHARPATCH)
(* ;
 "Patch to horrid Lyric NS chars bug")
(* ;
 "Patch to horrid Lyric NS chars bug")
(MOVD? 'PROMPTFORWORD 'TTYINPROMPTFORWORD NIL T]
(DECLARE%: DOEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML)
@@ -117,7 +116,7 @@ Copyright (c) 1982-1989, 1993-1994, 2021 by Xerox Corporation and Bolt Beranek a
(RPAQQ LAFITEVERSION# 10)
(RPAQQ LAFITESYSTEMDATE "24-Jun-2021 19:17:01")
(RPAQQ LAFITESYSTEMDATE "30-Sep-2021 22:59:08")
(DEFINEQ
(LAFITE
@@ -277,8 +276,8 @@ Mode affects SendMail only; mail is still retrieved in all modes.~]" (if \LAFITE
DEFAULTFONT)
(CHARWIDTH (CHARCODE "W")
DEFAULTFONT))
(* ;
 "Yes, user has not changed default to a variable width font")
(* ;
 "Yes, user has not changed default to a variable width font")
DEFAULTFONT)
(T (FONTCREATE '(GACHA 10]
(LAFITEHARDCOPYFONT LAFITEDISPLAYFONT)
@@ -317,8 +316,8 @@ Mode affects SendMail only; mail is still retrieved in all modes.~]" (if \LAFITE
DEFAULTFONT)
(CHARWIDTH (CHARCODE "W")
DEFAULTFONT))
(* ;
 "Yes, user has not changed default to a variable width font")
(* ;
 "Yes, user has not changed default to a variable width font")
DEFAULTFONT)
(T (FONTCREATE '(GACHA 10])
@@ -864,8 +863,8 @@ Mode affects SendMail only; mail is still retrieved in all modes.~]" (if \LAFITE
(COND
((EQ MAKESYSNAME :LYRIC)
(FILESLOAD (SYSLOAD)
NSCHARPATCH) (* ;
 "Patch to horrid Lyric NS chars bug")
NSCHARPATCH) (* ;
 "Patch to horrid Lyric NS chars bug")
(MOVD? 'PROMPTFORWORD 'TTYINPROMPTFORWORD NIL T)))
)
(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
1986 1987 1988 1989 1993 1994 2021))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (7140 22186 (LAFITE 7150 . 8461) (LAFITE.ON.FROM.BACKGROUND 8463 . 8834) (\LAFITE.OFF
8836 . 9220) (\LAFITE.START.PROC 9222 . 10998) (LAFITE.COMPUTE.CACHED.VARS 11000 . 13702) (
\LAFITE.PROCESS 13704 . 14070) (\LAFITE.START.ABORT 14072 . 14264) (\LAFITE.QUIT 14266 . 14508) (
\LAFITE.RESTART 14510 . 14643) (\LAFITE.SUBQUIT 14645 . 15943) (\LAFITE.QUIT.PROC 15945 . 18681) (
\LAFITEDEFAULTHOST&DIR 18683 . 19493) (LAFITEDEFAULTHOST&DIR 19495 . 19665) (MAKELAFITECOMMANDWINDOW
19667 . 21306) (EXTRACTMENUCOMMAND 21308 . 21556) (DOMAINLAFITECOMMAND 21558 . 21707) (
LAFITE.TOGGLE.SERVER.TRACE 21709 . 22184)) (22261 25229 (LAFITEMODE 22271 . 22751) (\LAFITE.INFER.MODE
22753 . 23106) (\LAFITE.SHOW.MODE 23108 . 23345) (\LAFITE.MODE.TITLE 23347 . 23632) (
LAFITE.SHOW.MODE.P 23634 . 23875) (LAFITE.ALL.MODES.P 23877 . 24220) (SET.LAFITE.MODE.INTERACTIVELY
24222 . 24804) (\LAFITE.COMPUTE.MODE.COMMANDS 24806 . 25227)) (26079 27835 (\LAFITE.LOGIN 26089 .
26471) (\LAFITE.LOGIN.NORESTART 26473 . 26579) (LAFITE.PROMPT.FOR.LOGIN 26581 . 27600) (
\LAFITE.REAUTHENTICATE 27602 . 27833)) (35346 38788 (LAFITE.AROUNDEXIT 35356 . 35894) (
\LAFITE.MARK.FOLDERS.OBSOLETE 35896 . 36812) (\LAFITE.CHECK.FOLDERS 36814 . 37213) (
\LAFITE.ASSURE.FOLDER.READY 37215 . 37625) (\LAFITE.AFTERLOGIN 37627 . 38786)) (38820 41758 (
LA.RESETSHADE 38830 . 39208) (LA.MENU.ITEM 39210 . 39628) (NTHMESSAGE 39630 . 39713) (
\LAFITE.MAKE.MSGARRAY 39715 . 40145) (\LAFITE.ADDMESSAGES.TO.ARRAY 40147 . 40728) (
\MAILFOLDER.DEFPRINT 40730 . 40977) (\LAFITEMSG.DEFPRINT 40979 . 41141) (LA.POSITION.FROM.REGION 41143
. 41620) (MAILFOLDERBUSY 41622 . 41756)) (41936 58324 (TOCFILENAME 41946 . 42377) (DELETEMAILFOLDER
42379 . 42899) (\LAFITE.OPEN.FOLDER 42901 . 47516) (\LAFITE.REPORT.FILE.WONT.OPEN 47518 . 48242) (
\LAFITE.FOLDER.CHANGED 48244 . 50648) (\LAFITE.REBROWSE.FOLDER 50650 . 53615) (
\LAFITE.FOLDER.CHANGED.MENU 53617 . 54540) (\LAFITE.SET.FOLDER.STREAM 54542 . 55236) (
\LAFITE.OPENSTREAM 55238 . 55777) (\LAFITE.CREATE.MENU 55779 . 56132) (\LAFITE.EOF 56134 . 57476) (
\LAFITE.CLOSE.FOLDER 57478 . 58322)) (58325 58909 (\LAFITE.DESCRIBE.FOLDER 58335 . 58907)) (58970
60076 (LOAD-LAFITE 58980 . 60074)) (67787 69064 (\LAFITE.GLOBAL.INIT 67797 . 69062)))))
(FILEMAP (NIL (7104 22150 (LAFITE 7114 . 8425) (LAFITE.ON.FROM.BACKGROUND 8427 . 8798) (\LAFITE.OFF
8800 . 9184) (\LAFITE.START.PROC 9186 . 10962) (LAFITE.COMPUTE.CACHED.VARS 10964 . 13666) (
\LAFITE.PROCESS 13668 . 14034) (\LAFITE.START.ABORT 14036 . 14228) (\LAFITE.QUIT 14230 . 14472) (
\LAFITE.RESTART 14474 . 14607) (\LAFITE.SUBQUIT 14609 . 15907) (\LAFITE.QUIT.PROC 15909 . 18645) (
\LAFITEDEFAULTHOST&DIR 18647 . 19457) (LAFITEDEFAULTHOST&DIR 19459 . 19629) (MAKELAFITECOMMANDWINDOW
19631 . 21270) (EXTRACTMENUCOMMAND 21272 . 21520) (DOMAINLAFITECOMMAND 21522 . 21671) (
LAFITE.TOGGLE.SERVER.TRACE 21673 . 22148)) (22225 25193 (LAFITEMODE 22235 . 22715) (\LAFITE.INFER.MODE
22717 . 23070) (\LAFITE.SHOW.MODE 23072 . 23309) (\LAFITE.MODE.TITLE 23311 . 23596) (
LAFITE.SHOW.MODE.P 23598 . 23839) (LAFITE.ALL.MODES.P 23841 . 24184) (SET.LAFITE.MODE.INTERACTIVELY
24186 . 24768) (\LAFITE.COMPUTE.MODE.COMMANDS 24770 . 25191)) (26043 27799 (\LAFITE.LOGIN 26053 .
26435) (\LAFITE.LOGIN.NORESTART 26437 . 26543) (LAFITE.PROMPT.FOR.LOGIN 26545 . 27564) (
\LAFITE.REAUTHENTICATE 27566 . 27797)) (35310 38752 (LAFITE.AROUNDEXIT 35320 . 35858) (
\LAFITE.MARK.FOLDERS.OBSOLETE 35860 . 36776) (\LAFITE.CHECK.FOLDERS 36778 . 37177) (
\LAFITE.ASSURE.FOLDER.READY 37179 . 37589) (\LAFITE.AFTERLOGIN 37591 . 38750)) (38784 41722 (
LA.RESETSHADE 38794 . 39172) (LA.MENU.ITEM 39174 . 39592) (NTHMESSAGE 39594 . 39677) (
\LAFITE.MAKE.MSGARRAY 39679 . 40109) (\LAFITE.ADDMESSAGES.TO.ARRAY 40111 . 40692) (
\MAILFOLDER.DEFPRINT 40694 . 40941) (\LAFITEMSG.DEFPRINT 40943 . 41105) (LA.POSITION.FROM.REGION 41107
. 41584) (MAILFOLDERBUSY 41586 . 41720)) (41900 58288 (TOCFILENAME 41910 . 42341) (DELETEMAILFOLDER
42343 . 42863) (\LAFITE.OPEN.FOLDER 42865 . 47480) (\LAFITE.REPORT.FILE.WONT.OPEN 47482 . 48206) (
\LAFITE.FOLDER.CHANGED 48208 . 50612) (\LAFITE.REBROWSE.FOLDER 50614 . 53579) (
\LAFITE.FOLDER.CHANGED.MENU 53581 . 54504) (\LAFITE.SET.FOLDER.STREAM 54506 . 55200) (
\LAFITE.OPENSTREAM 55202 . 55741) (\LAFITE.CREATE.MENU 55743 . 56096) (\LAFITE.EOF 56098 . 57440) (
\LAFITE.CLOSE.FOLDER 57442 . 58286)) (58289 58873 (\LAFITE.DESCRIBE.FOLDER 58299 . 58871)) (58934
60040 (LOAD-LAFITE 58944 . 60038)) (67751 69028 (\LAFITE.GLOBAL.INIT 67761 . 69026)))))
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)
(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)
(RPAQQ LAFITEFINDCOMS ((FNS \LAFITE.FIND \LAFITE.FIND.RELATED \LAFITE.FIND.RELATED.BACKWARD
\LAFITE.GO.TO.FIRST \LAFITE.GO.TO.INTERACTIVE \LAFITE.GO.TO.LAST
\LAFITE.FIND.AGAIN \LAFITE.FIND.PROMPT \LAFITE.DO.FIND
\LAFITE.FIND.START)
(DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS SEARCHSTATE)
(GLOBALVARS LAFITEFINDAREAMENUITEMS LAFITEFINDTYPEMENUITEMS
LAFITEFINDTYPEMENU LAFITEFINDAREAMENU LAFITEEXTRAMENU
LAFITEEXTRAMENUFLG \LAFITE.LAST.SEARCH)
(FILES (SOURCE)
LAFITEDECLS)
(LOCALVARS . T))
(INITVARS LAFITEFINDTYPEMENU LAFITEFINDAREAMENU)
(VARS LAFITEFINDAREAMENUITEMS LAFITEFINDTYPEMENUITEMS)
(ADDVARS [LAFITEEXTRAMENUITEMS ("Find" '\LAFITE.FIND
"Search mail for something")
["Find Related" '\LAFITE.FIND.RELATED
"Find all messages from here on in reply to this message"
(SUBITEMS ("Find Related Forward"
'\LAFITE.FIND.RELATED)
("Find Related Backward"
'\LAFITE.FIND.RELATED.BACKWARD]
("Find Again" '\LAFITE.FIND.AGAIN "Repeat previous search"
)
("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."]
(LAFITEMENUVARS LAFITEFINDTYPEMENU LAFITEFINDAREAMENU))
(VARS (\LAFITE.LAST.SEARCH))))
(RPAQQ LAFITEFINDCOMS
((FNS \LAFITE.FIND \LAFITE.FIND.RELATED \LAFITE.FIND.RELATED.BACKWARD \LAFITE.GO.TO.FIRST
\LAFITE.GO.TO.INTERACTIVE \LAFITE.GO.TO.LAST \LAFITE.FIND.AGAIN \LAFITE.FIND.PROMPT
\LAFITE.DO.FIND \LAFITE.FIND.START)
(DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS SEARCHSTATE)
(GLOBALVARS LAFITEFINDAREAMENUITEMS LAFITEFINDTYPEMENUITEMS LAFITEFINDTYPEMENU
LAFITEFINDAREAMENU LAFITEEXTRAMENU LAFITEEXTRAMENUFLG \LAFITE.LAST.SEARCH)
(FILES (SOURCE)
LAFITEDECLS)
(LOCALVARS . T))
(INITVARS LAFITEFINDTYPEMENU LAFITEFINDAREAMENU)
(VARS LAFITEFINDAREAMENUITEMS LAFITEFINDTYPEMENUITEMS)
(ADDVARS [LAFITEEXTRAMENUITEMS ("Find" '\LAFITE.FIND "Search mail for something")
["Find Related" '\LAFITE.FIND.RELATED
"Find all messages from here on in reply to this message"
(SUBITEMS ("Find Related Forward" '\LAFITE.FIND.RELATED)
("Find Related Backward" '\LAFITE.FIND.RELATED.BACKWARD]
("Find Again" '\LAFITE.FIND.AGAIN "Repeat previous search")
("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."]
(LAFITEMENUVARS LAFITEFINDTYPEMENU LAFITEFINDAREAMENU))
(VARS (\LAFITE.LAST.SEARCH))))
(DEFINEQ
(\LAFITE.FIND
@@ -147,45 +145,47 @@ Copyright (c) 1984, 1985, 1986, 1987, 1988, 1990, 1992 by Venue & Xerox Corporat
(RPAQ? LAFITEFINDAREAMENU NIL)
(RPAQQ LAFITEFINDAREAMENUITEMS ((From 'From "Search From: field for string (or To: if from self)"
)
(Subject 'Subject "Search Subject: field for string")
(Body 'Body "Search message bodies for string")
(Mark 'Mark "Search for messages with specified mark character")
(Related 'Related
"Search for a message with same Subject, modulo Re:")))
(RPAQQ LAFITEFINDAREAMENUITEMS
((From 'From "Search From: field for string (or To: if from self)")
(Subject 'Subject "Search Subject: field for string")
(Body 'Body "Search message bodies for string")
(Mark 'Mark "Search for messages with specified mark character")
(Related 'Related "Search for a message with same Subject, modulo Re:")))
(RPAQQ LAFITEFINDTYPEMENUITEMS (("Find Next One" '(FORWARD ONE)
"Search forward from selected message")
("Find Next All" '(FORWARD ALL)
"Search forward from selected message")
("Find Previous One" '(BACKWARD ONE)
"Search backward from selected message")
("Find Previous All" '(BACKWARD ALL)
"Search backward from selected message")))
(RPAQQ LAFITEFINDTYPEMENUITEMS
(("Find Next One" '(FORWARD ONE)
"Search forward from selected message")
("Find Next All" '(FORWARD ALL)
"Search forward from selected message")
("Find Previous One" '(BACKWARD ONE)
"Search backward from selected message")
("Find Previous All" '(BACKWARD ALL)
"Search backward from selected message")))
(ADDTOVAR LAFITEEXTRAMENUITEMS ("Find" '\LAFITE.FIND "Search mail for something")
["Find Related" '\LAFITE.FIND.RELATED
"Find all messages from here on in reply to this message"
(SUBITEMS ("Find Related Forward" '\LAFITE.FIND.RELATED)
("Find Related Backward"
'\LAFITE.FIND.RELATED.BACKWARD]
("Find Again" '\LAFITE.FIND.AGAIN "Repeat previous search")
("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 LAFITEEXTRAMENUITEMS
("Find" '\LAFITE.FIND "Search mail for something")
["Find Related" '\LAFITE.FIND.RELATED
"Find all messages from here on in reply to this message" (SUBITEMS
("Find Related Forward"
'\LAFITE.FIND.RELATED)
("Find Related Backward"
'
\LAFITE.FIND.RELATED.BACKWARD
]
("Find Again" '\LAFITE.FIND.AGAIN "Repeat previous search")
("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)
(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
(FILEMAP (NIL (3089 12861 (\LAFITE.FIND 3099 . 4131) (\LAFITE.FIND.RELATED 4133 . 4798) (
\LAFITE.FIND.RELATED.BACKWARD 4800 . 4936) (\LAFITE.GO.TO.FIRST 4938 . 5105) (
\LAFITE.GO.TO.INTERACTIVE 5107 . 5719) (\LAFITE.GO.TO.LAST 5721 . 5929) (\LAFITE.FIND.AGAIN 5931 .
6513) (\LAFITE.FIND.PROMPT 6515 . 8637) (\LAFITE.DO.FIND 8639 . 11790) (\LAFITE.FIND.START 11792 .
12859)))))
(FILEMAP (NIL (2309 12081 (\LAFITE.FIND 2319 . 3351) (\LAFITE.FIND.RELATED 3353 . 4018) (
\LAFITE.FIND.RELATED.BACKWARD 4020 . 4156) (\LAFITE.GO.TO.FIRST 4158 . 4325) (
\LAFITE.GO.TO.INTERACTIVE 4327 . 4939) (\LAFITE.GO.TO.LAST 4941 . 5149) (\LAFITE.FIND.AGAIN 5151 .
5733) (\LAFITE.FIND.PROMPT 5735 . 7857) (\LAFITE.DO.FIND 7859 . 11010) (\LAFITE.FIND.START 11012 .
12079)))))
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")
(FILECREATED " 7-Feb-95 13:10:22" {DSK}<lispcore>lafite>parc-94>LAFITESORT.;2 12117
changes to%: (VARS LAFITESORTCOMS)
previous date%: " 7-Oct-89 14:07:49" {DSK}<lispcore>lafite>parc-94>LAFITESORT.;1)
(* ; "
Copyright (c) 1989, 1995 by Xerox Corporation. All rights reserved.
")
(PRETTYCOMPRINT LAFITESORTCOMS)
(RPAQQ LAFITESORTCOMS
[(DECLARE%: EVAL@COMPILE DONTCOPY (FILES (SOURCE)
LAFITEDECLS))
(FNS LAFITE.ASSURE.DATE.FIELDS LAFITE.PARSE.DATE.FIELD LAFITE.PARSE.DATE.FIELD.ONLY
LAFITE.SORT.BY.DATE LAFITE.SORT.MESSAGES LAFITEMSG.DATE.ORDER
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "30-Sep-2021 22:58:58" 
{DSK}<USERS>KAPLAN>LOCAL>MEDLEY3.5>GIT-MEDLEY>LIBRARY>LAFITE>LAFITESORT.;1 19675
previous date%: " 7-Feb-95 13:10:22"
{DSK}<USERS>KAPLAN>LOCAL>MEDLEY3.5>GIT-MEDLEY>LIBRARY>LAFITE>LAFITESORT.;1)
(* ; "
Copyright (c) 1989, 1995, 2021 by Xerox Corporation.
")
(PRETTYCOMPRINT LAFITESORTCOMS)
(RPAQQ LAFITESORTCOMS
[(DECLARE%: EVAL@COMPILE DONTCOPY (FILES (SOURCE)
LAFITEDECLS))
(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.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)
(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)
(VARS LAFITETEDITCOMS)
changes to%: (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)
@@ -21,10 +25,10 @@ Copyright (c) 1988, 1990, 1992 by Xerox Corporation. All rights reserved.
LA.WINDOW.FROM.TEXTSTREAM TEDIT.ASSURE.NO.BACKING.FILE)
(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)
(FILESLOAD TEDITDECLS)))
(P (CL:UNLESS (GET 'TEDITDCL 'FILE)
(FILESLOAD TEDITDCL)))
(FILES (SOURCE)
LAFITEDECLS)
(GLOBALVARS *TEDIT-FILE-READTABLE*)
@@ -181,8 +185,8 @@ Copyright (c) 1988, 1990, 1992 by Xerox Corporation. All rights reserved.
)
(DECLARE%: EVAL@COMPILE DONTCOPY
(CL:UNLESS (GET 'TEDITDECLS 'FILE)
(FILESLOAD TEDITDECLS))
(CL:UNLESS (GET 'TEDITDCL 'FILE)
(FILESLOAD TEDITDCL))
(FILESLOAD (SOURCE)
@@ -198,9 +202,9 @@ Copyright (c) 1988, 1990, 1992 by Xerox Corporation. All rights reserved.
(LOCALVARS . T)
)
)
(PUTPROPS LAFITETEDIT COPYRIGHT ("Xerox Corporation" 1988 1990 1992))
(PUTPROPS LAFITETEDIT COPYRIGHT ("Xerox Corporation" 1988 1990 1992 2021))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (1342 11940 (LA.ADJUST.FORMATTING 1352 . 7488) (LA.SKIP.LOOKS.LIST 7490 . 8064) (
LA.DETACH.TEDIT 8066 . 8431) (LA.TEDIT.INCLUDE 8433 . 8922) (LA.WINDOW.FROM.TEXTSTREAM 8924 . 9370) (
TEDIT.ASSURE.NO.BACKING.FILE 9372 . 11938)))))
(FILEMAP (NIL (1549 12147 (LA.ADJUST.FORMATTING 1559 . 7695) (LA.SKIP.LOOKS.LIST 7697 . 8271) (
LA.DETACH.TEDIT 8273 . 8638) (LA.TEDIT.INCLUDE 8640 . 9129) (LA.WINDOW.FROM.TEXTSTREAM 9131 . 9577) (
TEDIT.ASSURE.NO.BACKING.FILE 9579 . 12145)))))
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.

BIN
library/lafite/MAILSCAVENGE.TEDIT Normal file
View File

Binary file not shown.

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