Compare commits
27 Commits
medley-210
...
medley-211
| Author | SHA1 | Date | |
|---|---|---|---|
|
e222743f74 | ||
|
|
ea0f303988 | ||
|
b85084ce31 | ||
|
e39943fdcc | ||
|
|
a4370ae57d | ||
|
|
cbfdfd6dab | ||
|
|
84bf09394e | ||
|
a92bce555f | ||
|
|
ae26c3c9fa | ||
|
|
09fec6ac56 | ||
|
|
625a5a839c | ||
|
|
f28a7a6278 | ||
|
|
9f85f4e17e | ||
|
|
1380722e55 | ||
|
|
d6173b5269 | ||
|
|
1d8fa0301d | ||
|
|
65a2d8000e | ||
|
|
388d54b713 | ||
|
|
f58936e762 | ||
|
|
63904f754c | ||
|
|
2dabe594f3 | ||
|
|
0462c1aa5e | ||
|
|
1d4c9ed6ee | ||
|
|
6b66665e9d | ||
|
|
db3ca49564 | ||
|
|
c89ac61d34 | ||
|
|
9b7464d966 |
@@ -1,13 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
|
||||
(FILECREATED "16-Nov-94 16:28:04" |{DSK}<lispcore>internal>library>MULTI-COMPILE.;4| 37236
|
||||
(FILECREATED "25-Sep-2021 21:28:08"
|
||||
|{DSK}<Users>kaplan>Local>medley3.5>git-medley>internal>library>MULTI-COMPILE.;2| 37172
|
||||
|
||||
|changes| |to:| (VARS MULTI-COMPILECOMS)
|
||||
(FNS FIND-UNCOMPILED-FILES)
|
||||
|
||||
|previous| |date:| " 9-Sep-94 13:03:19" |{DSK}<lispcore>internal>library>MULTI-COMPILE.;3|)
|
||||
|previous| |date:| "16-Nov-94 16:28:04"
|
||||
|{DSK}<Users>kaplan>Local>medley3.5>git-medley>internal>library>MULTI-COMPILE.;1|)
|
||||
|
||||
|
||||
; Copyright (c) 1988, 1990, 1991, 1992, 1993, 1994 by Venue & Xerox Corporation. All rights reserved.
|
||||
; Copyright (c) 1988, 1990-1994, 2021 by Venue & Xerox Corporation.
|
||||
|
||||
(PRETTYCOMPRINT MULTI-COMPILECOMS)
|
||||
|
||||
@@ -601,12 +600,12 @@
|
||||
|
||||
(ADDTOVAR LAMA FIX-FILES)
|
||||
)
|
||||
(PUTPROPS MULTI-COMPILE COPYRIGHT ("Venue & Xerox Corporation" 1988 1990 1991 1992 1993 1994))
|
||||
(PUTPROPS MULTI-COMPILE COPYRIGHT ("Venue & Xerox Corporation" 1988 1990 1991 1992 1993 1994 2021))
|
||||
(DECLARE\: DONTCOPY
|
||||
(FILEMAP (NIL (7131 8389 (FIND-UNCOMPILED-FILES 7141 . 8387)) (8461 19787 (NEWERDCOMS? 8471 . 12445) (
|
||||
NEWERSOURCES? 12447 . 16359) (SETUP-FOR-RECOMPILE 16361 . 18749) (SMASH-OPCODES 18751 . 19269) (
|
||||
GET-DIRECTORY-LISTING 19271 . 19568) (GET-OPEN-FILES 19570 . 19785)) (31690 36610 (FIX-FILES 31700 .
|
||||
34497) (FIX-FILE 34499 . 35090) (FIX-COPYRIGHT 35092 . 35319) (FIX-FILE-COPYRIGHT 35321 . 35481) (
|
||||
QUALIFY-FIELDS 35483 . 36022) (FIX-TEDIT 36024 . 36330) (FIX-DOCS 36332 . 36608)) (36735 36917 (CLFIX
|
||||
36745 . 36915)))))
|
||||
(FILEMAP (NIL (2676 6156 (BIGCOMP 2676 . 6156)) (6289 7061 (FIND-ALL-SOURCE-FILES 6289 . 7061)) (7062
|
||||
8320 (FIND-UNCOMPILED-FILES 7072 . 8318)) (8392 19718 (NEWERDCOMS? 8402 . 12376) (NEWERSOURCES? 12378
|
||||
. 16290) (SETUP-FOR-RECOMPILE 16292 . 18680) (SMASH-OPCODES 18682 . 19200) (GET-DIRECTORY-LISTING
|
||||
19202 . 19499) (GET-OPEN-FILES 19501 . 19716)) (31621 36541 (FIX-FILES 31631 . 34428) (FIX-FILE 34430
|
||||
. 35021) (FIX-COPYRIGHT 35023 . 35250) (FIX-FILE-COPYRIGHT 35252 . 35412) (QUALIFY-FIELDS 35414 .
|
||||
35953) (FIX-TEDIT 35955 . 36261) (FIX-DOCS 36263 . 36539)) (36666 36848 (CLFIX 36676 . 36846)))))
|
||||
STOP
|
||||
|
||||
@@ -1,9 +1,9 @@
|
||||
(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)
|
||||
|
||||
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)
|
||||
(CLISPIFTRANFLG T)
|
||||
(CROSSCOMPILING 'ASK)
|
||||
(DFNFLG 'PROP))
|
||||
(DFNFLG 'PROP)
|
||||
(*REPLACE-OLD-EDIT-DATES* NIL)
|
||||
(COPYRIGHTFLG 'PRESERVE))
|
||||
(P (RESETVARS ((CROSSCOMPILING T))
|
||||
(LOAD? 'EXPORTS.ALL])
|
||||
|
||||
@@ -37,6 +39,10 @@ Copyright (c) 1984, 1987, 1990, 2021 by Venue & Xerox Corporation.
|
||||
|
||||
(RPAQQ DFNFLG PROP)
|
||||
|
||||
(RPAQQ *REPLACE-OLD-EDIT-DATES* NIL)
|
||||
|
||||
(RPAQQ COPYRIGHTFLG PRESERVE)
|
||||
|
||||
(RESETVARS ((CROSSCOMPILING T))
|
||||
(LOAD? 'EXPORTS.ALL))
|
||||
(PUTPROPS SYSEDIT COPYRIGHT ("Venue & Xerox Corporation" 1984 1987 1990 2021))
|
||||
|
||||
@@ -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
|
||||
|
||||
Binary file not shown.
1035
library/TEDITDCL
1035
library/TEDITDCL
File diff suppressed because it is too large
Load Diff
@@ -1,9 +1,9 @@
|
||||
(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
|
||||
(FILECREATED "30-Apr-2021 17:26:58" ("compiled on "
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>TEDITDCL.;2) "29-Apr-2021 09:48:40" brecompiled
|
||||
exprs%: nothing in "Medley Full Sysout 30-Apr-2021 ..." dated "30-Apr-2021 14:49:58")
|
||||
(FILECREATED "30-Apr-2021 17:26:17" {DSK}<Users>kaplan>Local>medley3.5>git-medley>library>TEDITDCL.;2
|
||||
86155 previous date%: "25-Aug-94 10:53:00"
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
(FILECREATED "21-Sep-2021 12:53:57" ("compiled on "
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>TEDITDCL.;2) "20-Sep-2021 11:14:12" brecompiled
|
||||
exprs%: nothing in "FULL 20-Sep-2021 ..." dated "20-Sep-2021 11:14:18")
|
||||
(FILECREATED "21-Sep-2021 12:53:57" {DSK}<Users>kaplan>Local>medley3.5>git-medley>library>TEDITDCL.;2
|
||||
86549 changes to%: (VARS TEDITDCLCOMS) previous date%: "30-Apr-2021 17:26:17"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>TEDITDCL.;1)
|
||||
(PRETTYCOMPRINT TEDITDCLCOMS)
|
||||
(RPAQQ TEDITDCLCOMS ((* ;;;
|
||||
@@ -38,7 +38,9 @@ WORDDELETE.TTC 2) (DELETE.TTC 3) (FUNCTIONCALL.TTC 4) (REDO.TTC 5) (UNDO.TTC 6)
|
||||
8) (EXPAND.TTC 9) (PUNCT.TTC 20) (TEXT.TTC 21) (WHITESPACE.TTC 22))) (DECLARE%: EVAL@COMPILE DONTCOPY
|
||||
(CONSTANTS (MSPACE 153) (NSPACE 152) (THINSPACE 159) (FIGSPACE 154))) (* ;; "FROM TEDITWINDOW") (
|
||||
DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS TEDITCARET)) (INITRECORDS TEDITCARET) (* ;;
|
||||
"FROM PCTREE added by Nakamura") (RECORDS PCTNODE) (* ;;; "THE END") (COMS (* ;;
|
||||
"FROM PCTREE added by Nakamura") (RECORDS PCTNODE) (* ;; "FROM TEDITHCPY and TEDITSCREEN") (DECLARE%:
|
||||
EVAL@COMPILE DONTCOPY (GLOBALVARS TEDIT.DONT.BREAK.CHARS TEDIT.DONT.LAST.CHARS)) (* ;;; "THE END") (
|
||||
COMS (* ;;
|
||||
"Bits in the CHARTABLE that control line breaking, and what happens when a line is broken on this character "
|
||||
) (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (NOTBEFORE.LB 1) (* ;
|
||||
"Must not break before this character (e.g. Japanese right-paren)") (NOTAFTER.LB 2) (* ;
|
||||
|
||||
@@ -1,12 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
(FILECREATED "20-Sep-2021 11:12:06"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>TEDITHCPY.;4 105838
|
||||
(FILECREATED "21-Sep-2021 15:33:24"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>TEDITHCPY.;10 106458
|
||||
|
||||
changes to%: (FNS TEDIT.HARDCOPYFN)
|
||||
(VARS TEDITHCPYCOMS)
|
||||
|
||||
previous date%: "20-Sep-2021 11:06:37"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>TEDITHCPY.;3)
|
||||
previous date%: "21-Sep-2021 12:54:04"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>TEDITHCPY.;7)
|
||||
|
||||
|
||||
(* ; "
|
||||
@@ -15,7 +15,7 @@ Copyright (c) 1983-1994, 2021 by Venue & Xerox Corporation.
|
||||
|
||||
(PRETTYCOMPRINT TEDITHCPYCOMS)
|
||||
|
||||
(RPAQQ TEDITHCPYCOMS
|
||||
(RPAQQ TEDITHCPYCOMS
|
||||
((FILES TEDITDCL)
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (\SCRATCHLEN 64))
|
||||
(FILES (LOADCOMP)
|
||||
@@ -41,20 +41,26 @@ Copyright (c) 1983-1994, 2021 by Venue & Xerox Corporation.
|
||||
(* ;; "Support for the window-menu's HARDCOPY button, LISTFILES, etc.")
|
||||
|
||||
(FNS TEDIT.HARDCOPYFN \TEDIT.HARDCOPY \TEDIT.PRESS.HARDCOPY)
|
||||
[P (LET [(IPVALUES (ASSOC 'CONVERSION (ASSOC 'INTERPRESS PRINTFILETYPES]
|
||||
(COND (IPVALUES (* ;
|
||||
"Only install INTERPRESS printing if INTERPRESS is loaded.")
|
||||
(LISTPUT IPVALUES 'TEDIT (FUNCTION \TEDIT.HARDCOPY]
|
||||
(P (LISTPUT (ASSOC 'CONVERSION (ASSOC 'INTERPRESS PRINTFILETYPES))
|
||||
'TEDIT
|
||||
(FUNCTION \TEDIT.HARDCOPY)))
|
||||
(P (LET [(PRESSVALUES (ASSOC 'CONVERSION (ASSOC 'PRESS PRINTFILETYPES]
|
||||
(COND (PRESSVALUES (LISTPUT PRESSVALUES 'TEDIT (FUNCTION \TEDIT.PRESS.HARDCOPY]
|
||||
(COMS
|
||||
(COND (PRESSVALUES (* ;
|
||||
"Only install PRESS printing if PRESS is loaded.")
|
||||
(LISTPUT PRESSVALUES 'TEDIT (FUNCTION \TEDIT.PRESS.HARDCOPY]
|
||||
[COMS
|
||||
(* ;; "vars for Japanese Line Break")
|
||||
|
||||
[VARS (TEDIT.DONT.BREAK.CHARS '(8482 8483 8491 8492 8508 8525 8539 8537 8535 9249 9251
|
||||
9253 9255 9257 9283 9315 9317 9319 9326 9505 9507
|
||||
9509 9511 9513 9539 9571 9573 9575 9582))
|
||||
(TEDIT.DONT.LAST.CHARS '(8524 8538 8536 8534]
|
||||
(GLOBALVARS TEDIT.DONT.BREAK.CHARS TEDIT.DONT.LAST.CHARS))
|
||||
(INITVARS (TEDIT.DONT.BREAK.CHARS (CHARCODE ("41,42" "41,43" "41,53" "41,54" "41,74"
|
||||
"41,115" "41,133" "41,131" "41,127"
|
||||
"Hira,41" "Hira,43" "Hira,45"
|
||||
"Hira,47" "Hira,51" "Hira,103"
|
||||
"Hira,143" "Hira,145" "Hira,147"
|
||||
"Hira,156" "Kata,41" "Kata,43"
|
||||
"Kata,45" "Kata,47" "Kata,51"
|
||||
"Kata,103" "Kata,143" "Kata,145"
|
||||
"Kata,147" "Kata,156")))
|
||||
(TEDIT.DONT.LAST.CHARS (CHARCODE ("41,114" "41,132" "41,130" "41,126"]
|
||||
(COMS
|
||||
(* ;; "Support for hardcopying several files as one document")
|
||||
|
||||
@@ -1512,7 +1518,7 @@ Copyright (c) 1983-1994, 2021 by Venue & Xerox Corporation.
|
||||
(DEFINEQ
|
||||
|
||||
(TEDIT.HARDCOPYFN
|
||||
[LAMBDA (WINDOW IMAGESTREAM) (* ; "Edited 20-Sep-2021 11:12 by rmk:")
|
||||
[LAMBDA (WINDOW IMAGESTREAM) (* ; "Edited 21-Sep-2021 15:33 by rmk:")
|
||||
|
||||
(* ;;
|
||||
"This is the TEdit HARDCOPYFN, hooking into the system's standard Hardcopy window-menu operation.")
|
||||
@@ -1562,30 +1568,28 @@ Copyright (c) 1983-1994, 2021 by Venue & Xerox Corporation.
|
||||
PFILE)])
|
||||
)
|
||||
|
||||
[LET [(IPVALUES (ASSOC 'CONVERSION (ASSOC 'INTERPRESS PRINTFILETYPES]
|
||||
(COND
|
||||
(IPVALUES (* ;
|
||||
"Only install INTERPRESS printing if INTERPRESS is loaded.")
|
||||
(LISTPUT IPVALUES 'TEDIT (FUNCTION \TEDIT.HARDCOPY]
|
||||
(LISTPUT (ASSOC 'CONVERSION (ASSOC 'INTERPRESS PRINTFILETYPES))
|
||||
'TEDIT
|
||||
(FUNCTION \TEDIT.HARDCOPY))
|
||||
|
||||
[LET [(PRESSVALUES (ASSOC 'CONVERSION (ASSOC 'PRESS PRINTFILETYPES]
|
||||
(COND
|
||||
(PRESSVALUES (LISTPUT PRESSVALUES 'TEDIT (FUNCTION \TEDIT.PRESS.HARDCOPY]
|
||||
(PRESSVALUES (* ;
|
||||
"Only install PRESS printing if PRESS is loaded.")
|
||||
(LISTPUT PRESSVALUES 'TEDIT (FUNCTION \TEDIT.PRESS.HARDCOPY]
|
||||
|
||||
|
||||
|
||||
(* ;; "vars for Japanese Line Break")
|
||||
|
||||
|
||||
(RPAQQ TEDIT.DONT.BREAK.CHARS
|
||||
(8482 8483 8491 8492 8508 8525 8539 8537 8535 9249 9251 9253 9255 9257 9283 9315 9317 9319
|
||||
9326 9505 9507 9509 9511 9513 9539 9571 9573 9575 9582))
|
||||
(RPAQ? TEDIT.DONT.BREAK.CHARS
|
||||
(CHARCODE ("41,42" "41,43" "41,53" "41,54" "41,74" "41,115" "41,133" "41,131" "41,127"
|
||||
"Hira,41" "Hira,43" "Hira,45" "Hira,47" "Hira,51" "Hira,103" "Hira,143"
|
||||
"Hira,145" "Hira,147" "Hira,156" "Kata,41" "Kata,43" "Kata,45" "Kata,47"
|
||||
"Kata,51" "Kata,103" "Kata,143" "Kata,145" "Kata,147" "Kata,156")))
|
||||
|
||||
(RPAQQ TEDIT.DONT.LAST.CHARS (8524 8538 8536 8534))
|
||||
(DECLARE%: DOEVAL@COMPILE DONTCOPY
|
||||
|
||||
(GLOBALVARS TEDIT.DONT.BREAK.CHARS TEDIT.DONT.LAST.CHARS)
|
||||
)
|
||||
(RPAQ? TEDIT.DONT.LAST.CHARS (CHARCODE ("41,114" "41,132" "41,130" "41,126")))
|
||||
|
||||
|
||||
|
||||
@@ -1612,11 +1616,11 @@ Copyright (c) 1983-1994, 2021 by Venue & Xerox Corporation.
|
||||
(PUTPROPS TEDITHCPY COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1989 1990
|
||||
1991 1992 1993 1994 2021))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (3137 99855 (TEDIT.HARDCOPY 3147 . 4398) (TEDIT.HCPYFILE 4400 . 6474) (
|
||||
\TEDIT.HARDCOPY.DISPLAYLINE 6476 . 20621) (\TEDIT.HARDCOPY.FORMATLINE 20623 . 67945) (
|
||||
\DOFORMATTING.HARDCOPY 67947 . 81240) (\TEDIT.HARDCOPY.MODIFYLOOKS 81242 . 83649) (
|
||||
\TEDIT.HCPYLOOKS.UPDATE 83651 . 94259) (\TEDIT.HCPYFMTSPEC 94261 . 99281) (\TEDIT.INTEGER.IMAGEBOX
|
||||
99283 . 99853)) (99944 101028 (\TEDIT.SCALE 99954 . 100248) (\TEDIT.SCALEREGION 100250 . 101026)) (
|
||||
101271 103822 (TEDIT.HARDCOPYFN 101281 . 102186) (\TEDIT.HARDCOPY 102188 . 103097) (
|
||||
\TEDIT.PRESS.HARDCOPY 103099 . 103820)) (104785 105688 (TEDIT-BOOK 104795 . 105686)))))
|
||||
(FILEMAP (NIL (3655 100373 (TEDIT.HARDCOPY 3665 . 4916) (TEDIT.HCPYFILE 4918 . 6992) (
|
||||
\TEDIT.HARDCOPY.DISPLAYLINE 6994 . 21139) (\TEDIT.HARDCOPY.FORMATLINE 21141 . 68463) (
|
||||
\DOFORMATTING.HARDCOPY 68465 . 81758) (\TEDIT.HARDCOPY.MODIFYLOOKS 81760 . 84167) (
|
||||
\TEDIT.HCPYLOOKS.UPDATE 84169 . 94777) (\TEDIT.HCPYFMTSPEC 94779 . 99799) (\TEDIT.INTEGER.IMAGEBOX
|
||||
99801 . 100371)) (100462 101546 (\TEDIT.SCALE 100472 . 100766) (\TEDIT.SCALEREGION 100768 . 101544)) (
|
||||
101789 104340 (TEDIT.HARDCOPYFN 101799 . 102704) (\TEDIT.HARDCOPY 102706 . 103615) (
|
||||
\TEDIT.PRESS.HARDCOPY 103617 . 104338)) (105405 106308 (TEDIT-BOOK 105415 . 106306)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
File diff suppressed because one or more lines are too long
Binary file not shown.
417
library/UNICODE
417
library/UNICODE
@@ -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
|
||||
|
||||
Binary file not shown.
235
library/UNIXMAIL
235
library/UNIXMAIL
File diff suppressed because one or more lines are too long
Binary file not shown.
@@ -1,18 +1,27 @@
|
||||
(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
|
||||
(FILECREATED "16-Feb-90 17:00:31" "{piglet/n}<piglet>vanmelle>lispusers>UNIXTELNET;11" 3551
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
(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)
|
||||
|
||||
(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
|
||||
|
||||
(UNIX-TCPCHAT.HOST.FILTER
|
||||
@@ -20,8 +29,20 @@ Copyright (c) 1989, 1990 by Xerox Corporation. All rights reserved.
|
||||
)
|
||||
|
||||
(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
|
||||
(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
|
||||
|
||||
(GLOBALVARS CHAT.LOGINS CHAT.LOGINS.MENU)
|
||||
)
|
||||
(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))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (836 3203 (UNIX-TCPCHAT.HOST.FILTER 846 . 1353) (UNIX-TCPCHAT.OPEN 1355 . 1924) (
|
||||
UNIX-TCPCHAT.GET.LOGIN 1926 . 2495) (UNIX-TCPCHAT.INIT 2497 . 3201)))))
|
||||
(FILEMAP (NIL (872 3597 (UNIX-TCPCHAT.HOST.FILTER 882 . 1389) (UNIX-TCPCHAT.OPEN 1391 . 2318) (
|
||||
UNIX-TCPCHAT.GET.LOGIN 2320 . 2889) (UNIX-TCPCHAT.INIT 2891 . 3595)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,40 +1,37 @@
|
||||
(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)
|
||||
|
||||
(RPAQQ VTCHATCOMS [
|
||||
(* ;; "VT100 emulator")
|
||||
(RPAQQ VTCHATCOMS
|
||||
[
|
||||
(* ;; "VT100 emulator")
|
||||
|
||||
(FNS VTCHAT.STATE VTCHAT.HANDLECHARACTER VTCHAT.SEQUENCE VTCHAT.DOCOMMAND)
|
||||
(FNS VTCHAT.ADDRESS VTCHAT.REVERSE.INDEX VTCHAT.ATTRIBUTES VTCHAT.DECLFONT
|
||||
VTCHAT.CLEARMODES VTCHAT.SAVE VTCHAT.RESTORE VTCHAT.SETMODE
|
||||
VTCHAT.SETMARGINS VTCHAT.REPORT VTCHAT.STATUS)
|
||||
(INITVARS (VTCHAT.DEBUGGING.FLG)
|
||||
(VTCHAT.TERM.IDENTITY.STRING "[?1;0c"))
|
||||
(GLOBALVARS VTCHAT.DEBUGGING.FLG CHATFONT GRAPHICSFONT
|
||||
VTCHAT.TERM.IDENTITY.STRING)
|
||||
(ADDVARS (CHAT.DRIVERTYPES (VT100 VTCHAT.HANDLECHARACTER VTCHAT.STATE)))
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY (LOCALVARS . T)
|
||||
(FILES (LOADCOMP)
|
||||
CHATDECLS)
|
||||
(RECORDS VT100SAVE VT100.STATE))
|
||||
(INITRECORDS VT100.STATE)
|
||||
(SYSRECORDS VT100.STATE)
|
||||
(DECLARE%: DONTEVAL@LOAD DOCOPY (FILES (SYSLOAD)
|
||||
VT100KP)
|
||||
(ADDVARS (CHAT.DISPLAYTYPES (
|
||||
"Replace this string with NIL to prefer vt100"
|
||||
NIL VT100])
|
||||
(FNS VTCHAT.STATE VTCHAT.HANDLECHARACTER VTCHAT.SEQUENCE VTCHAT.DOCOMMAND)
|
||||
(FNS VTCHAT.ADDRESS VTCHAT.REVERSE.INDEX VTCHAT.ATTRIBUTES VTCHAT.DECLFONT VTCHAT.CLEARMODES
|
||||
VTCHAT.SAVE VTCHAT.RESTORE VTCHAT.SETMODE VTCHAT.SETMARGINS VTCHAT.REPORT VTCHAT.STATUS)
|
||||
(INITVARS (VTCHAT.DEBUGGING.FLG)
|
||||
(VTCHAT.TERM.IDENTITY.STRING "[?1;0c"))
|
||||
(GLOBALVARS VTCHAT.DEBUGGING.FLG CHATFONT GRAPHICSFONT VTCHAT.TERM.IDENTITY.STRING)
|
||||
(ADDVARS (CHAT.DRIVERTYPES (VT100 VTCHAT.HANDLECHARACTER VTCHAT.STATE)))
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY (LOCALVARS . T)
|
||||
(FILES (LOADCOMP)
|
||||
CHATDECLS)
|
||||
(RECORDS VT100SAVE VT100.STATE))
|
||||
(INITRECORDS VT100.STATE)
|
||||
(SYSRECORDS VT100.STATE)
|
||||
(DECLARE%: DONTEVAL@LOAD DOCOPY (FILES (SYSLOAD)
|
||||
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
|
||||
(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 "[0n" 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 "[0n" 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 )
|
||||
@@ -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))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (1995 10061 (VTCHAT.STATE 2005 . 2515) (VTCHAT.HANDLECHARACTER 2517 . 5091) (
|
||||
VTCHAT.SEQUENCE 5093 . 6636) (VTCHAT.DOCOMMAND 6638 . 10059)) (10062 16968 (VTCHAT.ADDRESS 10072 .
|
||||
10590) (VTCHAT.REVERSE.INDEX 10592 . 11161) (VTCHAT.ATTRIBUTES 11163 . 11549) (VTCHAT.DECLFONT 11551
|
||||
. 11820) (VTCHAT.CLEARMODES 11822 . 12325) (VTCHAT.SAVE 12327 . 13066) (VTCHAT.RESTORE 13068 . 13775)
|
||||
(VTCHAT.SETMODE 13777 . 14849) (VTCHAT.SETMARGINS 14851 . 15442) (VTCHAT.REPORT 15444 . 16204) (
|
||||
VTCHAT.STATUS 16206 . 16966)))))
|
||||
(FILEMAP (NIL (1532 9598 (VTCHAT.STATE 1542 . 2052) (VTCHAT.HANDLECHARACTER 2054 . 4628) (
|
||||
VTCHAT.SEQUENCE 4630 . 6173) (VTCHAT.DOCOMMAND 6175 . 9596)) (9599 17110 (VTCHAT.ADDRESS 9609 . 10127)
|
||||
(VTCHAT.REVERSE.INDEX 10129 . 10698) (VTCHAT.ATTRIBUTES 10700 . 11086) (VTCHAT.DECLFONT 11088 . 11357
|
||||
) (VTCHAT.CLEARMODES 11359 . 11862) (VTCHAT.SAVE 11864 . 12603) (VTCHAT.RESTORE 12605 . 13312) (
|
||||
VTCHAT.SETMODE 13314 . 14386) (VTCHAT.SETMARGINS 14388 . 14979) (VTCHAT.REPORT 14981 . 15741) (
|
||||
VTCHAT.STATUS 15743 . 17108)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -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
|
||||
|
||||
Binary file not shown.
File diff suppressed because one or more lines are too long
Binary file not shown.
File diff suppressed because one or more lines are too long
Binary file not shown.
@@ -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
|
||||
|
||||
Binary file not shown.
File diff suppressed because one or more lines are too long
Binary file not shown.
File diff suppressed because one or more lines are too long
Binary file not shown.
@@ -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
|
||||
|
||||
Binary file not shown.
@@ -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
|
||||
|
||||
Binary file not shown.
File diff suppressed because one or more lines are too long
Binary file not shown.
1390
library/lafite/UNIXMAIL
Normal file
1390
library/lafite/UNIXMAIL
Normal file
File diff suppressed because it is too large
Load Diff
BIN
library/lafite/UNIXMAIL.DFASL
Normal file
BIN
library/lafite/UNIXMAIL.DFASL
Normal file
Binary file not shown.
18
run-medley
18
run-medley
@@ -1,7 +1,8 @@
|
||||
#!/bin/sh
|
||||
# Run Medley
|
||||
#
|
||||
# Syntax: run-medley [--dimensions WIDTHxHEIGHT] # sets both -g -sc
|
||||
# Syntax: run-medley [-noscroll] #turn off scrollbars
|
||||
# [--dimensions WIDTHxHEIGHT] # sets both -g -sc
|
||||
# [-g WIDTHxHEIGHT]
|
||||
# [-sc WIDTHxHEIGHT]
|
||||
# [--display X_DISPLAY] # defaults to $DISPLAY or :0
|
||||
@@ -38,6 +39,8 @@ fi
|
||||
prog="lde"
|
||||
passthrough_args=""
|
||||
mem="-m 256"
|
||||
scroll=22
|
||||
noscroll=""
|
||||
|
||||
if [ -z "$LDEDESTSYSOUT" ] ; then
|
||||
if [ -z "$LOGINDIR" ] ; then
|
||||
@@ -65,19 +68,24 @@ while [ "$#" -ne 0 ]; do
|
||||
mkdir -p $MEDLEYDIR/tmp/logindir
|
||||
export HOME=$MEDLEYDIR/tmp/logindir
|
||||
export LOGINDIR=$MEDLEYDIR/tmp/logindir
|
||||
|
||||
export LDEINIT="$MEDLEYDIR/greetfiles/NOGREET"
|
||||
;;
|
||||
"-greet" | "--greet")
|
||||
export LDEINIT="$2"
|
||||
shift
|
||||
;;
|
||||
"-noscroll")
|
||||
scroll=0
|
||||
noscroll="-noscroll"
|
||||
;;
|
||||
"--dimensions" | "-dimensions")
|
||||
sw=`expr "$2" : "\([0-9]*\)x[0-9]*$"`
|
||||
sh=`expr "$2" : "[0-9]*x\([0-9]*\)$"`
|
||||
if [ -n "$sw" -a -n "$sh" ] ; then
|
||||
sw=$(( (31+$sw)/32*32 ))
|
||||
gw=$(( 22+$sw ))
|
||||
gh=$(( 22+$sh ))
|
||||
gw=$(( $scroll+$sw ))
|
||||
gh=$(( $scroll+$sh ))
|
||||
geometry="-g ${gw}x${gh}"
|
||||
screensize="-sc ${sw}x${sh}"
|
||||
fi
|
||||
@@ -180,11 +188,11 @@ if ! command -v "$prog" > /dev/null 2>&1; then
|
||||
fi
|
||||
fi
|
||||
|
||||
echo "running: $prog $geometry $screensize $mem $passthrough_args $LDESRCESYSOUT"
|
||||
echo "running: $prog $noscroll $geometry $screensize $mem $passthrough_args $LDESRCESYSOUT"
|
||||
echo "greet: $LDEINIT"
|
||||
|
||||
export INMEDLEY=1
|
||||
|
||||
"$prog" $geometry $screensize $mem -t "Medley Interlisp" $passthrough_args "$LDESRCESYSOUT"
|
||||
"$prog" $noscroll $geometry $screensize $mem -t "Medley Interlisp" $passthrough_args "$LDESRCESYSOUT"
|
||||
|
||||
|
||||
|
||||
@@ -17,4 +17,4 @@ tr '\r' '\n' < $1 | \
|
||||
-e 's//[33m/g'\
|
||||
-e 's//[32m/g'\
|
||||
-e 's/ /[35m:[0m/g' \
|
||||
| less -R
|
||||
| less -r
|
||||
|
||||
@@ -1,11 +1,11 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
(FILECREATED "17-Aug-2021 00:08:39"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>BOOTSTRAP.;58 47657
|
||||
(FILECREATED "27-Sep-2021 10:25:31"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>BOOTSTRAP.;60 47698
|
||||
|
||||
changes to%: (FNS \DO-DEFINE-FILE-INFO PRINT-READER-ENVIRONMENT)
|
||||
changes to%: (FNS PRINT-READER-ENVIRONMENT READ-READER-ENVIRONMENT)
|
||||
|
||||
previous date%: "15-Aug-2021 21:21:35"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>BOOTSTRAP.;57)
|
||||
previous date%: "17-Aug-2021 00:08:39"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>BOOTSTRAP.;58)
|
||||
|
||||
|
||||
(* ; "
|
||||
@@ -15,14 +15,14 @@ Copyright (c) 1983-1990, 1992, 2021 by Venue & Xerox Corporation.
|
||||
(PRETTYCOMPRINT BOOTSTRAPCOMS)
|
||||
|
||||
(RPAQQ BOOTSTRAPCOMS
|
||||
[(COMS (* ; "Some basic fns. Note that several are redefined later. E.g., RPAQQ et al real definitions are on UNDO")
|
||||
[(COMS (* ; "Some basic fns. Note that several are redefined later. E.g., RPAQQ et al real definitions are on UNDO")
|
||||
(FNS GETPROP SETATOMVAL RPAQQ RPAQ RPAQ? MOVD MOVD? SELECTQ SELECTQ1 NCONC1 PUTPROP
|
||||
PROPNAMES ADDPROP REMPROP MEMB CLOSEF?))
|
||||
(COMS (* ;
|
||||
"Need these in order to load even compiled files SYSLOAD")
|
||||
(COMS (* ;
|
||||
"Need these in order to load even compiled files SYSLOAD")
|
||||
(FNS LOAD \LOAD-STREAM FILECREATED FILECREATED1 PRETTYCOMPRINT BOOTSTRAP-NAMEFIELD
|
||||
PUTPROPS DECLARE%: DECLARE%:1 ROOTFILENAME))
|
||||
[COMS (* ; "For DEFINE-FILE-INFO")
|
||||
[COMS (* ; "For DEFINE-FILE-INFO")
|
||||
(FNS DEFINE-FILE-INFO \DO-DEFINE-FILE-INFO PRINT-READER-ENVIRONMENT
|
||||
READ-READER-ENVIRONMENT MAKE-DEFINE-FILE-INFO-ENV)
|
||||
(INITVARS (*DEFINE-FILE-INFO-ENV* (MAKE-DEFINE-FILE-INFO-ENV]
|
||||
@@ -76,7 +76,7 @@ Copyright (c) 1983-1990, 1992, 2021 by Venue & Xerox Corporation.
|
||||
(AND (CCODEP 'BOOTSTRAP-NAMEFIELD)
|
||||
(PUTD 'BOOTSTRAP-NAMEFIELD]
|
||||
(P (RADIX 10)))
|
||||
(DECLARE%: DOEVAL@COMPILE DONTCOPY (* ; "eventually imported from FASL")
|
||||
(DECLARE%: DOEVAL@COMPILE DONTCOPY (* ; "eventually imported from FASL")
|
||||
(CONSTANTS FASL:SIGNATURE))
|
||||
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
|
||||
(ADDVARS (NLAMA DEFINE-FILE-INFO DECLARE%: PUTPROPS FILECREATED SELECTQ)
|
||||
@@ -784,9 +784,9 @@ Copyright (c) 1983-1990, 1992, 2021 by Venue & Xerox Corporation.
|
||||
REREADTABLEFORM _ READTABLEFORM])
|
||||
|
||||
(PRINT-READER-ENVIRONMENT
|
||||
[LAMBDA (ENV STREAM) (* ; "Edited 16-Aug-2021 23:51 by rmk:")
|
||||
[LAMBDA (ENV STREAM) (* ; "Edited 27-Sep-2021 10:24 by rmk:")
|
||||
|
||||
(* ;;; "If ENV is not the old default interlisp reader environment, writes a DEFINE-FILE-INFO expression on STREAM that will produce this environment when the file is loaded.")
|
||||
(* ;;; "If ENV is not the old default interlisp reader environment, writes a DEFINE-FILE-INFO expression on STREAM that will produce this environment when the file is loaded.")
|
||||
|
||||
(CL:UNLESS (EQUAL-READER-ENVIRONMENT ENV *OLD-INTERLISP-READ-ENVIRONMENT*)
|
||||
(LET ((*PACKAGE* *INTERLISP-PACKAGE*)
|
||||
@@ -807,14 +807,15 @@ Copyright (c) 1983-1990, 1992, 2021 by Venue & Xerox Corporation.
|
||||
,@(CL:UNLESS (EQ :XCCS (FETCH REFORMAT OF ENV))
|
||||
`(:FORMAT ,(FETCH REFORMAT OF ENV)))]
|
||||
STREAM
|
||||
(FETCH (READER-ENVIRONMENT REREADTABLE) OF *DEFINE-FILE-INFO-ENV*))))])
|
||||
(FETCH (READER-ENVIRONMENT REREADTABLE) OF *DEFINE-FILE-INFO-ENV*))
|
||||
(TERPRI STREAM)))])
|
||||
|
||||
(READ-READER-ENVIRONMENT
|
||||
[LAMBDA (STREAM DEFAULTENV RETURNFORM) (* ; "Edited 30-Jul-2021 09:58 by rmk:")
|
||||
[LAMBDA (STREAM DEFAULTENV RETURNFORM) (* ; "Edited 26-Sep-2021 23:31 by rmk:")
|
||||
|
||||
(* ;; "Starting environment is the old interlisp file, just for the seprchar scans.")
|
||||
(* ;; "Starting environment is the old interlisp file, just for the seprchar scans.")
|
||||
|
||||
(* ;; "RETURNFORM=T means return the DEFINE-FILE-INFO as a second value, for READFILE")
|
||||
(* ;; "RETURNFORM=T means return the DEFINE-FILE-INFO as a second value, for READFILE")
|
||||
|
||||
(CL:UNLESS DEFAULTENV (SETQ DEFAULTENV *OLD-INTERLISP-READ-ENVIRONMENT*))
|
||||
(LET ((START (GETFILEPTR STREAM))
|
||||
@@ -825,32 +826,32 @@ Copyright (c) 1983-1990, 1992, 2021 by Venue & Xerox Corporation.
|
||||
)))
|
||||
(DECLARE (SPECVARS *READTABLE*))
|
||||
(SELCHARQ (SKIPSEPRCODES STREAM)
|
||||
(";" (* ; "Assume it's a common lisp file")
|
||||
(";" (* ; "Assume it's a common lisp file")
|
||||
(\EXTERNALFORMAT STREAM (FETCH (READER-ENVIRONMENT REFORMAT) OF
|
||||
*COMMON-LISP-READ-ENVIRONMENT*
|
||||
))
|
||||
*COMMON-LISP-READ-ENVIRONMENT*)
|
||||
("(" (\EXTERNALFORMAT STREAM (FETCH (READER-ENVIRONMENT REFORMAT) OF
|
||||
*DEFINE-FILE-INFO-ENV*
|
||||
)) (* ;
|
||||
"Should we reset the format if we fail?")
|
||||
)) (* ;
|
||||
"Should we reset the format if we fail?")
|
||||
(READCCODE STREAM)
|
||||
(WITH-READER-ENVIRONMENT *DEFINE-FILE-INFO-ENV*
|
||||
(IF (EQ 'DEFINE-FILE-INFO (RATOM STREAM))
|
||||
(IF (STREQUAL "DEFINE-FILE-INFO" (RSTRING STREAM))
|
||||
THEN
|
||||
|
||||
(* ;;
|
||||
"After the \DO-DEFINE-FILE-INFO, we have the new environment and we have set the new format.")
|
||||
(* ;;
|
||||
"After the \DO-DEFINE-FILE-INFO, we have the new environment and we have set the new format.")
|
||||
|
||||
[SETQ ENV (\DO-DEFINE-FILE-INFO STREAM (SETQ ARGS
|
||||
(CL:READ-DELIMITED-LIST
|
||||
(CHARCODE ")")
|
||||
STREAM]
|
||||
ELSE (* ; "Hope we are RANDACCESSP")
|
||||
ELSE (* ; "Hope we are RANDACCESSP")
|
||||
(SETFILEPTR STREAM START))
|
||||
|
||||
(* ;;
|
||||
"If we didn't see ARGS, then we didn't see a DEFINE-FILE-INFO, no form to return.")
|
||||
(* ;;
|
||||
"If we didn't see ARGS, then we didn't see a DEFINE-FILE-INFO, no form to return.")
|
||||
|
||||
(CL:IF (AND RETURNFORM ARGS)
|
||||
(CL:VALUES ENV (CONS 'DEFINE-FILE-INFO ARGS))
|
||||
@@ -981,13 +982,13 @@ Copyright (c) 1983-1990, 1992, 2021 by Venue & Xerox Corporation.
|
||||
(PUTPROPS BOOTSTRAP COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1989 1990
|
||||
1992 2021))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (4748 14420 (GETPROP 4758 . 5330) (SETATOMVAL 5332 . 5461) (RPAQQ 5463 . 5516) (RPAQ
|
||||
5518 . 5830) (RPAQ? 5832 . 6202) (MOVD 6204 . 8068) (MOVD? 8070 . 8500) (SELECTQ 8502 . 8689) (
|
||||
SELECTQ1 8691 . 9033) (NCONC1 9035 . 9231) (PUTPROP 9233 . 10717) (PROPNAMES 10719 . 10910) (ADDPROP
|
||||
10912 . 12975) (REMPROP 12977 . 13831) (MEMB 13833 . 14092) (CLOSEF? 14094 . 14418)) (14493 35057 (
|
||||
LOAD 14503 . 15672) (\LOAD-STREAM 15674 . 28748) (FILECREATED 28750 . 30168) (FILECREATED1 30170 .
|
||||
31278) (PRETTYCOMPRINT 31280 . 31765) (BOOTSTRAP-NAMEFIELD 31767 . 32727) (PUTPROPS 32729 . 33097) (
|
||||
DECLARE%: 33099 . 33231) (DECLARE%:1 33233 . 34105) (ROOTFILENAME 34107 . 35055)) (35095 45489 (
|
||||
DEFINE-FILE-INFO 35105 . 35540) (\DO-DEFINE-FILE-INFO 35542 . 39888) (PRINT-READER-ENVIRONMENT 39890
|
||||
. 41443) (READ-READER-ENVIRONMENT 41445 . 44211) (MAKE-DEFINE-FILE-INFO-ENV 44213 . 45487)))))
|
||||
(FILEMAP (NIL (4751 14423 (GETPROP 4761 . 5333) (SETATOMVAL 5335 . 5464) (RPAQQ 5466 . 5519) (RPAQ
|
||||
5521 . 5833) (RPAQ? 5835 . 6205) (MOVD 6207 . 8071) (MOVD? 8073 . 8503) (SELECTQ 8505 . 8692) (
|
||||
SELECTQ1 8694 . 9036) (NCONC1 9038 . 9234) (PUTPROP 9236 . 10720) (PROPNAMES 10722 . 10913) (ADDPROP
|
||||
10915 . 12978) (REMPROP 12980 . 13834) (MEMB 13836 . 14095) (CLOSEF? 14097 . 14421)) (14496 35060 (
|
||||
LOAD 14506 . 15675) (\LOAD-STREAM 15677 . 28751) (FILECREATED 28753 . 30171) (FILECREATED1 30173 .
|
||||
31281) (PRETTYCOMPRINT 31283 . 31768) (BOOTSTRAP-NAMEFIELD 31770 . 32730) (PUTPROPS 32732 . 33100) (
|
||||
DECLARE%: 33102 . 33234) (DECLARE%:1 33236 . 34108) (ROOTFILENAME 34110 . 35058)) (35098 45530 (
|
||||
DEFINE-FILE-INFO 35108 . 35543) (\DO-DEFINE-FILE-INFO 35545 . 39891) (PRINT-READER-ENVIRONMENT 39893
|
||||
. 41475) (READ-READER-ENVIRONMENT 41477 . 44252) (MAKE-DEFINE-FILE-INFO-ENV 44254 . 45528)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
604
sources/EXTERNALFORMAT
Normal file
604
sources/EXTERNALFORMAT
Normal file
@@ -0,0 +1,604 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
(FILECREATED "19-Sep-2021 08:59:42"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>EXTERNALFORMAT.;16 31868
|
||||
|
||||
changes to%: (VARS EXTERNALFORMATCOMS)
|
||||
|
||||
previous date%: "11-Sep-2021 09:44:04"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>EXTERNALFORMAT.;15)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT EXTERNALFORMATCOMS)
|
||||
|
||||
(RPAQQ EXTERNALFORMATCOMS
|
||||
[(COMS (* ;
|
||||
"EXTERNALFORMAT declaration and related functions (originally on FILEIO)")
|
||||
(DECLARE%: DOEVAL@COMPILE DONTCOPY (EXPORT (RECORDS EXTERNALFORMAT)))
|
||||
(INITRECORDS EXTERNALFORMAT)
|
||||
(SYSRECORDS EXTERNALFORMAT)
|
||||
(FNS \EXTERNALFORMAT MAKE-EXTERNALFORMAT)
|
||||
(FNS \INSTALL.EXTERNALFORMAT \REMOVE.EXTERNALFORMAT FIND-FORMAT)
|
||||
(GLOBALVARS *EXTERNALFORMATS* *DEFAULT-EXTERNALFORMATS* *DEFAULT-EXTERNALFORMAT*)
|
||||
(INITVARS (*EXTERNALFORMATS* NIL)
|
||||
[*DEFAULT-EXTERNALFORMATS* '((DSK :XCCS]
|
||||
(*DEFAULT-EXTERNALFORMAT* :XCCS)))
|
||||
[COMS
|
||||
(* ;; "Generic functions not compiled open (originally on LLREAD)")
|
||||
|
||||
(FNS \OUTCHAR \INCCODE \BACKCCODE \BACKCCODE.EOLC \PEEKCCODE \PEEKCCODE.NOEOLC
|
||||
\INCCODE.EOLC \FORMATBYTESTREAM \CHECKEOLC.CRLF)
|
||||
(DECLARE%: DOEVAL@COMPILE DONTCOPY (EXPORT (MACROS \CHECKEOLC]
|
||||
(COMS
|
||||
(* ;; "Also from FILEIO, but not clear that this is or ever has been used.")
|
||||
|
||||
(FNS \CREATE.THROUGH.EXTERNALFORMAT \THROUGHIN \THROUGHBACKCCODE \THROUGHOUTCHARFN)
|
||||
(DECLARE%: DONTEVAL@LOAD DOCOPY (P (\CREATE.THROUGH.EXTERNALFORMAT])
|
||||
|
||||
|
||||
|
||||
(* ; "EXTERNALFORMAT declaration and related functions (originally on FILEIO)")
|
||||
|
||||
(DECLARE%: DOEVAL@COMPILE DONTCOPY
|
||||
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(DATATYPE EXTERNALFORMAT ((EOLVALID FLAG) (* ; "If true, the value of EOL field will replace the EOLCONVENTION field of the resulted stream. (Can't test EOL because it is always something)")
|
||||
(EOL BITS 2)
|
||||
(UNSTABLE FLAG) (* ; "T if (like XCCS runcodes) the byte encoding of a given character can change by other signals in the file, NIL if every charactercode has a single byte encoding (like UTF-8). ")
|
||||
(INCCODEFN POINTER) (* ;
|
||||
"Called with STREAM and 2 optional arguments, BYTECOUNTVAR and BYTECOUNTVAL")
|
||||
(PEEKCCODEFN POINTER) (* ;
|
||||
"Called with three arguments -- STREAM, NOERROR, and EOL")
|
||||
(BACKCCODEFN POINTER) (* ;
|
||||
"Called with STREAM and optional BYTECOUNTVAR and BYTECOUNTVAL")
|
||||
(OUTCHARFN POINTER) (* ;
|
||||
"Called with two arguments -- STREAM and CHARCODE")
|
||||
(NAME POINTER) (* ;
|
||||
"keyword name of this format, provided to \INSTALL.EXTERNALFORMAT")
|
||||
(FORMATBYTESTREAMFN POINTER) (* ; "Function to copy the format state of a given stream to an IO stream that allows formatted byte sequences to be examined")
|
||||
(EF1 POINTER) (* ;
|
||||
"Extra fields for use of particular formats. Possibly to hold standardized translation tables")
|
||||
(EF2 POINTER)))
|
||||
)
|
||||
|
||||
(/DECLAREDATATYPE 'EXTERNALFORMAT '(FLAG (BITS 2)
|
||||
FLAG POINTER POINTER POINTER POINTER POINTER POINTER POINTER
|
||||
POINTER)
|
||||
'((EXTERNALFORMAT 0 (FLAGBITS . 0))
|
||||
(EXTERNALFORMAT 0 (BITS . 17))
|
||||
(EXTERNALFORMAT 0 (FLAGBITS . 48))
|
||||
(EXTERNALFORMAT 0 POINTER)
|
||||
(EXTERNALFORMAT 2 POINTER)
|
||||
(EXTERNALFORMAT 4 POINTER)
|
||||
(EXTERNALFORMAT 6 POINTER)
|
||||
(EXTERNALFORMAT 8 POINTER)
|
||||
(EXTERNALFORMAT 10 POINTER)
|
||||
(EXTERNALFORMAT 12 POINTER)
|
||||
(EXTERNALFORMAT 14 POINTER))
|
||||
'16)
|
||||
|
||||
(* "END EXPORTED DEFINITIONS")
|
||||
|
||||
)
|
||||
|
||||
(/DECLAREDATATYPE 'EXTERNALFORMAT '(FLAG (BITS 2)
|
||||
FLAG POINTER POINTER POINTER POINTER POINTER POINTER POINTER
|
||||
POINTER)
|
||||
'((EXTERNALFORMAT 0 (FLAGBITS . 0))
|
||||
(EXTERNALFORMAT 0 (BITS . 17))
|
||||
(EXTERNALFORMAT 0 (FLAGBITS . 48))
|
||||
(EXTERNALFORMAT 0 POINTER)
|
||||
(EXTERNALFORMAT 2 POINTER)
|
||||
(EXTERNALFORMAT 4 POINTER)
|
||||
(EXTERNALFORMAT 6 POINTER)
|
||||
(EXTERNALFORMAT 8 POINTER)
|
||||
(EXTERNALFORMAT 10 POINTER)
|
||||
(EXTERNALFORMAT 12 POINTER)
|
||||
(EXTERNALFORMAT 14 POINTER))
|
||||
'16)
|
||||
(ADDTOVAR SYSTEMRECLST
|
||||
|
||||
(DATATYPE EXTERNALFORMAT ((EOLVALID FLAG)
|
||||
(EOL BITS 2)
|
||||
(UNSTABLE FLAG)
|
||||
(INCCODEFN POINTER)
|
||||
(PEEKCCODEFN POINTER)
|
||||
(BACKCCODEFN POINTER)
|
||||
(OUTCHARFN POINTER)
|
||||
(NAME POINTER)
|
||||
(FORMATBYTESTREAMFN POINTER)
|
||||
(EF1 POINTER)
|
||||
(EF2 POINTER)))
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
(\EXTERNALFORMAT
|
||||
[LAMBDA (STREAM NEWFORMAT/NAME) (* ; "Edited 10-Sep-2021 20:44 by rmk:")
|
||||
(* ; "Edited 26-Feb-91 13:20 by nm")
|
||||
|
||||
(* ;;; ";;; RMK July 2020: Added interface for per-device default external format. \DO.PARAMS.AT.OPEN will make that call even if it is not specified from the open. STREAMPROP is fixed to call \EXTERNALFORMAT to set the property EXTERNALFORMAT, to export a user-level way of manipulating this.")
|
||||
|
||||
(* ;;; "")
|
||||
|
||||
(* ;;; "If NEWFORMAT/NAME is nil, just returns the current external format name of STREAM. If NEWFORMAT/NAME is supplied and it is or names an external format, then the external format of STREAM is set to that format.")
|
||||
|
||||
(* ;;; "")
|
||||
|
||||
(* ;;; ":DEFAULT means the default external format for STREAM's filedevice")
|
||||
|
||||
(* ;;; "The all-device default is in *DEFAULT-EXTERNALFORMAT* or the DEFAULTEXTERNALFORMAT field of the file device. The list currently has priority since that makes it easier for a user without EXPORTS.ALL to systematically override. That may or may not be a useful capability. ")
|
||||
|
||||
(\DTEST STREAM 'STREAM)
|
||||
(SETQ SAVEDNAME (fetch DEVICENAME of (fetch DEVICE of STREAM)))
|
||||
(SETQ SAVEDDEFAULTFORMATNAME (fetch (FDEV DEFAULTEXTERNALFORMAT) of (fetch DEVICE
|
||||
of STREAM)))
|
||||
(SETQ FOUNDFORMAT (FIND-FORMAT SAVEDDEFAULTFORMATNAME T))
|
||||
(CL:WHEN NEWFORMAT/NAME
|
||||
(CL:WHEN (type? READER-ENVIRONMENT NEWFORMAT/NAME)
|
||||
(SETQ NEWFORMAT/NAME (fetch (READER-ENVIRONMENT REFORMAT) of NEWFORMAT/NAME)))
|
||||
[LET (EXTFORMAT)
|
||||
[COND
|
||||
((type? EXTERNALFORMAT NEWFORMAT/NAME)
|
||||
(SETQ EXTFORMAT NEWFORMAT/NAME))
|
||||
(T (CL:WHEN (EQ NEWFORMAT/NAME :DEFAULT)
|
||||
(SETQ NEWFORMAT/NAME (OR (CADR (ASSOC (fetch DEVICENAME
|
||||
of (fetch DEVICE of
|
||||
STREAM))
|
||||
*DEFAULT-EXTERNALFORMATS*))
|
||||
(fetch (FDEV DEFAULTEXTERNALFORMAT)
|
||||
of (fetch DEVICE of STREAM))
|
||||
*DEFAULT-EXTERNALFORMAT*)))
|
||||
(SETQ EXTFORMAT (FIND-FORMAT NEWFORMAT/NAME))
|
||||
(CL:UNLESS EXTFORMAT (ERROR NEWFORMAT/NAME
|
||||
"is not a registered external format name"))
|
||||
(CL:UNLESS (type? EXTERNALFORMAT EXTFORMAT)
|
||||
(ERROR "INVALID EXTERNALFORMAT " EXTFORMAT]
|
||||
(UNINTERRUPTABLY
|
||||
(freplace (STREAM EXTERNALFORMAT) of STREAM with EXTFORMAT)
|
||||
(CL:WHEN (ffetch (EXTERNALFORMAT EOLVALID) of EXTFORMAT)
|
||||
(freplace (STREAM EOLCONVENTION) of STREAM with (ffetch
|
||||
(EXTERNALFORMAT
|
||||
EOL) of
|
||||
EXTFORMAT
|
||||
)))
|
||||
(freplace (STREAM OUTCHARFN) of STREAM with (ffetch (EXTERNALFORMAT
|
||||
OUTCHARFN)
|
||||
of EXTFORMAT))
|
||||
(freplace (STREAM INCCODEFN) of STREAM with (ffetch (EXTERNALFORMAT
|
||||
INCCODEFN)
|
||||
of EXTFORMAT))
|
||||
(freplace (STREAM PEEKCCODEFN) of STREAM with (ffetch (
|
||||
EXTERNALFORMAT
|
||||
PEEKCCODEFN)
|
||||
of EXTFORMAT))
|
||||
(freplace (STREAM BACKCCODEFN) of STREAM with (ffetch (
|
||||
EXTERNALFORMAT
|
||||
BACKCCODEFN)
|
||||
of EXTFORMAT)))])
|
||||
(ffetch (EXTERNALFORMAT NAME) of (fetch (STREAM EXTERNALFORMAT) of STREAM])
|
||||
|
||||
(MAKE-EXTERNALFORMAT
|
||||
[LAMBDA (NAME INCCODEFN PEEKCCODEFN BACKCCODEFN OUTCHARFN FORMATBYTESTREAMFN EOL UNSTABLE)
|
||||
(* ; "Edited 10-Sep-2021 19:47 by rmk:")
|
||||
|
||||
(* ;; "Compiled creator for EXTERNALFORMAT so that declaration (EXPORTS.ALL) is not needed. If EOL is not specified, then EOLVALID is also NIL")
|
||||
|
||||
(SETQ EOL (SELECTC EOL
|
||||
((LIST 'LF LF.EOLC)
|
||||
LF.EOLC)
|
||||
((LIST 'CR CR.EOLC)
|
||||
CR.EOLC)
|
||||
((LIST 'CRLF CRLF.EOLC)
|
||||
CRLF.EOLC)
|
||||
(NIL)
|
||||
(SHOULDNT)))
|
||||
(\INSTALL.EXTERNALFORMAT (CREATE EXTERNALFORMAT
|
||||
NAME _ NAME
|
||||
INCCODEFN _ INCCODEFN
|
||||
PEEKCCODEFN _ PEEKCCODEFN
|
||||
BACKCCODEFN _ BACKCCODEFN
|
||||
OUTCHARFN _ OUTCHARFN
|
||||
FORMATBYTESTREAMFN _ FORMATBYTESTREAMFN
|
||||
EOLVALID _ EOL
|
||||
EOL _ (OR EOL LF.EOLC)
|
||||
UNSTABLE _ UNSTABLE])
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
(\INSTALL.EXTERNALFORMAT
|
||||
[LAMBDA (EXTFORMAT/NAME EXTERNALFORMAT) (* ; "Edited 5-Aug-2021 14:22 by rmk:")
|
||||
|
||||
(* ;;; "Register an instance of the datatype EXTERNALFORMAT.")
|
||||
|
||||
(* ;;; "For backward compatibility, the first argument can be a NAME with the second argument being the format. If so, the NAME must match the name inside the format")
|
||||
|
||||
(LET (NAME)
|
||||
(IF EXTERNALFORMAT
|
||||
THEN
|
||||
|
||||
(* ;; "Backwards compatibility")
|
||||
|
||||
(SETQ NAME (MKATOM EXTFORMAT/NAME))
|
||||
(IF (EQ NAME (FETCH (EXTERNALFORMAT NAME) OF EXTERNALFORMAT))
|
||||
ELSEIF (FETCH (EXTERNALFORMAT NAME) OF EXTERNALFORMAT)
|
||||
THEN (ERROR "Mismatch of specified name and name of the external format")
|
||||
ELSE (REPLACE (EXTERNALFORMAT NAME) OF EXTERNALFORMAT WITH
|
||||
NAME))
|
||||
ELSE (SETQ EXTERNALFORMAT EXTFORMAT/NAME)
|
||||
(SETQ NAME (FETCH (EXTERNALFORMAT NAME) OF EXTERNALFORMAT)))
|
||||
(IF (type? EXTERNALFORMAT EXTERNALFORMAT)
|
||||
THEN (\REMOVE.EXTERNALFORMAT NAME)
|
||||
(push *EXTERNALFORMATS* EXTERNALFORMAT)
|
||||
ELSE (ERROR "INVALID EXTERNALFORMAT " EXTERNALFORMAT))
|
||||
EXTERNALFORMAT])
|
||||
|
||||
(\REMOVE.EXTERNALFORMAT
|
||||
[LAMBDA (NAME/EXTFORMAT) (* ; "Edited 5-May-2021 15:42 by rmk:")
|
||||
|
||||
(* ;;; "Deregisters external format EXTERNALFORMAT .")
|
||||
|
||||
(SETQ NAME/EXTFORMAT (IF (TYPE? EXTERNALFORMAT NAME/EXTFORMAT)
|
||||
THEN (FETCH (EXTERNALFORMAT NAME) OF NAME/EXTFORMAT)
|
||||
ELSE (MKATOM NAME/EXTFORMAT)))
|
||||
(SETQ *EXTERNALFORMATS* (DREMOVE (FIND EF IN *EXTERNALFORMATS*
|
||||
SUCHTHAT (EQ NAME/EXTFORMAT (FETCH (EXTERNALFORMAT
|
||||
NAME)
|
||||
OF EF)))
|
||||
*EXTERNALFORMATS*])
|
||||
|
||||
(FIND-FORMAT
|
||||
[LAMBDA (NAME NOERROR) (* ; "Edited 7-Aug-2021 09:29 by rmk:")
|
||||
(IF (TYPE? EXTERNALFORMAT NAME)
|
||||
THEN NAME
|
||||
ELSE (SETQ NAME (MKATOM NAME)) (* ;
|
||||
"The EQMEMB allows for synonyms, the first of which should be canonical. E.g. (:UTF-8 :UTF8)")
|
||||
(OR (FIND EF IN *EXTERNALFORMATS* SUCHTHAT (EQ NAME (FETCH (
|
||||
EXTERNALFORMAT
|
||||
NAME)
|
||||
OF EF)))
|
||||
(CL:UNLESS NOERROR (ERROR NAME "is not an external format"])
|
||||
)
|
||||
(DECLARE%: DOEVAL@COMPILE DONTCOPY
|
||||
|
||||
(GLOBALVARS *EXTERNALFORMATS* *DEFAULT-EXTERNALFORMATS* *DEFAULT-EXTERNALFORMAT*)
|
||||
)
|
||||
|
||||
(RPAQ? *EXTERNALFORMATS* NIL)
|
||||
|
||||
(RPAQ? *DEFAULT-EXTERNALFORMATS* '((DSK :XCCS)))
|
||||
|
||||
(RPAQ? *DEFAULT-EXTERNALFORMAT* :XCCS)
|
||||
|
||||
|
||||
|
||||
(* ;; "Generic functions not compiled open (originally on LLREAD)")
|
||||
|
||||
(DEFINEQ
|
||||
|
||||
(\OUTCHAR
|
||||
[LAMBDA (STREAM CODE) (* ; "Edited 10-Aug-2021 10:29 by rmk:")
|
||||
|
||||
(* ;; "We can't do the EOL stuff here because we don't know whether BOUTs are legit.")
|
||||
|
||||
(* ;; "Maybe the implementation function does something else, like move the X and Y positions. At best we could convert the EOL into either CR or LF, or into a CR-LF sequence that we pass by two calls to the lower implementation function.")
|
||||
|
||||
(* ;; "")
|
||||
|
||||
(* ;; "This would make CHARPOSITION generic:")
|
||||
(* (FREPLACE (STREAM CHARPOSITION)
|
||||
OF STREAM WITH (CL:IF
|
||||
(EQ CODE (CHARCODE EOL)) 0
|
||||
(IPLUS16 1 (FFETCH
|
||||
(STREAM CHARPOSITION) OF STREAM)))))
|
||||
(CL:FUNCALL (OR (ffetch (STREAM OUTCHARFN) of STREAM)
|
||||
\DEFAULTOUTCHAR)
|
||||
STREAM CODE)
|
||||
CODE])
|
||||
|
||||
(\INCCODE
|
||||
[LAMBDA (STREAM BYTECOUNTVAR BYTECOUNTVAL) (* ; "Edited 7-Aug-2021 00:11 by rmk:")
|
||||
|
||||
(* ;; "Calling functions pass the name of the BYTECOUNTVAR, or NIL. If non-NIL, implementing functions are required to SETQ *BYTECOUNTER* to the number of bytes read (positive) or backed up (negative).")
|
||||
|
||||
(* ;; "Caller must bind BYTECOUNTVAR as a SPECVAR. BYTECOUNTVAL can be passed as the current value of BYTECOUNTVAR, to save a call to \EVALV1.")
|
||||
|
||||
(IF BYTECOUNTVAR
|
||||
THEN [LET ((*BYTECOUNTER* 0))
|
||||
(DECLARE (SPECVARS *BYTECOUNTER*))
|
||||
(PROG1 (CL:FUNCALL (OR (ffetch (STREAM INCCODEFN) of STREAM)
|
||||
\DEFAULTINCCODE)
|
||||
STREAM
|
||||
'*BYTECOUNTER*)
|
||||
(SET BYTECOUNTVAR (IDIFFERENCE (OR BYTECOUNTVAL (\EVALV1 BYTECOUNTVAR))
|
||||
*BYTECOUNTER*)))]
|
||||
ELSE (CL:FUNCALL (OR (ffetch (STREAM INCCODEFN) of STREAM)
|
||||
\DEFAULTINCCODE)
|
||||
STREAM])
|
||||
|
||||
(\BACKCCODE
|
||||
[LAMBDA (STREAM BYTECOUNTVAR BYTECOUNTVAL) (* ; "Edited 14-Aug-2021 00:26 by rmk:")
|
||||
|
||||
(* ;;
|
||||
"Format function returns T if the backup succeed, NIL otherwise (e.g at the beginning of the file)")
|
||||
|
||||
(IF BYTECOUNTVAR
|
||||
THEN [LET ((*BYTECOUNTER* 0))
|
||||
(DECLARE (SPECVARS *BYTECOUNTER*))
|
||||
(PROG1 (CL:FUNCALL (OR (ffetch (STREAM BACKCCODEFN) of STREAM)
|
||||
\DEFAULTBACKCCODE)
|
||||
STREAM T)
|
||||
(SET BYTECOUNTVAR (IPLUS (OR BYTECOUNTVAL (\EVALV1 BYTECOUNTVAR))
|
||||
*BYTECOUNTER*)))]
|
||||
ELSE (CL:FUNCALL (OR (ffetch (STREAM BACKCCODEFN) of STREAM)
|
||||
\DEFAULTBACKCCODE)
|
||||
STREAM])
|
||||
|
||||
(\BACKCCODE.EOLC
|
||||
[LAMBDA (STREAM BYTECOUNTVAR BYTECOUNTVAL) (* ; "Edited 14-Aug-2021 00:27 by rmk:")
|
||||
|
||||
(* ;; "If the EOLCONVENTION is CRLF, and the first backup is over an LF encoding, this looks to see whether the preceding bytes encode a CR and if so, backs up over those.")
|
||||
|
||||
(* ;; "Within this we operate at the external-format implementation level.")
|
||||
|
||||
(* ;; "Counting is unusual in general (mostly just COPYCHARS and PFCOPYBYTES) , and counting while backing up is even rarer. So for simplicity here we just count by looking at the byte pointer.")
|
||||
|
||||
(LET [(STARTPOS (CL:WHEN BYTECOUNTVAR (\GETFILEPTR STREAM]
|
||||
|
||||
(* ;; "In almost all cases, we just execute the first backup")
|
||||
|
||||
(PROG1 (CL:WHEN (CL:FUNCALL (OR (ffetch (STREAM BACKCCODEFN) of STREAM)
|
||||
\DEFAULTBACKCCODE)
|
||||
STREAM)
|
||||
(IF (AND (EQ CRLF.EOLC (FETCH (STREAM EOLCONVENTION) OF STREAM))
|
||||
(EQ (CHARCODE LF)
|
||||
(CL:FUNCALL (OR (ffetch (STREAM PEEKCCODEFN) of STREAM)
|
||||
\DEFAULTPEEKCCODE)
|
||||
STREAM)))
|
||||
THEN
|
||||
|
||||
(* ;;
|
||||
"We just backed over an LF in a CRLF file. If we go one more, do we get a CR?")
|
||||
|
||||
(CL:WHEN (CL:FUNCALL (OR (ffetch (STREAM BACKCCODEFN) of STREAM
|
||||
)
|
||||
\DEFAULTBACKCCODE)
|
||||
STREAM)
|
||||
(CL:UNLESS (EQ (CHARCODE CR)
|
||||
(CL:FUNCALL (OR (ffetch (STREAM PEEKCCODEFN)
|
||||
of STREAM)
|
||||
\DEFAULTPEEKCCODE)
|
||||
STREAM))
|
||||
|
||||
(* ;; "Not a preceding CR, reread it.")
|
||||
|
||||
(CL:FUNCALL (OR (ffetch (STREAM INCCODEFN) of STREAM)
|
||||
\DEFAULTINCCODE)
|
||||
STREAM))
|
||||
T)
|
||||
ELSE T))
|
||||
(CL:WHEN BYTECOUNTVAR
|
||||
[SET BYTECOUNTVAR (IPLUS (OR BYTECOUNTVAL (\EVALV1 BYTECOUNTVAR))
|
||||
(IDIFFERENCE STARTPOS (\GETFILEPTR STREAM]))])
|
||||
|
||||
(\PEEKCCODE
|
||||
[LAMBDA (STREAM NOERROR EOL) (* ; "Edited 14-Jun-2021 12:40 by rmk:")
|
||||
(\CHECKEOLC (CL:FUNCALL (OR (ffetch (STREAM PEEKCCODEFN) of STREAM)
|
||||
\DEFAULTPEEKCCODE)
|
||||
STREAM NOERROR)
|
||||
EOL STREAM T])
|
||||
|
||||
(\PEEKCCODE.NOEOLC
|
||||
[LAMBDA (STREAM NOERROR) (* ; "Edited 27-Jun-2021 23:26 by rmk:")
|
||||
(CL:FUNCALL (OR (ffetch (STREAM PEEKCCODEFN) of STREAM)
|
||||
\DEFAULTPEEKCCODE)
|
||||
STREAM NOERROR])
|
||||
|
||||
(\INCCODE.EOLC
|
||||
[LAMBDA (STREAM EOLC BYTECOUNTVAR BYTECOUNTVAL) (* ; "Edited 8-Aug-2021 14:52 by rmk:")
|
||||
|
||||
(* ;;
|
||||
"EOL conversion around essentially a copy of \INCCODE but avoids the extra function call.")
|
||||
|
||||
(* ;; " EOLC of NIL means all patterns go to EOL")
|
||||
|
||||
(IF BYTECOUNTVAR
|
||||
THEN [LET (*BYTECOUNTER* CODE)
|
||||
(DECLARE (SPECVARS *BYTECOUNTER*))
|
||||
|
||||
(* ;; "The INCCODEFN first sets *BYTECOUNTER*")
|
||||
|
||||
(CL:UNLESS BYTECOUNTVAL
|
||||
(SETQ BYTECOUNTVAL (\EVALV1 BYTECOUNTVAR)))
|
||||
(SETQ CODE (CL:FUNCALL (OR (ffetch (STREAM INCCODEFN) of STREAM)
|
||||
\DEFAULTINCCODE)
|
||||
STREAM T))
|
||||
|
||||
(* ;; "Update according to the number of first-char (CR or LF) bytes")
|
||||
|
||||
(SETQ BYTECOUNTVAL (IDIFFERENCE BYTECOUNTVAL *BYTECOUNTER*))
|
||||
(SETQ *BYTECOUNTER* 0)
|
||||
|
||||
(* ;;
|
||||
"*BYTECOUNTER* will now be reset to the number of LF-after-CR bytes, if any")
|
||||
|
||||
(PROG1 (\CHECKEOLC CODE (OR EOLC (FFETCH (STREAM EOLCONVENTION)
|
||||
OF STREAM))
|
||||
STREAM NIL T)
|
||||
|
||||
(* ;; "Post the results")
|
||||
|
||||
(SET BYTECOUNTVAR (IDIFFERENCE BYTECOUNTVAL *BYTECOUNTER*)))]
|
||||
ELSE (\CHECKEOLC (CL:FUNCALL (OR (ffetch (STREAM INCCODEFN) of STREAM)
|
||||
\DEFAULTINCCODE)
|
||||
STREAM)
|
||||
(OR EOLC (FFETCH (STREAM EOLCONVENTION) OF STREAM))
|
||||
STREAM])
|
||||
|
||||
(\FORMATBYTESTREAM
|
||||
[LAMBDA (STREAM BYTESTREAM) (* ; "Edited 24-Jun-2021 17:26 by rmk:")
|
||||
|
||||
(* ;; "Create or modify a stream that will simulate the current character input/output byte sequences of STREAM. The set up here does what is common to all formats: an IO stream starting with STREAM external format and EOL.")
|
||||
|
||||
(* ;; "If the format has its own FORMATBYTESTREAMFN function, that is applied to copy any other state. (Currently that function is a property of the format, not carried over into a stream field that can be changed dynamically.)")
|
||||
|
||||
(CL:UNLESS (AND (STREAMP BYTESTREAM)
|
||||
(\IOMODEP STREAM 'BOTH))
|
||||
(SETQ BYTESTREAM (OPENSTREAM '{NODIRCORE} 'BOTH)))
|
||||
(LET ((FORMAT (FETCH (STREAM EXTERNALFORMAT) OF STREAM))
|
||||
(EOLC (FETCH (STREAM EOLCONVENTION) OF STREAM)))
|
||||
(\EXTERNALFORMAT BYTESTREAM FORMAT)
|
||||
(CL:WHEN (EQ EOLC ANY.EOLC)
|
||||
(SETQ EOLC (OR (FETCH (EXTERNALFORMAT EOL) OF FORMAT)
|
||||
LF.EOLC)))
|
||||
(REPLACE (STREAM EOLCONVENTION) OF BYTESTREAM WITH EOLC)
|
||||
(SETFILEPTR BYTESTREAM 0)
|
||||
(SETFILEINFO BYTESTREAM 'ENDOFSTREAMOP (FUNCTION NILL))
|
||||
(CL:WHEN (FETCH (EXTERNALFORMAT FORMATBYTESTREAMFN) OF FORMAT)
|
||||
(APPLY* (FETCH (EXTERNALFORMAT FORMATBYTESTREAMFN) OF FORMAT)
|
||||
STREAM BYTESTREAM))
|
||||
BYTESTREAM])
|
||||
|
||||
(\CHECKEOLC.CRLF
|
||||
[LAMBDA (STREAM PEEKBINFLG COUNTP) (* ; "Edited 6-Aug-2021 23:30 by rmk:")
|
||||
|
||||
(* ;; "This is called only when a CR has been read and EOLC is either any or CRLF. This returns EOL if the next code is an LF")
|
||||
|
||||
(* ;; "If COUNTP, that sets *BYTECOUNTER* freely with the number of LF bytes.")
|
||||
|
||||
(DECLARE (USEDFREE *BYTECOUNTER*))
|
||||
(LET (CH)
|
||||
[SETQ CH (COND
|
||||
[PEEKBINFLG
|
||||
|
||||
(* ;;
|
||||
"T from PEEKC. In this case, must leave the fileptr where it was.")
|
||||
|
||||
(* ;; "The CR itself hasn't been read, just peeked. So here we have to read it, then peek at the next character to see if it is an LF, and then back out the CR")
|
||||
|
||||
(COND
|
||||
([EQ (CHARCODE LF)
|
||||
(UNINTERRUPTABLY
|
||||
|
||||
(* ;; " Since we are going to \BACKCCODE back the peeked character, we don't need to update the counter variable")
|
||||
|
||||
(\INCCODE STREAM)
|
||||
(PROG1 (\PEEKCCODE STREAM T 'NOEOLC)
|
||||
|
||||
(* ;;
|
||||
"This has to be a call to \PEEKCODE that doesn't itself to the checkeolc")
|
||||
|
||||
(* ;;
|
||||
"LF must be the next char after the CR. We back up over the CR that \INCCODE just read.")
|
||||
|
||||
(\BACKCCODE STREAM)))]
|
||||
|
||||
(* ;; "Got the CRLF, it's an EOL")
|
||||
|
||||
(CHARCODE EOL))
|
||||
(T (CHARCODE CR]
|
||||
((EQ (CHARCODE LF)
|
||||
(\PEEKCCODE STREAM T 'NOEOLC))
|
||||
|
||||
(* ;; "Since we aren't peeking, the CR has actually been read, and we are entitled to read the LF that we just peeked at.")
|
||||
|
||||
(IF COUNTP
|
||||
THEN (LET (NUMLFBYTES)
|
||||
(DECLARE (SPECVARS NUMLFBYTES))
|
||||
(\INCCODE STREAM 'NUMLFBYTES 0)
|
||||
(ADD *BYTECOUNTER* NUMLFBYTES))
|
||||
ELSE (\INCCODE STREAM))
|
||||
(CHARCODE EOL))
|
||||
(T (CHARCODE CR]
|
||||
CH])
|
||||
)
|
||||
(DECLARE%: DOEVAL@COMPILE DONTCOPY
|
||||
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(PUTPROPS \CHECKEOLC MACRO [OPENLAMBDA (CH EOLC STRM PEEKBINFLG COUNTP)
|
||||
(COND
|
||||
((EQ EOLC 'NOEOLC)
|
||||
CH)
|
||||
(T (SELCHARQ CH
|
||||
(LF (SELECTC (OR EOLC (FFETCH (STREAM
|
||||
EOLCONVENTION
|
||||
)
|
||||
OF STRM))
|
||||
((LIST LF.EOLC ANY.EOLC)
|
||||
(CHARCODE EOL))
|
||||
(CHARCODE LF)))
|
||||
(CR (SELECTC (OR EOLC (FFETCH (STREAM
|
||||
EOLCONVENTION
|
||||
)
|
||||
OF STRM))
|
||||
(CR.EOLC (CHARCODE EOL))
|
||||
((LIST ANY.EOLC CRLF.EOLC)
|
||||
(\CHECKEOLC.CRLF STRM PEEKBINFLG
|
||||
COUNTP))
|
||||
(CHARCODE CR)))
|
||||
CH])
|
||||
)
|
||||
|
||||
(* "END EXPORTED DEFINITIONS")
|
||||
|
||||
)
|
||||
|
||||
|
||||
|
||||
(* ;; "Also from FILEIO, but not clear that this is or ever has been used.")
|
||||
|
||||
(DEFINEQ
|
||||
|
||||
(\CREATE.THROUGH.EXTERNALFORMAT
|
||||
[LAMBDA NIL (* ; "Edited 23-Jun-2021 13:34 by rmk:")
|
||||
|
||||
(* ;;; "Create an instance of EXTERNALFORMAT datatype and install it with :THROUGH as its name. EOL is adjusted to CR so as not to do any eol conversion on this stream.")
|
||||
|
||||
(\INSTALL.EXTERNALFORMAT (create EXTERNALFORMAT
|
||||
NAME _ :THROUGH
|
||||
INCCODEFN _ (FUNCTION \THROUGHIN)
|
||||
PEEKCCODEFN _ (FUNCTION \PEEKBIN)
|
||||
BACKCCODEFN _ (FUNCTION \THROUGHBACKCCODE)
|
||||
OUTCHARFN _ (FUNCTION \THROUGHOUTCHARFN)
|
||||
EOL _ CR.EOLC])
|
||||
|
||||
(\THROUGHIN
|
||||
[LAMBDA (STREAM COUNTP) (* ; "Edited 6-Aug-2021 16:13 by rmk:")
|
||||
|
||||
(* ;;; "Read in a single byte from STREAM and returns it without any character conversion, just through as if.")
|
||||
|
||||
(* ;;; "If COUNTP is non-NIL, the byte counter is always set to 1.")
|
||||
|
||||
(DECLARE (USEDFREE *BYTECOUNTER*))
|
||||
(CL:WHEN COUNTP (SETQ *BYTECOUNTER* 1))
|
||||
(\BIN STREAM])
|
||||
|
||||
(\THROUGHBACKCCODE
|
||||
[LAMBDA (STREAM COUNTP) (* ; "Edited 6-Aug-2021 16:14 by rmk:")
|
||||
(DECLARE (USEDFREE *BYTECOUNTER*))
|
||||
(CL:WHEN (\BACKFILEPTR STREAM)
|
||||
(CL:WHEN COUNTP (SETQ *BYTECOUNTER* -1))
|
||||
T)])
|
||||
|
||||
(\THROUGHOUTCHARFN
|
||||
[LAMBDA (OUTSTREAM CHARCODE) (* ; "Edited 26-Feb-91 13:44 by nm")
|
||||
|
||||
(* ;;; "Encoder for THROUGH format.")
|
||||
|
||||
(COND
|
||||
((> CHARCODE 255)
|
||||
(\BOUT OUTSTREAM (\CHARSET CHARCODE))
|
||||
(\BOUT OUTSTREAM (\CHAR8CODE CHARCODE)))
|
||||
(T (\BOUT OUTSTREAM CHARCODE])
|
||||
)
|
||||
(DECLARE%: DONTEVAL@LOAD DOCOPY
|
||||
|
||||
(\CREATE.THROUGH.EXTERNALFORMAT)
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (5657 12044 (\EXTERNALFORMAT 5667 . 10729) (MAKE-EXTERNALFORMAT 10731 . 12042)) (12045
|
||||
15158 (\INSTALL.EXTERNALFORMAT 12055 . 13504) (\REMOVE.EXTERNALFORMAT 13506 . 14337) (FIND-FORMAT
|
||||
14339 . 15156)) (15488 27986 (\OUTCHAR 15498 . 16634) (\INCCODE 16636 . 17822) (\BACKCCODE 17824 .
|
||||
18718) (\BACKCCODE.EOLC 18720 . 21483) (\PEEKCCODE 21485 . 21801) (\PEEKCCODE.NOEOLC 21803 . 22065) (
|
||||
\INCCODE.EOLC 22067 . 23926) (\FORMATBYTESTREAM 23928 . 25418) (\CHECKEOLC.CRLF 25420 . 27984)) (29929
|
||||
31772 (\CREATE.THROUGH.EXTERNALFORMAT 29939 . 30741) (\THROUGHIN 30743 . 31163) (\THROUGHBACKCCODE
|
||||
31165 . 31432) (\THROUGHOUTCHARFN 31434 . 31770)))))
|
||||
STOP
|
||||
BIN
sources/EXTERNALFORMAT.LCOM
Normal file
BIN
sources/EXTERNALFORMAT.LCOM
Normal file
Binary file not shown.
410
sources/FILEIO
410
sources/FILEIO
@@ -1,11 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
(FILECREATED " 6-Sep-2021 15:54:14"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>FILEIO.;92 178421
|
||||
(FILECREATED "25-Sep-2021 21:02:29"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>FILEIO.;99 162362
|
||||
|
||||
changes to%: (RECORDS FDEV)
|
||||
changes to%: (VARS FILEIOCOMS)
|
||||
(RECORDS FDEV)
|
||||
|
||||
previous date%: "13-Aug-2021 18:39:18"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>FILEIO.;91)
|
||||
previous date%: "25-Sep-2021 17:25:04"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>FILEIO.;98)
|
||||
|
||||
|
||||
(* ; "
|
||||
@@ -51,20 +52,6 @@ Copyright (c) 1981-1993, 1999, 2020-2021 by Venue & Xerox Corporation.
|
||||
(RECORDS FDEV FILEGENOBJ)))
|
||||
(INITRECORDS FDEV)
|
||||
(SYSRECORDS FDEV))
|
||||
[COMS (* ;
|
||||
"EXTERNALFORMAT declaration and related functions")
|
||||
(DECLARE%: DOEVAL@COMPILE DONTCOPY (EXPORT (RECORDS EXTERNALFORMAT)))
|
||||
(FNS MAKE-EXTERNALFORMAT)
|
||||
(INITRECORDS EXTERNALFORMAT)
|
||||
(SYSRECORDS EXTERNALFORMAT)
|
||||
(FNS \INSTALL.EXTERNALFORMAT \REMOVE.EXTERNALFORMAT FIND-FORMAT \EXTERNALFORMAT)
|
||||
(INITVARS [*DEFAULT-EXTERNALFORMATS* '((DSK :XCCS]
|
||||
(*EXTERNALFORMATS* NIL))
|
||||
(GLOBALVARS *EXTERNALFORMATS* *DEFAULT-EXTERNALFORMATS* *DEFAULT-EXTERNALFORMAT*)
|
||||
(EXPORT (INITVARS (*DEFAULT-EXTERNALFORMAT* :XCCS)))
|
||||
(COMS (FNS \CREATE.THROUGH.EXTERNALFORMAT \THROUGHIN \THROUGHBACKCCODE
|
||||
\THROUGHOUTCHARFN)
|
||||
(DECLARE%: DONTEVAL@LOAD DOCOPY (P (\CREATE.THROUGH.EXTERNALFORMAT]
|
||||
(COMS (* ; "Device operations")
|
||||
(FNS \DEFINEDEVICE \GETDEVICEFROMNAME \GETDEVICEFROMHOSTNAME \REMOVEDEVICE
|
||||
\REMOVEDEVICE.NAMES)
|
||||
@@ -573,9 +560,9 @@ Copyright (c) 1981-1993, 1999, 2020-2021 by Venue & Xerox Corporation.
|
||||
(DEFINEQ
|
||||
|
||||
(STREAMPROP
|
||||
[LAMBDA X (* rda%: "22-Aug-84 14:24")
|
||||
[LAMBDA X (* rda%: "22-Aug-84 14:24")
|
||||
|
||||
(* ;; "general top level entry for both fetching and setting stream properties.")
|
||||
(* ;; "general top level entry for both fetching and setting stream properties.")
|
||||
|
||||
(COND
|
||||
((IGREATERP X 2)
|
||||
@@ -588,24 +575,24 @@ Copyright (c) 1981-1993, 1999, 2020-2021 by Venue & Xerox Corporation.
|
||||
(T (\ILLEGAL.ARG NIL])
|
||||
|
||||
(GETSTREAMPROP
|
||||
[LAMBDA (STREAM PROP) (* ; "Edited 29-Jun-2021 17:06 by rmk:")
|
||||
(* rda%: "22-Aug-84 16:17")
|
||||
[LAMBDA (STREAM PROP) (* ; "Edited 29-Jun-2021 17:06 by rmk:")
|
||||
(* rda%: "22-Aug-84 16:17")
|
||||
(SELECTQ PROP
|
||||
((FORMAT EXTERNALFORMAT)
|
||||
(\EXTERNALFORMAT STREAM))
|
||||
(\EXTERNALFORMAT STREAM))
|
||||
(ENDOFSTREAMOP (FETCH (STREAM ENDOFSTREAMOP) OF STREAM))
|
||||
(LISTGET (fetch (STREAM OTHERPROPS) of STREAM)
|
||||
PROP])
|
||||
|
||||
(PUTSTREAMPROP
|
||||
[LAMBDA (STREAM PROP VALUE) (* ; "Edited 29-Jun-2021 17:06 by rmk:")
|
||||
(* rda%: "22-Aug-84 16:11")
|
||||
[LAMBDA (STREAM PROP VALUE) (* ; "Edited 29-Jun-2021 17:06 by rmk:")
|
||||
(* rda%: "22-Aug-84 16:11")
|
||||
(SELECTQ PROP
|
||||
((FORMAT EXTERNALFORMAT)
|
||||
(* ;; "Return the old name (=VALUE), not the format datum. Better design: the format should have it's name, and not have name as a separate property.")
|
||||
(* ;; "Return the old name (=VALUE), not the format datum. Better design: the format should have it's name, and not have name as a separate property.")
|
||||
|
||||
(PROG1 (\EXTERNALFORMAT STREAM NIL)
|
||||
(AND VALUE (\EXTERNALFORMAT STREAM VALUE))))
|
||||
(PROG1 (\EXTERNALFORMAT STREAM NIL)
|
||||
(AND VALUE (\EXTERNALFORMAT STREAM VALUE))))
|
||||
(ENDOFSTREAMOP (PROG1 (fetch (STREAM ENDOFSTREAMOP) of STREAM)
|
||||
(replace (STREAM ENDOFSTREAMOP) of STREAM with VALUE)))
|
||||
(PROG ((OLDDATA (fetch OTHERPROPS of STREAM))
|
||||
@@ -614,7 +601,7 @@ Copyright (c) 1981-1993, 1999, 2020-2021 by Venue & Xerox Corporation.
|
||||
(OLDDATA (SETQ OLDVALUE (LISTGET OLDDATA PROP))
|
||||
[COND
|
||||
(VALUE (LISTPUT OLDDATA PROP VALUE))
|
||||
(OLDVALUE (* ; "Remove the property")
|
||||
(OLDVALUE (* ; "Remove the property")
|
||||
(COND
|
||||
((EQ (CAR OLDDATA)
|
||||
PROP)
|
||||
@@ -629,7 +616,7 @@ Copyright (c) 1981-1993, 1999, 2020-2021 by Venue & Xerox Corporation.
|
||||
OLDVALUE)
|
||||
(VALUE (replace OTHERPROPS of STREAM with (LIST PROP
|
||||
VALUE))
|
||||
(* ; "know old value is NIL")
|
||||
(* ; "know old value is NIL")
|
||||
NIL])
|
||||
|
||||
(STREAMP
|
||||
@@ -957,8 +944,7 @@ Copyright (c) 1981-1993, 1999, 2020-2021 by Venue & Xerox Corporation.
|
||||
OPENP _ (FUNCTION NILL)
|
||||
UNREGISTERFILE _ (FUNCTION NILL)
|
||||
CHARSETFN _ (FUNCTION \GENERIC.CHARSET)
|
||||
BREAKCONNECTION _ (FUNCTION NILL)
|
||||
DEFAULTEXTERNALFORMAT _ *DEFAULT-EXTERNALFORMAT*)
|
||||
BREAKCONNECTION _ (FUNCTION NILL))
|
||||
|
||||
(RECORD FILEGENOBJ (NEXTFILEFN FILEINFOFN . GENFILESTATE))
|
||||
)
|
||||
@@ -1182,288 +1168,6 @@ Copyright (c) 1981-1993, 1999, 2020-2021 by Venue & Xerox Corporation.
|
||||
|
||||
|
||||
|
||||
(* ; "EXTERNALFORMAT declaration and related functions")
|
||||
|
||||
(DECLARE%: DOEVAL@COMPILE DONTCOPY
|
||||
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(DATATYPE EXTERNALFORMAT ((EOLVALID FLAG) (* ; "If true, the value of EOL field will replace the EOLCONVENTION field of the resulted stream. (Can't test EOL because it is always something)")
|
||||
(EOL BITS 2)
|
||||
(NIL BITS 1)
|
||||
(INCCODEFN POINTER) (* ;
|
||||
"Called with STREAM and 2 optional arguments, BYTECOUNTVAR and BYTECOUNTVAL")
|
||||
(PEEKCCODEFN POINTER) (* ;
|
||||
"Called with three arguments -- STREAM, NOERROR, and EOL")
|
||||
(BACKCCODEFN POINTER) (* ;
|
||||
"Called with STREAM and optional BYTECOUNTVAR and BYTECOUNTVAL")
|
||||
(OUTCHARFN POINTER) (* ;
|
||||
"Called with two arguments -- STREAM and CHARCODE")
|
||||
(NAME POINTER) (* ;
|
||||
"keyword name of this format, provided to \INSTALL.EXTERNALFORMAT")
|
||||
(FORMATBYTESTREAMFN POINTER) (* ; "Function to copy the format state of a given stream to an IO stream that allows formatted byte sequences to be examined")
|
||||
(EF1 POINTER) (* ;
|
||||
"Extra fields for use of particular formats. Possibly to hold standardized translation tables")
|
||||
(EF2 POINTER)))
|
||||
)
|
||||
|
||||
(/DECLAREDATATYPE 'EXTERNALFORMAT '(FLAG (BITS 2)
|
||||
(BITS 1)
|
||||
POINTER POINTER POINTER POINTER POINTER POINTER POINTER
|
||||
POINTER)
|
||||
'((EXTERNALFORMAT 0 (FLAGBITS . 0))
|
||||
(EXTERNALFORMAT 0 (BITS . 17))
|
||||
(EXTERNALFORMAT 0 (BITS . 48))
|
||||
(EXTERNALFORMAT 0 POINTER)
|
||||
(EXTERNALFORMAT 2 POINTER)
|
||||
(EXTERNALFORMAT 4 POINTER)
|
||||
(EXTERNALFORMAT 6 POINTER)
|
||||
(EXTERNALFORMAT 8 POINTER)
|
||||
(EXTERNALFORMAT 10 POINTER)
|
||||
(EXTERNALFORMAT 12 POINTER)
|
||||
(EXTERNALFORMAT 14 POINTER))
|
||||
'16)
|
||||
|
||||
(* "END EXPORTED DEFINITIONS")
|
||||
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
(MAKE-EXTERNALFORMAT
|
||||
[LAMBDA (NAME INCCODEFN PEEKCCODEFN BACKCCODEFN OUTCHARFN FORMATBYTESTREAMFN EOL)
|
||||
(* ; "Edited 1-Aug-2021 23:13 by rmk:")
|
||||
|
||||
(* ;; "Compiled creator for EXTERNALFORMAT so that declaration (EXPORTS.ALL) is not needed. If EOL is not specified, then EOLVALID is also NIL")
|
||||
|
||||
(SETQ EOL (SELECTC EOL
|
||||
((LIST 'LF LF.EOLC)
|
||||
LF.EOLC)
|
||||
((LIST 'CR CR.EOLC)
|
||||
CR.EOLC)
|
||||
((LIST 'CRLF CRLF.EOLC)
|
||||
CRLF.EOLC)
|
||||
(NIL)
|
||||
(SHOULDNT)))
|
||||
(\INSTALL.EXTERNALFORMAT (CREATE EXTERNALFORMAT
|
||||
NAME _ NAME
|
||||
INCCODEFN _ INCCODEFN
|
||||
PEEKCCODEFN _ PEEKCCODEFN
|
||||
BACKCCODEFN _ BACKCCODEFN
|
||||
OUTCHARFN _ OUTCHARFN
|
||||
FORMATBYTESTREAMFN _ FORMATBYTESTREAMFN
|
||||
EOLVALID _ EOL
|
||||
EOL _ (OR EOL LF.EOLC])
|
||||
)
|
||||
|
||||
(/DECLAREDATATYPE 'EXTERNALFORMAT '(FLAG (BITS 2)
|
||||
(BITS 1)
|
||||
POINTER POINTER POINTER POINTER POINTER POINTER POINTER
|
||||
POINTER)
|
||||
'((EXTERNALFORMAT 0 (FLAGBITS . 0))
|
||||
(EXTERNALFORMAT 0 (BITS . 17))
|
||||
(EXTERNALFORMAT 0 (BITS . 48))
|
||||
(EXTERNALFORMAT 0 POINTER)
|
||||
(EXTERNALFORMAT 2 POINTER)
|
||||
(EXTERNALFORMAT 4 POINTER)
|
||||
(EXTERNALFORMAT 6 POINTER)
|
||||
(EXTERNALFORMAT 8 POINTER)
|
||||
(EXTERNALFORMAT 10 POINTER)
|
||||
(EXTERNALFORMAT 12 POINTER)
|
||||
(EXTERNALFORMAT 14 POINTER))
|
||||
'16)
|
||||
(ADDTOVAR SYSTEMRECLST
|
||||
|
||||
(DATATYPE EXTERNALFORMAT ((EOLVALID FLAG)
|
||||
(EOL BITS 2)
|
||||
(NIL BITS 1)
|
||||
(INCCODEFN POINTER)
|
||||
(PEEKCCODEFN POINTER)
|
||||
(BACKCCODEFN POINTER)
|
||||
(OUTCHARFN POINTER)
|
||||
(NAME POINTER)
|
||||
(FORMATBYTESTREAMFN POINTER)
|
||||
(EF1 POINTER)
|
||||
(EF2 POINTER)))
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
(\INSTALL.EXTERNALFORMAT
|
||||
[LAMBDA (EXTFORMAT/NAME EXTERNALFORMAT) (* ; "Edited 5-Aug-2021 14:22 by rmk:")
|
||||
|
||||
(* ;;; "Register an instance of the datatype EXTERNALFORMAT.")
|
||||
|
||||
(* ;;; "For backward compatibility, the first argument can be a NAME with the second argument being the format. If so, the NAME must match the name inside the format")
|
||||
|
||||
(LET (NAME)
|
||||
(IF EXTERNALFORMAT
|
||||
THEN
|
||||
|
||||
(* ;; "Backwards compatibility")
|
||||
|
||||
(SETQ NAME (MKATOM EXTFORMAT/NAME))
|
||||
(IF (EQ NAME (FETCH (EXTERNALFORMAT NAME) OF EXTERNALFORMAT))
|
||||
ELSEIF (FETCH (EXTERNALFORMAT NAME) OF EXTERNALFORMAT)
|
||||
THEN (ERROR "Mismatch of specified name and name of the external format")
|
||||
ELSE (REPLACE (EXTERNALFORMAT NAME) OF EXTERNALFORMAT WITH
|
||||
NAME))
|
||||
ELSE (SETQ EXTERNALFORMAT EXTFORMAT/NAME)
|
||||
(SETQ NAME (FETCH (EXTERNALFORMAT NAME) OF EXTERNALFORMAT)))
|
||||
(IF (type? EXTERNALFORMAT EXTERNALFORMAT)
|
||||
THEN (\REMOVE.EXTERNALFORMAT NAME)
|
||||
(push *EXTERNALFORMATS* EXTERNALFORMAT)
|
||||
ELSE (ERROR "INVALID EXTERNALFORMAT " EXTERNALFORMAT))
|
||||
EXTERNALFORMAT])
|
||||
|
||||
(\REMOVE.EXTERNALFORMAT
|
||||
[LAMBDA (NAME/EXTFORMAT) (* ; "Edited 5-May-2021 15:42 by rmk:")
|
||||
|
||||
(* ;;; "Deregisters external format EXTERNALFORMAT .")
|
||||
|
||||
(SETQ NAME/EXTFORMAT (IF (TYPE? EXTERNALFORMAT NAME/EXTFORMAT)
|
||||
THEN (FETCH (EXTERNALFORMAT NAME) OF NAME/EXTFORMAT)
|
||||
ELSE (MKATOM NAME/EXTFORMAT)))
|
||||
(SETQ *EXTERNALFORMATS* (DREMOVE (FIND EF IN *EXTERNALFORMATS*
|
||||
SUCHTHAT (EQ NAME/EXTFORMAT (FETCH (EXTERNALFORMAT
|
||||
NAME)
|
||||
OF EF)))
|
||||
*EXTERNALFORMATS*])
|
||||
|
||||
(FIND-FORMAT
|
||||
[LAMBDA (NAME NOERROR) (* ; "Edited 7-Aug-2021 09:29 by rmk:")
|
||||
(IF (TYPE? EXTERNALFORMAT NAME)
|
||||
THEN NAME
|
||||
ELSE (SETQ NAME (MKATOM NAME)) (* ;
|
||||
"The EQMEMB allows for synonyms, the first of which should be canonical. E.g. (:UTF-8 :UTF8)")
|
||||
(OR (FIND EF IN *EXTERNALFORMATS* SUCHTHAT (EQ NAME (FETCH (
|
||||
EXTERNALFORMAT
|
||||
NAME)
|
||||
OF EF)))
|
||||
(CL:UNLESS NOERROR (ERROR NAME "is not an external format"])
|
||||
|
||||
(\EXTERNALFORMAT
|
||||
[LAMBDA (STREAM NEWFORMAT/NAME) (* ; "Edited 8-Aug-2021 14:30 by rmk:")
|
||||
(* ; "Edited 26-Feb-91 13:20 by nm")
|
||||
|
||||
(* ;;; ";;; RMK July 2020: Added interface for per-device default external format. \DO.PARAMS.AT.OPEN will make that call even if it is not specified from the open. STREAMPROP is fixed to call \EXTERNALFORMAT to set the property EXTERNALFORMAT, to export a user-level way of manipulating this.")
|
||||
|
||||
(* ;;; "")
|
||||
|
||||
(* ;;; "If NEWFORMAT/NAME is nil, just returns the current external format name of STREAM. If NEWFORMAT/NAME is supplied and it is or names an external format, then the external format of STREAM is set to that format.")
|
||||
|
||||
(* ;;; "")
|
||||
|
||||
(* ;;; ":DEFAULT means the default external format for STREAM's filedevice")
|
||||
|
||||
(* ;;; "The all-device default is in *DEFAULT-EXTERNALFORMAT* or the DEFAULTEXTERNALFORMAT field of the file device. The list currently has priority since that makes it easier for a user without EXPORTS.ALL to systematically override. That may or may not be a useful capability. ")
|
||||
|
||||
(\DTEST STREAM 'STREAM)
|
||||
(CL:WHEN NEWFORMAT/NAME
|
||||
(CL:WHEN (type? READER-ENVIRONMENT NEWFORMAT/NAME)
|
||||
(SETQ NEWFORMAT/NAME (fetch (READER-ENVIRONMENT REFORMAT) of NEWFORMAT/NAME)))
|
||||
[LET (EXTFORMAT)
|
||||
[COND
|
||||
((type? EXTERNALFORMAT NEWFORMAT/NAME)
|
||||
(SETQ EXTFORMAT NEWFORMAT/NAME))
|
||||
(T (CL:WHEN (EQ NEWFORMAT/NAME :DEFAULT)
|
||||
(SETQ NEWFORMAT/NAME (OR (CADR (ASSOC (fetch DEVICENAME
|
||||
of (fetch DEVICE of
|
||||
STREAM))
|
||||
*DEFAULT-EXTERNALFORMATS*))
|
||||
(fetch (FDEV DEFAULTEXTERNALFORMAT)
|
||||
of (fetch DEVICE of STREAM))
|
||||
*DEFAULT-EXTERNALFORMAT*)))
|
||||
(SETQ EXTFORMAT (FIND-FORMAT NEWFORMAT/NAME))
|
||||
(CL:UNLESS EXTFORMAT (ERROR NEWFORMAT/NAME
|
||||
"is not a registered external format name"))
|
||||
(CL:UNLESS (type? EXTERNALFORMAT EXTFORMAT)
|
||||
(ERROR "INVALID EXTERNALFORMAT " EXTFORMAT]
|
||||
(UNINTERRUPTABLY
|
||||
(freplace (STREAM EXTERNALFORMAT) of STREAM with EXTFORMAT)
|
||||
(CL:WHEN (ffetch (EXTERNALFORMAT EOLVALID) of EXTFORMAT)
|
||||
(freplace (STREAM EOLCONVENTION) of STREAM with (ffetch
|
||||
(EXTERNALFORMAT
|
||||
EOL) of
|
||||
EXTFORMAT
|
||||
)))
|
||||
(freplace (STREAM OUTCHARFN) of STREAM with (ffetch (EXTERNALFORMAT
|
||||
OUTCHARFN)
|
||||
of EXTFORMAT))
|
||||
(freplace (STREAM INCCODEFN) of STREAM with (ffetch (EXTERNALFORMAT
|
||||
INCCODEFN)
|
||||
of EXTFORMAT))
|
||||
(freplace (STREAM PEEKCCODEFN) of STREAM with (ffetch (
|
||||
EXTERNALFORMAT
|
||||
PEEKCCODEFN)
|
||||
of EXTFORMAT))
|
||||
(freplace (STREAM BACKCCODEFN) of STREAM with (ffetch (
|
||||
EXTERNALFORMAT
|
||||
BACKCCODEFN)
|
||||
of EXTFORMAT)))])
|
||||
(ffetch (EXTERNALFORMAT NAME) of (fetch (STREAM EXTERNALFORMAT) of STREAM])
|
||||
)
|
||||
|
||||
(RPAQ? *DEFAULT-EXTERNALFORMATS* '((DSK :XCCS)))
|
||||
|
||||
(RPAQ? *EXTERNALFORMATS* NIL)
|
||||
(DECLARE%: DOEVAL@COMPILE DONTCOPY
|
||||
|
||||
(GLOBALVARS *EXTERNALFORMATS* *DEFAULT-EXTERNALFORMATS* *DEFAULT-EXTERNALFORMAT*)
|
||||
)
|
||||
(* "FOLLOWING DEFINITIONS EXPORTED")
|
||||
(RPAQ? *DEFAULT-EXTERNALFORMAT* :XCCS)
|
||||
|
||||
(* "END EXPORTED DEFINITIONS")
|
||||
|
||||
(DEFINEQ
|
||||
|
||||
(\CREATE.THROUGH.EXTERNALFORMAT
|
||||
[LAMBDA NIL (* ; "Edited 23-Jun-2021 13:34 by rmk:")
|
||||
|
||||
(* ;;; "Create an instance of EXTERNALFORMAT datatype and install it with :THROUGH as its name. EOL is adjusted to CR so as not to do any eol conversion on this stream.")
|
||||
|
||||
(\INSTALL.EXTERNALFORMAT (create EXTERNALFORMAT
|
||||
NAME _ :THROUGH
|
||||
INCCODEFN _ (FUNCTION \THROUGHIN)
|
||||
PEEKCCODEFN _ (FUNCTION \PEEKBIN)
|
||||
BACKCCODEFN _ (FUNCTION \THROUGHBACKCCODE)
|
||||
OUTCHARFN _ (FUNCTION \THROUGHOUTCHARFN)
|
||||
EOL _ CR.EOLC])
|
||||
|
||||
(\THROUGHIN
|
||||
[LAMBDA (STREAM COUNTP) (* ; "Edited 6-Aug-2021 16:13 by rmk:")
|
||||
|
||||
(* ;;; "Read in a single byte from STREAM and returns it without any character conversion, just through as if.")
|
||||
|
||||
(* ;;; "If COUNTP is non-NIL, the byte counter is always set to 1.")
|
||||
|
||||
(DECLARE (USEDFREE *BYTECOUNTER*))
|
||||
(CL:WHEN COUNTP (SETQ *BYTECOUNTER* 1))
|
||||
(\BIN STREAM])
|
||||
|
||||
(\THROUGHBACKCCODE
|
||||
[LAMBDA (STREAM COUNTP) (* ; "Edited 6-Aug-2021 16:14 by rmk:")
|
||||
(DECLARE (USEDFREE *BYTECOUNTER*))
|
||||
(CL:WHEN (\BACKFILEPTR STREAM)
|
||||
(CL:WHEN COUNTP (SETQ *BYTECOUNTER* -1))
|
||||
T)])
|
||||
|
||||
(\THROUGHOUTCHARFN
|
||||
[LAMBDA (OUTSTREAM CHARCODE) (* ; "Edited 26-Feb-91 13:44 by nm")
|
||||
|
||||
(* ;;; "Encoder for THROUGH format.")
|
||||
|
||||
(COND
|
||||
((> CHARCODE 255)
|
||||
(\BOUT OUTSTREAM (\CHARSET CHARCODE))
|
||||
(\BOUT OUTSTREAM (\CHAR8CODE CHARCODE)))
|
||||
(T (\BOUT OUTSTREAM CHARCODE])
|
||||
)
|
||||
(DECLARE%: DONTEVAL@LOAD DOCOPY
|
||||
|
||||
(\CREATE.THROUGH.EXTERNALFORMAT)
|
||||
)
|
||||
|
||||
|
||||
|
||||
(* ; "Device operations")
|
||||
|
||||
(DEFINEQ
|
||||
@@ -3396,44 +3100,40 @@ update the map")
|
||||
(PUTPROPS FILEIO COPYRIGHT ("Venue & Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1988 1989
|
||||
1990 1991 1992 1993 1999 2020 2021))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (28396 31886 (STREAMPROP 28406 . 28840) (GETSTREAMPROP 28842 . 29315) (PUTSTREAMPROP
|
||||
29317 . 31734) (STREAMP 31736 . 31884)) (31929 34448 (\DEFPRINT.BY.NAME 31939 . 33091) (
|
||||
\STREAM.DEFPRINT 33093 . 34141) (\FDEV.DEFPRINT 34143 . 34446)) (34706 39747 (\GETACCESS 34716 . 35170
|
||||
) (\SETACCESS 35172 . 39745)) (63132 64385 (MAKE-EXTERNALFORMAT 63142 . 64383)) (65618 73447 (
|
||||
\INSTALL.EXTERNALFORMAT 65628 . 67077) (\REMOVE.EXTERNALFORMAT 67079 . 67910) (FIND-FORMAT 67912 .
|
||||
68729) (\EXTERNALFORMAT 68731 . 73445)) (73770 75633 (\CREATE.THROUGH.EXTERNALFORMAT 73780 . 74582) (
|
||||
\THROUGHIN 74584 . 75008) (\THROUGHBACKCCODE 75010 . 75281) (\THROUGHOUTCHARFN 75283 . 75631)) (75741
|
||||
81710 (\DEFINEDEVICE 75751 . 78067) (\GETDEVICEFROMNAME 78069 . 78542) (\GETDEVICEFROMHOSTNAME 78544
|
||||
. 79588) (\REMOVEDEVICE 79590 . 80713) (\REMOVEDEVICE.NAMES 80715 . 81708)) (81750 106410 (\CLOSEFILE
|
||||
81760 . 82585) (\DELETEFILE 82587 . 82881) (\DEVICEEVENT 82883 . 84653) (\GENERATEFILES 84655 . 85133
|
||||
) (\GENERATENEXTFILE 85135 . 85786) (\GENERATEFILEINFO 85788 . 86249) (\GETFILENAME 86251 . 86640) (
|
||||
\GENERIC.OUTFILEP 86642 . 87112) (\OPENFILE 87114 . 89692) (\DO.PARAMS.AT.OPEN 89694 . 92247) (
|
||||
\RENAMEFILE 92249 . 92673) (\REVALIDATEFILE 92675 . 95277) (\PAGED.REVALIDATEFILELST 95279 . 96837) (
|
||||
\PAGED.REVALIDATEFILES 96839 . 98558) (\PAGED.REVALIDATEFILE 98560 . 100843) (\BUFFERED.REVALIDATEFILE
|
||||
100845 . 103131) (\BUFFERED.REVALIDATEFILELST 103133 . 104317) (\PRINT-REVALIDATION-RESULT 104319 .
|
||||
104734) (\TRUNCATEFILE 104736 . 105127) (\FILE-CONFLICT 105129 . 106408)) (106446 111109 (
|
||||
\GENERATENOFILES 106456 . 108552) (\NULLFILEGENERATOR 108554 . 108798) (\NOFILESNEXTFILEFN 108800 .
|
||||
110791) (\NOFILESINFOFN 110793 . 111107)) (111228 113136 (\FILE.NOT.OPEN 111238 . 111751) (
|
||||
\FILE.WONT.OPEN 111753 . 112081) (\ILLEGAL.DEVICEOP 112083 . 112365) (\IS.NOT.RANDACCESSP 112367 .
|
||||
112813) (\STREAM.NOT.OPEN 112815 . 113134)) (113271 115569 (\FDEVINSTANCE 113281 . 115567)) (117119
|
||||
124493 (CNDIR 117129 . 118434) (DIRECTORYNAME 118436 . 122619) (DIRECTORYNAMEP 122621 . 123237) (
|
||||
HOSTNAMEP 123239 . 124046) (\ADD.CONNECTED.DIR 124048 . 124491)) (124538 151925 (\BACKFILEPTR 124548
|
||||
. 124736) (\BACKPEEKBIN 124738 . 125099) (\BACKBIN 125101 . 125452) (BIN 125454 . 125671) (\BIN
|
||||
125673 . 125950) (\BINS 125952 . 126238) (BOUT 126240 . 126602) (\BOUT 126604 . 126919) (\BOUTS 126921
|
||||
. 127232) (COPYBYTES 127234 . 130566) (COPYCHARS 130568 . 134234) (COPYFILE 134236 . 135033) (
|
||||
\COPYOPENFILE 135035 . 138108) (\INFER.FILE.TYPE 138110 . 139064) (EOFP 139066 . 139363) (FORCEOUTPUT
|
||||
139365 . 139612) (\FLUSH.OPEN.STREAMS 139614 . 139970) (CHARSET 139972 . 141636) (ACCESS-CHARSET
|
||||
141638 . 141855) (GETEOFPTR 141857 . 142107) (GETFILEINFO 142109 . 145302) (\TYPE.FROM.FILETYPE 145304
|
||||
. 145774) (\FILETYPE.FROM.TYPE 145776 . 145955) (GETFILEPTR 145957 . 146209) (SETFILEINFO 146211 .
|
||||
149824) (SETFILEPTR 149826 . 151545) (BOUT16 151547 . 151732) (BIN16 151734 . 151923)) (152028 157233
|
||||
(\GENERIC.BINS 152038 . 152318) (\GENERIC.BOUTS 152320 . 152585) (\GENERIC.RENAMEFILE 152587 . 154418)
|
||||
(\GENERIC.OPENP 154420 . 155735) (\GENERIC.READP 155737 . 156778) (\GENERIC.CHARSET 156780 . 157231))
|
||||
(157234 157573 (\MAP-OPEN-STREAMS 157244 . 157571)) (159443 161523 (\EOF.ACTION 159453 . 159704) (
|
||||
\EOSERROR 159706 . 159899) (\GETEOFPTR 159901 . 160083) (\INCFILEPTR 160085 . 160435) (\PEEKBIN 160437
|
||||
. 160628) (\SETCLOSEDFILELENGTH 160630 . 160964) (\SETEOFPTR 160966 . 161154) (\SETFILEPTR 161156 .
|
||||
161521)) (161524 162066 (\FIXPOUT 161534 . 161834) (\FIXPIN 161836 . 162064)) (162067 162633 (\BOUTEOL
|
||||
162077 . 162631)) (165725 175589 (\BUFFERED.BIN 165735 . 166587) (\BUFFERED.PEEKBIN 166589 . 167371)
|
||||
(\BUFFERED.BOUT 167373 . 168233) (\BUFFERED.BINS 168235 . 171920) (\BUFFERED.BOUTS 171922 . 173723) (
|
||||
\BUFFERED.COPYBYTES 173725 . 175587)) (175618 177970 (\NULLDEVICE 175628 . 177646) (\NULL.OPENFILE
|
||||
177648 . 177968)))))
|
||||
(FILEMAP (NIL (27462 30940 (STREAMPROP 27472 . 27906) (GETSTREAMPROP 27908 . 28377) (PUTSTREAMPROP
|
||||
28379 . 30788) (STREAMP 30790 . 30938)) (30983 33502 (\DEFPRINT.BY.NAME 30993 . 32145) (
|
||||
\STREAM.DEFPRINT 32147 . 33195) (\FDEV.DEFPRINT 33197 . 33500)) (33760 38801 (\GETACCESS 33770 . 34224
|
||||
) (\SETACCESS 34226 . 38799)) (59682 65651 (\DEFINEDEVICE 59692 . 62008) (\GETDEVICEFROMNAME 62010 .
|
||||
62483) (\GETDEVICEFROMHOSTNAME 62485 . 63529) (\REMOVEDEVICE 63531 . 64654) (\REMOVEDEVICE.NAMES 64656
|
||||
. 65649)) (65691 90351 (\CLOSEFILE 65701 . 66526) (\DELETEFILE 66528 . 66822) (\DEVICEEVENT 66824 .
|
||||
68594) (\GENERATEFILES 68596 . 69074) (\GENERATENEXTFILE 69076 . 69727) (\GENERATEFILEINFO 69729 .
|
||||
70190) (\GETFILENAME 70192 . 70581) (\GENERIC.OUTFILEP 70583 . 71053) (\OPENFILE 71055 . 73633) (
|
||||
\DO.PARAMS.AT.OPEN 73635 . 76188) (\RENAMEFILE 76190 . 76614) (\REVALIDATEFILE 76616 . 79218) (
|
||||
\PAGED.REVALIDATEFILELST 79220 . 80778) (\PAGED.REVALIDATEFILES 80780 . 82499) (\PAGED.REVALIDATEFILE
|
||||
82501 . 84784) (\BUFFERED.REVALIDATEFILE 84786 . 87072) (\BUFFERED.REVALIDATEFILELST 87074 . 88258) (
|
||||
\PRINT-REVALIDATION-RESULT 88260 . 88675) (\TRUNCATEFILE 88677 . 89068) (\FILE-CONFLICT 89070 . 90349)
|
||||
) (90387 95050 (\GENERATENOFILES 90397 . 92493) (\NULLFILEGENERATOR 92495 . 92739) (\NOFILESNEXTFILEFN
|
||||
92741 . 94732) (\NOFILESINFOFN 94734 . 95048)) (95169 97077 (\FILE.NOT.OPEN 95179 . 95692) (
|
||||
\FILE.WONT.OPEN 95694 . 96022) (\ILLEGAL.DEVICEOP 96024 . 96306) (\IS.NOT.RANDACCESSP 96308 . 96754) (
|
||||
\STREAM.NOT.OPEN 96756 . 97075)) (97212 99510 (\FDEVINSTANCE 97222 . 99508)) (101060 108434 (CNDIR
|
||||
101070 . 102375) (DIRECTORYNAME 102377 . 106560) (DIRECTORYNAMEP 106562 . 107178) (HOSTNAMEP 107180 .
|
||||
107987) (\ADD.CONNECTED.DIR 107989 . 108432)) (108479 135866 (\BACKFILEPTR 108489 . 108677) (
|
||||
\BACKPEEKBIN 108679 . 109040) (\BACKBIN 109042 . 109393) (BIN 109395 . 109612) (\BIN 109614 . 109891)
|
||||
(\BINS 109893 . 110179) (BOUT 110181 . 110543) (\BOUT 110545 . 110860) (\BOUTS 110862 . 111173) (
|
||||
COPYBYTES 111175 . 114507) (COPYCHARS 114509 . 118175) (COPYFILE 118177 . 118974) (\COPYOPENFILE
|
||||
118976 . 122049) (\INFER.FILE.TYPE 122051 . 123005) (EOFP 123007 . 123304) (FORCEOUTPUT 123306 .
|
||||
123553) (\FLUSH.OPEN.STREAMS 123555 . 123911) (CHARSET 123913 . 125577) (ACCESS-CHARSET 125579 .
|
||||
125796) (GETEOFPTR 125798 . 126048) (GETFILEINFO 126050 . 129243) (\TYPE.FROM.FILETYPE 129245 . 129715
|
||||
) (\FILETYPE.FROM.TYPE 129717 . 129896) (GETFILEPTR 129898 . 130150) (SETFILEINFO 130152 . 133765) (
|
||||
SETFILEPTR 133767 . 135486) (BOUT16 135488 . 135673) (BIN16 135675 . 135864)) (135969 141174 (
|
||||
\GENERIC.BINS 135979 . 136259) (\GENERIC.BOUTS 136261 . 136526) (\GENERIC.RENAMEFILE 136528 . 138359)
|
||||
(\GENERIC.OPENP 138361 . 139676) (\GENERIC.READP 139678 . 140719) (\GENERIC.CHARSET 140721 . 141172))
|
||||
(141175 141514 (\MAP-OPEN-STREAMS 141185 . 141512)) (143384 145464 (\EOF.ACTION 143394 . 143645) (
|
||||
\EOSERROR 143647 . 143840) (\GETEOFPTR 143842 . 144024) (\INCFILEPTR 144026 . 144376) (\PEEKBIN 144378
|
||||
. 144569) (\SETCLOSEDFILELENGTH 144571 . 144905) (\SETEOFPTR 144907 . 145095) (\SETFILEPTR 145097 .
|
||||
145462)) (145465 146007 (\FIXPOUT 145475 . 145775) (\FIXPIN 145777 . 146005)) (146008 146574 (\BOUTEOL
|
||||
146018 . 146572)) (149666 159530 (\BUFFERED.BIN 149676 . 150528) (\BUFFERED.PEEKBIN 150530 . 151312)
|
||||
(\BUFFERED.BOUT 151314 . 152174) (\BUFFERED.BINS 152176 . 155861) (\BUFFERED.BOUTS 155863 . 157664) (
|
||||
\BUFFERED.COPYBYTES 157666 . 159528)) (159559 161911 (\NULLDEVICE 159569 . 161587) (\NULL.OPENFILE
|
||||
161589 . 161909)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,11 +1,11 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
(FILECREATED "25-Jun-2021 10:21:40"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>FILESETS.;6 6395
|
||||
(FILECREATED "11-Sep-2021 00:01:52"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>FILESETS.;10 6469
|
||||
|
||||
changes to%: (VARS 0LISPSET)
|
||||
changes to%: (VARS MAKEINITTYPES 0LISPSET EXPORTFILES)
|
||||
|
||||
previous date%: "19-Jun-2021 12:13:31"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>FILESETS.;5)
|
||||
previous date%: "10-Sep-2021 19:53:14"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>FILESETS.;8)
|
||||
|
||||
|
||||
(* ; "
|
||||
@@ -17,13 +17,13 @@ Copyright (c) 1981-1990, 1998, 2021 by Xerox Corporation.
|
||||
(RPAQQ FILESETSCOMS
|
||||
(
|
||||
|
||||
(* ;;; "contains all of the lists of files which are used in various ways")
|
||||
(* ;;; "contains all of the lists of files which are used in various ways")
|
||||
|
||||
|
||||
(* ;; "I took out the EXPORT of the filesets because it led to inconsistency when one had loaded ABC. -- Pavel")
|
||||
(* ;; "I took out the EXPORT of the filesets because it led to inconsistency when one had loaded ABC. -- Pavel")
|
||||
|
||||
|
||||
(* ;; "The file with the default EXTERNALFORMAT should come right after FILEIO, and particularly before ATERM.")
|
||||
(* ;; "The file with the default EXTERNALFORMAT should come right after FILEIO, and particularly before ATERM.")
|
||||
|
||||
(VARS * FILESETS)
|
||||
(VARS EXPORTFILES)
|
||||
@@ -51,10 +51,10 @@ Copyright (c) 1981-1990, 1998, 2021 by Xerox Corporation.
|
||||
|
||||
(RPAQQ FILESETS (0LISPSET 1LISPSET 2LISPSET 3LISPSET))
|
||||
|
||||
(RPAQQ 0LISPSET (PACKAGE-CONVERSION-TABLE LLFAULT LLSUBRS LLBFS LLNEW FILEIO IMAGEIO LLBASIC LLGC
|
||||
LLARRAYELT LLINTERP LLMVS DEFSTRUCT-RUN-TIME SETF-RUNTIME CMLSEQBASICS
|
||||
LLARITH LLFLOAT LLBIGNUM LLREAD XCCS LLCHAR LLSTK LLDATATYPE IOCHAR LLKEY
|
||||
LLTIMER))
|
||||
(RPAQQ 0LISPSET (PACKAGE-CONVERSION-TABLE LLFAULT LLSUBRS LLBFS LLNEW FILEIO EXTERNALFORMAT
|
||||
IMAGEIO LLBASIC LLGC LLARRAYELT LLINTERP LLMVS DEFSTRUCT-RUN-TIME
|
||||
SETF-RUNTIME CMLSEQBASICS LLARITH LLFLOAT LLBIGNUM LLREAD XCCS LLCHAR
|
||||
LLSTK LLDATATYPE IOCHAR LLKEY LLTIMER))
|
||||
|
||||
(RPAQQ 1LISPSET
|
||||
(ASTACK DTDECLARE ATBL LLCODE ACODE COREIO AOFD ADIR PMAP VANILLADISK ATERM APRINT ABASIC
|
||||
@@ -69,17 +69,17 @@ Copyright (c) 1981-1990, 1998, 2021 by Xerox Corporation.
|
||||
|
||||
(RPAQQ EXPORTFILES
|
||||
(MODARITH LLPARAMS LLCODE AERROR AOFD APRINT ATERM LLARRAYELT LLDATATYPE LLNEW LLBASIC LLCHAR
|
||||
LLSTK PMAP LLGC ATBL FILEIO LLARITH LLFLOAT FONT LLKEY LLDISPLAY ADISPLAY AINTERRUPT
|
||||
RENAMEMACROS HLDISPLAY WINDOW MACROAUX ADDARITH LLFAULT LLTIMER IMAGEIO PROC XCCS
|
||||
LLREAD PASSWORDS INTERPRESS HARDCOPY CMLARRAY LLSUBRS))
|
||||
LLSTK PMAP LLGC ATBL FILEIO EXTERNALFORMAT LLARITH LLFLOAT FONT LLKEY LLDISPLAY
|
||||
ADISPLAY AINTERRUPT RENAMEMACROS HLDISPLAY WINDOW MACROAUX ADDARITH LLFAULT LLTIMER
|
||||
IMAGEIO PROC XCCS LLREAD PASSWORDS INTERPRESS HARDCOPY CMLARRAY LLSUBRS))
|
||||
|
||||
(RPAQQ MAKEINITFILES (MAKEINIT MEM I-NEW))
|
||||
|
||||
(RPAQQ MAKEINITTYPES
|
||||
((NIL INIT (0 1)
|
||||
2LISPSET 1600)
|
||||
(SMALLINIT SMALLINIT (LLFAULT LLSUBRS LLNEW FILEIO LLBASIC LLGC LLINTERP LLARITH LLREAD
|
||||
LLCHAR TINYPATCH))
|
||||
(SMALLINIT SMALLINIT (LLFAULT LLSUBRS LLNEW FILEIO EXTERNALFORMAT LLBASIC LLGC LLINTERP
|
||||
LLARITH LLREAD LLCHAR TINYPATCH))
|
||||
(MACROTEST MACROTEST ((MACROTEST)
|
||||
0 1)
|
||||
2LISPSET)
|
||||
@@ -114,7 +114,7 @@ Copyright (c) 1981-1990, 1998, 2021 by Xerox Corporation.
|
||||
(COMSNAME . RDCOMS)
|
||||
(EXTRACOMS
|
||||
|
||||
(* ;; "YOU MUST REMAKE THIS FILE using (DORENAME 'R) (after CONNing to library) whenever the SYSOUT layout changes in LLPARAMS (e.g., if MDSTypeTable moves)")
|
||||
(* ;; "YOU MUST REMAKE THIS FILE using (DORENAME 'R) (after CONNing to library) whenever the SYSOUT layout changes in LLPARAMS (e.g., if MDSTypeTable moves)")
|
||||
|
||||
(FILES VMEM)
|
||||
(VARS RDVALS RDPTRS)
|
||||
|
||||
@@ -1,11 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10 FORMAT XCCS)
|
||||
(FILECREATED " 2-Aug-2021 19:41:35"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>IMAGEIO.;4 79616
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
(FILECREATED "25-Sep-2021 20:58:07"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>IMAGEIO.;4 79783
|
||||
|
||||
changes to%: (FNS \DISPLAYINIT)
|
||||
changes to%: (VARS IMAGEIOCOMS)
|
||||
(FNS \DISPLAYINIT \4DISPLAYINIT \8DISPLAYINIT \24DISPLAYINIT)
|
||||
|
||||
previous date%: "28-Jun-99 16:33:59"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>IMAGEIO.;1)
|
||||
previous date%: " 2-Aug-2021 19:41:35"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>IMAGEIO.;2)
|
||||
|
||||
|
||||
(* ; "
|
||||
@@ -27,7 +28,7 @@ Copyright (c) 1983-1991, 1993-1994, 1999, 2021 by Venue & Xerox Corporation.
|
||||
(FNS \DRAWPOINT.GENERIC \DRAWPOLYGON.GENERIC \DRAWCIRCLE.GENERIC \DRAWELLIPSE.GENERIC)
|
||||
(FNS \IMAGEIOINIT \NOIMAGE.DSPFONT \UNIMPIMAGEOP)
|
||||
[COMS
|
||||
(* ;; "stuff to support the checking and defaulting of arguments in the device independent drawing functions.")
|
||||
(* ;; "stuff to support the checking and defaulting of arguments in the device independent drawing functions.")
|
||||
|
||||
(FNS INSURE.BRUSH BRUSHP \POSSIBLECOLOR NEGSHADE)
|
||||
(DECLARE%: DONTCOPY EVAL@COMPILE (RESOURCES SYSTEMBRUSH))
|
||||
@@ -42,7 +43,7 @@ Copyright (c) 1983-1991, 1993-1994, 1999, 2021 by Venue & Xerox Corporation.
|
||||
(SYSRECORDS IMAGEOPS)
|
||||
(DECLARE%: DONTEVAL@LOAD DOCOPY (P (\IMAGEIOINIT)))
|
||||
[COMS
|
||||
(* ;; "Implementation of display stream resident `files.' Done here cause it might matter that the display device get defined early so that its event fn will be evaluated as the last thing before logout")
|
||||
(* ;; "Implementation of display stream resident `files.' Done here cause it might matter that the display device get defined early so that its event fn will be evaluated as the last thing before logout")
|
||||
|
||||
(INITVARS (\COLORDISPLAYSTREAMTYPES '(4DISPLAY 8DISPLAY 24DISPLAY))
|
||||
(\DISPLAYSTREAMTYPES (CONS 'DISPLAY \COLORDISPLAYSTREAMTYPES)))
|
||||
@@ -1170,11 +1171,11 @@ Copyright (c) 1983-1991, 1993-1994, 1999, 2021 by Venue & Xerox Corporation.
|
||||
NIL])
|
||||
|
||||
(\DISPLAYINIT
|
||||
[LAMBDA NIL (* ; "Edited 2-Aug-2021 19:41 by rmk:")
|
||||
[LAMBDA NIL (* ; "Edited 25-Sep-2021 20:57 by rmk:")
|
||||
|
||||
(* ;; "Initializes global variables for the Display device")
|
||||
(* ;; "Initializes global variables for the Display device")
|
||||
|
||||
(* ;; "Display Streams are referred to only by themselves so they do not need directory operations. Most of the fields in the DisplayDevice are empty to avoid something bad happening.")
|
||||
(* ;; "Display Streams are referred to only by themselves so they do not need directory operations. Most of the fields in the DisplayDevice are empty to avoid something bad happening.")
|
||||
|
||||
(DECLARE (GLOBALVARS DisplayFDEV \DISPLAYIMAGEOPS \DisplayDeviceMethods \DisplayDeviceData))
|
||||
(SETQ \DisplayDeviceMethods (create WSOPS))
|
||||
@@ -1186,6 +1187,8 @@ Copyright (c) 1983-1991, 1993-1994, 1999, 2021 by Venue & Xerox Corporation.
|
||||
BOTTOM _ 0
|
||||
WIDTH _ 1024
|
||||
HEIGHT _ 808)))
|
||||
(MAKE-EXTERNALFORMAT :DISPLAY NIL NIL NIL (FUNCTION \DSPPRINTCHAR)
|
||||
NIL CR.EOLC)
|
||||
(SETQ \DISPLAYIMAGEOPS (create IMAGEOPS
|
||||
IMAGETYPE _ 'DISPLAY
|
||||
IMFONT _ (FUNCTION \DSPFONT.DISPLAY)
|
||||
@@ -1252,13 +1255,11 @@ Copyright (c) 1983-1991, 1993-1994, 1999, 2021 by Venue & Xerox Corporation.
|
||||
WINDOWOPS _ \DisplayDeviceMethods
|
||||
WINDOWDATA _ \DisplayDeviceData
|
||||
DEVICEINFO _ (create DISPLAYSTATE)
|
||||
DEFAULTEXTERNALFORMAT _ (MAKE-EXTERNALFORMAT :DISPLAY NIL NIL NIL
|
||||
(FUNCTION \DSPPRINTCHAR)
|
||||
NIL CR.EOLC)))
|
||||
DEFAULTEXTERNALFORMAT _ :DISPLAY))
|
||||
(\DEFINEDEVICE 'LFDISPLAY DisplayFDEV])
|
||||
|
||||
(\4DISPLAYINIT
|
||||
[LAMBDA NIL (* ; "Edited 22-Apr-94 15:17 by sybalsky")
|
||||
[LAMBDA NIL (* ; "Edited 25-Sep-2021 18:42 by rmk:")
|
||||
(DECLARE (GLOBALVARS \4DISPLAYIMAGEOPS \4DISPLAYFDEV))
|
||||
(SETQ \4DISPLAYIMAGEOPS (create IMAGEOPS
|
||||
IMAGETYPE _ '4DISPLAY
|
||||
@@ -1322,11 +1323,12 @@ Copyright (c) 1983-1991, 1993-1994, 1999, 2021 by Venue & Xerox Corporation.
|
||||
BLOCKIN _ (FUNCTION \ILLEGAL.DEVICEOP)
|
||||
BLOCKOUT _ (FUNCTION \NONPAGEDBOUTS)
|
||||
DEVICEINFO _ (create DISPLAYSTATE)
|
||||
WINDOWOPS _ NIL))
|
||||
WINDOWOPS _ NIL
|
||||
DEFAULTEXTERNALFORMAT _ :DISPLAY))
|
||||
(\DEFINEDEVICE NIL \4DISPLAYFDEV])
|
||||
|
||||
(\8DISPLAYINIT
|
||||
[LAMBDA NIL (* ; "Edited 22-Apr-94 15:18 by sybalsky")
|
||||
[LAMBDA NIL (* ; "Edited 25-Sep-2021 18:43 by rmk:")
|
||||
(DECLARE (GLOBALVARS \8DISPLAYIMAGEOPS \8DISPLAYFDEV))
|
||||
(SETQ \8DISPLAYIMAGEOPS (create IMAGEOPS
|
||||
IMAGETYPE _ '8DISPLAY
|
||||
@@ -1390,11 +1392,12 @@ Copyright (c) 1983-1991, 1993-1994, 1999, 2021 by Venue & Xerox Corporation.
|
||||
BLOCKIN _ (FUNCTION \ILLEGAL.DEVICEOP)
|
||||
BLOCKOUT _ (FUNCTION \NONPAGEDBOUTS)
|
||||
DEVICEINFO _ (create DISPLAYSTATE)
|
||||
WINDOWOPS _ NIL))
|
||||
WINDOWOPS _ NIL
|
||||
DEFAULTEXTERNALFORMAT _ :DISPLAY))
|
||||
(\DEFINEDEVICE NIL \8DISPLAYFDEV])
|
||||
|
||||
(\24DISPLAYINIT
|
||||
[LAMBDA NIL (* ; "Edited 22-Apr-94 15:18 by sybalsky")
|
||||
[LAMBDA NIL (* ; "Edited 25-Sep-2021 18:44 by rmk:")
|
||||
(DECLARE (GLOBALVARS \24DISPLAYIMAGEOPS \24DISPLAYFDEV))
|
||||
(SETQ \24DISPLAYIMAGEOPS (create IMAGEOPS
|
||||
IMAGETYPE _ '24DISPLAY
|
||||
@@ -1458,7 +1461,8 @@ Copyright (c) 1983-1991, 1993-1994, 1999, 2021 by Venue & Xerox Corporation.
|
||||
BLOCKIN _ (FUNCTION \ILLEGAL.DEVICEOP)
|
||||
BLOCKOUT _ (FUNCTION \NONPAGEDBOUTS)
|
||||
DEVICEINFO _ (create DISPLAYSTATE)
|
||||
WINDOWOPS _ NIL))
|
||||
WINDOWOPS _ NIL
|
||||
DEFAULTEXTERNALFORMAT _ :DISPLAY))
|
||||
(\DEFINEDEVICE NIL \24DISPLAYFDEV])
|
||||
|
||||
(\DISPLAYSTREAMTYPEBPP
|
||||
@@ -1509,24 +1513,24 @@ Copyright (c) 1983-1991, 1993-1994, 1999, 2021 by Venue & Xerox Corporation.
|
||||
(PUTPROPS IMAGEIO COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1989 1990 1991
|
||||
1993 1994 1999 2021))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (3353 12110 (IMAGESTREAMP 3363 . 4195) (IMAGESTREAMTYPE 4197 . 4410) (IMAGESTREAMTYPEP
|
||||
4412 . 5047) (OPENIMAGESTREAM 5049 . 10003) (\GOOD.DASHLST 10005 . 12108)) (12145 14442 (
|
||||
DRAWDASHEDLINE 12155 . 14440)) (14443 21783 (DSPBACKCOLOR 14453 . 14825) (DSPBOTTOMMARGIN 14827 .
|
||||
15212) (DSPCOLOR 15214 . 15578) (DSPCLIPPINGREGION 15580 . 16285) (DSPRESET 16287 . 16567) (DSPFONT
|
||||
16569 . 16933) (DSPLEFTMARGIN 16935 . 17316) (DSPLINEFEED 17318 . 17618) (DSPOPERATION 17620 . 17997)
|
||||
(DSPRIGHTMARGIN 17999 . 18382) (DSPTOPMARGIN 18384 . 18763) (DSPSCALE 18765 . 19132) (DSPSPACEFACTOR
|
||||
19134 . 19527) (DSPXPOSITION 19529 . 19834) (DSPYPOSITION 19836 . 20141) (DSPROTATE 20143 . 20438) (
|
||||
DSPPUSHSTATE 20440 . 20686) (DSPPOPSTATE 20688 . 20931) (DSPDEFAULTSTATE 20933 . 21185) (DSPSCALE2
|
||||
21187 . 21478) (DSPTRANSLATE 21480 . 21781)) (21784 30585 (DSPNEWPAGE 21794 . 22486) (DRAWBETWEEN
|
||||
22488 . 23190) (DRAWCIRCLE 23192 . 23688) (DRAWARC 23690 . 24207) (DRAWCURVE 24209 . 24886) (
|
||||
DRAWELLIPSE 24888 . 25674) (DRAWLINE 25676 . 26066) (DRAWPOLYGON 26068 . 26523) (DRAWPOINT 26525 .
|
||||
26944) (FILLPOLYGON 26946 . 27512) (DRAWTO 27514 . 27932) (FILLCIRCLE 27934 . 28157) (MOVETO 28159 .
|
||||
28523) (RELDRAWTO 28525 . 29442) (BITMAPIMAGESIZE 29444 . 29615) (SCALEDBITBLT 29617 . 30583)) (30586
|
||||
37625 (\DRAWPOINT.GENERIC 30596 . 30943) (\DRAWPOLYGON.GENERIC 30945 . 33253) (\DRAWCIRCLE.GENERIC
|
||||
33255 . 34913) (\DRAWELLIPSE.GENERIC 34915 . 37623)) (37626 43012 (\IMAGEIOINIT 37636 . 41769) (
|
||||
\NOIMAGE.DSPFONT 41771 . 42846) (\UNIMPIMAGEOP 42848 . 43010)) (43135 46259 (INSURE.BRUSH 43145 .
|
||||
44519) (BRUSHP 44521 . 45311) (\POSSIBLECOLOR 45313 . 45864) (NEGSHADE 45866 . 46257)) (46815 47499 (
|
||||
DASHINGP 46825 . 47155) (INSURE.DASHING 47157 . 47497)) (57980 78429 (\DisplayEventFn 57990 . 58500) (
|
||||
\DISPLAYINIT 58502 . 64181) (\4DISPLAYINIT 64183 . 68820) (\8DISPLAYINIT 68822 . 73461) (
|
||||
\24DISPLAYINIT 73463 . 78170) (\DISPLAYSTREAMTYPEBPP 78172 . 78427)))))
|
||||
(FILEMAP (NIL (3423 12180 (IMAGESTREAMP 3433 . 4265) (IMAGESTREAMTYPE 4267 . 4480) (IMAGESTREAMTYPEP
|
||||
4482 . 5117) (OPENIMAGESTREAM 5119 . 10073) (\GOOD.DASHLST 10075 . 12178)) (12215 14512 (
|
||||
DRAWDASHEDLINE 12225 . 14510)) (14513 21853 (DSPBACKCOLOR 14523 . 14895) (DSPBOTTOMMARGIN 14897 .
|
||||
15282) (DSPCOLOR 15284 . 15648) (DSPCLIPPINGREGION 15650 . 16355) (DSPRESET 16357 . 16637) (DSPFONT
|
||||
16639 . 17003) (DSPLEFTMARGIN 17005 . 17386) (DSPLINEFEED 17388 . 17688) (DSPOPERATION 17690 . 18067)
|
||||
(DSPRIGHTMARGIN 18069 . 18452) (DSPTOPMARGIN 18454 . 18833) (DSPSCALE 18835 . 19202) (DSPSPACEFACTOR
|
||||
19204 . 19597) (DSPXPOSITION 19599 . 19904) (DSPYPOSITION 19906 . 20211) (DSPROTATE 20213 . 20508) (
|
||||
DSPPUSHSTATE 20510 . 20756) (DSPPOPSTATE 20758 . 21001) (DSPDEFAULTSTATE 21003 . 21255) (DSPSCALE2
|
||||
21257 . 21548) (DSPTRANSLATE 21550 . 21851)) (21854 30655 (DSPNEWPAGE 21864 . 22556) (DRAWBETWEEN
|
||||
22558 . 23260) (DRAWCIRCLE 23262 . 23758) (DRAWARC 23760 . 24277) (DRAWCURVE 24279 . 24956) (
|
||||
DRAWELLIPSE 24958 . 25744) (DRAWLINE 25746 . 26136) (DRAWPOLYGON 26138 . 26593) (DRAWPOINT 26595 .
|
||||
27014) (FILLPOLYGON 27016 . 27582) (DRAWTO 27584 . 28002) (FILLCIRCLE 28004 . 28227) (MOVETO 28229 .
|
||||
28593) (RELDRAWTO 28595 . 29512) (BITMAPIMAGESIZE 29514 . 29685) (SCALEDBITBLT 29687 . 30653)) (30656
|
||||
37695 (\DRAWPOINT.GENERIC 30666 . 31013) (\DRAWPOLYGON.GENERIC 31015 . 33323) (\DRAWCIRCLE.GENERIC
|
||||
33325 . 34983) (\DRAWELLIPSE.GENERIC 34985 . 37693)) (37696 43082 (\IMAGEIOINIT 37706 . 41839) (
|
||||
\NOIMAGE.DSPFONT 41841 . 42916) (\UNIMPIMAGEOP 42918 . 43080)) (43205 46329 (INSURE.BRUSH 43215 .
|
||||
44589) (BRUSHP 44591 . 45381) (\POSSIBLECOLOR 45383 . 45934) (NEGSHADE 45936 . 46327)) (46885 47569 (
|
||||
DASHINGP 46895 . 47225) (INSURE.DASHING 47227 . 47567)) (58050 78596 (\DisplayEventFn 58060 . 58570) (
|
||||
\DISPLAYINIT 58572 . 64155) (\4DISPLAYINIT 64157 . 68858) (\8DISPLAYINIT 68860 . 73563) (
|
||||
\24DISPLAYINIT 73565 . 78337) (\DISPLAYSTREAMTYPEBPP 78339 . 78594)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
345
sources/LLREAD
345
sources/LLREAD
@@ -1,11 +1,11 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
(FILECREATED "24-Aug-2021 10:04:18"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>LLREAD.;103 105490
|
||||
(FILECREATED "10-Sep-2021 19:41:58"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>LLREAD.;101 90912
|
||||
|
||||
changes to%: (FNS CHARCODE.DECODE)
|
||||
changes to%: (VARS LLREADCOMS)
|
||||
|
||||
previous date%: "24-Aug-2021 08:32:13"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>LLREAD.;101)
|
||||
previous date%: "24-Aug-2021 10:04:18"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>LLREAD.;100)
|
||||
|
||||
|
||||
(* ; "
|
||||
@@ -15,25 +15,25 @@ Copyright (c) 1981-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
(PRETTYCOMPRINT LLREADCOMS)
|
||||
|
||||
(RPAQQ LLREADCOMS
|
||||
[(COMS (* ; "Reader entrypoints")
|
||||
[(COMS (* ; "Reader entrypoints")
|
||||
(FNS LASTC PEEKC PEEKCCODE RATOM READ READC READCCODE READP SETREADMACROFLG
|
||||
SKIPSEPRCODES SKIPSEPRS SKREAD))
|
||||
(COMS (* ; "CommonLisp read entry points")
|
||||
(COMS (* ; "CommonLisp read entry points")
|
||||
(FNS CL:READ CL:READ-PRESERVING-WHITESPACE CL:READ-DELIMITED-LIST CL:PARSE-INTEGER)
|
||||
(GLOBALVARS CMLRDTBL))
|
||||
(COMS (* ; "reading strings")
|
||||
(COMS (* ; "reading strings")
|
||||
(FNS RSTRING READ-EXTENDED-TOKEN \RSTRING2))
|
||||
[COMS (* ; "Core of the reader")
|
||||
[COMS (* ; "Core of the reader")
|
||||
(FNS \TOP-LEVEL-READ \SUBREAD \SUBREADCONCAT \ORIG-READ.SYMBOL \ORIG-INVALID.SYMBOL
|
||||
\APPLYREADMACRO INREADMACROP)
|
||||
(DECLARE%: DONTEVAL@LOAD DOCOPY (P (MOVD? '\ORIG-READ.SYMBOL '\READ.SYMBOL)
|
||||
(MOVD? '\ORIG-INVALID.SYMBOL '\INVALID.SYMBOL]
|
||||
(COMS (* ; "Read macro for '")
|
||||
(COMS (* ; "Read macro for '")
|
||||
(FNS READQUOTE))
|
||||
(COMS (* ; "# macro")
|
||||
(COMS (* ; "# macro")
|
||||
(FNS READVBAR READHASHMACRO DEFMACRO-LAMBDA-LIST-KEYWORD-P DIGITBASEP READNUMBERINBASE
|
||||
ESTIMATE-DIMENSIONALITY SKIP.HASH.COMMENT CMLREAD.FEATURE.PARSER))
|
||||
(COMS (* ; "Reading characters with #\")
|
||||
(COMS (* ; "Reading characters with #\")
|
||||
(FNS CHARACTER.READ CHARCODE.DECODE)
|
||||
(FNS HEXNUM? OCTALNUM?)
|
||||
(VARS CHARACTERNAMES CHARACTERSETNAMES))
|
||||
@@ -41,19 +41,13 @@ Copyright (c) 1981-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
(MACROS .CALL.SUBREAD. FIXDOT RBCONTEXT PROPRB \RDCONC)
|
||||
(SPECVARS *READ-NEWLINE-SUPPRESS* \RefillBufferFn)
|
||||
(GLOBALVARS *KEYWORD-PACKAGE* *INTERLISP-PACKAGE*))
|
||||
(COMS
|
||||
(* ;; "Generic functions not compiled open")
|
||||
|
||||
(FNS \OUTCHAR \INCCODE \BACKCCODE \BACKCCODE.EOLC \PEEKCCODE \PEEKCCODE.NOEOLC
|
||||
\INCCODE.EOLC \FORMATBYTESTREAM \CHECKEOLC.CRLF)
|
||||
(MACROS \CHECKEOLC))
|
||||
(COMS (INITVARS (*REPLACE-NO-FONT-CODE* T)
|
||||
(*DEFAULT-NOT-CONVERTED-FAT-CODE* 8739))
|
||||
(GLOBALVARS *REPLACE-NO-FONT-CODE* *DEFAULT-NOT-CONVERTED-FAT-CODE*))
|
||||
(INITVARS (*READ-NEWLINE-SUPPRESS*)
|
||||
(\RefillBufferFn (FUNCTION \READCREFILL)))
|
||||
(* ;
|
||||
"Top level val of \RefillBufferFn means act like READC--we must be doing a raw BIN (or PEEKBIN?)")
|
||||
(* ;
|
||||
"Top level val of \RefillBufferFn means act like READC--we must be doing a raw BIN (or PEEKBIN?)")
|
||||
(LOCALVARS . T)
|
||||
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
|
||||
(ADDVARS (NLAMA)
|
||||
@@ -1604,8 +1598,8 @@ Copyright (c) 1981-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
EOF-SUPPRESS EOF-VALUE CHAR PRESERVE-WHITESPACE
|
||||
))))
|
||||
|
||||
(PUTPROPS FIXDOT MACRO [NIL (PROGN (* ;
|
||||
"Fix a non-first dot followed by a singleton")
|
||||
(PUTPROPS FIXDOT MACRO [NIL (PROGN (* ;
|
||||
"Fix a non-first dot followed by a singleton")
|
||||
(AND DOTLOC (CDDR DOTLOC)
|
||||
(NULL (CDDDR DOTLOC))
|
||||
(RPLACD DOTLOC (CADDR DOTLOC])
|
||||
@@ -1617,21 +1611,21 @@ Copyright (c) 1981-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
\RBFLG]
|
||||
NIL)))
|
||||
|
||||
(PUTPROPS PROPRB MACRO [(X . Y) (* ;
|
||||
"Propagates the right-bracket flag")
|
||||
(PUTPROPS PROPRB MACRO [(X . Y) (* ;
|
||||
"Propagates the right-bracket flag")
|
||||
(AND (RBCONTEXT X . Y)
|
||||
(OR (EQ READTYPE NOPROPRB.RT)
|
||||
(SETQ \RBFLG T])
|
||||
|
||||
(PUTPROPS \RDCONC MACRO [(ELT . TOPFORMS)
|
||||
|
||||
(* ;; "Add ELT to the accumulating list to be returned by \SUBREAD. If at top level and no list accumulated, then run TOPFORMS")
|
||||
(* ;; "Add ELT to the accumulating list to be returned by \SUBREAD. If at top level and no list accumulated, then run TOPFORMS")
|
||||
|
||||
(COND
|
||||
[LST (RPLACD END (SETQ END (CONS ELT]
|
||||
(TOPLEVELP . TOPFORMS)
|
||||
((NOT *READ-SUPPRESS*) (* ;
|
||||
"Don't bother consing the result if it's going to be thrown away")
|
||||
((NOT *READ-SUPPRESS*) (* ;
|
||||
"Don't bother consing the result if it's going to be thrown away")
|
||||
(SETQ END (SETQ LST (CONS ELT])
|
||||
)
|
||||
|
||||
@@ -1646,274 +1640,6 @@ Copyright (c) 1981-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
)
|
||||
)
|
||||
|
||||
|
||||
|
||||
(* ;; "Generic functions not compiled open")
|
||||
|
||||
(DEFINEQ
|
||||
|
||||
(\OUTCHAR
|
||||
[LAMBDA (STREAM CODE) (* ; "Edited 10-Aug-2021 10:29 by rmk:")
|
||||
|
||||
(* ;; "We can't do the EOL stuff here because we don't know whether BOUTs are legit.")
|
||||
|
||||
(* ;; "Maybe the implementation function does something else, like move the X and Y positions. At best we could convert the EOL into either CR or LF, or into a CR-LF sequence that we pass by two calls to the lower implementation function.")
|
||||
|
||||
(* ;; "")
|
||||
|
||||
(* ;; "This would make CHARPOSITION generic:")
|
||||
(* (FREPLACE (STREAM CHARPOSITION)
|
||||
OF STREAM WITH (CL:IF
|
||||
(EQ CODE (CHARCODE EOL)) 0
|
||||
(IPLUS16 1 (FFETCH
|
||||
(STREAM CHARPOSITION) OF STREAM)))))
|
||||
(CL:FUNCALL (OR (ffetch (STREAM OUTCHARFN) of STREAM)
|
||||
\DEFAULTOUTCHAR)
|
||||
STREAM CODE)
|
||||
CODE])
|
||||
|
||||
(\INCCODE
|
||||
[LAMBDA (STREAM BYTECOUNTVAR BYTECOUNTVAL) (* ; "Edited 7-Aug-2021 00:11 by rmk:")
|
||||
|
||||
(* ;; "Calling functions pass the name of the BYTECOUNTVAR, or NIL. If non-NIL, implementing functions are required to SETQ *BYTECOUNTER* to the number of bytes read (positive) or backed up (negative).")
|
||||
|
||||
(* ;; "Caller must bind BYTECOUNTVAR as a SPECVAR. BYTECOUNTVAL can be passed as the current value of BYTECOUNTVAR, to save a call to \EVALV1.")
|
||||
|
||||
(IF BYTECOUNTVAR
|
||||
THEN [LET ((*BYTECOUNTER* 0))
|
||||
(DECLARE (SPECVARS *BYTECOUNTER*))
|
||||
(PROG1 (CL:FUNCALL (OR (ffetch (STREAM INCCODEFN) of STREAM)
|
||||
\DEFAULTINCCODE)
|
||||
STREAM
|
||||
'*BYTECOUNTER*)
|
||||
(SET BYTECOUNTVAR (IDIFFERENCE (OR BYTECOUNTVAL (\EVALV1 BYTECOUNTVAR))
|
||||
*BYTECOUNTER*)))]
|
||||
ELSE (CL:FUNCALL (OR (ffetch (STREAM INCCODEFN) of STREAM)
|
||||
\DEFAULTINCCODE)
|
||||
STREAM])
|
||||
|
||||
(\BACKCCODE
|
||||
[LAMBDA (STREAM BYTECOUNTVAR BYTECOUNTVAL) (* ; "Edited 14-Aug-2021 00:26 by rmk:")
|
||||
|
||||
(* ;;
|
||||
"Format function returns T if the backup succeed, NIL otherwise (e.g at the beginning of the file)")
|
||||
|
||||
(IF BYTECOUNTVAR
|
||||
THEN [LET ((*BYTECOUNTER* 0))
|
||||
(DECLARE (SPECVARS *BYTECOUNTER*))
|
||||
(PROG1 (CL:FUNCALL (OR (ffetch (STREAM BACKCCODEFN) of STREAM)
|
||||
\DEFAULTBACKCCODE)
|
||||
STREAM T)
|
||||
(SET BYTECOUNTVAR (IPLUS (OR BYTECOUNTVAL (\EVALV1 BYTECOUNTVAR))
|
||||
*BYTECOUNTER*)))]
|
||||
ELSE (CL:FUNCALL (OR (ffetch (STREAM BACKCCODEFN) of STREAM)
|
||||
\DEFAULTBACKCCODE)
|
||||
STREAM])
|
||||
|
||||
(\BACKCCODE.EOLC
|
||||
[LAMBDA (STREAM BYTECOUNTVAR BYTECOUNTVAL) (* ; "Edited 14-Aug-2021 00:27 by rmk:")
|
||||
|
||||
(* ;; "If the EOLCONVENTION is CRLF, and the first backup is over an LF encoding, this looks to see whether the preceding bytes encode a CR and if so, backs up over those.")
|
||||
|
||||
(* ;; "Within this we operate at the external-format implementation level.")
|
||||
|
||||
(* ;; "Counting is unusual in general (mostly just COPYCHARS and PFCOPYBYTES) , and counting while backing up is even rarer. So for simplicity here we just count by looking at the byte pointer.")
|
||||
|
||||
(LET [(STARTPOS (CL:WHEN BYTECOUNTVAR (\GETFILEPTR STREAM]
|
||||
|
||||
(* ;; "In almost all cases, we just execute the first backup")
|
||||
|
||||
(PROG1 (CL:WHEN (CL:FUNCALL (OR (ffetch (STREAM BACKCCODEFN) of STREAM)
|
||||
\DEFAULTBACKCCODE)
|
||||
STREAM)
|
||||
(IF (AND (EQ CRLF.EOLC (FETCH (STREAM EOLCONVENTION) OF STREAM))
|
||||
(EQ (CHARCODE LF)
|
||||
(CL:FUNCALL (OR (ffetch (STREAM PEEKCCODEFN) of STREAM)
|
||||
\DEFAULTPEEKCCODE)
|
||||
STREAM)))
|
||||
THEN
|
||||
|
||||
(* ;;
|
||||
"We just backed over an LF in a CRLF file. If we go one more, do we get a CR?")
|
||||
|
||||
(CL:WHEN (CL:FUNCALL (OR (ffetch (STREAM BACKCCODEFN) of STREAM
|
||||
)
|
||||
\DEFAULTBACKCCODE)
|
||||
STREAM)
|
||||
(CL:UNLESS (EQ (CHARCODE CR)
|
||||
(CL:FUNCALL (OR (ffetch (STREAM PEEKCCODEFN)
|
||||
of STREAM)
|
||||
\DEFAULTPEEKCCODE)
|
||||
STREAM))
|
||||
|
||||
(* ;; "Not a preceding CR, reread it.")
|
||||
|
||||
(CL:FUNCALL (OR (ffetch (STREAM INCCODEFN) of STREAM)
|
||||
\DEFAULTINCCODE)
|
||||
STREAM))
|
||||
T)
|
||||
ELSE T))
|
||||
(CL:WHEN BYTECOUNTVAR
|
||||
[SET BYTECOUNTVAR (IPLUS (OR BYTECOUNTVAL (\EVALV1 BYTECOUNTVAR))
|
||||
(IDIFFERENCE STARTPOS (\GETFILEPTR STREAM]))])
|
||||
|
||||
(\PEEKCCODE
|
||||
[LAMBDA (STREAM NOERROR EOL) (* ; "Edited 14-Jun-2021 12:40 by rmk:")
|
||||
(\CHECKEOLC (CL:FUNCALL (OR (ffetch (STREAM PEEKCCODEFN) of STREAM)
|
||||
\DEFAULTPEEKCCODE)
|
||||
STREAM NOERROR)
|
||||
EOL STREAM T])
|
||||
|
||||
(\PEEKCCODE.NOEOLC
|
||||
[LAMBDA (STREAM NOERROR) (* ; "Edited 27-Jun-2021 23:26 by rmk:")
|
||||
(CL:FUNCALL (OR (ffetch (STREAM PEEKCCODEFN) of STREAM)
|
||||
\DEFAULTPEEKCCODE)
|
||||
STREAM NOERROR])
|
||||
|
||||
(\INCCODE.EOLC
|
||||
[LAMBDA (STREAM EOLC BYTECOUNTVAR BYTECOUNTVAL) (* ; "Edited 8-Aug-2021 14:52 by rmk:")
|
||||
|
||||
(* ;;
|
||||
"EOL conversion around essentially a copy of \INCCODE but avoids the extra function call.")
|
||||
|
||||
(* ;; " EOLC of NIL means all patterns go to EOL")
|
||||
|
||||
(IF BYTECOUNTVAR
|
||||
THEN [LET (*BYTECOUNTER* CODE)
|
||||
(DECLARE (SPECVARS *BYTECOUNTER*))
|
||||
|
||||
(* ;; "The INCCODEFN first sets *BYTECOUNTER*")
|
||||
|
||||
(CL:UNLESS BYTECOUNTVAL
|
||||
(SETQ BYTECOUNTVAL (\EVALV1 BYTECOUNTVAR)))
|
||||
(SETQ CODE (CL:FUNCALL (OR (ffetch (STREAM INCCODEFN) of STREAM)
|
||||
\DEFAULTINCCODE)
|
||||
STREAM T))
|
||||
|
||||
(* ;; "Update according to the number of first-char (CR or LF) bytes")
|
||||
|
||||
(SETQ BYTECOUNTVAL (IDIFFERENCE BYTECOUNTVAL *BYTECOUNTER*))
|
||||
(SETQ *BYTECOUNTER* 0)
|
||||
|
||||
(* ;;
|
||||
"*BYTECOUNTER* will now be reset to the number of LF-after-CR bytes, if any")
|
||||
|
||||
(PROG1 (\CHECKEOLC CODE (OR EOLC (FFETCH (STREAM EOLCONVENTION)
|
||||
OF STREAM))
|
||||
STREAM NIL T)
|
||||
|
||||
(* ;; "Post the results")
|
||||
|
||||
(SET BYTECOUNTVAR (IDIFFERENCE BYTECOUNTVAL *BYTECOUNTER*)))]
|
||||
ELSE (\CHECKEOLC (CL:FUNCALL (OR (ffetch (STREAM INCCODEFN) of STREAM)
|
||||
\DEFAULTINCCODE)
|
||||
STREAM)
|
||||
(OR EOLC (FFETCH (STREAM EOLCONVENTION) OF STREAM))
|
||||
STREAM])
|
||||
|
||||
(\FORMATBYTESTREAM
|
||||
[LAMBDA (STREAM BYTESTREAM) (* ; "Edited 24-Jun-2021 17:26 by rmk:")
|
||||
|
||||
(* ;; "Create or modify a stream that will simulate the current character input/output byte sequences of STREAM. The set up here does what is common to all formats: an IO stream starting with STREAM external format and EOL.")
|
||||
|
||||
(* ;; "If the format has its own FORMATBYTESTREAMFN function, that is applied to copy any other state. (Currently that function is a property of the format, not carried over into a stream field that can be changed dynamically.)")
|
||||
|
||||
(CL:UNLESS (AND (STREAMP BYTESTREAM)
|
||||
(\IOMODEP STREAM 'BOTH))
|
||||
(SETQ BYTESTREAM (OPENSTREAM '{NODIRCORE} 'BOTH)))
|
||||
(LET ((FORMAT (FETCH (STREAM EXTERNALFORMAT) OF STREAM))
|
||||
(EOLC (FETCH (STREAM EOLCONVENTION) OF STREAM)))
|
||||
(\EXTERNALFORMAT BYTESTREAM FORMAT)
|
||||
(CL:WHEN (EQ EOLC ANY.EOLC)
|
||||
(SETQ EOLC (OR (FETCH (EXTERNALFORMAT EOL) OF FORMAT)
|
||||
LF.EOLC)))
|
||||
(REPLACE (STREAM EOLCONVENTION) OF BYTESTREAM WITH EOLC)
|
||||
(SETFILEPTR BYTESTREAM 0)
|
||||
(SETFILEINFO BYTESTREAM 'ENDOFSTREAMOP (FUNCTION NILL))
|
||||
(CL:WHEN (FETCH (EXTERNALFORMAT FORMATBYTESTREAMFN) OF FORMAT)
|
||||
(APPLY* (FETCH (EXTERNALFORMAT FORMATBYTESTREAMFN) OF FORMAT)
|
||||
STREAM BYTESTREAM))
|
||||
BYTESTREAM])
|
||||
|
||||
(\CHECKEOLC.CRLF
|
||||
[LAMBDA (STREAM PEEKBINFLG COUNTP) (* ; "Edited 6-Aug-2021 23:30 by rmk:")
|
||||
|
||||
(* ;; "This is called only when a CR has been read and EOLC is either any or CRLF. This returns EOL if the next code is an LF")
|
||||
|
||||
(* ;; "If COUNTP, that sets *BYTECOUNTER* freely with the number of LF bytes.")
|
||||
|
||||
(DECLARE (USEDFREE *BYTECOUNTER*))
|
||||
(LET (CH)
|
||||
[SETQ CH (COND
|
||||
[PEEKBINFLG
|
||||
|
||||
(* ;;
|
||||
"T from PEEKC. In this case, must leave the fileptr where it was.")
|
||||
|
||||
(* ;; "The CR itself hasn't been read, just peeked. So here we have to read it, then peek at the next character to see if it is an LF, and then back out the CR")
|
||||
|
||||
(COND
|
||||
([EQ (CHARCODE LF)
|
||||
(UNINTERRUPTABLY
|
||||
|
||||
(* ;; " Since we are going to \BACKCCODE back the peeked character, we don't need to update the counter variable")
|
||||
|
||||
(\INCCODE STREAM)
|
||||
(PROG1 (\PEEKCCODE STREAM T 'NOEOLC)
|
||||
|
||||
(* ;;
|
||||
"This has to be a call to \PEEKCODE that doesn't itself to the checkeolc")
|
||||
|
||||
(* ;;
|
||||
"LF must be the next char after the CR. We back up over the CR that \INCCODE just read.")
|
||||
|
||||
(\BACKCCODE STREAM)))]
|
||||
|
||||
(* ;; "Got the CRLF, it's an EOL")
|
||||
|
||||
(CHARCODE EOL))
|
||||
(T (CHARCODE CR]
|
||||
((EQ (CHARCODE LF)
|
||||
(\PEEKCCODE STREAM T 'NOEOLC))
|
||||
|
||||
(* ;; "Since we aren't peeking, the CR has actually been read, and we are entitled to read the LF that we just peeked at.")
|
||||
|
||||
(IF COUNTP
|
||||
THEN (LET (NUMLFBYTES)
|
||||
(DECLARE (SPECVARS NUMLFBYTES))
|
||||
(\INCCODE STREAM 'NUMLFBYTES 0)
|
||||
(ADD *BYTECOUNTER* NUMLFBYTES))
|
||||
ELSE (\INCCODE STREAM))
|
||||
(CHARCODE EOL))
|
||||
(T (CHARCODE CR]
|
||||
CH])
|
||||
)
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(PUTPROPS \CHECKEOLC MACRO [OPENLAMBDA (CH EOLC STRM PEEKBINFLG COUNTP)
|
||||
(COND
|
||||
((EQ EOLC 'NOEOLC)
|
||||
CH)
|
||||
(T (SELCHARQ CH
|
||||
(LF (SELECTC (OR EOLC (FFETCH (STREAM
|
||||
EOLCONVENTION
|
||||
)
|
||||
OF STRM))
|
||||
((LIST LF.EOLC ANY.EOLC)
|
||||
(CHARCODE EOL))
|
||||
(CHARCODE LF)))
|
||||
(CR (SELECTC (OR EOLC (FFETCH (STREAM
|
||||
EOLCONVENTION
|
||||
)
|
||||
OF STRM))
|
||||
(CR.EOLC (CHARCODE EOL))
|
||||
((LIST ANY.EOLC CRLF.EOLC)
|
||||
(\CHECKEOLC.CRLF STRM PEEKBINFLG
|
||||
COUNTP))
|
||||
(CHARCODE CR)))
|
||||
CH])
|
||||
)
|
||||
|
||||
(RPAQ? *REPLACE-NO-FONT-CODE* T)
|
||||
|
||||
(RPAQ? *DEFAULT-NOT-CONVERTED-FAT-CODE* 8739)
|
||||
@@ -1946,20 +1672,17 @@ Copyright (c) 1981-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
(PUTPROPS LLREAD COPYRIGHT ("Venue & Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1988 1990
|
||||
1991 1993 2021))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (3516 11745 (LASTC 3526 . 3832) (PEEKC 3834 . 4222) (PEEKCCODE 4224 . 4517) (RATOM 4519
|
||||
. 5600) (READ 5602 . 6162) (READC 6164 . 6805) (READCCODE 6807 . 7566) (READP 7568 . 8120) (
|
||||
SETREADMACROFLG 8122 . 8421) (SKIPSEPRCODES 8423 . 9406) (SKIPSEPRS 9408 . 9794) (SKREAD 9796 . 11743)
|
||||
) (11791 20400 (CL:READ 11801 . 12350) (CL:READ-PRESERVING-WHITESPACE 12352 . 13074) (
|
||||
CL:READ-DELIMITED-LIST 13076 . 13991) (CL:PARSE-INTEGER 13993 . 20398)) (20493 32970 (RSTRING 20503 .
|
||||
21235) (READ-EXTENDED-TOKEN 21237 . 25109) (\RSTRING2 25111 . 32968)) (33006 64146 (\TOP-LEVEL-READ
|
||||
33016 . 34999) (\SUBREAD 35001 . 60562) (\SUBREADCONCAT 60564 . 61187) (\ORIG-READ.SYMBOL 61189 .
|
||||
62257) (\ORIG-INVALID.SYMBOL 62259 . 63158) (\APPLYREADMACRO 63160 . 63576) (INREADMACROP 63578 .
|
||||
64144)) (64305 64480 (READQUOTE 64315 . 64478)) (64505 76409 (READVBAR 64515 . 65846) (READHASHMACRO
|
||||
65848 . 71658) (DEFMACRO-LAMBDA-LIST-KEYWORD-P 71660 . 71880) (DIGITBASEP 71882 . 72616) (
|
||||
READNUMBERINBASE 72618 . 74504) (ESTIMATE-DIMENSIONALITY 74506 . 74831) (SKIP.HASH.COMMENT 74833 .
|
||||
75801) (CMLREAD.FEATURE.PARSER 75803 . 76407)) (76453 82797 (CHARACTER.READ 76463 . 77717) (
|
||||
CHARCODE.DECODE 77719 . 82795)) (82798 85968 (HEXNUM? 82808 . 85151) (OCTALNUM? 85153 . 85966)) (90440
|
||||
102934 (\OUTCHAR 90450 . 91586) (\INCCODE 91588 . 92774) (\BACKCCODE 92776 . 93670) (\BACKCCODE.EOLC
|
||||
93672 . 96435) (\PEEKCCODE 96437 . 96753) (\PEEKCCODE.NOEOLC 96755 . 97017) (\INCCODE.EOLC 97019 .
|
||||
98878) (\FORMATBYTESTREAM 98880 . 100366) (\CHECKEOLC.CRLF 100368 . 102932)))))
|
||||
(FILEMAP (NIL (3236 11465 (LASTC 3246 . 3552) (PEEKC 3554 . 3942) (PEEKCCODE 3944 . 4237) (RATOM 4239
|
||||
. 5320) (READ 5322 . 5882) (READC 5884 . 6525) (READCCODE 6527 . 7286) (READP 7288 . 7840) (
|
||||
SETREADMACROFLG 7842 . 8141) (SKIPSEPRCODES 8143 . 9126) (SKIPSEPRS 9128 . 9514) (SKREAD 9516 . 11463)
|
||||
) (11511 20120 (CL:READ 11521 . 12070) (CL:READ-PRESERVING-WHITESPACE 12072 . 12794) (
|
||||
CL:READ-DELIMITED-LIST 12796 . 13711) (CL:PARSE-INTEGER 13713 . 20118)) (20213 32690 (RSTRING 20223 .
|
||||
20955) (READ-EXTENDED-TOKEN 20957 . 24829) (\RSTRING2 24831 . 32688)) (32726 63866 (\TOP-LEVEL-READ
|
||||
32736 . 34719) (\SUBREAD 34721 . 60282) (\SUBREADCONCAT 60284 . 60907) (\ORIG-READ.SYMBOL 60909 .
|
||||
61977) (\ORIG-INVALID.SYMBOL 61979 . 62878) (\APPLYREADMACRO 62880 . 63296) (INREADMACROP 63298 .
|
||||
63864)) (64025 64200 (READQUOTE 64035 . 64198)) (64225 76129 (READVBAR 64235 . 65566) (READHASHMACRO
|
||||
65568 . 71378) (DEFMACRO-LAMBDA-LIST-KEYWORD-P 71380 . 71600) (DIGITBASEP 71602 . 72336) (
|
||||
READNUMBERINBASE 72338 . 74224) (ESTIMATE-DIMENSIONALITY 74226 . 74551) (SKIP.HASH.COMMENT 74553 .
|
||||
75521) (CMLREAD.FEATURE.PARSER 75523 . 76127)) (76173 82517 (CHARACTER.READ 76183 . 77437) (
|
||||
CHARCODE.DECODE 77439 . 82515)) (82518 85688 (HEXNUM? 82528 . 84871) (OCTALNUM? 84873 . 85686)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,8 +1,11 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10 FORMAT XCCS)
|
||||
(FILECREATED " 8-Aug-2021 15:15:00"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>PRINTFN.;18 13138
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
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)
|
||||
|
||||
|
||||
@@ -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])
|
||||
|
||||
(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
|
||||
(PROG (TEM)
|
||||
[COND
|
||||
@@ -128,10 +131,15 @@ Copyright (c) 1986-1987, 1990, 1999, 2018, 2021 by Venue & Xerox Corporation.
|
||||
DSTFIL T)
|
||||
(PRIN1 "}
|
||||
" 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
|
||||
((OR (NOT (DISPLAYP DSTFIL))
|
||||
(EQ PFDEFAULT 'COPYBYTES)
|
||||
(EQ TYPE 'MAC))
|
||||
(NEQ TYPE 'MAP))
|
||||
(COPYBYTES SRCFIL DSTFIL START END))
|
||||
(T (PFCOPYBYTES SRCFIL DSTFIL START END PFDEFAULT)))
|
||||
(TERPRI DSTFIL))])
|
||||
@@ -160,21 +168,23 @@ Copyright (c) 1986-1987, 1990, 1999, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(T FULL])
|
||||
|
||||
(PFCOPYBYTES
|
||||
[LAMBDA (SRCFIL DSTFIL START END FLG) (* ; "Edited 8-Aug-2021 14:51 by rmk:")
|
||||
(* ; "Edited 24-Mar-93 14:16 by rmk:")
|
||||
(* lmm "28-Sep-86 14:38")
|
||||
[LAMBDA (SRCFIL DSTFIL START END FLG) (* ; "Edited 28-Sep-2021 23:35 by rmk:")
|
||||
(* ; "Edited 24-Mar-93 14:16 by rmk:")
|
||||
(* 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))
|
||||
(RESETLST
|
||||
(PROG ((SSTRM (\INSTREAMARG SRCFIL))
|
||||
(DSTRM (\OUTSTREAMARG DSTFIL))
|
||||
FONTARRAY CHARCODE %#CHARS MAXFONT)
|
||||
(DECLARE (SPECVARS . T)) (* ;
|
||||
"In particular, #CHARS must be a specvar for \INCCODE")
|
||||
(DECLARE (SPECVARS . T)) (* ;
|
||||
"In particular, #CHARS must be a specvar for \INCCODE")
|
||||
(COND
|
||||
((IMAGESTREAMP DSTRM)
|
||||
(SETQ FONTARRAY (FONTMAPARRAY))
|
||||
@@ -187,7 +197,7 @@ Copyright (c) 1986-1987, 1990, 1999, 2018, 2021 by Venue & Xerox Corporation.
|
||||
[SETQ %#CHARS (COND
|
||||
(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
|
||||
((EQ END -1)
|
||||
@@ -195,26 +205,26 @@ Copyright (c) 1986-1987, 1990, 1999, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(T END))
|
||||
START))
|
||||
(START)
|
||||
(T (* ;
|
||||
"Copy everything from here to the end-of-file")
|
||||
(T (* ;
|
||||
"Copy everything from here to the end-of-file")
|
||||
(SETQ START (GETFILEPTR SSTRM))
|
||||
(IDIFFERENCE (GETEOFPTR SSTRM)
|
||||
(GETFILEPTR SSTRM]
|
||||
(COND
|
||||
((ILEQ %#CHARS 0)
|
||||
(RETURN T))) (* ; "Nothing to do")
|
||||
(RETURN T))) (* ; "Nothing to do")
|
||||
LP (COND
|
||||
((ILEQ %#CHARS 0)
|
||||
(CL:WHEN (AND (EQ START 0)
|
||||
(EOFP SSTRM)) (* ; "We copied the whole file")
|
||||
(EOFP SSTRM)) (* ; "We copied the whole file")
|
||||
(TERPRI DSTRM))
|
||||
(RETURN T)))
|
||||
(SETQ CHARCODE (\INCCODE.EOLC SSTRM ANY.EOLC '%#CHARS %#CHARS))
|
||||
(IF (EQ CHARCODE (CONSTANT (CHARCODE.DECODE FONTESCAPECHAR)))
|
||||
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))
|
||||
(CL:WHEN (AND (IGEQ MAXFONT CHARCODE)
|
||||
@@ -257,7 +267,7 @@ Copyright (c) 1986-1987, 1990, 1999, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(COND
|
||||
((AND WIDTH (IGREATERP (add HPOS WIDTH)
|
||||
RMAR))
|
||||
(* past RIGHT margin, force eol)
|
||||
(* past RIGHT margin, force eol)
|
||||
(TERPRI DSTRM)
|
||||
(SETQ HPOS WIDTH)))
|
||||
(\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))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (1097 11016 (PF 1107 . 3802) (PF* 3804 . 4098) (PMORE 4100 . 4419) (PRINTFN 4421 . 5012)
|
||||
(PRINTFNDEF 5014 . 6131) (FINDFNDEF 6133 . 7157) (PFCOPYBYTES 7159 . 10766) (DISPLAYP 10768 . 11014))
|
||||
(FILEMAP (NIL (1134 11871 (PF 1144 . 3839) (PF* 3841 . 4135) (PMORE 4137 . 4456) (PRINTFN 4458 . 5049)
|
||||
(PRINTFNDEF 5051 . 6790) (FINDFNDEF 6792 . 7816) (PFCOPYBYTES 7818 . 11621) (DISPLAYP 11623 . 11869))
|
||||
)))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
Reference in New Issue
Block a user