Compare commits
24 Commits
lmm-delete
...
rmk161--Lo
| Author | SHA1 | Date | |
|---|---|---|---|
|
20f6407905 | ||
|
|
5943ef448b | ||
|
|
6e37c48d38 | ||
|
|
6d433e8347 | ||
|
|
a2e78b8035 | ||
|
|
af574e5c6c | ||
|
|
80a47b1409 | ||
|
|
8e7463cbc0 | ||
|
|
547015e70e | ||
|
|
2c9b6a6f7a | ||
|
1569a27209 | ||
|
|
2c328448e0 | ||
|
|
acd3cde277 | ||
|
|
d837dbdff0 | ||
|
|
43251b18be | ||
|
|
7687944866 | ||
|
|
f8c0de913a | ||
|
|
1bac4153e7 | ||
|
|
1ff475a42c | ||
|
|
7904f9dd86 | ||
|
|
93a04227d8 | ||
|
|
e12891cf28 | ||
|
|
1b8c73e7fc | ||
|
|
78bc424c71 |
@@ -1,12 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED " 5-Feb-2026 10:26:39" {WMEDLEY}<internal>loadups>LOADUP-FULL.;36 5858
|
||||
(FILECREATED "14-Feb-2026 00:42:39" {WMEDLEY}<internal>loadups>LOADUP-FULL.;38 5967
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (FNS LOADUP-FULL)
|
||||
|
||||
:PREVIOUS-DATE "28-Dec-2025 12:06:12" {WMEDLEY}<internal>loadups>LOADUP-FULL.;35)
|
||||
:PREVIOUS-DATE "13-Feb-2026 00:47:52" {WMEDLEY}<internal>loadups>LOADUP-FULL.;37)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT LOADUP-FULLCOMS)
|
||||
@@ -47,7 +47,8 @@
|
||||
(PRINTOUT T "FULL fonts loaded" T])
|
||||
|
||||
(LOADUP-FULL
|
||||
[LAMBDA (DRIBBLEFILE) (* ; "Edited 5-Feb-2026 10:26 by rmk")
|
||||
[LAMBDA (DRIBBLEFILE) (* ; "Edited 14-Feb-2026 00:42 by rmk")
|
||||
(* ; "Edited 5-Feb-2026 10:26 by rmk")
|
||||
(* ; "Edited 28-Dec-2025 12:06 by rmk")
|
||||
(* ; "Edited 1-Sep-2025 11:59 by rmk")
|
||||
(* ; "Edited 18-Aug-2025 12:09 by rmk")
|
||||
@@ -78,7 +79,6 @@
|
||||
(DIRECTORYNAME T)
|
||||
T T) (* ; "For FONTSAVAILABLE lookup")
|
||||
(LOADUP '(POSTSCRIPTSTREAM)) (* ; " to get PSCFONT.READFONT")
|
||||
(LOADFULLFONTS)
|
||||
(LISTPUT IDLE.PROFILE 'TIMEOUT 0)
|
||||
(SETQQ *DEFAULT-CLEANUP-COMPILER* BCOMPL)
|
||||
|
||||
@@ -88,6 +88,7 @@
|
||||
GRAPHER SPY WHERE-IS COPYFILES MSANALYZE MSPARSE MASTERSCOPE UNIXPRINT HELPSYS
|
||||
DINFO CLIPBOARD MODERNIZE WHEELSCROLL PRETTYFILEINDEX WHO-LINE UNIXCOMM UNIXCHAT
|
||||
UNIXYCD))
|
||||
(LOADFULLFONTS)
|
||||
(COND
|
||||
((WINDOWP *WHO-LINE*)
|
||||
(CLOSEW *WHO-LINE*)))
|
||||
@@ -102,5 +103,5 @@
|
||||
|
||||
(FIXMETA)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (456 5820 (LOADFULLFONTS 466 . 2601) (LOADUP-FULL 2603 . 5570) (FIXMETA 5572 . 5818)))))
|
||||
(FILEMAP (NIL (456 5929 (LOADFULLFONTS 466 . 2601) (LOADUP-FULL 2603 . 5679) (FIXMETA 5681 . 5927)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,13 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
|
||||
|
||||
(FILECREATED "28-Jan-2026 14:30:48" |{DSK}<Users>larry>IL>medley>internal>loadups>LOADUP-LISP.;2| 7369
|
||||
(FILECREATED "22-Feb-2026 14:15:31" |{WMEDLEY}<internal>loadups>LOADUP-LISP.;27| 7420
|
||||
|
||||
:EDIT-BY "lmm"
|
||||
:EDIT-BY |rmk|
|
||||
|
||||
:CHANGES-TO (FNS LOADUP-LISP)
|
||||
|
||||
:PREVIOUS-DATE "27-Dec-2025 15:02:04"
|
||||
|{DSK}<Users>larry>IL>medley>internal>loadups>LOADUP-LISP.;1|)
|
||||
:PREVIOUS-DATE "22-Feb-2026 09:49:23" |{WMEDLEY}<internal>loadups>LOADUP-LISP.;26|)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT LOADUP-LISPCOMS)
|
||||
@@ -20,7 +19,8 @@
|
||||
(DEFINEQ
|
||||
|
||||
(LOADUP-LISP
|
||||
(LAMBDA (DRIBBLEFILE) (* \; "Edited 28-Jan-2026 14:30 by lmm")
|
||||
(LAMBDA (DRIBBLEFILE) (* \; "Edited 22-Feb-2026 14:15 by rmk")
|
||||
(* \; "Edited 28-Jan-2026 14:30 by lmm")
|
||||
(* \; "Edited 27-Dec-2025 15:02 by rmk")
|
||||
(* \; "Edited 16-Oct-2025 16:55 by rmk")
|
||||
(* \; "Edited 18-Aug-2025 12:08 by rmk")
|
||||
@@ -95,9 +95,9 @@
|
||||
|
||||
(* |;;| "Also, UNICODE is split into UNICODE-TABLES and UNICODE, so the tables are loaded before their MCCS/Uncode client functions are installed. Functions in UFS now depend on those translations so that filenames can have characters outside of Ascii. ")
|
||||
|
||||
(LOADUP '(UNICODE-TABLES UNICODE CMLPATHNAME HPRINT AARITH ADISPLAY HLDISPLAY FONTPROFILE MENU
|
||||
WINDOWOBJ WINDOWSCROLL WINDOW WINDOWICON PAINTW ATTACHEDWINDOW XXGEOM XXFILL
|
||||
DEXEC INSPECT DESCRIBE CMLARRAYINSPECTOR EDITINTERFACE TTYIN))
|
||||
(LOADUP '(CMLPATHNAME HPRINT AARITH ADISPLAY HLDISPLAY FONTPROFILE MENU WINDOWOBJ WINDOWSCROLL
|
||||
WINDOW WINDOWICON PAINTW ATTACHEDWINDOW XXGEOM XXFILL DEXEC INSPECT DESCRIBE
|
||||
CMLARRAYINSPECTOR EDITINTERFACE TTYIN))
|
||||
(LOADUP '(BREAK-AND-TRACE))
|
||||
(LOADUP '(FASDUMP XCL-COMPILER ADVISE))
|
||||
|
||||
@@ -147,5 +147,5 @@
|
||||
(GLOBALVARS MAKESYSFILENAME MEDLEY-INIT-VARS MEDLEYDIR SYSTEMINITVARS USERRECLST)
|
||||
)
|
||||
(DECLARE\: DONTCOPY
|
||||
(FILEMAP (NIL (675 7163 (LOADUP-LISP 685 . 7161)))))
|
||||
(FILEMAP (NIL (640 7214 (LOADUP-LISP 650 . 7212)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
Binary file not shown.
@@ -1,13 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "25-Sep-2025 15:00:01"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>working-medley>library>CLIPBOARD.;28 8305
|
||||
(FILECREATED "23-Feb-2026 12:35:55" {WMEDLEY}<library>CLIPBOARD.;29 8228
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (FNS PUTCLIPBOARD CLIPBOARD-COPY-STREAM)
|
||||
:CHANGES-TO (VARS CLIPBOARDCOMS)
|
||||
|
||||
:PREVIOUS-DATE "21-Apr-2024 09:12:04" {WMEDLEY}<library>CLIPBOARD.;18)
|
||||
:PREVIOUS-DATE "25-Sep-2025 15:00:01" {WMEDLEY}<library>CLIPBOARD.;28)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT CLIPBOARDCOMS)
|
||||
@@ -18,7 +17,7 @@
|
||||
CLIPBOARD-PASTE-STREAM)
|
||||
(FNS SEDIT.COPYTOCLIPBOARD)
|
||||
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DOCOPY (FILES (SYSLOAD)
|
||||
UNIXCOMM UNICODE)
|
||||
UNIXCOMM)
|
||||
(P (INSTALL-CLIPBOARD)))
|
||||
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
|
||||
(NLAML)
|
||||
@@ -148,7 +147,7 @@
|
||||
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DOCOPY
|
||||
|
||||
(FILESLOAD (SYSLOAD)
|
||||
UNIXCOMM UNICODE)
|
||||
UNIXCOMM)
|
||||
|
||||
|
||||
(INSTALL-CLIPBOARD)
|
||||
@@ -162,7 +161,7 @@
|
||||
(ADDTOVAR LAMA )
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (1167 6486 (INSTALL-CLIPBOARD 1177 . 2504) (GETCLIPBOARD 2506 . 2880) (PUTCLIPBOARD 2882
|
||||
. 4306) (PASTEFROMCLIPBOARD 4308 . 5226) (CLIPBOARD-COPY-STREAM 5228 . 5762) (CLIPBOARD-PASTE-STREAM
|
||||
5764 . 6484)) (6487 8026 (SEDIT.COPYTOCLIPBOARD 6497 . 8024)))))
|
||||
(FILEMAP (NIL (1098 6417 (INSTALL-CLIPBOARD 1108 . 2435) (GETCLIPBOARD 2437 . 2811) (PUTCLIPBOARD 2813
|
||||
. 4237) (PASTEFROMCLIPBOARD 4239 . 5157) (CLIPBOARD-COPY-STREAM 5159 . 5693) (CLIPBOARD-PASTE-STREAM
|
||||
5695 . 6415)) (6418 7957 (SEDIT.COPYTOCLIPBOARD 6428 . 7955)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,12 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED " 8-Feb-2026 19:27:31" {DSK}<Users>larry>il>MEDLEY>LIBRARY>MASTERSCOPE.;3 197425
|
||||
(FILECREATED "16-Feb-2026 13:34:31" {WMEDLEY}<library>MASTERSCOPE.;41 197959
|
||||
|
||||
:EDIT-BY "lmm"
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (FNS BUILDGETRELQ)
|
||||
:CHANGES-TO (FNS MSOUTPUT)
|
||||
|
||||
:PREVIOUS-DATE " 8-Feb-2026 18:47:30" {DSK}<Users>larry>il>MEDLEY>LIBRARY>MASTERSCOPE.;2)
|
||||
:PREVIOUS-DATE " 8-Feb-2026 22:38:50" {WMEDLEY}<library>MASTERSCOPE.;40)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT MASTERSCOPECOMS)
|
||||
@@ -2566,7 +2566,7 @@
|
||||
(* ; "interactive routines")
|
||||
|
||||
|
||||
(RPAQ MASTERSCOPEDATE " 8-Feb-2026")
|
||||
(RPAQ MASTERSCOPEDATE "16-Feb-2026")
|
||||
|
||||
(ADDTOVAR HISTORYCOMS %.)
|
||||
(DEFINEQ
|
||||
@@ -3498,13 +3498,17 @@
|
||||
(ERROR!])
|
||||
|
||||
(MSOUTPUT
|
||||
[LAMBDA (FILE) (* ; "Edited 5-Apr-2025 11:48 by rmk")
|
||||
[LAMBDA (FILE) (* ; "Edited 16-Feb-2026 13:34 by rmk")
|
||||
(* ; "Edited 5-Feb-2026 01:01 by rmk")
|
||||
(* ; "Edited 18-Nov-2025 14:01 by rmk")
|
||||
(* ; "Edited 8-Nov-2025 23:21 by rmk")
|
||||
(* ; "Edited 5-Apr-2025 11:48 by rmk")
|
||||
(* ; "Edited 14-Jul-2024 08:41 by rmk")
|
||||
(* ; "Edited 5-Jul-2024 11:54 by rmk")
|
||||
(* ; "Edited 12-Jun-90 20:43 by teruuchi")
|
||||
(LET ((LLENGTH FILELINELENGTH))
|
||||
[COND
|
||||
((AND (LITATOM FILE)
|
||||
[(AND (LITATOM FILE)
|
||||
(MEMB (U-CASE FILE)
|
||||
'(TEDIT :TEDIT))
|
||||
(GETD (FUNCTION TEDIT)))
|
||||
@@ -3512,12 +3516,14 @@
|
||||
(* ;;
|
||||
"If no TEDIT, leave the current OUTPUT. The readtable for seprs etc is the current readtable.")
|
||||
|
||||
[SETQ FILE (TEXTSTREAM (TEDIT NIL 'Masterscope NIL `(LEAVETTY T TITLE Masterscope FONT
|
||||
,DEFAULTFONT BOUNDTABLE
|
||||
,(TEDIT.ATOMBOUND.READTABLE]
|
||||
[SETQ FILE (OPENTEXTSTREAM NIL NIL `(FONT ,DEFAULTFONT BOUNDTABLE ,(
|
||||
TEDIT.ATOMBOUND.READTABLE
|
||||
]
|
||||
(SETQ LLENGTH T)
|
||||
(TEDIT.DEFER.UPDATES FILE '(READONLY QUIET))
|
||||
(RESETSAVE NIL (LIST 'CLOSEF FILE)))
|
||||
(RESETSAVE NIL `(PROGN (CL:UNLESS RESETSTATE
|
||||
(TEDIT ,FILE 'Masterscope NIL
|
||||
'(TITLE Masterscope READONLY QUIET LEAVETTY T)))
|
||||
(CLOSEF? ,FILE]
|
||||
((OPENP FILE 'OUTPUT))
|
||||
(T (SETQ FILE (OPENSTREAM FILE 'OUTPUT))
|
||||
(RESETSAVE NIL (LIST 'CLOSEF FILE]
|
||||
@@ -3724,36 +3730,36 @@
|
||||
(ADDTOVAR LAMA MSEDITE MSEDITF)
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (3300 19547 (UPDATEFN 3310 . 4927) (MSGETDEF 4929 . 6335) (MSNOTICEFILE 6337 . 8730) (
|
||||
MSSHOWUSE 8732 . 14713) (MSUPDATEFN1 14715 . 15403) (MSUPDATE 15405 . 17831) (MSNLAMBDACHECK 17833 .
|
||||
18715) (MSCOLLECTDATA 18717 . 19545)) (19548 20447 (UPDATECHANGED 19558 . 19921) (UPDATECHANGED1 19923
|
||||
. 20445)) (21021 21444 (MSCLOSEFILES 21031 . 21442)) (22125 26557 (MSDESCRIBE 22135 . 24923) (
|
||||
MSDESCRIBE1 24925 . 25988) (FMAPRINT 25990 . 26555)) (26650 27090 (MSPRINTHELPFILE 26660 . 27088)) (
|
||||
27140 30278 (TEMPLATE 27150 . 28571) (GETTEMPLATE 28573 . 28708) (SETTEMPLATE 28710 . 30276)) (31148
|
||||
36072 (ADDTEMPLATEWORD 31158 . 31830) (MSADDANALYZE 31832 . 33330) (MSADDMODIFIER 33332 . 34413) (
|
||||
MSADDRELATION 34415 . 35162) (MSADDTYPE 35164 . 36070)) (37573 42669 (MSMARKCHANGE1 37583 . 38377) (
|
||||
MSINIT 38379 . 39560) (GETVERBTABLES 39562 . 40115) (MSSTOREDATA 40117 . 41671) (STORETABLE 41673 .
|
||||
42667)) (44071 49141 (PARSERELATION 44081 . 44681) (PARSERELATION1 44683 . 46138) (GETRELATION 46140
|
||||
. 47169) (MAPRELATION 47171 . 48305) (TESTRELATION 48307 . 49139)) (49142 50782 (ADDHASH 49152 .
|
||||
49630) (SUBHASH 49632 . 49860) (MAKEHASH 49862 . 50006) (MSREHASH 50008 . 50461) (EQMEMBHASH 50463 .
|
||||
50780)) (51121 57437 (MSVBTABLES 51131 . 57011) (MSUSERVBTABLES 57013 . 57435)) (57520 59823 (
|
||||
BUILDGETRELQ 57530 . 58728) (BUILDTESTRELQ 58730 . 59821)) (59994 60382 (MSERASE 60004 . 60380)) (
|
||||
60383 64843 (DUMPDATABASE 60393 . 62958) (DUMPDATABASE1 62960 . 63305) (READATABASE 63307 . 64841)) (
|
||||
65925 94984 (MSCHECKBLOCKS 65935 . 69755) (MSCHECKBLOCK 69757 . 78377) (MSCHECKFNINBLOCK 78379 . 81379
|
||||
) (MSCHECKBLOCKBASIC 81381 . 83801) (MSCHECKBOUNDFREE 83803 . 85702) (GLOBALVARP 85704 . 85871) (
|
||||
PRINTERROR 85873 . 89089) (MSCHECKVARS1 89091 . 92044) (UNECCSPEC 92046 . 92324) (NECCSPEC 92326 .
|
||||
92673) (SPECVARP 92675 . 93202) (SHORTLST 93204 . 93660) (DOERROR 93662 . 94372) (MSMSGPRINT 94374 .
|
||||
94982)) (96128 110956 (MSPATHS 96138 . 99540) (MSPATHS1 99542 . 103777) (MSPATHS2 103779 . 107189) (
|
||||
MSONPATH 107191 . 108419) (MSPATHS4 108421 . 109503) (DASHES 109505 . 110031) (DOTABS 110033 . 110274)
|
||||
(BELOWMARKER 110276 . 110739) (MSPATHSPRINTFN 110741 . 110954)) (111342 114766 (MSFIND 111352 .
|
||||
111627) (MSEDITF 111629 . 112629) (MSEDITE 112631 . 113668) (EDITGETDEF 113670 . 114764)) (115708
|
||||
124309 (MSMARKCHANGED 115718 . 117442) (CHANGEMACRO 117444 . 118149) (CHANGEVAR 118151 . 118467) (
|
||||
CHANGEI.S. 118469 . 119802) (CHANGERECORD 119804 . 120675) (MSNEEDUNSAVE 120677 . 121669) (UNSAVEFNS
|
||||
121671 . 124307)) (124742 128352 (%. 124752 . 124892) (MASTERSCOPE 124894 . 125420) (MASTERSCOPE1
|
||||
125422 . 126290) (MASTERSCOPEXEC 126292 . 128350)) (128391 168041 (MSINTERPRETSET 128401 . 156935) (
|
||||
MSINTERPA 156937 . 157471) (MSGETBLOCKDEC 157473 . 159986) (LISTHARD 159988 . 161206) (MSMEMBSET
|
||||
161208 . 161353) (MSLISTSET 161355 . 161720) (MSHASHLIST 161722 . 161889) (MSHASHLIST1 161891 . 162217
|
||||
) (CHECKPATHS 162219 . 162859) (ONFILE 162861 . 168039)) (168042 191603 (MSINTERPRET 168052 . 184107)
|
||||
(VERBNOTICELIST 184109 . 185219) (MSOUTPUT 185221 . 186731) (MSCHECKEMPTY 186733 . 187937) (
|
||||
CHECKFORCHANGED 187939 . 188459) (MSSOLVE 188461 . 191601)))))
|
||||
(FILEMAP (NIL (3260 19507 (UPDATEFN 3270 . 4887) (MSGETDEF 4889 . 6295) (MSNOTICEFILE 6297 . 8690) (
|
||||
MSSHOWUSE 8692 . 14673) (MSUPDATEFN1 14675 . 15363) (MSUPDATE 15365 . 17791) (MSNLAMBDACHECK 17793 .
|
||||
18675) (MSCOLLECTDATA 18677 . 19505)) (19508 20407 (UPDATECHANGED 19518 . 19881) (UPDATECHANGED1 19883
|
||||
. 20405)) (20981 21404 (MSCLOSEFILES 20991 . 21402)) (22085 26517 (MSDESCRIBE 22095 . 24883) (
|
||||
MSDESCRIBE1 24885 . 25948) (FMAPRINT 25950 . 26515)) (26610 27050 (MSPRINTHELPFILE 26620 . 27048)) (
|
||||
27100 30238 (TEMPLATE 27110 . 28531) (GETTEMPLATE 28533 . 28668) (SETTEMPLATE 28670 . 30236)) (31108
|
||||
36032 (ADDTEMPLATEWORD 31118 . 31790) (MSADDANALYZE 31792 . 33290) (MSADDMODIFIER 33292 . 34373) (
|
||||
MSADDRELATION 34375 . 35122) (MSADDTYPE 35124 . 36030)) (37533 42629 (MSMARKCHANGE1 37543 . 38337) (
|
||||
MSINIT 38339 . 39520) (GETVERBTABLES 39522 . 40075) (MSSTOREDATA 40077 . 41631) (STORETABLE 41633 .
|
||||
42627)) (44031 49101 (PARSERELATION 44041 . 44641) (PARSERELATION1 44643 . 46098) (GETRELATION 46100
|
||||
. 47129) (MAPRELATION 47131 . 48265) (TESTRELATION 48267 . 49099)) (49102 50742 (ADDHASH 49112 .
|
||||
49590) (SUBHASH 49592 . 49820) (MAKEHASH 49822 . 49966) (MSREHASH 49968 . 50421) (EQMEMBHASH 50423 .
|
||||
50740)) (51081 57397 (MSVBTABLES 51091 . 56971) (MSUSERVBTABLES 56973 . 57395)) (57480 59783 (
|
||||
BUILDGETRELQ 57490 . 58688) (BUILDTESTRELQ 58690 . 59781)) (59954 60342 (MSERASE 59964 . 60340)) (
|
||||
60343 64803 (DUMPDATABASE 60353 . 62918) (DUMPDATABASE1 62920 . 63265) (READATABASE 63267 . 64801)) (
|
||||
65885 94944 (MSCHECKBLOCKS 65895 . 69715) (MSCHECKBLOCK 69717 . 78337) (MSCHECKFNINBLOCK 78339 . 81339
|
||||
) (MSCHECKBLOCKBASIC 81341 . 83761) (MSCHECKBOUNDFREE 83763 . 85662) (GLOBALVARP 85664 . 85831) (
|
||||
PRINTERROR 85833 . 89049) (MSCHECKVARS1 89051 . 92004) (UNECCSPEC 92006 . 92284) (NECCSPEC 92286 .
|
||||
92633) (SPECVARP 92635 . 93162) (SHORTLST 93164 . 93620) (DOERROR 93622 . 94332) (MSMSGPRINT 94334 .
|
||||
94942)) (96088 110916 (MSPATHS 96098 . 99500) (MSPATHS1 99502 . 103737) (MSPATHS2 103739 . 107149) (
|
||||
MSONPATH 107151 . 108379) (MSPATHS4 108381 . 109463) (DASHES 109465 . 109991) (DOTABS 109993 . 110234)
|
||||
(BELOWMARKER 110236 . 110699) (MSPATHSPRINTFN 110701 . 110914)) (111302 114726 (MSFIND 111312 .
|
||||
111587) (MSEDITF 111589 . 112589) (MSEDITE 112591 . 113628) (EDITGETDEF 113630 . 114724)) (115668
|
||||
124269 (MSMARKCHANGED 115678 . 117402) (CHANGEMACRO 117404 . 118109) (CHANGEVAR 118111 . 118427) (
|
||||
CHANGEI.S. 118429 . 119762) (CHANGERECORD 119764 . 120635) (MSNEEDUNSAVE 120637 . 121629) (UNSAVEFNS
|
||||
121631 . 124267)) (124702 128312 (%. 124712 . 124852) (MASTERSCOPE 124854 . 125380) (MASTERSCOPE1
|
||||
125382 . 126250) (MASTERSCOPEXEC 126252 . 128310)) (128351 168001 (MSINTERPRETSET 128361 . 156895) (
|
||||
MSINTERPA 156897 . 157431) (MSGETBLOCKDEC 157433 . 159946) (LISTHARD 159948 . 161166) (MSMEMBSET
|
||||
161168 . 161313) (MSLISTSET 161315 . 161680) (MSHASHLIST 161682 . 161849) (MSHASHLIST1 161851 . 162177
|
||||
) (CHECKPATHS 162179 . 162819) (ONFILE 162821 . 167999)) (168002 192137 (MSINTERPRET 168012 . 184067)
|
||||
(VERBNOTICELIST 184069 . 185179) (MSOUTPUT 185181 . 187265) (MSCHECKEMPTY 187267 . 188471) (
|
||||
CHECKFORCHANGED 188473 . 188993) (MSSOLVE 188995 . 192135)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
1508
library/UNICODE
1508
library/UNICODE
File diff suppressed because it is too large
Load Diff
@@ -1,19 +1,22 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10 FORMAT UTF-8)
|
||||
|
||||
(FILECREATED "22-Oct-2025 23:28:42" {WMEDLEY}<library>UNICODE-TABLES.;4 34028
|
||||
(FILECREATED "22-Feb-2026 10:44:33" {WMEDLEY}<library>UNICODE-TABLES.;20 44960
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (VARS UNICODE-TABLESCOMS)
|
||||
:CHANGES-TO (FNS ALL-UNICODE-MAPPINGS GET-MCCS-UNICODE-MAPPING INVERT-UNICODE-MAPPING
|
||||
MAKE-UNICODE-TRANSLATION-TABLES MERGE-UNICODE-TRANSLATION-TABLES
|
||||
READ-UNICODE-MAPPING-FILENAMES)
|
||||
(VARS UNICODE-TABLESCOMS)
|
||||
|
||||
:PREVIOUS-DATE "16-Oct-2025 16:47:54" {WMEDLEY}<library>UNICODE-TABLES.;3)
|
||||
:PREVIOUS-DATE "22-Feb-2026 09:15:20" {WMEDLEY}<library>UNICODE-TABLES.;16)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT UNICODE-TABLESCOMS)
|
||||
|
||||
(RPAQQ UNICODE-TABLESCOMS
|
||||
[
|
||||
(* ;; "Read Unicode mapping tables. A separate file before UNICODE in the loadup, because the tables must be loaded while UTF8TOMCODE and MCODETOUTF8 are still equivalenced to EVQ. This file has to come before UNICODE in the loadup sequence.")
|
||||
(* ;; "This is code for reading/writing the XCCS-to-UNICODE mapping tables. It runs offline, when UNICODE-UTF8 is modified. ")
|
||||
|
||||
(COMS (* ; "Read Unicode mapping files")
|
||||
(INITVARS (UNICODEDIRECTORIES NIL))
|
||||
@@ -22,22 +25,32 @@
|
||||
(FNS READ-UNICODE-MAPPING-FILENAMES READ-UNICODE-MAPPING))
|
||||
(COMS (* ;
|
||||
"Make translation tables for UTF external formats")
|
||||
(FNS MAKE-UNICODE-TRANSLATION-TABLES XCCSTOMCCS-MAPPING
|
||||
MERGE-UNICODE-TRANSLATION-TABLES UNICODE.UNMAPPED UNICODE-EXTEND-TRANSLATION?)
|
||||
(FNS MAKE-UNICODE-TRANSLATION-TABLES GET-MCCS-UNICODE-MAPPING INVERT-UNICODE-MAPPING
|
||||
XCCSTOMCCS-MAPPING)
|
||||
(FNS ALL-UNICODE-MAPPINGS XCCSJAPANESECHARSETS)
|
||||
(INITVARS (*MCCSTOUNICODE*)
|
||||
(*UNICODETOMCCS*)
|
||||
(*MCCS-LOADED-CHARSETS*)
|
||||
(*UNICODE-LOADED-CHARSETS*)
|
||||
(*LARGEUNICODES*))
|
||||
[DECLARE%: DONTEVAL@LOAD DOCOPY (P (MAKE-UNICODE-TRANSLATION-TABLES 'ALL]
|
||||
(COMS (* ; "Write Unicode mapping files")
|
||||
(FNS WRITE-UNICODE-MAPPING WRITE-UNICODE-INCLUDED WRITE-UNICODE-MAPPING-HEADER
|
||||
WRITE-UNICODE-MAPPING-FILENAME)
|
||||
(FNS XCCS-UTF8-AFTER-OPEN)
|
||||
|
||||
(* ;; "Automate dumping of a documentation prefix")
|
||||
|
||||
[DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (MISSINGCODE (CL:PARSE-INTEGER "FFFE"
|
||||
:RADIX 16))
|
||||
(UNDEFINEDCODE (CL:PARSE-INTEGER "FFFF"
|
||||
:RADIX 16]
|
||||
(VARS UNICODE-MAPPING-HEADER))
|
||||
(FNS UTF8HEXSTRING)
|
||||
(COMS (* ; "debugging")
|
||||
(FNS SHOWCHARS)
|
||||
(DECLARE%: DOEVAL@LOAD DONTCOPY (MACROS HEXCHAR OCTALCHAR)))
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP)
|
||||
UNICODE-EXPORTS])
|
||||
|
||||
|
||||
|
||||
(* ;;
|
||||
"Read Unicode mapping tables. A separate file before UNICODE in the loadup, because the tables must be loaded while UTF8TOMCODE and MCODETOUTF8 are still equivalenced to EVQ. This file has to come before UNICODE in the loadup sequence."
|
||||
"This is code for reading/writing the XCCS-to-UNICODE mapping tables. It runs offline, when UNICODE-UTF8 is modified. "
|
||||
)
|
||||
|
||||
|
||||
@@ -94,7 +107,8 @@
|
||||
(DEFINEQ
|
||||
|
||||
(READ-UNICODE-MAPPING-FILENAMES
|
||||
[LAMBDA (FILESPEC) (* ; "Edited 16-Oct-2025 16:43 by rmk")
|
||||
[LAMBDA (FILESPEC) (* ; "Edited 21-Feb-2026 18:14 by rmk")
|
||||
(* ; "Edited 16-Oct-2025 16:43 by rmk")
|
||||
(* ; "Edited 4-Sep-2025 00:11 by rmk")
|
||||
(* ; "Edited 27-Jan-2025 16:46 by rmk")
|
||||
(* ; "Edited 21-Jan-2025 22:51 by rmk")
|
||||
@@ -107,51 +121,47 @@
|
||||
|
||||
(* ;; "FILESPEC can be a file name, character-set name, the name of a collection of character sets, an XCCS character code, or a list of those. Maps those into the names of files that contain the indicated Unicode mappings.")
|
||||
|
||||
(CL:REMOVE-DUPLICATES [for F X CSI inside (if (EQ FILESPEC 'ALL)
|
||||
then
|
||||
(* ;;
|
||||
(for F X CSI inside (if (EQ FILESPEC 'ALL)
|
||||
then
|
||||
(* ;;
|
||||
"Perhaps should figure out which files in the directories and subdirectories are relevant?")
|
||||
|
||||
(for N in XCCS-CHARSETS
|
||||
collect (CAR N))
|
||||
else FILESPEC)
|
||||
join
|
||||
(* ;; "Last case hopes to pick up all the tables that are grouped together in a subdirectory (e.g. if F is JIS)")
|
||||
(for N in XCCS-CHARSETS collect (CAR N))
|
||||
else FILESPEC)
|
||||
join
|
||||
(* ;; "Last case hopes to pick up all the tables that are grouped together in a subdirectory (e.g. if F is JIS)")
|
||||
|
||||
(OR (CL:WHEN (CHARCODEP F) (* ;
|
||||
[OR (CL:WHEN (CHARCODEP F) (* ;
|
||||
"An XCCS code can retrieve its character set")
|
||||
(for D FN (FOCTAL _ (OCTALSTRING (LRSH F 8))) inside
|
||||
UNICODEDIRECTORIES
|
||||
when (SETQ FN (FILDIR (PACKFILENAME 'DIRECTORY D
|
||||
'BODY
|
||||
(CONCAT 'XCCS- FOCTAL
|
||||
'=*)
|
||||
'EXTENSION
|
||||
'TXT
|
||||
'VERSION "")))
|
||||
do (RETURN FN)))
|
||||
(MKLIST (FINDFILE (PACKFILENAME 'BODY F 'EXTENSION 'TXT
|
||||
'VERSION "")
|
||||
T UNICODEDIRECTORIES))
|
||||
(for D inside UNICODEDIRECTORIES
|
||||
when [SETQ $$VAL (OR (FILDIR (PACKFILENAME 'NAME
|
||||
(CONCAT "XCCS-*=" F)
|
||||
'EXTENSION
|
||||
'TXT
|
||||
'VERSION "" 'BODY D))
|
||||
(FILDIR (PACKFILENAME 'NAME
|
||||
(CONCAT "XCCS-" F "=*")
|
||||
'EXTENSION
|
||||
'TXT
|
||||
'VERSION "" 'BODY D]
|
||||
do (RETURN $$VAL))
|
||||
(AND (SETQ CSI (ASSOC F XCCS-CHARSETS))
|
||||
(READ-UNICODE-MAPPING-FILENAMES (CDR CSI)))
|
||||
(for D inside UNICODEDIRECTORIES
|
||||
when (DIRECTORYNAMEP (SETQ D (CONCAT D ">" F ">")))
|
||||
join (FILDIR (CONCAT D ">*.TXT;"]
|
||||
:TEST
|
||||
(FUNCTION STRING.EQUAL])
|
||||
(for D FN (FOCTAL ← (OCTALSTRING (LRSH F 8))) inside UNICODEDIRECTORIES
|
||||
when (SETQ FN (DIRECTORY (PACKFILENAME 'DIRECTORY D 'BODY (CONCAT 'XCCS-
|
||||
FOCTAL
|
||||
'=*)
|
||||
'EXTENSION
|
||||
'TXT
|
||||
'VERSION ""))) do (RETURN FN)))
|
||||
(MKLIST (FINDFILE (PACKFILENAME 'BODY F 'EXTENSION 'TXT 'VERSION "")
|
||||
T UNICODEDIRECTORIES))
|
||||
(for D inside UNICODEDIRECTORIES
|
||||
when [SETQ $$VAL (OR (DIRECTORY (PACKFILENAME 'NAME (CONCAT "XCCS-*=" F)
|
||||
'EXTENSION
|
||||
'TXT
|
||||
'VERSION "" 'BODY D))
|
||||
(DIRECTORY (PACKFILENAME 'NAME (CONCAT "XCCS-" F "=*")
|
||||
'EXTENSION
|
||||
'TXT
|
||||
'VERSION "" 'BODY D]
|
||||
do (RETURN $$VAL))
|
||||
(AND (SETQ CSI (ASSOC F XCCS-CHARSETS))
|
||||
(READ-UNICODE-MAPPING-FILENAMES (CDR CSI)))
|
||||
(for D inside UNICODEDIRECTORIES when (DIRECTORYNAMEP (SETQ D
|
||||
(CONCAT D ">" F ">")))
|
||||
join (DIRECTORY (CONCAT D ">*.TXT;"]
|
||||
finally (* ;
|
||||
"CL:REMOVE-DUPLICATES doesn't exist in MAKEINIT")
|
||||
(RETURN (for FTAIL on $$VAL unless (thereis FF in (CDR FTAIL)
|
||||
suchthat (STRING-EQUAL (CAR FTAIL)
|
||||
FF)) collect (CAR FTAIL])
|
||||
|
||||
(READ-UNICODE-MAPPING
|
||||
[LAMBDA (FILESPEC PRINT NOERROR) (* ; "Edited 16-Oct-2025 11:25 by rmk")
|
||||
@@ -179,7 +189,7 @@
|
||||
(* ;; "")
|
||||
|
||||
(RESETLST
|
||||
(for FILE STREAM [SEPBITTABLE _ (MAKEBITTABLE (CHARCODE (TAB SPACE] in (
|
||||
(for FILE STREAM [SEPBITTABLE ← (MAKEBITTABLE (CHARCODE (TAB SPACE] in (
|
||||
READ-UNICODE-MAPPING-FILENAMES
|
||||
FILESPEC)
|
||||
join
|
||||
@@ -221,7 +231,8 @@
|
||||
(DEFINEQ
|
||||
|
||||
(MAKE-UNICODE-TRANSLATION-TABLES
|
||||
[LAMBDA (MAPPING REINSTALL) (* ; "Edited 11-Oct-2025 11:54 by rmk")
|
||||
[LAMBDA (MAPPING REINSTALL) (* ; "Edited 21-Feb-2026 22:42 by rmk")
|
||||
(* ; "Edited 11-Oct-2025 11:54 by rmk")
|
||||
(* ; "Edited 4-Sep-2025 00:30 by rmk")
|
||||
(* ; "Edited 24-Apr-2025 15:47 by rmk")
|
||||
(* ; "Edited 31-Jan-2025 17:46 by rmk")
|
||||
@@ -232,26 +243,13 @@
|
||||
(* ; "Edited 3-Feb-2024 00:24 by rmk")
|
||||
(* ; "Edited 30-Jan-2024 09:54 by rmk")
|
||||
(* ; "Edited 21-Aug-2021 13:12 by rmk:")
|
||||
(SETQ MAPPING (GET-MCCS-UNICODE-MAPPING MAPPING))
|
||||
|
||||
(* ;; "MAPPING is the list of numeric code correspondence pairs constructed by applying READ-UNICODE-MAPPING to XCCS-to-Unicode mapping files. This applies the XCCS-to-MCCS translations, and then updates or produces two recoding arrays, one maps left-side codes into right-side codes (e.g. MCCS or ISO8859-1 to Unicode), for printing, the other maps right-side (Unicode) codes to corresponding right-side codes (e.g. MCCS).")
|
||||
(* ; "Edited 17-Aug-2020 08:46 by rmk:")
|
||||
(CL:UNLESS [AND (LISTP MAPPING)
|
||||
(FOR PAIR R IN MAPPING AS I TO 10
|
||||
ALWAYS (AND (LISTP PAIR)
|
||||
(CHARCODEP (CAR PAIR))
|
||||
[FIXP (SETQ R (CAR (MKLIST (CADR PAIR]
|
||||
(CHARCODEP (IABS R]
|
||||
|
||||
(* ;; "Seems like the argument is not already a list of mapping pairs (perhaps with a combiner), presumably a list of charsets to be read.")
|
||||
|
||||
(SETQ MAPPING (READ-UNICODE-MAPPING MAPPING)))
|
||||
(SETQ MAPPING (XCCSTOMCCS-MAPPING MAPPING))
|
||||
|
||||
(* ;; "This updates or 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).")
|
||||
(* ;; "This updates or produces two recoding arrays, one maps left-side codes into right-side codes (e.g. MCCS to Unicode), for printing, the other maps right-side (Unicode) codes to corresponding right-side codes (e.g. MCCS).")
|
||||
|
||||
(* ;; "")
|
||||
|
||||
(* ;; "If REINSTALL is T, the new mapping vectors replace the current maps in the *XCCSTOUNICODE* and *UNICODETOXCCS* global variables. Otherwise we create new tables (mostly for comparison and debugging).")
|
||||
(* ;; "If REINSTALL is T, the new mapping vectors replace the current maps in the *MCCSTOUNICODE* and *UNICODETOMCCS* global variables. Otherwise we create new tables (mostly for comparison and debugging).")
|
||||
|
||||
(* ;; "")
|
||||
|
||||
@@ -270,6 +268,55 @@
|
||||
(SETQ *NEXT-PRIVATE-UNICODE* FIRST-PRIVATE-UNICODE))
|
||||
(MERGE-UNICODE-TRANSLATION-TABLES NIL MAPPING])
|
||||
|
||||
(GET-MCCS-UNICODE-MAPPING
|
||||
[LAMBDA (MAPPING) (* ; "Edited 22-Feb-2026 00:29 by rmk")
|
||||
|
||||
(* ;; "MAPPING is the list of numeric code correspondence pairs mapping MCCS-to-Unicode, or a specification of XCCS-to-Unicode files to be read and converted to MCCS-to-UNICODE.")
|
||||
|
||||
(SORT (if [AND (LISTP MAPPING)
|
||||
(for PAIR R in MAPPING as I to 10
|
||||
always (AND (LISTP PAIR)
|
||||
(CHARCODEP (CAR PAIR))
|
||||
[FIXP (SETQ R (CAR (MKLIST (CADR PAIR]
|
||||
(CHARCODEP (IABS R]
|
||||
then
|
||||
(* ;; "The argument is already a list of MCCS-to-UNICODE mapping pairs")
|
||||
|
||||
MAPPING
|
||||
else
|
||||
(* ;; "Mapping files are is read as XCCS-UNICODE, make it MCCS")
|
||||
|
||||
(XCCSTOMCCS-MAPPING (READ-UNICODE-MAPPING MAPPING)))
|
||||
T])
|
||||
|
||||
(INVERT-UNICODE-MAPPING
|
||||
[LAMBDA (MAPPING) (* ; "Edited 22-Feb-2026 00:39 by rmk")
|
||||
|
||||
(* ;; "MAPPING is a list of pairs that map domain codes to range codes (presumably MCCS to UNICODE). This produces an inverted list of pairs that map the range into the domain (Unicode to MCCS) ")
|
||||
|
||||
(LET (INVERTED)
|
||||
(SETQ INVERTED (SORT (for P D R OLDR in MAPPING eachtime (SETQ D (CAR P))
|
||||
(SETQ R (CADR P))
|
||||
|
||||
(* ;;
|
||||
"We don't do combiners, but we are allowing non-SMALLP's")
|
||||
unless (OR (LISTP D)
|
||||
(LISTP R)) collect (LIST R D))
|
||||
T))
|
||||
|
||||
(* ;; "If MAPPING contains two pairs that map to the same U (e.g. (M1 U) and (M2 U)), we want the inverse table to collect them into a single pair (U M1 M2) instead of two pairs (U M1) (U M2), with the lowest M code first. Those pairs represent alternative inverse mappings. There are no duplicates/alternative table entries in the M-to-U direction.")
|
||||
|
||||
(* ;; "The SORT above means that multiple inverted pairs for the same U will be next to each other in the list.")
|
||||
|
||||
[for PTAIL PTAIL2 U MS on INVERTED eachtime (SETQ U (CAAR PTAIL))
|
||||
when (SETQ MS (for old PTAIL2 P2 on PTAIL eachtime (SETQ P2 (CADR PTAIL2))
|
||||
while (EQ U (CAR P2)) collect (CADR P2)))
|
||||
do (RPLACD PTAIL (CDR PTAIL2))
|
||||
(RPLACD (CAR PTAIL)
|
||||
(SORT (CONS (CADR (CAR PTAIL))
|
||||
MS]
|
||||
INVERTED])
|
||||
|
||||
(XCCSTOMCCS-MAPPING
|
||||
[LAMBDA (XTOUMAPPING) (* ; "Edited 11-Oct-2025 12:57 by rmk")
|
||||
|
||||
@@ -292,152 +339,12 @@
|
||||
XTOMCODES)))
|
||||
finally (push XTOUMAPPING (CHARCODE (DEL DEL)))
|
||||
(RETURN XTOUMAPPING])
|
||||
|
||||
(MERGE-UNICODE-TRANSLATION-TABLES
|
||||
[LAMBDA (INVERSE MAPPING TABLE INVERSETABLE) (* ; "Edited 11-Oct-2025 10:24 by rmk")
|
||||
(* ; "Edited 24-Apr-2025 15:28 by rmk")
|
||||
(* ; "Edited 1-Feb-2025 21:42 by rmk")
|
||||
(* ; "Edited 26-Jan-2025 12:58 by rmk")
|
||||
(* ; "Edited 22-Jan-2025 08:20 by rmk")
|
||||
(* ; "Edited 19-Jan-2025 15:58 by rmk")
|
||||
(* ; "Edited 18-Jan-2025 11:49 by rmk")
|
||||
(* ; "Edited 27-Mar-2024 12:10 by rmk")
|
||||
(* ; "Edited 3-Feb-2024 12:46 by rmk")
|
||||
(* ; "Edited 31-Jan-2024 10:06 by rmk")
|
||||
|
||||
(* ;; "MAPPINGS is a list of pairs that map domain codes to range codes. TABLE and INVERSETABLE default to *MCCSTOUNICODE* *UNICODETOMCCS* respectively. ")
|
||||
|
||||
(CL:UNLESS TABLE
|
||||
[SETQ TABLE (OR *MCCSTOUNICODE* (SETQ *MCCSTOUNICODE* (HASHARRAY (LENGTH MAPPING])
|
||||
(CL:UNLESS INVERSETABLE
|
||||
[SETQ INVERSETABLE (OR *UNICODETOMCCS* (SETQ *UNICODETOMCCS* (HASHARRAY (LENGTH MAPPING])
|
||||
(for M D R OLDR in MAPPING first (CL:IF INVERSE (swap TABLE INVERSETABLE))
|
||||
eachtime (SETQ D (CAR M))
|
||||
(SETQ R (CADR M))
|
||||
|
||||
(* ;; "We don't do combiners, but we are allowing non-SMALLP's")
|
||||
unless (OR (LISTP D)
|
||||
(LISTP R)) do
|
||||
(* ;; "The (CONS R OLDR) deals with alternatives: (U X1) (U X2) => (U (X1 X2)), lowest code first. Those are only possible in the U-to-X direction when the tables contain (X1 U) and (X2 U). There are no duplicates/alternative table entries in the X-to-U direction.")
|
||||
|
||||
(SETQ OLDR (GETHASH D TABLE))
|
||||
(CL:UNLESS (MEMB R OLDR)
|
||||
(PUTHASH D (SORT (CONS R OLDR))
|
||||
TABLE))
|
||||
(swap D R)
|
||||
(SETQ OLDR (GETHASH D INVERSETABLE))
|
||||
(CL:UNLESS (MEMB R OLDR)
|
||||
(PUTHASH D (SORT (CONS R OLDR))
|
||||
INVERSETABLE)))
|
||||
(LIST TABLE INVERSETABLE])
|
||||
|
||||
(UNICODE.UNMAPPED
|
||||
[LAMBDA (CODE TABLE DONTFAKE) (* ; "Edited 24-Apr-2025 15:48 by rmk")
|
||||
(* ; "Edited 22-Jan-2025 08:19 by rmk")
|
||||
(* ; "Edited 19-Jan-2025 22:02 by rmk")
|
||||
(* ; "Edited 18-Jan-2025 12:02 by rmk")
|
||||
(* ; "Edited 2-Feb-2024 23:52 by rmk")
|
||||
(* ; "Edited 31-Jan-2024 10:07 by rmk")
|
||||
(* ; "Edited 11-Aug-2020 20:23 by rmk:")
|
||||
|
||||
(* ;; "This is the slow fall-out when UNICODE.TRANSLATE determines that CODE has no fast mapping in TRANSLATION-TABLE.")
|
||||
|
||||
(* ;; "")
|
||||
|
||||
(* ;; "If we have not already installed the mapping segment for that code, we try to retrieve it from the numberic file. If that segment mapping doesn't exist or doesn't have an entry for CODE, we fake up a mapping with a negative range in both directions. One way or the other, there will be an entry for that segment in both mapping vectors.")
|
||||
|
||||
(* ;; "")
|
||||
|
||||
(PROG ((INVERSE (EQ TABLE *UNICODETOMCCS*))
|
||||
RANGE HASH)
|
||||
|
||||
(* ;; "If we already looked up CODE's character set in a file, then we have already filled in its information in the translation table. If it didn't have a code for a particular character, then we fake it here. Faked codes are negative, so we can detect them easily, and interpret them with IABS.")
|
||||
|
||||
(CL:WHEN (AND (UNICODE-EXTEND-TRANSLATION? CODE TABLE)
|
||||
(SETQ RANGE (GETHASH CODE TABLE)))
|
||||
|
||||
(* ;; "We might have gotten the segment that didn't have an entry for CODE.")
|
||||
|
||||
(RETURN RANGE))
|
||||
|
||||
(* ;; "")
|
||||
|
||||
(CL:UNLESS DONTFAKE
|
||||
|
||||
(* ;; "Our attempt at extending the known tables did not provide a mapping for CODE. So we fake it up with the next unused private code in the code space. ")
|
||||
|
||||
(* ;; "The number of possible faked mappings is determined by the number of private-use Unicodes, since the MCCS character space is pretty sparse. The codes don't have to come from the same part of the code space, and the NEXTCODEs are saved in global variables. The last available codes are constants.")
|
||||
|
||||
(CL:WHEN (IEQP *NEXT-PRIVATE-MCCSCODE* LAST-PRIVATE-MCCSCODE)
|
||||
(* ;
|
||||
"Same number of available codes both ways")
|
||||
(ERROR "EXHAUSTED RANGE FOR UNMAPPED CODES"))
|
||||
(if INVERSE
|
||||
then (SETQ RANGE *NEXT-PRIVATE-MCCSCODE*)
|
||||
(add *NEXT-PRIVATE-MCCSCODE* 1)
|
||||
else (SETQ RANGE *NEXT-PRIVATE-UNICODE*)
|
||||
(add *NEXT-PRIVATE-UNICODE* 1))
|
||||
(MERGE-UNICODE-TRANSLATION-TABLES INVERSE (CONS (LIST CODE RANGE)))
|
||||
|
||||
(* ;; "CONS because of LIST convention so we can eventually distinguish combiners.")
|
||||
|
||||
(RETURN (CONS RANGE)))])
|
||||
|
||||
(UNICODE-EXTEND-TRANSLATION?
|
||||
[LAMBDA (CODE TABLE) (* ; "Edited 11-Oct-2025 09:49 by rmk")
|
||||
(* ; "Edited 4-Sep-2025 00:34 by rmk")
|
||||
(* ; "Edited 29-Jun-2025 16:44 by rmk")
|
||||
(* ; "Edited 24-Apr-2025 15:49 by rmk")
|
||||
(* ; "Edited 26-Jan-2025 11:26 by rmk")
|
||||
(* ; "Edited 21-Jan-2025 22:31 by rmk")
|
||||
(* ; "Edited 18-Jan-2025 12:40 by rmk")
|
||||
(* ; "Edited 13-Jan-2025 23:50 by rmk")
|
||||
(* ; "Edited 26-Aug-2024 16:49 by rmk")
|
||||
(* ; "Edited 27-Mar-2024 23:02 by rmk")
|
||||
(* ; "Edited 5-Feb-2024 13:48 by rmk")
|
||||
(* ; "Edited 3-Feb-2024 12:40 by rmk")
|
||||
|
||||
(* ;; "There is currently no mapping for CODE in TABLE, hopefully just because the relevant character-set mapping has not been installed. We infer from TABLE whether CODE is an MCCS or UNICODE code and look for the proper mapping table (forward or inverted) for its character set. ")
|
||||
|
||||
(* ;; "We record which character sets we have already expanded so we don't do them again.")
|
||||
|
||||
(LET ((CHARSET (\CHARSET CODE))
|
||||
(INVERSE (EQ TABLE *UNICODETOMCCS*))
|
||||
MAPPING FILE)
|
||||
|
||||
(* ;; "If we already looked for CHARSET in the file and found anything, it has already been merged. Otherwise, it would just fail again")
|
||||
|
||||
(CL:UNLESS (MEMB CHARSET (CL:IF INVERSE
|
||||
*UNICODE-LOADED-CHARSETS*
|
||||
*MCCS-LOADED-CHARSETS*))
|
||||
|
||||
(* ;; "Don't try this charset again.")
|
||||
|
||||
(CL:IF INVERSE
|
||||
(push *UNICODE-LOADED-CHARSETS* CHARSET)
|
||||
(push *MCCS-LOADED-CHARSETS* CHARSET))
|
||||
(SETQ FILE (FINDFILE (CL:IF INVERSE
|
||||
'UNICODE-TO-MCCS-MAPPINGS
|
||||
'MCCS-TO-UNICODE-MAPPINGS)
|
||||
T UNICODEDIRECTORIES))
|
||||
|
||||
(* ;; "The mappings files are indexed by CHARSET.")
|
||||
|
||||
(CL:WHEN [AND FILE (SETQ MAPPING (CL:WITH-OPEN-FILE (STREAM FILE :INPUT)
|
||||
(CL:WHEN (FILEPOS (CONCAT "[" CHARSET " ")
|
||||
STREAM NIL NIL NIL T)
|
||||
(READ STREAM]
|
||||
|
||||
(* ;;
|
||||
"Merge MAPPING into both tables, respecting the direction indicated by TABLE. ")
|
||||
|
||||
(MERGE-UNICODE-TRANSLATION-TABLES INVERSE MAPPING)
|
||||
T))])
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
(ALL-UNICODE-MAPPINGS
|
||||
[LAMBDA (INVERTED FILE) (* ; "Edited 24-Apr-2025 15:51 by rmk")
|
||||
[LAMBDA (INVERTED FILE) (* ; "Edited 22-Feb-2026 10:42 by rmk")
|
||||
(* ; "Edited 24-Apr-2025 15:51 by rmk")
|
||||
(* ; "Edited 31-Jan-2025 17:46 by rmk")
|
||||
(* ; "Edited 26-Jan-2025 13:40 by rmk")
|
||||
(* ; "Edited 22-Jan-2025 14:07 by rmk")
|
||||
@@ -453,38 +360,32 @@
|
||||
(* ;; "The first index level segments all the domain codes according to their character sets. The segments are sorted by character set, the pairs within each segment are sorted by their domain codes. ")
|
||||
|
||||
(* ;;
|
||||
"E.g. if INVERTED=NIL and given a XCCS code, the lookup for the corresponding Unicode(s) is")
|
||||
"E.g. if INVERTED=NIL and given a MCCS code, the lookup for the corresponding Unicode(s) is")
|
||||
|
||||
(* ;; " (CADR (ASSOC MCCSCODE (\CHARSET MCCSCODE) INDEX)))).")
|
||||
(* ;; " (CAR (GETMULTI INDEX (\CHARSET MCCSCODE) MCCSCODE).")
|
||||
|
||||
(* ;; "If FILE is not NIL, the result is written to a file. If FILE is T, the file is either MCCS-TO-UNICODE-MAPPINGS.TXT or UNICODE-TO-MCCS-MAPPINGS.TXT, depending on INVERTED.")
|
||||
|
||||
(LET (INDEX)
|
||||
(for PAIR DOMAIN RANGE CHARSET in (READ-UNICODE-MAPPING 'ALL) eachtime (SETQ DOMAIN
|
||||
(CAR PAIR))
|
||||
(SETQ RANGE (CADR PAIR))
|
||||
|
||||
(* ;;
|
||||
"(LISTP RANGE) is a combiner, ignored for now.")
|
||||
unless (LISTP RANGE) do (CL:WHEN INVERTED (SWAP DOMAIN RANGE))
|
||||
(LET [INDEX (MAPPING (GET-MCCS-UNICODE-MAPPING 'ALL]
|
||||
(for PAIR in (CL:IF INVERTED
|
||||
(INVERT-UNICODE-MAPPING MAPPING)
|
||||
MAPPING) unless (LISTP (CADR PAIR)) do
|
||||
(* ;;
|
||||
"(LISTP (CADR PAIR) is a combiner, ignored for now.")
|
||||
|
||||
(* ;;
|
||||
(* ;;
|
||||
"One segment for each high-byte character set. This aligns with UNICODE-EXTEND.TRANSLATION?")
|
||||
|
||||
[SETQ CHARSET (OR (ASSOC (\CHARSET DOMAIN)
|
||||
INDEX)
|
||||
(CAR (push INDEX (CONS (\CHARSET DOMAIN]
|
||||
(* ;; "For alternative mappings (in the U-to-M direction) we end up with (D R1 R2 ...). (CAR (GETMULTI)) is the first (and almost always) the only one.")
|
||||
|
||||
(* ;; "For alternative mappings (in the U-to-M direction) we end up with (D R1 R2 ...). (CADR is the first (and almost always) the only one.")
|
||||
|
||||
(pushnew [CDR (OR (ASSOC DOMAIN (CDR CHARSET))
|
||||
(CAR (push (CDR CHARSET)
|
||||
(CONS DOMAIN]
|
||||
RANGE))
|
||||
(PUSHMULTI-NEW INDEX
|
||||
(\CHARSET (CAR PAIR))
|
||||
(CAR PAIR)
|
||||
(CADR PAIR)))
|
||||
|
||||
(* ;; "Push the charset mappings down an extra CONS, so that a subsequent READ will get them all after a FILEPOS search for super-paren [")
|
||||
|
||||
[for CS in INDEX do (for M in (CDR CS) when (CDDR M) do
|
||||
(for CS in INDEX do (for M in (CDR CS) when (CDDR M) do
|
||||
(* ;;
|
||||
"Sort the range alternatives, if any")
|
||||
|
||||
@@ -494,7 +395,7 @@
|
||||
(* ;; "Sort by domain codes and push down a level")
|
||||
|
||||
(change (CDR CS)
|
||||
(CONS (SORT DATUM T]
|
||||
(SORT DATUM T)))
|
||||
(SETQ INDEX (SORT INDEX T)) (* ; "Sort character sets")
|
||||
(if FILE
|
||||
then (SETQ FILE (PACKFILENAME 'BODY (if (NEQ FILE T)
|
||||
@@ -544,18 +445,347 @@
|
||||
(FULLNAME STREAM))))])
|
||||
)
|
||||
|
||||
(RPAQ? *MCCSTOUNICODE* )
|
||||
|
||||
(RPAQ? *UNICODETOMCCS* )
|
||||
|
||||
(RPAQ? *MCCS-LOADED-CHARSETS* )
|
||||
(* ; "Write Unicode mapping files")
|
||||
|
||||
(RPAQ? *UNICODE-LOADED-CHARSETS* )
|
||||
(DEFINEQ
|
||||
|
||||
(RPAQ? *LARGEUNICODES* )
|
||||
(DECLARE%: DONTEVAL@LOAD DOCOPY
|
||||
(WRITE-UNICODE-MAPPING
|
||||
[LAMBDA (MAPPING INCLUDECHARSETS FILE EMPTYOK) (* ; "Edited 4-Jan-2024 22:44 by rmk")
|
||||
(* ; "Edited 16-Aug-2020 16:56 by rmk:")
|
||||
|
||||
(MAKE-UNICODE-TRANSLATION-TABLES 'ALL)
|
||||
(* ;; "Writes a symbol unicode mapping file. Mapping is a list of (XCCS-code Unicode) pairs, which may contain codes in multiple character sets.")
|
||||
|
||||
(* ;; "If FILE is NIL, it defaults to a name XCCS- followed by the octal character sets in the mapping, in the unicode/XEROX directory.")
|
||||
|
||||
(* ;; "The output lines are of the form x0XXX<tab>x0UUUU<tab># Unicode-char")
|
||||
|
||||
(* ;;
|
||||
"If INCLUDECHARSETS=T then the mappings are split up into separate per-character set files.")
|
||||
|
||||
(* ;; "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))
|
||||
THEN (IF MAPPING
|
||||
THEN (FOR CSI F IN XCCS-SET-NAMES WHEN (SETQ F (WRITE-UNICODE-MAPPING MAPPING
|
||||
(CAR CSI)
|
||||
NIL T)) COLLECT F)
|
||||
ELSE (PRINTOUT T "THERE ARE NO MAPPINGS" T)
|
||||
NIL)
|
||||
ELSE
|
||||
(LET
|
||||
(IMAPPING CSETINFO RANGES)
|
||||
(CL:MULTIPLE-VALUE-SETQ (IMAPPING CSETINFO RANGES)
|
||||
(WRITE-UNICODE-INCLUDED MAPPING INCLUDECHARSETS))
|
||||
(IF IMAPPING
|
||||
THEN (CL:WITH-OPEN-FILE
|
||||
(STREAM (WRITE-UNICODE-MAPPING-FILENAME FILE CSETINFO RANGES)
|
||||
:DIRECTION :OUTPUT :IF-EXISTS :NEW-VERSION :EXTERNAL-FORMAT :UTF-8-RAW)
|
||||
(WRITE-UNICODE-MAPPING-HEADER STREAM CSETINFO RANGES)
|
||||
(SORT IMAPPING T)
|
||||
(FOR M CSET LEFTC FIRSTRIGHTC CSI IN IMAPPING
|
||||
DO (SETQ LEFTC (CAR M))
|
||||
(SETQ FIRSTRIGHTC (CADR M))
|
||||
(CL:UNLESS (EQ CSET (LRSH LEFTC 8))
|
||||
(SETQ CSET (LRSH LEFTC 8))
|
||||
(SETQ CSI (ASSOC CSET CSETINFO))
|
||||
(PRINTOUT STREAM T "# " .P2 (CADR CSI)
|
||||
" "
|
||||
(CADDR CSI)
|
||||
T))
|
||||
(PRINTOUT STREAM "0x" (HEXSTRING LEFTC 4)
|
||||
%#
|
||||
(FOR RIGHTC IN (CDR M) DO (PRINTOUT NIL " " "0x" (HEXSTRING RIGHTC 4)))
|
||||
" # "
|
||||
(SELECTC FIRSTRIGHTC
|
||||
(UNDEFINEDCODE
|
||||
(* ;; "FFFF")
|
||||
|
||||
"UNDEFINED")
|
||||
(MISSINGCODE
|
||||
(* ;; "FFFE")
|
||||
|
||||
"MISSING")
|
||||
(IF (ILESSP FIRSTRIGHTC 32)
|
||||
THEN (* ; "Control chars")
|
||||
[CONCAT "↑" (CHARACTER (IPLUS FIRSTRIGHTC (CHARCODE @]
|
||||
ELSE (CHARACTER FIRSTRIGHTC)))
|
||||
T))
|
||||
(FULLNAME STREAM))
|
||||
ELSEIF (NOT EMPTYOK)
|
||||
THEN (PRINTOUT T "THERE ARE NO MAPPINGS")
|
||||
(CL:WHEN INCLUDECHARSETS
|
||||
(PRINTOUT T " FOR " .PPVTL (MKLIST INCLUDECHARSETS)
|
||||
T))
|
||||
NIL])
|
||||
|
||||
(WRITE-UNICODE-INCLUDED
|
||||
[LAMBDA (MAPPING INCLUDECHARSETS) (* ; "Edited 4-Aug-2020 17:47 by rmk:")
|
||||
|
||||
(* ;; "CSETINFO is a list of (num string name) for each included character set.")
|
||||
|
||||
(LET (CHARSETS CSETINFO RANGES ICSETS IMAPPING)
|
||||
|
||||
(* ;; "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
|
||||
COLLECT (CAR CSI)))
|
||||
JOIN [SETQ KNOWN (OR (SASSOC C XCCS-SET-NAMES)
|
||||
(FIND N IN XCCS-SET-NAMES
|
||||
SUCHTHAT (EQ C (CADR N)))
|
||||
(HELP "UNKNOWN CHARACTER SET" (OCTALSTRING C]
|
||||
(IF (SETQ POS (STRPOS "-" (CAR KNOWN)))
|
||||
THEN (FOR I FROM (CL:PARSE-INTEGER (SUBSTRING (CAR KNOWN)
|
||||
1
|
||||
(SUB1 POS))
|
||||
:RADIX 8)
|
||||
TO (CL:PARSE-INTEGER (SUBSTRING (CAR KNOWN)
|
||||
(ADD1 POS))
|
||||
:RADIX 8) COLLECT (LIST I (OCTALSTRING I)
|
||||
(CADR KNOWN)))
|
||||
ELSE (CONS (CONS (CL:PARSE-INTEGER (CAR KNOWN)
|
||||
:RADIX 8)
|
||||
KNOWN]
|
||||
(SETQ IMAPPING (FOR M CSI IN MAPPING WHEN (SETQ CSI (ASSOC (LRSH (CAR M)
|
||||
8)
|
||||
ICSETS))
|
||||
COLLECT
|
||||
|
||||
(* ;; "The attested subset of INCLUDED")
|
||||
|
||||
(CL:UNLESS (MEMB CSI CSETINFO)
|
||||
(PUSH CSETINFO CSI))
|
||||
M))
|
||||
|
||||
(* ;; "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 COLLECT (CAR CSI)) WHILE CTAIL
|
||||
COLLECT (SETQ START (CAR CTAIL))
|
||||
(SETQ END START)
|
||||
(CONS START (WHILE [AND (CDR CTAIL)
|
||||
(EQ END (SUB1 (CADR CTAIL]
|
||||
COLLECT (SETQ CTAIL (CDR CTAIL))
|
||||
(SETQ END (CAR CTAIL]
|
||||
|
||||
(* ;; "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)))
|
||||
(IF (EQ (CAR R)
|
||||
LAST)
|
||||
THEN (CONS (OCTALSTRING (CAR R)))
|
||||
ELSEIF (SETQ KNOWN (SASSOC (SETQ STR (CONCAT (OCTALSTRING
|
||||
(CAR R))
|
||||
"-"
|
||||
(OCTALSTRING LAST)))
|
||||
XCCS-SET-NAMES))
|
||||
THEN (CONS (CADR KNOWN))
|
||||
ELSEIF (CDDR R)
|
||||
THEN (CONS STR)
|
||||
ELSE (LIST (OCTALSTRING (CAR R))
|
||||
(OCTALSTRING LAST]
|
||||
(CL:VALUES IMAPPING CSETINFO RANGES])
|
||||
|
||||
(WRITE-UNICODE-MAPPING-HEADER
|
||||
[LAMBDA (STREAM CSETINFO RANGES) (* ; "Edited 5-Jan-2024 13:24 by rmk")
|
||||
(* ; "Edited 4-Aug-2020 17:38 by rmk:")
|
||||
|
||||
(* ;; "Writes the standard per-file header information")
|
||||
|
||||
(FOR LINE IN UNICODE-MAPPING-HEADER
|
||||
DO (PRINTOUT STREAM "#" 2)
|
||||
(SELECTQ LINE
|
||||
(XCCSCHARACTERSETS
|
||||
(PRINTOUT STREAM " XCCS charset")
|
||||
(IF (CDR CSETINFO)
|
||||
THEN (PRINTOUT STREAM "s:" -4)
|
||||
(FOR R IN RANGES DO (PRINTOUT STREAM R " "))
|
||||
ELSE (* ; "Singleton")
|
||||
(PRINTOUT STREAM ": " -4 (CADAR CSETINFO)
|
||||
" "
|
||||
(CADDAR CSETINFO)))
|
||||
(TERPRI STREAM))
|
||||
(DATE (PRINTOUT STREAM " Date:" -13 (DATE (DATEFORMAT NO.TIME NO.LEADING.SPACES)
|
||||
)
|
||||
T))
|
||||
(PRINTOUT STREAM LINE T)))
|
||||
(TERPRI STREAM])
|
||||
|
||||
(WRITE-UNICODE-MAPPING-FILENAME
|
||||
[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
|
||||
JOIN (SETQ R (CAR RTAIL))
|
||||
(SETQ R (CL:IF (LISTP R)
|
||||
(LIST (CAR R)
|
||||
"-"
|
||||
(CDR R))
|
||||
(CONS R)))
|
||||
(CL:IF (CDR RTAIL)
|
||||
(NCONC1 R ","))
|
||||
R)
|
||||
ELSE (LIST (CADAR CSETINFO)
|
||||
"="
|
||||
(CADDAR CSETINFO]
|
||||
'DIRECTORY
|
||||
(CAR UNICODEDIRECTORIES)
|
||||
'EXTENSION
|
||||
'TXT])
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
(XCCS-UTF8-AFTER-OPEN
|
||||
[LAMBDA (STREAM ACCESS PARAMETERS) (* ; "Edited 3-Jan-2024 10:27 by rmk")
|
||||
(* ; "Edited 13-Aug-2020 11:54 by rmk:")
|
||||
|
||||
(* ;;
|
||||
"If added to STREAM-AFTER-OPEN-FNS, causes mapping files to be opened as UTF-8. For development")
|
||||
|
||||
(CL:WHEN (AND (STRPOS "XCCS-" (U-CASE (FULLNAME STREAM)))
|
||||
[EQ 'TXT (U-CASE (FILENAMEFIELD (FULLNAME STREAM)
|
||||
'EXTENSION]
|
||||
(NOT (ASSOC 'EXTERNALFORMAT PARAMETERS)))
|
||||
(STREAMPROP STREAM 'EXTERNALFORMAT :UTF-8))])
|
||||
)
|
||||
|
||||
|
||||
|
||||
(* ;; "Automate dumping of a documentation prefix")
|
||||
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(RPAQ MISSINGCODE (CL:PARSE-INTEGER "FFFE" :RADIX 16))
|
||||
|
||||
(RPAQ UNDEFINEDCODE (CL:PARSE-INTEGER "FFFF" :RADIX 16))
|
||||
|
||||
|
||||
(CONSTANTS (MISSINGCODE (CL:PARSE-INTEGER "FFFE" :RADIX 16))
|
||||
(UNDEFINEDCODE (CL:PARSE-INTEGER "FFFF" :RADIX 16)))
|
||||
)
|
||||
)
|
||||
|
||||
(RPAQQ UNICODE-MAPPING-HEADER
|
||||
("" " Name: XCCS (Version 2.0) to Unicode" " Unicode version: 3.0"
|
||||
XCCSCHARACTERSETS " Table version: 0.1" " Table format: Format A"
|
||||
DATE " Author: Ron Kaplan <Ron.Kaplan@post.harvard.edu>" ""
|
||||
"This file contains mappings from the Xerox Character Code Standard (version"
|
||||
"2.0, 1990) into Unicode 3.0. standard codes. That is an extension of the"
|
||||
"version of XCCS corresponding to the fonts in the Medley system." ""
|
||||
"The format of this file conforms to the format of the other Unicode-supplied"
|
||||
"mapping files:" " Three white-space (tab or spaces) separated columns:"
|
||||
" Column 1 is the XCCS code (as hex 0xXXXX)"
|
||||
" Column 2 is the corresponding Unicode (as hex 0xXXXX)"
|
||||
" Column 3 (after #) is a comment column. For convenience, it contains the"
|
||||
" Unicode character itself and the Unicode character names when available."
|
||||
"Unicode FFFF is used for undefined XCCS codes (Column 3 = UNDEFINED"
|
||||
"Unicode FFFE is used for XCCS codes that have not yet been filled in."
|
||||
"(Column 3 = MISSING)" "" "This file is encoded in UTF-8, so that the Unicode characters"
|
||||
"are properly displayed in Column 3 and can be edited by standard"
|
||||
"Unicode-enabled editors (e.g. Mac Textedit)." ""
|
||||
"This file can also be read by the function"
|
||||
"READ-UNICODE-MAPPING in the UNICODE Medley library package." ""
|
||||
"The entries are in XCCS order and grouped by character sets. In front of"
|
||||
"the mappings, for convenience, there is a line with the octal XCCS"
|
||||
"character set, after #." ""
|
||||
"Note that a given XCCS code might map to codes in several different Unicode"
|
||||
"positions, since there are repetitions in the Unicode standard." ""
|
||||
"For more details, see the associated README.TXT file." ""
|
||||
"Any comments or problems, contact <ron.kaplan@post.harvard.edu>"))
|
||||
(DEFINEQ
|
||||
|
||||
(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)
|
||||
THEN (* ; "x10000")
|
||||
(LOGOR (LLSH (LOGOR (LLSH 7 5)
|
||||
(LRSH CHARCODE 12))
|
||||
16)
|
||||
(LLSH (LOGOR (LLSH 2 6)
|
||||
(LOADBYTE CHARCODE 6 6))
|
||||
8)
|
||||
(LOGOR (LLSH 2 6)
|
||||
(LOADBYTE CHARCODE 0 6)))
|
||||
ELSEIF (ILESSP CHARCODE 2097152)
|
||||
THEN (* ; "x200000")
|
||||
(LOGOR (LLSH (LOGOR (LLSH 15 4)
|
||||
(LRSH CHARCODE 18))
|
||||
24)
|
||||
(LLSH (LOGOR (LLSH 2 6)
|
||||
(LOADBYTE CHARCODE 12 6))
|
||||
16)
|
||||
(LLSH (LOGOR (LLSH 2 6)
|
||||
(LOADBYTE CHARCODE 6 6))
|
||||
8)
|
||||
(LOGOR (LLSH 2 6)
|
||||
(LOADBYTE CHARCODE 0 6)))
|
||||
ELSE (ERROR "CHARCODE too big for UTF8" CHARCODE])
|
||||
)
|
||||
|
||||
|
||||
|
||||
(* ; "debugging")
|
||||
|
||||
(DEFINEQ
|
||||
|
||||
(SHOWCHARS
|
||||
[LAMBDA (FONT FROMCHAR TOCHAR ONELINE) (* ; "Edited 5-Oct-2025 17:41 by rmk")
|
||||
(* ; "Edited 7-Sep-2025 20:29 by rmk")
|
||||
(* ; "Edited 2-Sep-2025 10:26 by rmk")
|
||||
(* ; "Edited 24-Jul-2025 11:30 by rmk")
|
||||
(* ; "Edited 8-Jun-2025 20:05 by rmk")
|
||||
(* ; "Edited 26-Jan-2024 14:18 by mth")
|
||||
(* ; "Edited 1-Aug-2020 09:27 by rmk:")
|
||||
[SETQ FONT (FONTCREATE (OR FONT '(CLASSIC 12]
|
||||
(RESETLST
|
||||
[LET ((OLDFONT (DSPFONT NIL T))
|
||||
CHARS)
|
||||
(CL:UNLESS (CHARCODEP FROMCHAR)
|
||||
(SETQ FROMCHAR (OR (CHARCODE.DECODE FROMCHAR T)
|
||||
FROMCHAR)))
|
||||
(SETQ CHARS (if (LISTP FROMCHAR)
|
||||
elseif (CHARCODEP FROMCHAR)
|
||||
then (CL:UNLESS (CHARCODEP TOCHAR)
|
||||
(SETQ TOCHAR (OR (CHARCODE.DECODE TOCHAR)
|
||||
FROMCHAR)))
|
||||
(for C from FROMCHAR to TOCHAR collect C)
|
||||
else (CHCON FROMCHAR)))
|
||||
[RESETSAVE OLDFONT '(PROGN (DSPFONT OLDVALUE]
|
||||
(TERPRI)
|
||||
(for C in CHARS do (PRINTOUT T .FONT OLDFONT (CONCAT (OCTALSTRING (\CHARSET C))
|
||||
","
|
||||
(OCTALSTRING (\CHAR8CODE C)))
|
||||
10 .FONT FONT (CHARACTER C))
|
||||
(CL:UNLESS ONELINE (PRINTOUT T T])
|
||||
(TERPRI])
|
||||
)
|
||||
(DECLARE%: DOEVAL@LOAD DONTCOPY
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(PUTPROPS HEXCHAR MACRO ((CODE)
|
||||
(HEXSTRING CODE)))
|
||||
|
||||
(PUTPROPS OCTALCHAR MACRO [(CODE)
|
||||
(CONCAT (OCTALSTRING (\CHARSET CODE))
|
||||
","
|
||||
(OCTALSTRING (LOGAND CODE 255])
|
||||
)
|
||||
)
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY
|
||||
|
||||
@@ -563,9 +793,12 @@
|
||||
UNICODE-EXPORTS)
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (3341 12542 (READ-UNICODE-MAPPING-FILENAMES 3351 . 8301) (READ-UNICODE-MAPPING 8303 .
|
||||
12540)) (12609 26839 (MAKE-UNICODE-TRANSLATION-TABLES 12619 . 16379) (XCCSTOMCCS-MAPPING 16381 . 17598
|
||||
) (MERGE-UNICODE-TRANSLATION-TABLES 17600 . 20253) (UNICODE.UNMAPPED 20255 . 23579) (
|
||||
UNICODE-EXTEND-TRANSLATION? 23581 . 26837)) (26840 33676 (ALL-UNICODE-MAPPINGS 26850 . 32339) (
|
||||
XCCSJAPANESECHARSETS 32341 . 33674)))))
|
||||
(FILEMAP (NIL (4107 12829 (READ-UNICODE-MAPPING-FILENAMES 4117 . 8586) (READ-UNICODE-MAPPING 8588 .
|
||||
12827)) (12896 19704 (MAKE-UNICODE-TRANSLATION-TABLES 12906 . 15666) (GET-MCCS-UNICODE-MAPPING 15668
|
||||
. 16688) (INVERT-UNICODE-MAPPING 16690 . 18483) (XCCSTOMCCS-MAPPING 18485 . 19702)) (19705 26328 (
|
||||
ALL-UNICODE-MAPPINGS 19715 . 24991) (XCCSJAPANESECHARSETS 24993 . 26326)) (26373 37135 (
|
||||
WRITE-UNICODE-MAPPING 26383 . 30127) (WRITE-UNICODE-INCLUDED 30129 . 34441) (
|
||||
WRITE-UNICODE-MAPPING-HEADER 34443 . 35691) (WRITE-UNICODE-MAPPING-FILENAME 35693 . 37133)) (37136
|
||||
37812 (XCCS-UTF8-AFTER-OPEN 37146 . 37810)) (40337 42426 (UTF8HEXSTRING 40347 . 42424)) (42453 44495 (
|
||||
SHOWCHARS 42463 . 44493)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
Binary file not shown.
@@ -1,13 +1,10 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "15-Feb-2025 14:11:54" {WMEDLEY}<library>lafite>LAFITE-INDENT.;4 26926
|
||||
(FILECREATED "18-Feb-2026 15:47:08" {WMEDLEY}<library>LAFITE>LAFITE-INDENT.;2 26210
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (FNS TEDIT-INDENT-BREAK-LONG-LINES TEDIT-INDENT-SELECTION TEDIT-OPEN-LINE
|
||||
TEDIT-MAKE-LINES-EXPLICIT TEDIT-INDENT-SET-INDENT)
|
||||
|
||||
:PREVIOUS-DATE "15-Feb-2025 09:21:58" {WMEDLEY}<library>lafite>LAFITE-INDENT.;3)
|
||||
:PREVIOUS-DATE "22-Jan-87 01:34:36" {WMEDLEY}<library>LAFITE>LAFITE-INDENT.;1)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT LAFITE-INDENTCOMS)
|
||||
@@ -133,10 +130,14 @@
|
||||
max-length max-length])
|
||||
|
||||
(TEDIT-INDENT-BREAK-LONG-LINES
|
||||
[LAMBDA (text-stream explicit-paragraph-breaks?) (* ; "Edited 15-Feb-2025 14:07 by rmk")
|
||||
(* smL "21-Jan-87 16:03")
|
||||
|
||||
(* ;;; "Break the current selection into explicit lines, each having no more than *TEDIT-INDENT-LINE-LENGTH* characters. --- If the flag *TEDIT-INDENT-KEEP-LINE-BREAKS* is false, existing line breaks in the current selection are removed. --- This is intended to be used in Lafite, where one wants to indent a piece of a forwarded document, but can be used in any TEdit document")
|
||||
[LAMBDA (text-stream explicit-paragraph-breaks?) (* smL "21-Jan-87 16:03")
|
||||
|
||||
(* * Break the current selection into explicit lines, each having no more than
|
||||
*TEDIT-INDENT-LINE-LENGTH* characters. -
|
||||
If the flag *TEDIT-INDENT-KEEP-LINE-BREAKS* is false, existing line breaks in
|
||||
the current selection are removed. -
|
||||
This is intended to be used in Lafite, where one wants to indent a piece of a
|
||||
forwarded document, but can be used in any TEdit document)
|
||||
|
||||
(LET ((selection (TEDIT.GETSEL text-stream)))
|
||||
(TEDIT-INDENT-REPLACE-SELECTION
|
||||
@@ -144,13 +145,11 @@
|
||||
(CONCATLIST (for string on (TEDIT-INDENT-SEPERATE-PARAGRAPHS (TEDIT.SEL.AS.STRING
|
||||
text-stream selection)
|
||||
explicit-paragraph-breaks?)
|
||||
bind [hanging-indent _ (AND [NOT (EQP (GETLD (CAR (GETSEL selection L1))
|
||||
LCHAR1)
|
||||
(TEDIT.SELPROP selection 'CH#]
|
||||
(DIFFERENCE (TEDIT.SELPROP selection
|
||||
'CH#)
|
||||
(GETLD (CAR (GETSEL selection L1))
|
||||
LCHAR1]
|
||||
bind [hanging-indent _
|
||||
(AND (NOT (EQP (fetch CHAR1 of (CAR (fetch L1 of selection)))
|
||||
(fetch CH# of selection)))
|
||||
(DIFFERENCE (fetch CH# of selection)
|
||||
(fetch CHAR1 of (CAR (fetch L1 of selection]
|
||||
join (PROG1 (LIST (TEDIT-INDENT-ADD-INDENTATION (CAR string)
|
||||
"" *TEDIT-INDENT-LINE-LENGTH* hanging-indent)
|
||||
*eol-string*)
|
||||
@@ -185,10 +184,15 @@
|
||||
'RIGHT])
|
||||
|
||||
(TEDIT-INDENT-SELECTION
|
||||
[LAMBDA (text-stream explicit-paragraph-breaks?) (* ; "Edited 15-Feb-2025 14:07 by rmk")
|
||||
(* smL "21-Jan-87 16:00")
|
||||
|
||||
(* ;;; "Indent the current selection by prefacing each line with the value of *TEDIT-INDENT-STRING*, and inserting line breaks after each *TEDIT-INDENT-LINE-LENGTH* characters. --- If the flag *TEDIT-INDENT-KEEP-LINE-BREAKS* is false, existing line breaks in the current selection are removed. --- This is intended to be used in Lafite, where one wants to indent a piece of a forwarded document, but can be used in any TEdit document")
|
||||
[LAMBDA (text-stream explicit-paragraph-breaks?) (* smL "21-Jan-87 16:00")
|
||||
|
||||
(* * Indent the current selection by prefacing each line with the value of
|
||||
*TEDIT-INDENT-STRING*, and inserting line breaks after each
|
||||
*TEDIT-INDENT-LINE-LENGTH* characters. -
|
||||
If the flag *TEDIT-INDENT-KEEP-LINE-BREAKS* is false, existing line breaks in
|
||||
the current selection are removed. -
|
||||
This is intended to be used in Lafite, where one wants to indent a piece of a
|
||||
forwarded document, but can be used in any TEdit document)
|
||||
|
||||
(LET ((selection (TEDIT.GETSEL text-stream)))
|
||||
(TEDIT-INDENT-REPLACE-SELECTION
|
||||
@@ -196,13 +200,11 @@
|
||||
(CONCATLIST (for string on (TEDIT-INDENT-SEPERATE-PARAGRAPHS (TEDIT.SEL.AS.STRING
|
||||
text-stream selection)
|
||||
explicit-paragraph-breaks?)
|
||||
bind [hanging-indent _ (AND [NOT (EQP (GETLD (CAR (GETSEL selection L1))
|
||||
LCHAR1)
|
||||
(TEDIT.SELPROP selection 'CH#]
|
||||
(DIFFERENCE (TEDIT.SELPROP selection
|
||||
'CH#)
|
||||
(GETLD (CAR (GETSEL selection L1))
|
||||
LCHAR1]
|
||||
bind [hanging-indent _
|
||||
(AND (NOT (EQP (fetch CHAR1 of (CAR (fetch L1 of selection)))
|
||||
(fetch CH# of selection)))
|
||||
(DIFFERENCE (fetch CH# of selection)
|
||||
(fetch CHAR1 of (CAR (fetch L1 of selection]
|
||||
join (PROG1 (LIST (TEDIT-INDENT-ADD-INDENTATION (CAR string)
|
||||
*TEDIT-INDENT-STRING* *TEDIT-INDENT-LINE-LENGTH*
|
||||
hanging-indent)
|
||||
@@ -232,19 +234,18 @@
|
||||
else (\TEDIT-INDENT-SEPERATE-PARAGRAPHS string NIL])
|
||||
|
||||
(TEDIT-INDENT-SET-INDENT
|
||||
[LAMBDA (text-stream) (* ; "Edited 15-Feb-2025 09:21 by rmk")
|
||||
(* smL "12-Sep-86 17:09")
|
||||
[LAMBDA (text-stream) (* smL "12-Sep-86 17:09")
|
||||
|
||||
(* * Prompt the user for a new indentation string)
|
||||
|
||||
(* ;;; "Prompt the user for a new indentation string")
|
||||
|
||||
(LET* ((window (\TEDIT.PRIMARYPANE text-stream))
|
||||
(LET* ((window (fetch \WINDOW of (TEXTOBJ text-stream)))
|
||||
(pwindow (if window
|
||||
then (GETPROMPTWINDOW (if (LISTP window)
|
||||
then (CAR window)
|
||||
else window))
|
||||
else PROMPTWINDOW)))
|
||||
(CLEARW pwindow)
|
||||
(SETQ *TEDIT-INDENT-STRING* (PROMPTFORWORD "New indent string: " *TEDIT-INDENT-STRING* NIL
|
||||
(SETQ *TEDIT-INDENT-STRING* (PROMPTFORWORD "New indent string: " *TEDIT-INDENT-STRING* NIL
|
||||
pwindow NIL NIL (LIST (CHARCODE EOL])
|
||||
|
||||
(TEDIT-INDENT-STRIP-INDENTATION
|
||||
@@ -269,34 +270,36 @@
|
||||
else string])
|
||||
|
||||
(TEDIT-MAKE-LINES-EXPLICIT
|
||||
[LAMBDA (text-stream) (* ; "Edited 15-Feb-2025 09:20 by rmk")
|
||||
(* smL " 8-Sep-86 18:20")
|
||||
|
||||
(* ;;; "Take the current selection and replace all TEdit end-of-lines with explicit line breaks. --- This is intended to be used in Lafite, where it is sometimes nice to know that anyone receiving the msg will see the same line breaks that you see. see, but can be used in any TEdit document")
|
||||
[LAMBDA (text-stream) (* smL " 8-Sep-86 18:20")
|
||||
|
||||
(* * Take the current selection and replace all TEdit end-of-lines with
|
||||
explicit line breaks. -
|
||||
This is intended to be used in Lafite, where it is sometimes nice to know that
|
||||
anyone receiving the msg will see the same line breaks that you see.
|
||||
see, but can be used in any TEdit document)
|
||||
|
||||
(LET ((selection (TEDIT.GETSEL text-stream)))
|
||||
[for i in (bind (this-line _ (CAR (GETSEL selection L1)))
|
||||
[last-line _ (CAR (LAST (GETSEL selection LN]
|
||||
repeatuntil (PROGN (SETQ this-line (GETLD this-line NEXTLINE))
|
||||
(EQ this-line last-line)) collect (GETLD this-line LCHARLIM)
|
||||
) do (TEDIT.SETSEL text-stream i 1 'LEFT T)
|
||||
(TEDIT.INSERT text-stream (CONSTANT (CHARACTER (CHARCODE EOL]
|
||||
[for i in (bind (this-line _ (CAR (fetch L1 of selection)))
|
||||
[last-line _ (CAR (LAST (fetch LN of selection]
|
||||
repeatuntil (PROGN (SETQ this-line (fetch NEXTLINE of this-line))
|
||||
(EQ this-line last-line)) collect (fetch CHARLIM
|
||||
of this-line))
|
||||
do (TEDIT.SETSEL text-stream i 1 'LEFT T)
|
||||
(TEDIT.INSERT text-stream (CONSTANT (CHARACTER (CHARCODE EOL]
|
||||
(TEDIT.SETSEL text-stream selection NIL 'RIGHT])
|
||||
|
||||
(TEDIT-OPEN-LINE
|
||||
[LAMBDA (text-stream) (* ; "Edited 15-Feb-2025 14:09 by rmk")
|
||||
(* smL "17-Sep-86 11:13")
|
||||
|
||||
(* ;;; "Open a new line at the current position.")
|
||||
[LAMBDA (text-stream) (* smL "17-Sep-86 11:13")
|
||||
|
||||
(* * Open a new line at the current position.)
|
||||
|
||||
(LET ((selection (TEDIT.GETSEL text-stream)))
|
||||
(TEDIT.INSERT text-stream (CONCAT *eol-string* (ALLOCSTRING
|
||||
(DIFFERENCE (TEDIT.SELPROP selection
|
||||
'CH#)
|
||||
(GETLD (CAR (GETSEL selection L1))
|
||||
LCHAR1))
|
||||
" ")))
|
||||
(if (ZEROP (TEDIT.SELPROP selection 'LENGTH))
|
||||
(TEDIT.INSERT text-stream (CONCAT *eol-string*
|
||||
(ALLOCSTRING [DIFFERENCE (fetch CH# of selection)
|
||||
(fetch CHAR1
|
||||
of (CAR (fetch L1 of selection]
|
||||
" ")))
|
||||
(if (ZEROP (fetch DCH of selection))
|
||||
then (TEDIT.SETSEL text-stream selection])
|
||||
|
||||
(TEDIT-REMOVE-INDENT
|
||||
@@ -433,12 +436,12 @@
|
||||
"Break long lines by inserting explicit <RETURN>'s"
|
||||
]
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (4363 24314 (TEDIT-INDENT-ADD-INDENTATION 4373 . 6941) (TEDIT-INDENT-BREAK-LINE 6943 .
|
||||
8876) (TEDIT-INDENT-BREAK-LONG-LINES 8878 . 10828) (TEDIT-INDENT-FIND-BREAKPOINT 10830 . 11653) (
|
||||
TEDIT-INDENT-REPLACE-SELECTION 11655 . 12212) (TEDIT-INDENT-SELECTION 12214 . 14283) (
|
||||
TEDIT-INDENT-SELECTION-KEEPING-LINEBREAKS 14285 . 14564) (TEDIT-INDENT-SEPERATE-PARAGRAPHS 14566 .
|
||||
15295) (TEDIT-INDENT-SET-INDENT 15297 . 16143) (TEDIT-INDENT-STRIP-INDENTATION 16145 . 17365) (
|
||||
TEDIT-MAKE-LINES-EXPLICIT 17367 . 18517) (TEDIT-OPEN-LINE 18519 . 19453) (TEDIT-REMOVE-INDENT 19455 .
|
||||
20225) (\TEDIT-INDENT-COUNT-SPACES 20227 . 20828) (\TEDIT-INDENT-FIND-PARAGRAPH-END 20830 . 21801) (
|
||||
\TEDIT-INDENT-SEPERATE-LINES 21803 . 22601) (\TEDIT-INDENT-SEPERATE-PARAGRAPHS 22603 . 24312)))))
|
||||
(FILEMAP (NIL (4193 23598 (TEDIT-INDENT-ADD-INDENTATION 4203 . 6771) (TEDIT-INDENT-BREAK-LINE 6773 .
|
||||
8706) (TEDIT-INDENT-BREAK-LONG-LINES 8708 . 10475) (TEDIT-INDENT-FIND-BREAKPOINT 10477 . 11300) (
|
||||
TEDIT-INDENT-REPLACE-SELECTION 11302 . 11859) (TEDIT-INDENT-SELECTION 11861 . 13762) (
|
||||
TEDIT-INDENT-SELECTION-KEEPING-LINEBREAKS 13764 . 14043) (TEDIT-INDENT-SEPERATE-PARAGRAPHS 14045 .
|
||||
14774) (TEDIT-INDENT-SET-INDENT 14776 . 15550) (TEDIT-INDENT-STRIP-INDENTATION 15552 . 16772) (
|
||||
TEDIT-MAKE-LINES-EXPLICIT 16774 . 17979) (TEDIT-OPEN-LINE 17981 . 18737) (TEDIT-REMOVE-INDENT 18739 .
|
||||
19509) (\TEDIT-INDENT-COUNT-SPACES 19511 . 20112) (\TEDIT-INDENT-FIND-PARAGRAPH-END 20114 . 21085) (
|
||||
\TEDIT-INDENT-SEPERATE-LINES 21087 . 21885) (\TEDIT-INDENT-SEPERATE-PARAGRAPHS 21887 . 23596)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,30 +1,28 @@
|
||||
(DEFINE-FILE-INFO §READTABLE "INTERLISP" §PACKAGE "INTERLISP")
|
||||
(FILECREATED "19-Jan-87 23:56:51" {ERIS}<LISPUSERS>LISPCORE>LAFITEPRIVATEDL.;1 10080
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
previous date%: "19-Jan-87 23:47:54" {PHYLUM}<LISPUSERS>KOTO>LAFITEPRIVATEDL.;2)
|
||||
(FILECREATED "18-Feb-2026 15:50:14" {WMEDLEY}<library>lafite>LAFITE-PRIVATEDL.;2 9719
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (FNS \GV.PARSERECIPIENTS1 \GV.PARSE.PRIVATE.DISTRIBUTION.LIST))
|
||||
|
||||
|
||||
(* "
|
||||
Copyright (c) 1986, 1987 by Xerox Corporation. All rights reserved.
|
||||
")
|
||||
(PRETTYCOMPRINT LAFITE-PRIVATEDLCOMS)
|
||||
|
||||
(PRETTYCOMPRINT LAFITEPRIVATEDLCOMS)
|
||||
|
||||
(RPAQQ LAFITEPRIVATEDLCOMS ((* * LAFITEDL.EXT is the default extension for dl files when no extension
|
||||
is specified)
|
||||
(* * LAFITEDLDIRECTORIES is a list of directories to be searched after
|
||||
the connected directory and the LAFITEDEFAULTHOST&DIR in order to
|
||||
locate a dl file when no host or directory is specified)
|
||||
(INITVARS (LAFITEDL.EXT 'DL)
|
||||
(LAFITEDLDIRECTORIES NIL))
|
||||
(* * no functions are user callable)
|
||||
(FNS \GV.PARSERECIPIENTS1 \GV.PARSE.PRIVATE.DISTRIBUTION.LIST)
|
||||
(* Lafite's readtable for parsing addresses needs to have CR as a
|
||||
SEPRCHAR so that lines from a text file can all be parsed at once.
|
||||
This has no effect on normal operation since before private dls no CR
|
||||
was ever passed to the parser)
|
||||
(P (SETSYNTAX (CHARCODE CR)
|
||||
'SEPRCHAR ADDRESSPARSERRDTBL))))
|
||||
(RPAQQ LAFITE-PRIVATEDLCOMS
|
||||
((* * LAFITEDL.EXT is the default extension for dl files when no extension is specified)
|
||||
(* * LAFITEDLDIRECTORIES is a list of directories to be searched after the connected
|
||||
directory and the LAFITEDEFAULTHOST&DIR in order to locate a dl file when no host or
|
||||
directory is specified)
|
||||
(INITVARS (LAFITEDL.EXT 'DL)
|
||||
(LAFITEDLDIRECTORIES NIL))
|
||||
(* * no functions are user callable)
|
||||
(FNS \GV.PARSERECIPIENTS1 \GV.PARSE.PRIVATE.DISTRIBUTION.LIST)
|
||||
(* Lafite's readtable for parsing addresses needs to have CR as a SEPRCHAR so that lines from
|
||||
a text file can all be parsed at once. This has no effect on normal operation since before
|
||||
private dls no CR was ever passed to the parser)
|
||||
(P (SETSYNTAX (CHARCODE CR)
|
||||
'SEPRCHAR ADDRESSPARSERRDTBL))))
|
||||
(* * LAFITEDL.EXT is the default extension for dl files when no extension is specified)
|
||||
|
||||
(* * LAFITEDLDIRECTORIES is a list of directories to be searched after the connected directory and the
|
||||
@@ -39,7 +37,7 @@ Copyright (c) 1986, 1987 by Xerox Corporation. All rights reserved.
|
||||
(DEFINEQ
|
||||
|
||||
(\GV.PARSERECIPIENTS1
|
||||
[LAMBDA (FIELD REGISTRY INTERNALFLG EDITWINDOW) (* N.H.Briggs "19-Jan-87 23:44")
|
||||
[LAMBDA (FIELD REGISTRY INTERNALFLG EDITWINDOW) (* N.H.Briggs "19-Jan-87 23:44")
|
||||
|
||||
(* ;;; "INTERNALFLG = T means produce addresses to give Grapevine; NIL means give human-readable addresses")
|
||||
|
||||
@@ -73,8 +71,8 @@ Copyright (c) 1986, 1987 by Xerox Corporation. All rights reserved.
|
||||
(CHARCODE %"))
|
||||
(HELP]
|
||||
(OR REGISTRY (SETQ REGISTRY DEFAULTREGISTRY))
|
||||
|
||||
(* ;; "first just collect all the atoms using a special readtable ")
|
||||
|
||||
(* ;; "first just collect all the atoms using a special readtable ")
|
||||
|
||||
(SETQ ADDRESSES (when (SETQ ADDR (until (OR (EOFP FIELDSTREAM)
|
||||
(EQ (SETQ TOKEN (READ FIELDSTREAM
|
||||
@@ -107,14 +105,13 @@ Copyright (c) 1986, 1987 by Xerox Corporation. All rights reserved.
|
||||
(EQ (CADDR ADDRESS)
|
||||
';))
|
||||
then
|
||||
|
||||
(* ;; "it's a private dl --- foo:;")
|
||||
(* ;; "it's a private dl --- foo:;")
|
||||
|
||||
(\GV.PARSE.PRIVATE.DISTRIBUTION.LIST ADDRESS REGISTRY INTERNALFLG
|
||||
(\GV.PARSE.PRIVATE.DISTRIBUTION.LIST ADDRESS REGISTRY INTERNALFLG
|
||||
EDITWINDOW)
|
||||
else
|
||||
|
||||
(* ;; "ADDRESS will only get rebound if there is an address with <>'s in it ")
|
||||
(* ;;
|
||||
"ADDRESS will only get rebound if there is an address with <>'s in it ")
|
||||
|
||||
(SETQ VALIDRECIPIENT (\GV.PARSE.SINGLE.ADDRESS
|
||||
(COND
|
||||
@@ -128,8 +125,8 @@ Copyright (c) 1986, 1987 by Xerox Corporation. All rights reserved.
|
||||
((OR T INTERNALFLG (NULL REALADDRESS))
|
||||
VALIDRECIPIENT)
|
||||
(T
|
||||
|
||||
(* ;; "Need to figure out how to make GETREGISTRY of this work, and remove duplicates in MAKEANSWERFORM before we can enable this")
|
||||
|
||||
(* ;; "Need to figure out how to make GETREGISTRY of this work, and remove duplicates in MAKEANSWERFORM before we can enable this")
|
||||
|
||||
(\GV.REPACKADDRESS (APPEND (LDIFF ADDRESS OPEN)
|
||||
(LIST '< VALIDRECIPIENT
|
||||
@@ -137,7 +134,7 @@ Copyright (c) 1986, 1987 by Xerox Corporation. All rights reserved.
|
||||
(CDR CLOSE])
|
||||
|
||||
(\GV.PARSE.PRIVATE.DISTRIBUTION.LIST
|
||||
[LAMBDA (DL REGISTRY INTERNALFLG EDITWINDOW) (* N.H.Briggs "19-Jan-87 23:45")
|
||||
[LAMBDA (DL REGISTRY INTERNALFLG EDITWINDOW) (* N.H.Briggs "19-Jan-87 23:45")
|
||||
(LET* [(FILENAME (FINDFILE (PACKFILENAME.STRING 'BODY (CAR DL)
|
||||
'EXTENSION LAFITEDL.EXT)
|
||||
T
|
||||
@@ -162,10 +159,10 @@ Copyright (c) 1986, 1987 by Xerox Corporation. All rights reserved.
|
||||
file can all be parsed at once. This has no effect on normal operation since before private dls no CR
|
||||
was ever passed to the parser)
|
||||
|
||||
|
||||
(SETSYNTAX (CHARCODE CR)
|
||||
'SEPRCHAR ADDRESSPARSERRDTBL)
|
||||
(PUTPROPS LAFITEPRIVATEDL COPYRIGHT ("Xerox Corporation" 1986 1987))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (1965 9682 (\GV.PARSERECIPIENTS1 1975 . 8562) (\GV.PARSE.PRIVATE.DISTRIBUTION.LIST 8564
|
||||
. 9680)))))
|
||||
(FILEMAP (NIL (1617 9389 (\GV.PARSERECIPIENTS1 1627 . 8273) (\GV.PARSE.PRIVATE.DISTRIBUTION.LIST 8275
|
||||
. 9387)))))
|
||||
STOP
|
||||
|
||||
BIN
library/lafite/LAFITE-PRIVATEDL.LCOM
Normal file
BIN
library/lafite/LAFITE-PRIVATEDL.LCOM
Normal file
Binary file not shown.
File diff suppressed because it is too large
Load Diff
Binary file not shown.
@@ -1,12 +1,13 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED " 7-Feb-2026 17:02:37" {WMEDLEY}<library>tedit>TEDIT-FILE.;657 173103
|
||||
(FILECREATED "15-Feb-2026 23:45:51" {WMEDLEY}<library>tedit>TEDIT-FILE.;666 175062
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (FNS TEDITFROMLISPSOURCE)
|
||||
:CHANGES-TO (FNS \TEDIT.PUT.MCCS.SPLITPIECES \TEDIT.PUT.PCTB.NEXTNEW)
|
||||
(VARS TEDIT-FILECOMS)
|
||||
|
||||
:PREVIOUS-DATE "23-Oct-2025 08:49:06" {WMEDLEY}<library>tedit>TEDIT-FILE.;656)
|
||||
:PREVIOUS-DATE "14-Feb-2026 10:32:44" {WMEDLEY}<library>tedit>TEDIT-FILE.;659)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT TEDIT-FILECOMS)
|
||||
@@ -50,8 +51,9 @@
|
||||
(* ;; "Putting pageframe functions are on TEDIT-PAGE)")
|
||||
|
||||
(FNS \TEDIT.PUT.PCTB \TEDIT.PUT.PCTB.PIECEDATA \TEDIT.PUT.TRAILER
|
||||
\TEDIT.PUT.PCTB.MERGEABLE \TEDIT.PUT.UTF8.SPLITPIECES \TEDIT.PUT.PCTB.NEXTNEW
|
||||
\TEDIT.INSERT.NEWPIECES \TEDIT.PUTRESET \ARBOUT \ATMOUT \DWOUT \STRINGOUT)
|
||||
\TEDIT.PUT.PCTB.MERGEABLE \TEDIT.PUT.UTF8.SPLITPIECES \TEDIT.PUT.MCCS.SPLITPIECES
|
||||
\TEDIT.PUT.PCTB.NEXTNEW \TEDIT.INSERT.NEWPIECES \TEDIT.PUTRESET \ARBOUT \ATMOUT
|
||||
\DWOUT \STRINGOUT)
|
||||
(FNS \TEDIT.PUT.CHARLOOKS.LIST \TEDIT.PUT.SINGLE.CHARLOOKS \TEDIT.PUT.CHARLOOKS
|
||||
\TEDIT.PUT.CHARLOOKS1 \TEDIT.PUT.OBJECT)
|
||||
(FNS \TEDIT.PUT.PARALOOKS.LIST \TEDIT.PUT.SINGLE.PARALOOKS \TEDIT.PUT.PARALOOKS))
|
||||
@@ -1830,6 +1832,7 @@
|
||||
|
||||
(\TEDIT.PUT.PCTB
|
||||
[LAMBDA (TEXTOBJ CHARSTREAM FORMATSTREAM CONTINUE KEEPSEPARATE)
|
||||
(* ; "Edited 14-Feb-2026 10:32 by rmk")
|
||||
(* ; "Edited 9-Sep-2025 21:32 by rmk")
|
||||
(* ; "Edited 26-Apr-2025 00:11 by rmk")
|
||||
(* ; "Edited 21-Oct-2024 00:33 by rmk")
|
||||
@@ -1922,10 +1925,10 @@
|
||||
|
||||
(* ;; "For MCCS, CHARSET will put out the char-shifting prefix bytes as needed. In format-version 3 all the file bytes belong to a piece, no skipping in the file. TEDIT.GET calls \TEDIT.INTERPRET.XCCS.SHIFTS to shave those bytes. NSHIFTBYTES is used here if the edit will continue.")
|
||||
|
||||
(CHARSET CHARSTREAM (CL:IF (MEMB (PTYPE PC)
|
||||
FAT.PTYPES)
|
||||
T
|
||||
0))
|
||||
(CHARSET CHARSTREAM (OR (AND (EQ EXTFORMAT :XCCS)
|
||||
(MEMB (PTYPE PC)
|
||||
FAT.PTYPES))
|
||||
(PCHARSET PC)))
|
||||
(SETQ NSHIFTBYTES (IDIFFERENCE (\GETFILEPTR CHARSTREAM)
|
||||
OLDBYTE#)))
|
||||
(do (\TEDIT.PUT.PCTB.PIECEDATA PC CHARSTREAM TEXTOBJ FORMATSTREAM OLDBYTE#)
|
||||
@@ -2152,8 +2155,35 @@
|
||||
(RETURN))))
|
||||
NIL])
|
||||
|
||||
(\TEDIT.PUT.MCCS.SPLITPIECES
|
||||
[LAMBDA (TEXTOBJ) (* ; "Edited 15-Feb-2026 23:45 by rmk")
|
||||
|
||||
(* ;; "We are putting to a :MCCS format file, and MCCS doesn't support single-byte runs of non-charset 0 characters. This function splits fat pieces into subpieces with only charset-0 characters or no charset-0 characters. The former will be put out as THINFILE pieces, the latter as FATFILE2.")
|
||||
|
||||
(for PC FIRST0 FIRSTNON0 inpieces (\TEDIT.FIRSTPIECE TEXTOBJ)
|
||||
when [AND (MEMB (PTYPE PC)
|
||||
(CONSTANT (LIST FATSTRING.PTYPE FATFILE2.PTYPE UTF8.PTYPE)))
|
||||
(SETQ FIRST0 (find I from 0 to (PLAST PC)
|
||||
suchthat (EQ 0 (\CHARSET (\TEDIT.PIECE.NTHCHARCODE PC I]
|
||||
do (if [SETQ FIRSTNON0 (find I from (ADD1 FIRST0) to (PLAST PC)
|
||||
suchthat (NEQ 0 (\CHARSET (\TEDIT.PIECE.NTHCHARCODE PC I]
|
||||
then
|
||||
(* ;; "xxx000yyy --> xxx 000yyy or 000yyy --> 000 yyy")
|
||||
|
||||
(\TEDIT.SPLITPIECE PC (CL:IF (EQ FIRST0 0)
|
||||
FIRSTNON0
|
||||
FIRST0)
|
||||
TEXTOBJ) (* ; "Iterate to the residual piece")
|
||||
(SETQ PC (PREVPIECE PC))
|
||||
elseif (NEQ 0 FIRST0)
|
||||
then
|
||||
(* ;; "xxx000")
|
||||
|
||||
(\TEDIT.SPLITPIECE PC FIRST0 TEXTOBJ])
|
||||
|
||||
(\TEDIT.PUT.PCTB.NEXTNEW
|
||||
[LAMBDA (NEXTNEW PC OLDBYTE# RUNLEN EXTFORMAT TEXTOBJ EOLC NSHIFTBYTES)
|
||||
(* ; "Edited 15-Feb-2026 15:09 by rmk")
|
||||
(* ; "Edited 25-Apr-2025 08:48 by rmk")
|
||||
(* ; "Edited 26-Mar-2025 09:27 by rmk")
|
||||
(* ; "Edited 21-Oct-2024 00:26 by rmk")
|
||||
@@ -2202,7 +2232,7 @@
|
||||
"The file may have LF, but we want to restore EOL internally")
|
||||
(CL:WHEN [AND (EQ THINFILE.PTYPE (PTYPE NEXTNEW))
|
||||
(EQ (CHARCODE EOL)
|
||||
(\TEDIT.PIECE.NTHCHARCODE PC (PLEN PC]
|
||||
(\TEDIT.PIECE.NTHCHARCODE PC (PLAST PC]
|
||||
(if (EQ 1 (PLEN NEXTNEW))
|
||||
then (FSETPC NEXTNEW PTYPE THINSTRING.PTYPE)
|
||||
(FSETPC NEXTNEW PCONTENTS (ALLOCSTRING 1 (CHARCODE EOL)))
|
||||
@@ -2691,28 +2721,29 @@
|
||||
|
||||
(RPAQ? *TEDIT-FILE-READTABLE* (COPYREADTABLE \ORIGREADTABLE))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (5304 35563 (TEDIT.GET 5314 . 11724) (TEDIT.FORMATTEDFILEP 11726 . 13042) (
|
||||
TEDIT.FILEDATE 13044 . 14353) (TEDIT.INCLUDE 14355 . 22384) (TEDIT.RAW.INCLUDE 22386 . 23194) (
|
||||
TEDIT.PUT 23196 . 31552) (TEDIT.PUT.STREAM 31554 . 35561)) (35564 56838 (\TEDIT.GET.FOREIGN.FILE 35574
|
||||
. 38999) (\TEDIT.GET.UNFORMATTED.FILE 39001 . 43307) (\TEDIT.GET.FORMATTED.FILE 43309 . 46952) (
|
||||
\TEDIT.FORMATTEDSTREAMP 46954 . 50085) (\ARBIN 50087 . 50807) (\ATMIN 50809 . 51346) (\DWIN 51348 .
|
||||
51727) (\STRINGIN 51729 . 52437) (\TEDIT.GET.TRAILER 52439 . 55307) (\TEDIT.CACHEFILE 55309 . 56836))
|
||||
(57004 73042 (\TEDIT.GET.PIECES3 57014 . 67977) (\TEDIT.GET.PROPS3 67979 . 71201) (
|
||||
\TEDIT.MAKE.STRINGPIECE 71203 . 73040)) (73043 86469 (\TEDIT.GET.UNFORMATTED.FILE.MCCS 73053 . 79286)
|
||||
(\TEDIT.INTERPRET.MCCS.SHIFTS 79288 . 85533) (\TEDIT.CONVERT.XCCSTOMCCS 85535 . 86467)) (86491 92736 (
|
||||
\TEDIT.GET.UNFORMATTED.FILE.UTF8 86501 . 92734)) (92759 104101 (\TEDIT.GET.CHARLOOKS.LIST 92769 .
|
||||
93500) (\TEDIT.GET.SINGLE.CHARLOOKS 93502 . 100574) (\TEDIT.GET.CHARLOOKS 100576 . 102132) (
|
||||
\TEDIT.GET.PARALOOKS.INDEX 102134 . 102678) (\TEDIT.GET.CHARLOOKS.INDEX 102680 . 104099)) (104102
|
||||
111759 (\TEDIT.GET.PARALOOKS.LIST 104112 . 104734) (\TEDIT.GET.SINGLE.PARALOOKS 104736 . 111757)) (
|
||||
111760 115593 (\TEDIT.GET.OBJECT 111770 . 115591)) (115658 148921 (\TEDIT.PUT.PCTB 115668 . 125575) (
|
||||
\TEDIT.PUT.PCTB.PIECEDATA 125577 . 128775) (\TEDIT.PUT.TRAILER 128777 . 130105) (
|
||||
\TEDIT.PUT.PCTB.MERGEABLE 130107 . 133880) (\TEDIT.PUT.UTF8.SPLITPIECES 133882 . 138584) (
|
||||
\TEDIT.PUT.PCTB.NEXTNEW 138586 . 143082) (\TEDIT.INSERT.NEWPIECES 143084 . 146519) (\TEDIT.PUTRESET
|
||||
146521 . 146763) (\ARBOUT 146765 . 147489) (\ATMOUT 147491 . 148096) (\DWOUT 148098 . 148377) (
|
||||
\STRINGOUT 148379 . 148919)) (148922 161656 (\TEDIT.PUT.CHARLOOKS.LIST 148932 . 150604) (
|
||||
\TEDIT.PUT.SINGLE.CHARLOOKS 150606 . 156886) (\TEDIT.PUT.CHARLOOKS 156888 . 158227) (
|
||||
\TEDIT.PUT.CHARLOOKS1 158229 . 159280) (\TEDIT.PUT.OBJECT 159282 . 161654)) (161657 169296 (
|
||||
\TEDIT.PUT.PARALOOKS.LIST 161667 . 162569) (\TEDIT.PUT.SINGLE.PARALOOKS 162571 . 168155) (
|
||||
\TEDIT.PUT.PARALOOKS 168157 . 169294)) (169391 172796 (TEDITFROMLISPSOURCE 169401 . 172045) (
|
||||
SHELLSCRIPTP 172047 . 172276) (TEDITFROMSHELLSCRIPT 172278 . 172794)))))
|
||||
(FILEMAP (NIL (5423 35682 (TEDIT.GET 5433 . 11843) (TEDIT.FORMATTEDFILEP 11845 . 13161) (
|
||||
TEDIT.FILEDATE 13163 . 14472) (TEDIT.INCLUDE 14474 . 22503) (TEDIT.RAW.INCLUDE 22505 . 23313) (
|
||||
TEDIT.PUT 23315 . 31671) (TEDIT.PUT.STREAM 31673 . 35680)) (35683 56957 (\TEDIT.GET.FOREIGN.FILE 35693
|
||||
. 39118) (\TEDIT.GET.UNFORMATTED.FILE 39120 . 43426) (\TEDIT.GET.FORMATTED.FILE 43428 . 47071) (
|
||||
\TEDIT.FORMATTEDSTREAMP 47073 . 50204) (\ARBIN 50206 . 50926) (\ATMIN 50928 . 51465) (\DWIN 51467 .
|
||||
51846) (\STRINGIN 51848 . 52556) (\TEDIT.GET.TRAILER 52558 . 55426) (\TEDIT.CACHEFILE 55428 . 56955))
|
||||
(57123 73161 (\TEDIT.GET.PIECES3 57133 . 68096) (\TEDIT.GET.PROPS3 68098 . 71320) (
|
||||
\TEDIT.MAKE.STRINGPIECE 71322 . 73159)) (73162 86588 (\TEDIT.GET.UNFORMATTED.FILE.MCCS 73172 . 79405)
|
||||
(\TEDIT.INTERPRET.MCCS.SHIFTS 79407 . 85652) (\TEDIT.CONVERT.XCCSTOMCCS 85654 . 86586)) (86610 92855 (
|
||||
\TEDIT.GET.UNFORMATTED.FILE.UTF8 86620 . 92853)) (92878 104220 (\TEDIT.GET.CHARLOOKS.LIST 92888 .
|
||||
93619) (\TEDIT.GET.SINGLE.CHARLOOKS 93621 . 100693) (\TEDIT.GET.CHARLOOKS 100695 . 102251) (
|
||||
\TEDIT.GET.PARALOOKS.INDEX 102253 . 102797) (\TEDIT.GET.CHARLOOKS.INDEX 102799 . 104218)) (104221
|
||||
111878 (\TEDIT.GET.PARALOOKS.LIST 104231 . 104853) (\TEDIT.GET.SINGLE.PARALOOKS 104855 . 111876)) (
|
||||
111879 115712 (\TEDIT.GET.OBJECT 111889 . 115710)) (115777 150880 (\TEDIT.PUT.PCTB 115787 . 125844) (
|
||||
\TEDIT.PUT.PCTB.PIECEDATA 125846 . 129044) (\TEDIT.PUT.TRAILER 129046 . 130374) (
|
||||
\TEDIT.PUT.PCTB.MERGEABLE 130376 . 134149) (\TEDIT.PUT.UTF8.SPLITPIECES 134151 . 138853) (
|
||||
\TEDIT.PUT.MCCS.SPLITPIECES 138855 . 140433) (\TEDIT.PUT.PCTB.NEXTNEW 140435 . 145041) (
|
||||
\TEDIT.INSERT.NEWPIECES 145043 . 148478) (\TEDIT.PUTRESET 148480 . 148722) (\ARBOUT 148724 . 149448) (
|
||||
\ATMOUT 149450 . 150055) (\DWOUT 150057 . 150336) (\STRINGOUT 150338 . 150878)) (150881 163615 (
|
||||
\TEDIT.PUT.CHARLOOKS.LIST 150891 . 152563) (\TEDIT.PUT.SINGLE.CHARLOOKS 152565 . 158845) (
|
||||
\TEDIT.PUT.CHARLOOKS 158847 . 160186) (\TEDIT.PUT.CHARLOOKS1 160188 . 161239) (\TEDIT.PUT.OBJECT
|
||||
161241 . 163613)) (163616 171255 (\TEDIT.PUT.PARALOOKS.LIST 163626 . 164528) (
|
||||
\TEDIT.PUT.SINGLE.PARALOOKS 164530 . 170114) (\TEDIT.PUT.PARALOOKS 170116 . 171253)) (171350 174755 (
|
||||
TEDITFROMLISPSOURCE 171360 . 174004) (SHELLSCRIPTP 174006 . 174235) (TEDITFROMSHELLSCRIPT 174237 .
|
||||
174753)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,12 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "10-Feb-2026 11:07:12" {WMEDLEY}<library>TEDIT>TEDIT-LOOKS.;465 155591
|
||||
(FILECREATED "16-Feb-2026 00:36:00" {WMEDLEY}<library>TEDIT>TEDIT-LOOKS.;467 155443
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (FNS \TEDIT.CHANGE.CHARLOOKS \TEDIT.CHANGE.PARALOOKS)
|
||||
:CHANGES-TO (FNS \TEDIT.MCCS.TRANSLATE)
|
||||
|
||||
:PREVIOUS-DATE " 7-Dec-2025 16:32:32" {WMEDLEY}<library>tedit>TEDIT-LOOKS.;460)
|
||||
:PREVIOUS-DATE "10-Feb-2026 11:07:12" {WMEDLEY}<library>tedit>TEDIT-LOOKS.;465)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT TEDIT-LOOKSCOMS)
|
||||
@@ -924,7 +924,8 @@
|
||||
(DEFINEQ
|
||||
|
||||
(\TEDIT.MCCS.TRANSLATE
|
||||
[LAMBDA (TSTREAM) (* ; "Edited 6-Oct-2025 20:50 by rmk")
|
||||
[LAMBDA (TSTREAM) (* ; "Edited 16-Feb-2026 00:35 by rmk")
|
||||
(* ; "Edited 6-Oct-2025 20:50 by rmk")
|
||||
(* ; "Edited 5-Oct-2025 10:57 by rmk")
|
||||
(* ; "Edited 25-Sep-2025 21:30 by rmk")
|
||||
(* ; "Edited 9-Sep-2025 21:48 by rmk")
|
||||
@@ -954,19 +955,17 @@
|
||||
(SETQ CLOOKS
|
||||
(PCHARLOOKS PC))
|
||||
CLFONT]
|
||||
do (for OFFSET OLDCODE STRING FAT from 1 to (PLEN PC) eachtime (SETQ OLDCODE
|
||||
(
|
||||
\TEDIT.PIECE.NTHCHARCODE
|
||||
PC OFFSET))
|
||||
do (for OFFSET OLDCODE STRING FAT from 0 to (PLAST PC)
|
||||
eachtime (SETQ OLDCODE (\TEDIT.PIECE.NTHCHARCODE PC OFFSET))
|
||||
unless (EQ OLDCODE (APPLY* TOMCCSFN OLDCODE))
|
||||
do
|
||||
(* ;; "This piece has recoded character. Start over to convert it to a string piece with necessary code conversions. (The logic to split the original piece at just the changes while still preserving the iteration would be very complicated).")
|
||||
|
||||
(SETQ STRING (ALLOCSTRING (PLEN PC)))
|
||||
[for OFFSET from 1 to (PLEN PC) do (RPLCHARCODE STRING OFFSET
|
||||
(APPLY* TOMCCSFN (
|
||||
[for I from 0 to (PLAST PC) do (RPLCHARCODE STRING (ADD1 I)
|
||||
(APPLY* TOMCCSFN (
|
||||
\TEDIT.PIECE.NTHCHARCODE
|
||||
PC OFFSET]
|
||||
PC I]
|
||||
(SETQ FAT (ffetch (STRINGP FATSTRINGP) of STRING))
|
||||
(FSETPC PC PTYPE (CL:IF FAT
|
||||
FATSTRING.PTYPE
|
||||
@@ -2465,26 +2464,26 @@
|
||||
(ADDTOVAR LAMA )
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (22045 23987 (\TEDIT.CHARLOOKS.DEFPRINT 22055 . 23191) (\TEDIT.PARALOOKS.DEFPRINT 23193
|
||||
. 23985)) (24091 24477 (\TEDIT.CREATE.FACE.MENU 24101 . 24273) (\TEDIT.CREATE.SIZE.MENU 24275 . 24475
|
||||
)) (25481 27370 (\TEDIT.CHARLOOKS.FEATURE.CHECK 25491 . 27368)) (27642 52899 (
|
||||
\TEDIT.CHARLOOKS.FROM.FONT 27652 . 29936) (\TEDIT.EQCLOOKS 29938 . 32969) (\TEDIT.SAMECLOOKS 32971 .
|
||||
36142) (TEDIT.CARETLOOKS 36144 . 37690) (TEDIT.COPY.LOOKS 37692 . 40975) (
|
||||
\TEDIT.UNPARSE.CHARLOOKS.LIST 40977 . 44471) (\TEDIT.MODIFYLOOKS 44473 . 46633) (TEDIT.NEW.FONT 46635
|
||||
. 47082) (\TEDIT.CARETLOOKS.VERIFY 47084 . 47921) (\TEDIT.CARETPIECE 47923 . 48228) (
|
||||
\TEDIT.GET.INSERT.CHARLOOKS 48230 . 51277) (\TEDIT.GET.TERMSA.WIDTHS 51279 . 51695) (
|
||||
\TEDIT.PARSE.CHARLOOKS.LIST 51697 . 52897)) (52900 65027 (\TEDIT.MCCS.TRANSLATE 52910 . 58763) (
|
||||
\TEDIT.CONVERT.TO.FORMATTED 58765 . 65025)) (65899 73236 (\TEDIT.UNIQUIFY.CHARLOOKS 65909 . 67569) (
|
||||
\TEDIT.UNIQUIFY.PARALOOKS 67571 . 68838) (\TEDIT.UNIQUIFY.ALL 68840 . 70928) (
|
||||
\TEDIT.FLUSH.UNUSED.LOOKS 70930 . 73234)) (73269 85227 (TEDIT.LOOKS 73279 . 75668) (TEDIT.GET.LOOKS
|
||||
75670 . 78005) (TEDIT.SUBLOOKS 78007 . 82387) (TEDIT.FINDLOOKS 82389 . 85225)) (85228 115001 (
|
||||
\TEDIT.CHANGE.CHARLOOKS 85238 . 94139) (\TEDIT.CHANGE.CHARLOOKS.NEW 94141 . 97956) (
|
||||
\TEDIT.CHARLOOKS.CHANGE.FONT 97958 . 106265) (\TEDIT.FONT.NEXTSIZE 106267 . 107888) (\TEDIT.LOOKS
|
||||
107890 . 111219) (\TEDIT.FONTCOPY 111221 . 112722) (\TEDIT.COERCE.FONTCLASS 112724 . 113875) (
|
||||
\TEDIT.FONTCLASS.TO.FONT 113877 . 114999)) (115044 146933 (\TEDIT.EQFMTSPEC 115054 . 118269) (
|
||||
TEDIT.GET.PARALOOKS 118271 . 122318) (\TEDIT.PARSE.PARALOOKS.LIST 122320 . 130353) (TEDIT.PARALOOKS
|
||||
130355 . 131395) (\TEDIT.CHANGE.PARALOOKS 131397 . 138606) (\TEDIT.CHANGE.PARALOOKS.NEW 138608 .
|
||||
142591) (TEDIT.COPY.PARALOOKS 142593 . 145267) (\TEDIT.PARABOUNDS 145269 . 146931)) (146993 154709 (
|
||||
TEDIT.SUBPARALOOKS 147003 . 151105) (SAMEPARALOOKS 151107 . 154707)) (154710 155397 (
|
||||
\TEDIT.MARK.REVISION 154720 . 155395)))))
|
||||
(FILEMAP (NIL (22019 23961 (\TEDIT.CHARLOOKS.DEFPRINT 22029 . 23165) (\TEDIT.PARALOOKS.DEFPRINT 23167
|
||||
. 23959)) (24065 24451 (\TEDIT.CREATE.FACE.MENU 24075 . 24247) (\TEDIT.CREATE.SIZE.MENU 24249 . 24449
|
||||
)) (25455 27344 (\TEDIT.CHARLOOKS.FEATURE.CHECK 25465 . 27342)) (27616 52873 (
|
||||
\TEDIT.CHARLOOKS.FROM.FONT 27626 . 29910) (\TEDIT.EQCLOOKS 29912 . 32943) (\TEDIT.SAMECLOOKS 32945 .
|
||||
36116) (TEDIT.CARETLOOKS 36118 . 37664) (TEDIT.COPY.LOOKS 37666 . 40949) (
|
||||
\TEDIT.UNPARSE.CHARLOOKS.LIST 40951 . 44445) (\TEDIT.MODIFYLOOKS 44447 . 46607) (TEDIT.NEW.FONT 46609
|
||||
. 47056) (\TEDIT.CARETLOOKS.VERIFY 47058 . 47895) (\TEDIT.CARETPIECE 47897 . 48202) (
|
||||
\TEDIT.GET.INSERT.CHARLOOKS 48204 . 51251) (\TEDIT.GET.TERMSA.WIDTHS 51253 . 51669) (
|
||||
\TEDIT.PARSE.CHARLOOKS.LIST 51671 . 52871)) (52874 64879 (\TEDIT.MCCS.TRANSLATE 52884 . 58615) (
|
||||
\TEDIT.CONVERT.TO.FORMATTED 58617 . 64877)) (65751 73088 (\TEDIT.UNIQUIFY.CHARLOOKS 65761 . 67421) (
|
||||
\TEDIT.UNIQUIFY.PARALOOKS 67423 . 68690) (\TEDIT.UNIQUIFY.ALL 68692 . 70780) (
|
||||
\TEDIT.FLUSH.UNUSED.LOOKS 70782 . 73086)) (73121 85079 (TEDIT.LOOKS 73131 . 75520) (TEDIT.GET.LOOKS
|
||||
75522 . 77857) (TEDIT.SUBLOOKS 77859 . 82239) (TEDIT.FINDLOOKS 82241 . 85077)) (85080 114853 (
|
||||
\TEDIT.CHANGE.CHARLOOKS 85090 . 93991) (\TEDIT.CHANGE.CHARLOOKS.NEW 93993 . 97808) (
|
||||
\TEDIT.CHARLOOKS.CHANGE.FONT 97810 . 106117) (\TEDIT.FONT.NEXTSIZE 106119 . 107740) (\TEDIT.LOOKS
|
||||
107742 . 111071) (\TEDIT.FONTCOPY 111073 . 112574) (\TEDIT.COERCE.FONTCLASS 112576 . 113727) (
|
||||
\TEDIT.FONTCLASS.TO.FONT 113729 . 114851)) (114896 146785 (\TEDIT.EQFMTSPEC 114906 . 118121) (
|
||||
TEDIT.GET.PARALOOKS 118123 . 122170) (\TEDIT.PARSE.PARALOOKS.LIST 122172 . 130205) (TEDIT.PARALOOKS
|
||||
130207 . 131247) (\TEDIT.CHANGE.PARALOOKS 131249 . 138458) (\TEDIT.CHANGE.PARALOOKS.NEW 138460 .
|
||||
142443) (TEDIT.COPY.PARALOOKS 142445 . 145119) (\TEDIT.PARABOUNDS 145121 . 146783)) (146845 154561 (
|
||||
TEDIT.SUBPARALOOKS 146855 . 150957) (SAMEPARALOOKS 150959 . 154559)) (154562 155249 (
|
||||
\TEDIT.MARK.REVISION 154572 . 155247)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,14 +1,13 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "28-Jul-2025 23:25:19"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>working-medley>library>tedit>TEDIT-PCTREE.;249 69193
|
||||
(FILECREATED "14-Feb-2026 13:22:06" {WMEDLEY}<library>TEDIT>TEDIT-PCTREE.;251 68691
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (FNS \TEDIT.MAKEPCTB)
|
||||
:CHANGES-TO (VARS TEDIT-PCTREECOMS)
|
||||
(FNS \TEDIT.UNLINKPIECE \TEDIT.DELETEPIECES)
|
||||
|
||||
:PREVIOUS-DATE " 8-Feb-2025 20:56:54"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>working-medley>library>tedit>TEDIT-PCTREE.;248)
|
||||
:PREVIOUS-DATE "28-Jul-2025 23:25:19" {WMEDLEY}<library>TEDIT>TEDIT-PCTREE.;249)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT TEDIT-PCTREECOMS)
|
||||
@@ -37,8 +36,8 @@
|
||||
(GLOBALVARS MULTIPLE-PIECE-TABLES)
|
||||
(FNS \TEDIT.MAKEPCTB \TEDIT.UPDATEPCNODES \TEDIT.FIRSTPIECE \TEDIT.DELETETREE
|
||||
\TEDIT.INSERTTREE \TEDIT.LASTPIECE \TEDIT.PCTOCH \TEDIT.CHTOPC \TEDIT.SET-TOTLEN
|
||||
\TEDIT.MAKE.VACANT.BTREESLOT \TEDIT.LINKNEWPIECE \TEDIT.UNLINKPIECE \TEDIT.SPLITPIECE
|
||||
\TEDIT.INSERTPIECE \TEDIT.INSERTPIECES \TEDIT.DELETEPIECES \TEDIT.ALIGNEDPIECE)
|
||||
\TEDIT.MAKE.VACANT.BTREESLOT \TEDIT.LINKNEWPIECE \TEDIT.SPLITPIECE \TEDIT.INSERTPIECE
|
||||
\TEDIT.INSERTPIECES \TEDIT.DELETEPIECES \TEDIT.ALIGNEDPIECE)
|
||||
(COMS (* ; "Debugging ")
|
||||
(FNS \TEDIT.BTVALIDATE \TEDIT.BTVALIDATE.PRINT \TEDIT.CHECK-BTREE \TEDIT.CHECK-BTREE1
|
||||
\TEDIT.BTFAIL \TEDIT.MATCHPCS)
|
||||
@@ -658,20 +657,6 @@
|
||||
(freplace (PIECE PREVPIECE) of NEXT with NEW))
|
||||
NEW])
|
||||
|
||||
(\TEDIT.UNLINKPIECE
|
||||
[LAMBDA (PREV PC TEXTOBJ) (* ; "Edited 7-Feb-2025 08:04 by rmk")
|
||||
(* ; "Edited 21-Oct-2024 00:26 by rmk")
|
||||
(* ; "Edited 21-Oct-2023 17:24 by rmk")
|
||||
(* ; "Edited 30-May-2023 00:31 by rmk")
|
||||
|
||||
(* ;; "Takes PC out of the piece chain, linking prev and next around it.")
|
||||
|
||||
(\TEDIT.THELP 'NOTCALLED?)
|
||||
(CL:WHEN PREV
|
||||
(freplace (PIECE NEXTPIECE) of PREV with (NEXTPIECE PC)))
|
||||
(freplace (PIECE PREVPIECE) of (OR (NEXTPIECE PC)
|
||||
(FGETTOBJ TEXTOBJ SUFFIXPIECE)) with PREV])
|
||||
|
||||
(\TEDIT.SPLITPIECE
|
||||
[LAMBDA (PC CHOFFSET TEXTOBJ) (* ; "Edited 21-Oct-2024 00:33 by rmk")
|
||||
(* ; "Edited 17-Mar-2024 00:11 by rmk")
|
||||
@@ -838,7 +823,8 @@
|
||||
PIECES])
|
||||
|
||||
(\TEDIT.DELETEPIECES
|
||||
[LAMBDA (SELPIECES TEXTOBJ) (* ; "Edited 7-Feb-2025 08:08 by rmk")
|
||||
[LAMBDA (SELPIECES TEXTOBJ) (* ; "Edited 14-Feb-2026 13:20 by rmk")
|
||||
(* ; "Edited 7-Feb-2025 08:08 by rmk")
|
||||
(* ; "Edited 26-Nov-2024 10:50 by rmk")
|
||||
(* ; "Edited 16-Mar-2024 10:00 by rmk")
|
||||
(* ; "Edited 25-Nov-2023 12:12 by rmk")
|
||||
@@ -859,6 +845,11 @@
|
||||
(* ;; "This may not be entirely safe against an interrupt, which only matters on the call from \INSERTSELPIECES (otherwise the data isn't yet visible). Although the tree is consistent with the remaining pieces after each deletion, the fact that we keep the SELPIECE links intact means that the remaining pieces point to pieces that are no longer in the tree. We could do a little more work to incrementally chain the deleted pieces together, one by one, as they are deleted--in the end they would all be out of the tree, and the deletion chain would have been reconnected. Alternatively, we can make the whole loop be uninterruptable. ")
|
||||
|
||||
(\TEDIT.BTVALIDATE '\TEDIT.DELETEPIECES 'BEFORE TEXTOBJ)
|
||||
(CL:WHEN (type? PIECE SELPIECES)
|
||||
(SETQ SELPIECES (create SELPIECES
|
||||
SPFIRST _ SELPIECES
|
||||
SPLAST _ SELPIECES
|
||||
SPLEN _ (PLEN SELPIECES))))
|
||||
(for PC PREV NEXT first (FSETTOBJ TEXTOBJ HINTPC NIL)
|
||||
(SETQ PREV (PREVPIECE (GETSPC SELPIECES SPFIRST)))
|
||||
(* ; "For incremental chain-update")
|
||||
@@ -1113,13 +1104,13 @@
|
||||
(GLOBALVARS BTVALIDATETAGS)
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (8767 56719 (\TEDIT.MAKEPCTB 8777 . 10670) (\TEDIT.UPDATEPCNODES 10672 . 12966) (
|
||||
\TEDIT.FIRSTPIECE 12968 . 14375) (\TEDIT.DELETETREE 14377 . 17651) (\TEDIT.INSERTTREE 17653 . 20398) (
|
||||
\TEDIT.LASTPIECE 20400 . 21207) (\TEDIT.PCTOCH 21209 . 23306) (\TEDIT.CHTOPC 23308 . 29485) (
|
||||
\TEDIT.SET-TOTLEN 29487 . 30275) (\TEDIT.MAKE.VACANT.BTREESLOT 30277 . 37007) (\TEDIT.LINKNEWPIECE
|
||||
37009 . 38598) (\TEDIT.UNLINKPIECE 38600 . 39420) (\TEDIT.SPLITPIECE 39422 . 44078) (
|
||||
\TEDIT.INSERTPIECE 44080 . 47352) (\TEDIT.INSERTPIECES 47354 . 50446) (\TEDIT.DELETEPIECES 50448 .
|
||||
54602) (\TEDIT.ALIGNEDPIECE 54604 . 56717)) (56747 69070 (\TEDIT.BTVALIDATE 56757 . 58298) (
|
||||
\TEDIT.BTVALIDATE.PRINT 58300 . 59665) (\TEDIT.CHECK-BTREE 59667 . 61994) (\TEDIT.CHECK-BTREE1 61996
|
||||
. 67627) (\TEDIT.BTFAIL 67629 . 68051) (\TEDIT.MATCHPCS 68053 . 69068)))))
|
||||
(FILEMAP (NIL (8731 56217 (\TEDIT.MAKEPCTB 8741 . 10634) (\TEDIT.UPDATEPCNODES 10636 . 12930) (
|
||||
\TEDIT.FIRSTPIECE 12932 . 14339) (\TEDIT.DELETETREE 14341 . 17615) (\TEDIT.INSERTTREE 17617 . 20362) (
|
||||
\TEDIT.LASTPIECE 20364 . 21171) (\TEDIT.PCTOCH 21173 . 23270) (\TEDIT.CHTOPC 23272 . 29449) (
|
||||
\TEDIT.SET-TOTLEN 29451 . 30239) (\TEDIT.MAKE.VACANT.BTREESLOT 30241 . 36971) (\TEDIT.LINKNEWPIECE
|
||||
36973 . 38562) (\TEDIT.SPLITPIECE 38564 . 43220) (\TEDIT.INSERTPIECE 43222 . 46494) (
|
||||
\TEDIT.INSERTPIECES 46496 . 49588) (\TEDIT.DELETEPIECES 49590 . 54100) (\TEDIT.ALIGNEDPIECE 54102 .
|
||||
56215)) (56245 68568 (\TEDIT.BTVALIDATE 56255 . 57796) (\TEDIT.BTVALIDATE.PRINT 57798 . 59163) (
|
||||
\TEDIT.CHECK-BTREE 59165 . 61492) (\TEDIT.CHECK-BTREE1 61494 . 67125) (\TEDIT.BTFAIL 67127 . 67549) (
|
||||
\TEDIT.MATCHPCS 67551 . 68566)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,12 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "14-Jan-2026 14:32:01" {WMEDLEY}<library>tedit>TEDIT-SELECTION.;736 162073
|
||||
(FILECREATED "16-Feb-2026 00:38:33" {WMEDLEY}<library>TEDIT>TEDIT-SELECTION.;738 162152
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (FNS \TEDIT.COPYSEL TEDIT.SELPROP)
|
||||
:CHANGES-TO (FNS \TEDIT.SELPIECES.CHARTRANSFORM)
|
||||
|
||||
:PREVIOUS-DATE "10-Jan-2026 12:33:26" {WMEDLEY}<library>tedit>TEDIT-SELECTION.;735)
|
||||
:PREVIOUS-DATE "14-Jan-2026 14:32:01" {WMEDLEY}<library>tedit>TEDIT-SELECTION.;736)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT TEDIT-SELECTIONCOMS)
|
||||
@@ -2041,7 +2041,8 @@
|
||||
SPLASTCHAR _ (ffetch (SELPIECES SPLASTCHAR) of SP2])
|
||||
|
||||
(\TEDIT.SELPIECES.CHARTRANSFORM
|
||||
[LAMBDA (SELPIECES CHARFN OBJECTSTOO TSTREAM) (* ; "Edited 24-Apr-2025 16:02 by rmk")
|
||||
[LAMBDA (SELPIECES CHARFN OBJECTSTOO TSTREAM) (* ; "Edited 16-Feb-2026 00:38 by rmk")
|
||||
(* ; "Edited 24-Apr-2025 16:02 by rmk")
|
||||
(* ; "Edited 20-Apr-2025 23:23 by rmk")
|
||||
(* ; "Edited 16-Mar-2025 10:03 by rmk")
|
||||
(* ; "Edited 7-Nov-2024 21:50 by rmk")
|
||||
@@ -2066,10 +2067,10 @@
|
||||
|
||||
(* ;; "This assumes that no file piece has a PLEN greater than \MaxArrayLen characters. We rely on the piece-table reader and writer to guarantee this. If not, ALLOCSTRING will cause an error.")
|
||||
|
||||
[for I from 1 to (PLEN PC)
|
||||
do (RPLCHARCODE STR I (APPLY* CHARFN (\TEDIT.PIECE.NTHCHARCODE
|
||||
PC I)
|
||||
(add INDEX 1]
|
||||
[for I from 0 to (PLAST PC)
|
||||
do (RPLCHARCODE STR (ADD1 I)
|
||||
(APPLY* CHARFN (\TEDIT.PIECE.NTHCHARCODE PC I)
|
||||
(add INDEX 1]
|
||||
(if (fetch (STRINGP FATSTRINGP) of STR)
|
||||
then (FSETPC PC PTYPE FATSTRING.PTYPE)
|
||||
(FSETPC PC PBYTESPERCHAR 2)
|
||||
@@ -2570,26 +2571,26 @@
|
||||
(ADDTOVAR LAMA TEDIT.SELPROP)
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (15886 17707 (\TEDIT.SELECTION.DEFPRINT 15896 . 17705)) (17744 19249 (
|
||||
\TEDIT.SET.GLOBAL.SELECTIONS 17754 . 19247)) (19250 25471 (\TEDIT.SELECTED.PIECES 19260 . 20899) (
|
||||
\TEDIT.FIND.PROTECTED.END 20901 . 22695) (\TEDIT.FIND.PROTECTED.START 22697 . 24680) (
|
||||
\TEDIT.WORD.BOUND 24682 . 25469)) (25605 59712 (\TEDIT.EXTEND.SEL 25615 . 32855) (\TEDIT.SCAN.LINE
|
||||
32857 . 44530) (\TEDIT.SCAN.LINE.WORD 44532 . 49525) (\TEDIT.XYTOSEL 49527 . 56865) (\TEDIT.REGIONTYPE
|
||||
56867 . 57886) (\TEDIT.XYTOSEL.INLINEP 57888 . 58343) (\TEDIT.XYTOSEL.LINE 58345 . 59710)) (59713
|
||||
73258 (\TEDIT.FIXSEL 59723 . 69100) (\TEDIT.CHTOLINEX 69102 . 73256)) (73259 77463 (
|
||||
\TEDIT.RESET.EXTEND.PENDING.DELETE 73269 . 74547) (\TEDIT.SET.SEL.LOOKS 74549 . 77461)) (78400 99553 (
|
||||
\TEDIT.SHOWSEL 78410 . 83386) (\TEDIT.NOSEL 83388 . 83689) (\TEDIT.SEL.OFF 83691 . 84102) (
|
||||
\TEDIT.SEL.ON 84104 . 84520) (\TEDIT.SHOWSEL.HILIGHT 84522 . 89143) (\TEDIT.UPDATE.SEL 89145 . 93747)
|
||||
(\TEDIT.CARETLINE 93749 . 94463) (\TEDIT.SEL.L1 94465 . 95148) (\TEDIT.SEL.LN 95150 . 95833) (
|
||||
\TEDIT.SEL.DELETEDCHARS 95835 . 99551)) (99554 104436 (\TEDIT.COPYSEL 99564 . 102206) (
|
||||
\TEDIT.SEL.CHANGED? 102208 . 104434)) (104467 118126 (\TEDIT.SELECT.OBJECT 104477 . 109430) (
|
||||
\TEDIT.SHOWSEL.OBJECT 109432 . 111663) (\TEDIT.CLIP.OBJECT 111665 . 113669) (\TEDIT.OPERATE.OBJECT
|
||||
113671 . 118124)) (118154 137903 (\TEDIT.SELPIECES 118164 . 122445) (\TEDIT.SELPIECES.COPY 122447 .
|
||||
124936) (\TEDIT.SELPIECES.CONCAT 124938 . 126817) (\TEDIT.SELPIECES.CHARTRANSFORM 126819 . 130278) (
|
||||
\TEDIT.SELPIECES.FROM.STRING 130280 . 135538) (\TEDIT.SELPIECES.TO.STRING 135540 . 137901)) (137956
|
||||
161904 (TEDIT.XYTOCH 137966 . 140542) (TEDIT.SELPROP 140544 . 144821) (TEDIT.GETPOINT 144823 . 146743)
|
||||
(TEDIT.GETSEL 146745 . 147621) (TEDIT.GETSEL.PARA 147623 . 148572) (TEDIT.SCANSEL 148574 . 149522) (
|
||||
TEDIT.SET.SEL.LOOKS 149524 . 151009) (TEDIT.SETSEL 151011 . 155929) (TEDIT.SHOWSEL 155931 . 157795) (
|
||||
TEDIT.SEL.AS.STRING 157797 . 160282) (TEDIT.SEL.AS.SEXPR 160284 . 161570) (TEDIT.SELECTALL 161572 .
|
||||
161902)))))
|
||||
(FILEMAP (NIL (15888 17709 (\TEDIT.SELECTION.DEFPRINT 15898 . 17707)) (17746 19251 (
|
||||
\TEDIT.SET.GLOBAL.SELECTIONS 17756 . 19249)) (19252 25473 (\TEDIT.SELECTED.PIECES 19262 . 20901) (
|
||||
\TEDIT.FIND.PROTECTED.END 20903 . 22697) (\TEDIT.FIND.PROTECTED.START 22699 . 24682) (
|
||||
\TEDIT.WORD.BOUND 24684 . 25471)) (25607 59714 (\TEDIT.EXTEND.SEL 25617 . 32857) (\TEDIT.SCAN.LINE
|
||||
32859 . 44532) (\TEDIT.SCAN.LINE.WORD 44534 . 49527) (\TEDIT.XYTOSEL 49529 . 56867) (\TEDIT.REGIONTYPE
|
||||
56869 . 57888) (\TEDIT.XYTOSEL.INLINEP 57890 . 58345) (\TEDIT.XYTOSEL.LINE 58347 . 59712)) (59715
|
||||
73260 (\TEDIT.FIXSEL 59725 . 69102) (\TEDIT.CHTOLINEX 69104 . 73258)) (73261 77465 (
|
||||
\TEDIT.RESET.EXTEND.PENDING.DELETE 73271 . 74549) (\TEDIT.SET.SEL.LOOKS 74551 . 77463)) (78402 99555 (
|
||||
\TEDIT.SHOWSEL 78412 . 83388) (\TEDIT.NOSEL 83390 . 83691) (\TEDIT.SEL.OFF 83693 . 84104) (
|
||||
\TEDIT.SEL.ON 84106 . 84522) (\TEDIT.SHOWSEL.HILIGHT 84524 . 89145) (\TEDIT.UPDATE.SEL 89147 . 93749)
|
||||
(\TEDIT.CARETLINE 93751 . 94465) (\TEDIT.SEL.L1 94467 . 95150) (\TEDIT.SEL.LN 95152 . 95835) (
|
||||
\TEDIT.SEL.DELETEDCHARS 95837 . 99553)) (99556 104438 (\TEDIT.COPYSEL 99566 . 102208) (
|
||||
\TEDIT.SEL.CHANGED? 102210 . 104436)) (104469 118128 (\TEDIT.SELECT.OBJECT 104479 . 109432) (
|
||||
\TEDIT.SHOWSEL.OBJECT 109434 . 111665) (\TEDIT.CLIP.OBJECT 111667 . 113671) (\TEDIT.OPERATE.OBJECT
|
||||
113673 . 118126)) (118156 137982 (\TEDIT.SELPIECES 118166 . 122447) (\TEDIT.SELPIECES.COPY 122449 .
|
||||
124938) (\TEDIT.SELPIECES.CONCAT 124940 . 126819) (\TEDIT.SELPIECES.CHARTRANSFORM 126821 . 130357) (
|
||||
\TEDIT.SELPIECES.FROM.STRING 130359 . 135617) (\TEDIT.SELPIECES.TO.STRING 135619 . 137980)) (138035
|
||||
161983 (TEDIT.XYTOCH 138045 . 140621) (TEDIT.SELPROP 140623 . 144900) (TEDIT.GETPOINT 144902 . 146822)
|
||||
(TEDIT.GETSEL 146824 . 147700) (TEDIT.GETSEL.PARA 147702 . 148651) (TEDIT.SCANSEL 148653 . 149601) (
|
||||
TEDIT.SET.SEL.LOOKS 149603 . 151088) (TEDIT.SETSEL 151090 . 156008) (TEDIT.SHOWSEL 156010 . 157874) (
|
||||
TEDIT.SEL.AS.STRING 157876 . 160361) (TEDIT.SEL.AS.SEXPR 160363 . 161649) (TEDIT.SELECTALL 161651 .
|
||||
161981)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,13 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "26-Jan-2026 23:58:48" {WMEDLEY}<library>tedit>TEDIT-STREAM.;936 194450
|
||||
(FILECREATED "16-Feb-2026 12:40:44" {WMEDLEY}<library>tedit>TEDIT-STREAM.;944 193110
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (VARS TEDIT-STREAMCOMS)
|
||||
(FNS TEDIT.IMAGESTREAM.OPEN \TEDIT.STREAMINIT \TEDIT.TEXTINIT)
|
||||
:CHANGES-TO (FNS \TEDIT.STREAMINIT)
|
||||
|
||||
:PREVIOUS-DATE "14-Jan-2026 14:32:01" {WMEDLEY}<library>tedit>TEDIT-STREAM.;933)
|
||||
:PREVIOUS-DATE "16-Feb-2026 09:39:00" {WMEDLEY}<library>tedit>TEDIT-STREAM.;943)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT TEDIT-STREAMCOMS)
|
||||
@@ -15,8 +14,8 @@
|
||||
(RPAQQ TEDIT-STREAMCOMS
|
||||
[(DECLARE%: EVAL@COMPILE DONTCOPY
|
||||
(EXPORT (RECORDS PIECE TEXTOBJ TEXTSTREAM)
|
||||
(MACROS NEXTPIECE PREVPIECE PLEN PTYPE PCONTENTS PCHARLOOKS PCHARSET PPARALOOKS
|
||||
PPARALAST PFPOS PBYTELEN PNEW PBINABLE PBYTESPERCHAR POBJ)
|
||||
(MACROS NEXTPIECE PREVPIECE PLEN PLAST PTYPE PCONTENTS PCHARLOOKS PCHARSET
|
||||
PPARALOOKS PPARALAST PFPOS PBYTELEN PNEW PBINABLE PBYTESPERCHAR POBJ)
|
||||
(MACROS SETPC FSETPC GETPC FGETPC)
|
||||
(MACROS THINPIECEP)
|
||||
(MACROS VISIBLEPIECEP \NEXT.VISIBLE.PIECE \PREV.VISIBLE.PIECE)
|
||||
@@ -72,10 +71,7 @@
|
||||
(MACROS \INSERTCH.EXTENDABLE))
|
||||
(FNS \TEDIT.DELETE.SELPIECES \TEDIT.INSERTCH \TEDIT.INSERTCH.HISTORY \TEDIT.INSERTEOL
|
||||
\TEDIT.INSERTCH.INSERTION \TEDIT.INSERTCH.EXTEND)
|
||||
(FNS \TEDIT.NEXTCHANGEABLE.CHNO \TEDIT.LASTCHANGEABLE.CHNO)
|
||||
(FNS \SETUPGETCH))
|
||||
(* ;
|
||||
"Deprecated, maybe still external callers")
|
||||
(FNS \TEDIT.NEXTCHANGEABLE.CHNO \TEDIT.LASTCHANGEABLE.CHNO))
|
||||
(FNS \TEDIT.INSTALL.PIECE)
|
||||
[COMS (* ; "Support for TEXTPROP")
|
||||
(FNS TEXTPROP GETTEXTPROP PUTTEXTPROP GETTEXTPROPS PUTTEXTPROPS TEXTPROP.ADD
|
||||
@@ -397,6 +393,9 @@
|
||||
(PUTPROPS PLEN MACRO ((PC)
|
||||
(ffetch (PIECE PLEN) of PC)))
|
||||
|
||||
(PUTPROPS PLAST MACRO ((PC)
|
||||
(SUB1 (PLEN PC))))
|
||||
|
||||
(PUTPROPS PTYPE MACRO ((PC)
|
||||
(ffetch (PIECE PTYPE) of PC)))
|
||||
|
||||
@@ -924,7 +923,8 @@
|
||||
else (STREAMOP 'ENDOFSTREAMOP TSTREAM TSTREAM])
|
||||
|
||||
(\TEDIT.TEXTBACKFILEPTR
|
||||
[LAMBDA (TSTREAM) (* ; "Edited 21-Oct-2024 00:33 by rmk")
|
||||
[LAMBDA (TSTREAM) (* ; "Edited 16-Feb-2026 08:54 by rmk")
|
||||
(* ; "Edited 21-Oct-2024 00:33 by rmk")
|
||||
(* ; "Edited 1-Feb-2024 11:25 by rmk")
|
||||
(* ; "Edited 5-Jan-2024 17:57 by rmk")
|
||||
(* ; "Edited 28-Dec-2023 13:34 by rmk")
|
||||
@@ -956,7 +956,7 @@
|
||||
then (CL:WHEN (SETQ PPC (\PREV.VISIBLE.PIECE PC))
|
||||
(* ;
|
||||
"Back up to last char of previous piece, if any.")
|
||||
(\TEDIT.INSTALL.PIECE TSTREAM PPC (SUB1 (PLEN PPC)))
|
||||
(\TEDIT.INSTALL.PIECE TSTREAM PPC (PLAST PPC))
|
||||
(SETQ PC PPC))
|
||||
elseif (AND (MEMB (PTYPE PC)
|
||||
FILE.PTYPES)
|
||||
@@ -1760,7 +1760,8 @@
|
||||
(DEFINEQ
|
||||
|
||||
(\TEDIT.STREAMINIT
|
||||
[LAMBDA NIL (* ; "Edited 26-Jan-2026 16:06 by rmk")
|
||||
[LAMBDA NIL (* ; "Edited 16-Feb-2026 12:40 by rmk")
|
||||
(* ; "Edited 26-Jan-2026 16:06 by rmk")
|
||||
(* ; "Edited 23-Sep-2025 21:03 by rmk")
|
||||
(* ; "Edited 20-Sep-2025 08:48 by rmk")
|
||||
(* ; "Edited 18-Sep-2025 14:52 by rmk")
|
||||
@@ -1817,7 +1818,7 @@
|
||||
|
||||
(* ;; "Maybe more functions later. The INCODE and BACK functions possibly need to count. If \TEXTBACKFILEPTR takes a count variable, the extra level wouldn't be needed. But INCCODE wants to go through the BIN opcode")
|
||||
|
||||
(MAKE-EXTERNALFORMAT :TEXTSTREAM (FUNCTION \TEDIT.TEXTINCCODEFN)
|
||||
(MAKE-EXTERNALFORMAT :TEDIT (FUNCTION \TEDIT.TEXTINCCODEFN)
|
||||
(FUNCTION \TEDIT.TEXTPEEKBIN)
|
||||
(FUNCTION \TEDIT.TEXTBACKCCODEFN)
|
||||
(FUNCTION \TEDIT.TEXTOUTCHARFN)
|
||||
@@ -1860,8 +1861,7 @@
|
||||
FDEXTENDABLE _ NIL
|
||||
TRUNCATEFILE _ (FUNCTION NILL)
|
||||
WRITEPAGES _ (FUNCTION NILL)
|
||||
DEFAULTEXTERNALFORMAT _ :TEXTSTREAM))
|
||||
(* ;
|
||||
DEFAULTEXTERNALFORMAT _ :TEDIT)) (* ;
|
||||
"Only load once, not every time TEDIT-STREAM is loaded e.g. in development")
|
||||
(RPAQ? *TEDIT-OLD-STREAM-ERROR-HANDLER* (CONDITION-HANDLER 'XCL:STREAM-NOT-OPEN))
|
||||
(CL:SETF (CONDITION-HANDLER 'XCL:STREAM-NOT-OPEN)
|
||||
@@ -2256,7 +2256,8 @@
|
||||
(DEFINEQ
|
||||
|
||||
(\TEDIT.NTHCHARCODE
|
||||
[LAMBDA (TSTREAM N) (* ; "Edited 24-Apr-2025 16:03 by rmk")
|
||||
[LAMBDA (TSTREAM N) (* ; "Edited 15-Feb-2026 14:40 by rmk")
|
||||
(* ; "Edited 24-Apr-2025 16:03 by rmk")
|
||||
(* ; "Edited 28-Mar-2025 18:31 by rmk")
|
||||
(* ; "Edited 7-Jul-2024 11:09 by rmk")
|
||||
(* ; "Edited 29-Apr-2024 13:06 by rmk")
|
||||
@@ -2273,11 +2274,11 @@
|
||||
(CL:WHEN (AND (IGEQ N 1)
|
||||
(ILEQ N (FGETTOBJ TEXTOBJ TEXTLEN)))
|
||||
(\TEDIT.PIECE.NTHCHARCODE (\TEDIT.CHTOPC N TEXTOBJ T)
|
||||
(IDIFFERENCE (ADD1 N)
|
||||
START-OF-PIECE)))])
|
||||
(IDIFFERENCE N START-OF-PIECE)))])
|
||||
|
||||
(\TEDIT.PIECE.NTHCHARCODE
|
||||
[LAMBDA (PC OFFSET) (* ; "Edited 24-Apr-2025 16:04 by rmk")
|
||||
[LAMBDA (PC OFFSET) (* ; "Edited 15-Feb-2026 14:31 by rmk")
|
||||
(* ; "Edited 24-Apr-2025 16:04 by rmk")
|
||||
(* ; "Edited 21-Oct-2024 00:26 by rmk")
|
||||
(* ; "Edited 29-Apr-2024 08:46 by rmk")
|
||||
(* ; "Edited 22-Mar-2024 00:02 by rmk")
|
||||
@@ -2289,24 +2290,24 @@
|
||||
(* ; "Edited 8-Nov-2023 08:43 by rmk")
|
||||
(* ; "Edited 5-Nov-2023 08:17 by rmk")
|
||||
|
||||
(* ;; "Returns the OFFSETth charcode of PC, NIL if OFFSET is out of bounds. For file pieces, ensures that the backing stream is restored to its original position, so that it remains comaptible with the values (buffer, offset) in the textstream.")
|
||||
(* ;; "Returns the OFFSETth charcode of PC, NIL if OFFSET is out of bounds. For file pieces, ensures that the backing stream is restored to its original position, so that it remains comaptible with the values (buffer, offset) in the textstream. OFFSET ranges from 0 to PLEN-1.")
|
||||
|
||||
(CL:WHEN (AND (IGEQ OFFSET 1)
|
||||
(ILEQ OFFSET (PLEN PC)))
|
||||
(CL:WHEN (AND (IGEQ OFFSET 0)
|
||||
(ILESSP OFFSET (PLEN PC)))
|
||||
[LET ((PCONTENTS (PCONTENTS PC))
|
||||
FILEPOS)
|
||||
(SELECTC (PTYPE PC)
|
||||
(STRING.PTYPES (NTHCHARCODE PCONTENTS OFFSET))
|
||||
(STRING.PTYPES (NTHCHARCODE PCONTENTS (ADD1 OFFSET)))
|
||||
(THINFILE.PTYPE
|
||||
(SETQ FILEPOS (\GETFILEPTR PCONTENTS))
|
||||
(\SETFILEPTR PCONTENTS (IPLUS (PFPOS PC)
|
||||
(SUB1 OFFSET)))
|
||||
OFFSET))
|
||||
(PROG1 (BIN PCONTENTS)
|
||||
(\SETFILEPTR PCONTENTS FILEPOS)))
|
||||
(FATFILE1.PTYPE
|
||||
(SETQ FILEPOS (\GETFILEPTR PCONTENTS))
|
||||
(\SETFILEPTR PCONTENTS (IPLUS (PFPOS PC)
|
||||
(SUB1 OFFSET)))
|
||||
OFFSET))
|
||||
(PROG1 (create WORD
|
||||
HIBYTE _ (PCHARSET PC)
|
||||
LOBYTE _ (BIN PCONTENTS))
|
||||
@@ -2314,14 +2315,12 @@
|
||||
(FATFILE2.PTYPE
|
||||
(SETQ FILEPOS (\GETFILEPTR PCONTENTS))
|
||||
(\SETFILEPTR PCONTENTS (IPLUS (PFPOS PC)
|
||||
(UNFOLD (SUB1 OFFSET)
|
||||
2)))
|
||||
(UNFOLD OFFSET 2)))
|
||||
(PROG1 (\WIN PCONTENTS)
|
||||
(\SETFILEPTR PCONTENTS FILEPOS)))
|
||||
(UTF8.PTYPE (SETQ FILEPOS (\GETFILEPTR PCONTENTS))
|
||||
[\SETFILEPTR PCONTENTS (IPLUS (PFPOS PC)
|
||||
(ITIMES (SUB1 OFFSET)
|
||||
(PBYTESPERCHAR PC]
|
||||
(ITIMES OFFSET (PBYTESPERCHAR PC]
|
||||
(PROG1 (UTF8.INCCODEFN PCONTENTS)
|
||||
(\SETFILEPTR PCONTENTS FILEPOS)))
|
||||
(OBJECT.PTYPE PCONTENTS)
|
||||
@@ -2334,7 +2333,8 @@
|
||||
(\TEDIT.THELP '\TEDIT.PIECE.NTHCHARCODE])])
|
||||
|
||||
(\TEDIT.RPLCHARCODE
|
||||
[LAMBDA (TSTREAM N NEWCHARCODE NEWCHARLOOKS DONTDISPLAY) (* ; "Edited 24-Apr-2025 17:24 by rmk")
|
||||
[LAMBDA (TSTREAM N NEWCHARCODE NEWCHARLOOKS DONTDISPLAY) (* ; "Edited 16-Feb-2026 08:37 by rmk")
|
||||
(* ; "Edited 24-Apr-2025 17:24 by rmk")
|
||||
(* ; "Edited 20-Apr-2025 13:25 by rmk")
|
||||
(* ; "Edited 28-Mar-2025 10:04 by rmk")
|
||||
|
||||
@@ -2350,16 +2350,17 @@
|
||||
(DECLARE (SPECVARS START-OF-PIECE))
|
||||
(replace (STREAM BINABLE) of TSTREAM with NIL)
|
||||
(SETQ OLDCHAR (\TEDIT.PIECE.RPLCHARCODE TEXTOBJ (\TEDIT.CHTOPC N TEXTOBJ T)
|
||||
(ADD1 (IDIFFERENCE N START-OF-PIECE))
|
||||
(IDIFFERENCE N START-OF-PIECE)
|
||||
NEWCHARCODE NEWCHARLOOKS))
|
||||
(\TEDIT.HISTORYADD TEXTOBJ (\TEDIT.HISTORY.EVENT TEXTOBJ :ReplaceCode N NIL NIL NIL
|
||||
(\TEDIT.HISTORYADD TEXTOBJ (\TEDIT.HISTORY.EVENT TEXTOBJ :ReplaceCode N 1 NIL NIL
|
||||
OLDCHAR))
|
||||
(CL:UNLESS (OR DONTDISPLAY (NOT (\TEDIT.PRIMARYPANE TEXTOBJ)))
|
||||
(\TEDIT.UPDATE.LINES TSTREAM 'CHANGED N 1))
|
||||
TSTREAM))])
|
||||
|
||||
(\TEDIT.PIECE.RPLCHARCODE
|
||||
[LAMBDA (TEXTOBJ PC OFFSET NEWCHARCODE NEWCHARLOOKS) (* ; "Edited 28-Jul-2025 23:38 by rmk")
|
||||
[LAMBDA (TEXTOBJ PC OFFSET NEWCHARCODE NEWCHARLOOKS) (* ; "Edited 16-Feb-2026 08:41 by rmk")
|
||||
(* ; "Edited 28-Jul-2025 23:38 by rmk")
|
||||
(* ; "Edited 24-Apr-2025 16:30 by rmk")
|
||||
(* ; "Edited 20-Apr-2025 13:25 by rmk")
|
||||
(* ; "Edited 28-Mar-2025 10:04 by rmk")
|
||||
@@ -2384,12 +2385,13 @@
|
||||
"Fast case: Smash a new character code into an existing string piece with same looks. ")
|
||||
|
||||
(SETQ OLDCHAR (NTHCHARCODE (PCONTENTS PC)
|
||||
OFFSET))
|
||||
(ADD1 OFFSET)))
|
||||
(RPLCHARCODE (PCONTENTS PC)
|
||||
OFFSET NEWCHARCODE) (* ;
|
||||
(ADD1 OFFSET)
|
||||
NEWCHARCODE) (* ;
|
||||
"May upgrade string from thin to fat")
|
||||
(CL:WHEN (AND (EQ THINSTRING.PTYPE (PTYPE PC))
|
||||
(IGREATERP NEWCHARCODE 255))
|
||||
(IGREATERP NEWCHARCODE \MAXTHINCHAR))
|
||||
(FSETPC PC PTYPE FATSTRING.PTYPE)
|
||||
(FSETPC PC PBINABLE NIL)
|
||||
(FSETPC PC PBYTESPERCHAR 2)
|
||||
@@ -2403,24 +2405,25 @@
|
||||
(FSETPC PC PCONTENTS NEWCHARCODE)
|
||||
else
|
||||
(* ;;
|
||||
"PC contained character OFFSET now becomes the suffix of characters after offset.")
|
||||
"The PC that contained character OFFSET now becomes the suffix of characters after offset.")
|
||||
|
||||
(CL:UNLESS (IEQP OFFSET (PLEN PC)) (* ; "No suffix for the last character")
|
||||
(CL:UNLESS (IEQP OFFSET (PLAST PC)) (* ; "No suffix for the last character")
|
||||
|
||||
(* ;;
|
||||
"Chop off the suffix (essentially (\TEDIT.ALIGNEDPIECE CHNO ..) but we already have the piece")
|
||||
|
||||
(\TEDIT.SPLITPIECE PC OFFSET TEXTOBJ)
|
||||
(\TEDIT.SPLITPIECE PC (ADD1 OFFSET)
|
||||
TEXTOBJ)
|
||||
(SETQ PC (PREVPIECE PC))) (* ;
|
||||
"Original PC holds the suffix, new PC ends with change position.")
|
||||
(CL:UNLESS (EQ OFFSET 1)
|
||||
(CL:UNLESS (EQ OFFSET 0)
|
||||
(SETQ PC (\TEDIT.SPLITPIECE PC (SUB1 OFFSET)
|
||||
TEXTOBJ))) (* ;
|
||||
"Chop off the prefix. PC is now the singleton target ")
|
||||
|
||||
(* ;; "OFFSET is now isolated into a one-character new piece which we smash. ")
|
||||
|
||||
(SETQ OLDCHAR (\TEDIT.PIECE.NTHCHARCODE PC 1))
|
||||
(SETQ OLDCHAR (\TEDIT.PIECE.NTHCHARCODE PC 0))
|
||||
(if (IMAGEOBJP NEWCHARCODE)
|
||||
then (FSETPC PC PBINABLE NIL)
|
||||
(FSETPC PC PCONTENTS NEWCHARCODE)
|
||||
@@ -2430,7 +2433,7 @@
|
||||
else (FSETPC PC PCONTENTS (MKSTRING (CHARACTER NEWCHARCODE)))
|
||||
(* ;
|
||||
"Use the extend-string in INSERTCH for repeated calls?")
|
||||
(if (IGREATERP NEWCHARCODE 255)
|
||||
(if (IGREATERP NEWCHARCODE \MAXTHINCHAR)
|
||||
then (FSETPC PC PTYPE FATSTRING.PTYPE)
|
||||
(FSETPC PC PBINABLE NIL)
|
||||
(FSETPC PC PBYTESPERCHAR 2)
|
||||
@@ -2817,7 +2820,8 @@
|
||||
else (SUB1 (\TEDIT.PCTOCH PC TEXTOBJ])
|
||||
|
||||
(\TEDIT.LASTCHANGEABLE.CHNO
|
||||
[LAMBDA (CHNO TEXTOBJ) (* ; "Edited 26-Nov-2024 00:00 by rmk")
|
||||
[LAMBDA (CHNO TEXTOBJ) (* ; "Edited 16-Feb-2026 08:53 by rmk")
|
||||
(* ; "Edited 26-Nov-2024 00:00 by rmk")
|
||||
|
||||
(* ;; "Returns the number of the first visible character at or before CHNO, NIL if the first visible character is protected. Almost always CHNO--PCTOCH is the unusual case.")
|
||||
|
||||
@@ -2826,46 +2830,11 @@
|
||||
CLPROTECTED) when (VISIBLEPIECEP PC)
|
||||
do (RETURN (if (EQ PC FIRSTPIECE)
|
||||
then CHNO
|
||||
else (IPLUS (SUB1 (PLEN PC))
|
||||
else (IPLUS (PLAST PC)
|
||||
(\TEDIT.PCTOCH PC TEXTOBJ])
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
(\SETUPGETCH
|
||||
[LAMBDA (CH# TEXTOBJ) (* ; "Edited 21-Oct-2024 00:26 by rmk")
|
||||
(* ; "Edited 29-Apr-2024 12:14 by rmk")
|
||||
(* ; "Edited 17-Mar-2024 00:27 by rmk")
|
||||
(* ; "Edited 23-Dec-2023 12:14 by rmk")
|
||||
(* ; "Edited 22-Aug-2022 13:04 by rmk")
|
||||
(* ; "Edited 10-Aug-2022 17:20 by rmk")
|
||||
(* ; "Edited 8-Aug-2022 15:07 by rmk")
|
||||
(* ; "Edited 31-Jul-2022 21:27 by rmk")
|
||||
(* ; "Edited 14-Apr-93 17:14 by jds")
|
||||
|
||||
(* ;;; "Set up TEXTOBJ so that the next \GETCH will retrieve character # CH#")
|
||||
|
||||
(* ;; "NB that 1st char in the textobj is #1.")
|
||||
|
||||
(* ;; "NOBODY CALLS IT WITH A PIECE. CALLS |INSTALL.PIECE INSTEAD")
|
||||
|
||||
(SETQ TEXTOBJ (TEXTOBJ))
|
||||
(LET ((TSTREAM (TEXTSTREAM TEXTOBJ)))
|
||||
(COND
|
||||
((TYPE? PIECE CH#)
|
||||
(\TEDIT.THELP "\SETUPGETCH CALLED WITH PIECE")
|
||||
(\TEDIT.INSTALL.PIECE TSTREAM CH# 0))
|
||||
(T (LET (START-OF-PIECE PC)
|
||||
(DECLARE (SPECVARS START-OF-PIECE))
|
||||
(SETQ PC (\TEDIT.CHTOPC CH# TEXTOBJ T))
|
||||
(\TEDIT.INSTALL.PIECE TSTREAM PC (- CH# START-OF-PIECE])
|
||||
)
|
||||
|
||||
|
||||
|
||||
(* ; "Deprecated, maybe still external callers")
|
||||
|
||||
(DEFINEQ
|
||||
|
||||
(\TEDIT.INSTALL.PIECE
|
||||
[LAMBDA (TSTREAM PC CHOFFSET) (* ; "Edited 21-Oct-2024 00:26 by rmk")
|
||||
(* ; "Edited 18-May-2024 22:39 by rmk")
|
||||
@@ -3158,34 +3127,33 @@
|
||||
(ADDTOVAR LAMA TEXTPROP)
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (36872 67731 (\TEDIT.TEXTBIN 36882 . 47675) (\TEDIT.TEXTPEEKBIN 47677 . 53227) (
|
||||
\TEDIT.TEXTBACKFILEPTR 53229 . 58902) (\TEDIT.TEXTBOUT 58904 . 63521) (\TEDIT.INSTALL.FILEBUFFER 63523
|
||||
. 67729)) (68629 72920 (\TEDIT.TEXTOUTCHARFN 68639 . 70195) (\TEDIT.TEXTINCCODEFN 70197 . 70936) (
|
||||
\TEDIT.TEXTBACKCCODEFN 70938 . 71530) (\TEDIT.TEXTFORMATBYTESTREAM 71532 . 72369) (
|
||||
\TEDIT.TEXTFORMATBYTESTRING 72371 . 72918)) (72967 85042 (OPENTEXTSTREAM 72977 . 79953) (
|
||||
COPYTEXTSTREAM 79955 . 84265) (TEDIT.STREAMCHANGEDP 84267 . 84569) (TXTFILE 84571 . 85040)) (85043
|
||||
108248 (\TEDIT.REOPENTEXTSTREAM 85053 . 86405) (\TEDIT.OPENTEXTSTREAM.PIECES 86407 . 91335) (
|
||||
\TEDIT.OPENTEXTSTREAM.PROPS 91337 . 92439) (\TEDIT.OPENTEXTSTREAM.SETUP.SEL 92441 . 97891) (
|
||||
\TEDIT.OPENTEXTSTREAM.WINDOW 97893 . 100684) (\TEDIT.OPENTEXTSTREAM.DEFAULTLOOKS 100686 . 102625) (
|
||||
\TEDIT.OPENTEXTFILE 102627 . 104759) (\TEDIT.CREATE.TEXTSTREAM 104761 . 105908) (\TEDIT.REOPEN.STREAM
|
||||
105910 . 108246)) (108249 116436 (\TEDIT.STREAMINIT 108259 . 116253) (TEDIT.IMAGESTREAM.OPEN 116255 .
|
||||
116434)) (116624 117812 (\TEDIT.TTYBOUT 116634 . 117810)) (117930 139613 (\TEDIT.TEXTCLOSEF 117940 .
|
||||
119264) (\TEDIT.TEXTDSPFONT 119266 . 120464) (\TEDIT.TEXTEOFP 120466 . 122221) (\TEDIT.TEXTGETEOFPTR
|
||||
122223 . 122546) (\TEDIT.TEXTSETEOFPTR 122548 . 123835) (\TEDIT.TEXTGETFILEPTR 123837 . 126672) (
|
||||
\TEDIT.TEXTSETFILEINFO 126674 . 127182) (\TEDIT.TEXTOPENF 127184 . 128115) (\TEDIT.TEXTSETEOF 128117
|
||||
. 128733) (\TEDIT.TEXTSETFILEPTR 128735 . 130845) (\TEDIT.TEXTDSPXPOSITION 130847 . 133550) (
|
||||
\TEDIT.TEXTDSPYPOSITION 133552 . 134293) (\TEDIT.TEXTLEFTMARGIN 134295 . 134886) (\TEDIT.TEXTCOLOR
|
||||
134888 . 135471) (\TEDIT.TEXTRIGHTMARGIN 135473 . 138762) (\TEDIT.TEXTDSPCHARWIDTH 138764 . 139068) (
|
||||
\TEDIT.TEXTDSPSTRINGWIDTH 139070 . 139376) (\TEDIT.TEXTDSPLINEFEED 139378 . 139611)) (139651 152264 (
|
||||
\TEDIT.NTHCHARCODE 139661 . 141112) (\TEDIT.PIECE.NTHCHARCODE 141114 . 145024) (\TEDIT.RPLCHARCODE
|
||||
145026 . 146484) (\TEDIT.PIECE.RPLCHARCODE 146486 . 151909) (\TEDIT.NTHCHARLOOKS 151911 . 152262)) (
|
||||
153311 174405 (\TEDIT.DELETE.SELPIECES 153321 . 156946) (\TEDIT.INSERTCH 156948 . 164987) (
|
||||
\TEDIT.INSERTCH.HISTORY 164989 . 168453) (\TEDIT.INSERTEOL 168455 . 170280) (\TEDIT.INSERTCH.INSERTION
|
||||
170282 . 173119) (\TEDIT.INSERTCH.EXTEND 173121 . 174403)) (174406 175910 (\TEDIT.NEXTCHANGEABLE.CHNO
|
||||
174416 . 175131) (\TEDIT.LASTCHANGEABLE.CHNO 175133 . 175908)) (175911 177615 (\SETUPGETCH 175921 .
|
||||
177613)) (177673 182131 (\TEDIT.INSTALL.PIECE 177683 . 182129)) (182169 191635 (TEXTPROP 182179 .
|
||||
182526) (GETTEXTPROP 182528 . 182772) (PUTTEXTPROP 182774 . 183031) (GETTEXTPROPS 183033 . 183477) (
|
||||
PUTTEXTPROPS 183479 . 184383) (TEXTPROP.ADD 184385 . 184648) (\TEDIT.TEXTPROP 184650 . 191633)) (
|
||||
191636 194013 (\TEDIT.TEXTOBJ.PROPNAMES 191646 . 192905) (\TEDIT.TEXTOBJ.PROPFETCHFN 192907 . 193423)
|
||||
(\TEDIT.TEXTOBJ.PROPSTOREFN 193425 . 194011)))))
|
||||
(FILEMAP (NIL (36667 67629 (\TEDIT.TEXTBIN 36677 . 47470) (\TEDIT.TEXTPEEKBIN 47472 . 53022) (
|
||||
\TEDIT.TEXTBACKFILEPTR 53024 . 58800) (\TEDIT.TEXTBOUT 58802 . 63419) (\TEDIT.INSTALL.FILEBUFFER 63421
|
||||
. 67627)) (68527 72818 (\TEDIT.TEXTOUTCHARFN 68537 . 70093) (\TEDIT.TEXTINCCODEFN 70095 . 70834) (
|
||||
\TEDIT.TEXTBACKCCODEFN 70836 . 71428) (\TEDIT.TEXTFORMATBYTESTREAM 71430 . 72267) (
|
||||
\TEDIT.TEXTFORMATBYTESTRING 72269 . 72816)) (72865 84940 (OPENTEXTSTREAM 72875 . 79851) (
|
||||
COPYTEXTSTREAM 79853 . 84163) (TEDIT.STREAMCHANGEDP 84165 . 84467) (TXTFILE 84469 . 84938)) (84941
|
||||
108146 (\TEDIT.REOPENTEXTSTREAM 84951 . 86303) (\TEDIT.OPENTEXTSTREAM.PIECES 86305 . 91233) (
|
||||
\TEDIT.OPENTEXTSTREAM.PROPS 91235 . 92337) (\TEDIT.OPENTEXTSTREAM.SETUP.SEL 92339 . 97789) (
|
||||
\TEDIT.OPENTEXTSTREAM.WINDOW 97791 . 100582) (\TEDIT.OPENTEXTSTREAM.DEFAULTLOOKS 100584 . 102523) (
|
||||
\TEDIT.OPENTEXTFILE 102525 . 104657) (\TEDIT.CREATE.TEXTSTREAM 104659 . 105806) (\TEDIT.REOPEN.STREAM
|
||||
105808 . 108144)) (108147 116372 (\TEDIT.STREAMINIT 108157 . 116189) (TEDIT.IMAGESTREAM.OPEN 116191 .
|
||||
116370)) (116560 117748 (\TEDIT.TTYBOUT 116570 . 117746)) (117866 139549 (\TEDIT.TEXTCLOSEF 117876 .
|
||||
119200) (\TEDIT.TEXTDSPFONT 119202 . 120400) (\TEDIT.TEXTEOFP 120402 . 122157) (\TEDIT.TEXTGETEOFPTR
|
||||
122159 . 122482) (\TEDIT.TEXTSETEOFPTR 122484 . 123771) (\TEDIT.TEXTGETFILEPTR 123773 . 126608) (
|
||||
\TEDIT.TEXTSETFILEINFO 126610 . 127118) (\TEDIT.TEXTOPENF 127120 . 128051) (\TEDIT.TEXTSETEOF 128053
|
||||
. 128669) (\TEDIT.TEXTSETFILEPTR 128671 . 130781) (\TEDIT.TEXTDSPXPOSITION 130783 . 133486) (
|
||||
\TEDIT.TEXTDSPYPOSITION 133488 . 134229) (\TEDIT.TEXTLEFTMARGIN 134231 . 134822) (\TEDIT.TEXTCOLOR
|
||||
134824 . 135407) (\TEDIT.TEXTRIGHTMARGIN 135409 . 138698) (\TEDIT.TEXTDSPCHARWIDTH 138700 . 139004) (
|
||||
\TEDIT.TEXTDSPSTRINGWIDTH 139006 . 139312) (\TEDIT.TEXTDSPLINEFEED 139314 . 139547)) (139587 152583 (
|
||||
\TEDIT.NTHCHARCODE 139597 . 141123) (\TEDIT.PIECE.NTHCHARCODE 141125 . 145033) (\TEDIT.RPLCHARCODE
|
||||
145035 . 146593) (\TEDIT.PIECE.RPLCHARCODE 146595 . 152228) (\TEDIT.NTHCHARLOOKS 152230 . 152581)) (
|
||||
153630 174724 (\TEDIT.DELETE.SELPIECES 153640 . 157265) (\TEDIT.INSERTCH 157267 . 165306) (
|
||||
\TEDIT.INSERTCH.HISTORY 165308 . 168772) (\TEDIT.INSERTEOL 168774 . 170599) (\TEDIT.INSERTCH.INSERTION
|
||||
170601 . 173438) (\TEDIT.INSERTCH.EXTEND 173440 . 174722)) (174725 176332 (\TEDIT.NEXTCHANGEABLE.CHNO
|
||||
174735 . 175450) (\TEDIT.LASTCHANGEABLE.CHNO 175452 . 176330)) (176333 180791 (\TEDIT.INSTALL.PIECE
|
||||
176343 . 180789)) (180829 190295 (TEXTPROP 180839 . 181186) (GETTEXTPROP 181188 . 181432) (PUTTEXTPROP
|
||||
181434 . 181691) (GETTEXTPROPS 181693 . 182137) (PUTTEXTPROPS 182139 . 183043) (TEXTPROP.ADD 183045
|
||||
. 183308) (\TEDIT.TEXTPROP 183310 . 190293)) (190296 192673 (\TEDIT.TEXTOBJ.PROPNAMES 190306 . 191565
|
||||
) (\TEDIT.TEXTOBJ.PROPFETCHFN 191567 . 192083) (\TEDIT.TEXTOBJ.PROPSTOREFN 192085 . 192671)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,11 +1,11 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "14-Jan-2026 14:50:53"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>working-medley>library>tedit>tedit-exports.all;248 52743
|
||||
(FILECREATED "16-Feb-2026 08:56:58"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>working-medley>library>tedit>tedit-exports.all;249 52790
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:PREVIOUS-DATE "10-Jan-2026 23:04:09" {WMEDLEY}<library>TEDIT>tedit-exports.all;247)
|
||||
:PREVIOUS-DATE "14-Jan-2026 14:50:53" {WMEDLEY}<library>TEDIT>tedit-exports.all;248)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT ((E (MAPC (MKLIST FROMFILES) (FUNCTION (LAMBDA (F) (MAPC (IMPORTFILE F FLG) (FUNCTION
|
||||
@@ -17,7 +17,7 @@ PRINT))))))))
|
||||
(PUTPROPS FTEXTOBJ MACRO ((X) (TEXTOBJ! (CL:IF (type? TEXTOBJ X) X (GETTSTR X TEXTOBJ)))))
|
||||
(GLOBALVARS CHECK-TEDIT-ASSERTIONS)
|
||||
(RPAQ? CHECK-TEDIT-ASSERTIONS T)
|
||||
(PUTPROP (QUOTE TEDIT) (QUOTE IMPORTDATE) (IDATE "10-Jan-2026 01:39:21"))
|
||||
(PUTPROP (QUOTE TEDIT) (QUOTE IMPORTDATE) (IDATE " 4-Feb-2026 16:02:02"))
|
||||
(RPAQQ \BTREEWORDSPERSLOT 4)
|
||||
(RPAQQ \BTREEMAXCOUNT 8)
|
||||
(CONSTANTS (\BTREEWORDSPERSLOT 4) (\BTREEMAXCOUNT 8))
|
||||
@@ -51,7 +51,7 @@ DLEN1 DOWN2 DLEN2 DOWN3 DLEN3 DOWN4 DLEN4 DOWN5 DLEN5 DOWN6 DLEN6 DOWN7 DLEN7 DO
|
||||
(\DTEST (OR (NEXTPIECE I.V.) (GO $$OUT)) (QUOTE PIECE)))))
|
||||
(I.S.OPR (QUOTE backpieces) NIL (QUOTE (first (SETQ I.V. (\DTEST (OR BODY (GO $$OUT)) (QUOTE PIECE)))
|
||||
by (\DTEST (OR (PREVPIECE I.V.) (GO $$OUT)) (QUOTE PIECE)))))
|
||||
(PUTPROP (QUOTE TEDIT-PCTREE) (QUOTE IMPORTDATE) (IDATE "28-Jul-2025 23:25:19"))
|
||||
(PUTPROP (QUOTE TEDIT-PCTREE) (QUOTE IMPORTDATE) (IDATE "14-Feb-2026 13:22:06"))
|
||||
(DATATYPE SELECTION ((* ;;
|
||||
"Description of a piece of selected text for TEdit. Text has to be selected before it can be operated on by the user. The caret is to the left of CH# if POINT is LEFT, to the keft of CHLIM if POINT is RIGHT."
|
||||
) (* ;; "If DCH > 0, highlighting goes from CH# to (SUB1 CHLIM = (SUB1 (IPLUS CH# DCH)).") (* ;;
|
||||
@@ -128,7 +128,7 @@ TSTREAM ONLYPANE DONTFIX)))
|
||||
(PUTPROPS \TEDIT.SEL.OFF MACRO ((TSTREAM SEL ONLYPANE) (* ;
|
||||
"Takes down SEL in TSTREAM, where SEL defaults to the current selection") (\TEDIT.SHOWSEL SEL NIL
|
||||
TSTREAM ONLYPANE)))
|
||||
(PUTPROP (QUOTE TEDIT-SELECTION) (QUOTE IMPORTDATE) (IDATE "14-Jan-2026 14:32:01"))
|
||||
(PUTPROP (QUOTE TEDIT-SELECTION) (QUOTE IMPORTDATE) (IDATE "16-Feb-2026 00:38:33"))
|
||||
(RECORD TAB (TABX . TABKIND))
|
||||
(RECORD TABSPEC (DEFAULTTAB . TABS))
|
||||
(DATATYPE LINECACHE ((* ;; "Image cache for display lines.") LCBITMAP (* ;
|
||||
@@ -259,7 +259,7 @@ NEXTAVAILABLECHARSLOT) of THISLINE))) (T $$STARTSLOT))) (SETQ $$CHARSLOTLIMIT (F
|
||||
) by (PREVCHARSLOT I.V.) eachtime (SETQ CHAR (fetch (CHARSLOT CHAR) of I.V.)) (SETQ CHARW (fetch (
|
||||
CHARSLOT CHARW) of I.V.)) (SETQ CHARCL (fetch (CHARSLOT CHARCL) of I.V.)) repeatuntil (EQ I.V.
|
||||
$$CHARSLOTLIMIT))))) T)
|
||||
(PUTPROP (QUOTE TEDIT-SCREEN) (QUOTE IMPORTDATE) (IDATE "31-Dec-2025 23:10:18"))
|
||||
(PUTPROP (QUOTE TEDIT-SCREEN) (QUOTE IMPORTDATE) (IDATE " 5-Feb-2026 00:39:54"))
|
||||
(DATATYPE PIECE ((* ;
|
||||
"The piece describes either a string or part of a file. , or a generalized OBJECT.") PCONTENTS (* ;
|
||||
"The background source of data for this piece (stream, string, block, object, depending on the PTYPE)."
|
||||
@@ -372,6 +372,7 @@ IMAGEDATA _ NIL)))
|
||||
(PUTPROPS NEXTPIECE MACRO ((PC) (ffetch (PIECE NEXTPIECE) of PC)))
|
||||
(PUTPROPS PREVPIECE MACRO ((PC) (ffetch (PIECE PREVPIECE) of PC)))
|
||||
(PUTPROPS PLEN MACRO ((PC) (ffetch (PIECE PLEN) of PC)))
|
||||
(PUTPROPS PLAST MACRO ((PC) (SUB1 (PLEN PC))))
|
||||
(PUTPROPS PTYPE MACRO ((PC) (ffetch (PIECE PTYPE) of PC)))
|
||||
(PUTPROPS PCONTENTS MACRO ((PC) (ffetch (PIECE PCONTENTS) of PC)))
|
||||
(PUTPROPS PCHARLOOKS MACRO ((PC) (ffetch (PIECE PCHARLOOKS) of PC)))
|
||||
@@ -440,7 +441,7 @@ UTF8.PTYPE UTF16BE.PTYPE UTF16LE.PTYPE)) (STRING.PTYPES (LIST THINSTRING.PTYPE F
|
||||
BINABLE.PTYPES (LIST THINFILE.PTYPE THINSTRING.PTYPE)) (THIN.PTYPES (LIST THINFILE.PTYPE
|
||||
THINSTRING.PTYPE)) (FAT.PTYPES (LIST FATFILE2.PTYPE FATSTRING.PTYPE FATFILE1.PTYPE)))
|
||||
(GLOBALVARS \TEXTIMAGEOPS \TEXTFDEV)
|
||||
(PUTPROP (QUOTE TEDIT-STREAM) (QUOTE IMPORTDATE) (IDATE "14-Jan-2026 14:32:01"))
|
||||
(PUTPROP (QUOTE TEDIT-STREAM) (QUOTE IMPORTDATE) (IDATE "16-Feb-2026 08:56:40"))
|
||||
(PUTPROPS \TEDIT.MOUSESTATE MACRO (BUTTON (* ;;
|
||||
"Test to see if only the specified mouse button is down. DOES NOT call GETMOUSESTATE, so the mouse-button info is the same as the last time it was called."
|
||||
) (SELECTQ (CAR BUTTON) (LEFT (QUOTE (EQ LASTMOUSEBUTTONS 4))) (MIDDLE (QUOTE (EQ LASTMOUSEBUTTONS 1))
|
||||
@@ -454,7 +455,7 @@ I in ARGS as J on ARGS when (NOT (STRINGP I)) collect (LIST (QUOTE OR) I (LIST (
|
||||
\BIN STREAM)) BITSPERWORD)))
|
||||
(PUTPROPS \SMALLPOUT MACRO (OPENLAMBDA (STREAM W) (* ; "Signed smallp, unlike \WOUT") (\BOUT STREAM (
|
||||
LOGAND 255 (LRSH W 8))) (\BOUT STREAM (LOGAND W 255))))
|
||||
(PUTPROP (QUOTE TEDIT-FILE) (QUOTE IMPORTDATE) (IDATE "23-Oct-2025 08:49:06"))
|
||||
(PUTPROP (QUOTE TEDIT-FILE) (QUOTE IMPORTDATE) (IDATE "15-Feb-2026 23:45:51"))
|
||||
(PUTPROP (QUOTE TEDIT-OLDFILE) (QUOTE IMPORTDATE) (IDATE " 8-Sep-2025 22:10:10"))
|
||||
(DATATYPE CHARLOOKS ((* ;; "Describes the appearance (%"Looks%") of characters in a TEdit document.")
|
||||
(* ;; "NOTE: If fields change EQCLOOKS should change too.") CLFONT (* ;
|
||||
@@ -537,7 +538,7 @@ LINELEAD _ 0)
|
||||
(PUTPROPS FSETPLOOKS MACRO ((PLOOKS FIELD NEWVALUE) (freplace (PARALOOKS FIELD) of PLOOKS with
|
||||
NEWVALUE)))
|
||||
(PUTPROPS PARALOOKS! MACRO ((PL) (\DTEST PL (QUOTE PARALOOKS))))
|
||||
(PUTPROP (QUOTE TEDIT-LOOKS) (QUOTE IMPORTDATE) (IDATE " 7-Dec-2025 16:32:32"))
|
||||
(PUTPROP (QUOTE TEDIT-LOOKS) (QUOTE IMPORTDATE) (IDATE "16-Feb-2026 00:36:00"))
|
||||
(PUTPROP (QUOTE TEDIT-STYLES) (QUOTE IMPORTDATE) (IDATE "28-Jul-2025 23:25:43"))
|
||||
(DATATYPE TEDITCARET (TCNOWTIME (* Used to hold the current time, when checking to see if a transition
|
||||
is due) TCTHENTIME (* Time when the next transition is to take place) TCFORCEDDOWN (* TCFORCEDOWN = T
|
||||
@@ -600,9 +601,9 @@ OR (CL:IF (TYPENAMEP $$BODY (QUOTE TEXTOBJ)) (FGETTOBJ $$BODY PRIMARYPANE) $$BOD
|
||||
GETPANEPROP (PANEPROPS P) NEXTPANE))) (GO $$OUT))) by (OR (GETPANEPROP (PANEPROPS I.V.) PREVPANE) (GO
|
||||
$$OUT)))))
|
||||
(PUTPROPS ALLBUTTONSUP MACRO (NIL (ZEROP (LOGAND 7 LASTMOUSEBUTTONS))))
|
||||
(PUTPROP (QUOTE TEDIT-WINDOW) (QUOTE IMPORTDATE) (IDATE "14-Jan-2026 14:32:01"))
|
||||
(PUTPROP (QUOTE TEDIT-BUTTONS) (QUOTE IMPORTDATE) (IDATE "19-Oct-2025 10:44:18"))
|
||||
(PUTPROP (QUOTE TEDIT-MENU) (QUOTE IMPORTDATE) (IDATE "12-Dec-2025 00:01:26"))
|
||||
(PUTPROP (QUOTE TEDIT-WINDOW) (QUOTE IMPORTDATE) (IDATE " 7-Feb-2026 18:53:22"))
|
||||
(PUTPROP (QUOTE TEDIT-BUTTONS) (QUOTE IMPORTDATE) (IDATE "25-Jan-2026 09:14:04"))
|
||||
(PUTPROP (QUOTE TEDIT-MENU) (QUOTE IMPORTDATE) (IDATE " 9-Feb-2026 09:10:43"))
|
||||
(PUTPROP (QUOTE TEDIT-FIND) (QUOTE IMPORTDATE) (IDATE "21-Apr-2025 22:42:57"))
|
||||
(RPAQQ \TEDIT.TTCCODES ((NONE . 0) (CHARDELETE . 1) (:CHARDELETE.BACKWARD . 1) (WORDDELETE . 2) (
|
||||
:WORDDELETE.BACKWORD . 2) (DELETE . 3) (:DELETE . 3) (FN . 4) (REDO . 5) (:REDO . 5) (UNDO . 6) (:UNDO
|
||||
@@ -610,8 +611,8 @@ $$OUT)))))
|
||||
(:CHARDELETE.FORWARD . 10) (:WORDDELETE.FORWARD . 11) (PUNCT . 20) (TEXT . 21) (WHITESPACE . 22)))
|
||||
(CONSTANTS \TEDIT.TTCCODES)
|
||||
(PUTPROPS \TEDIT.TTC MACRO ((ACTION) (CONSTANT (GETMULTI \TEDIT.TTCCODES (QUOTE ACTION)))))
|
||||
(PUTPROP (QUOTE TEDIT-FNKEYS) (QUOTE IMPORTDATE) (IDATE "24-Nov-2025 08:40:56"))
|
||||
(PUTPROP (QUOTE TEDIT-HCPY) (QUOTE IMPORTDATE) (IDATE "24-Dec-2025 11:16:22"))
|
||||
(PUTPROP (QUOTE TEDIT-FNKEYS) (QUOTE IMPORTDATE) (IDATE " 8-Feb-2026 19:54:41"))
|
||||
(PUTPROP (QUOTE TEDIT-HCPY) (QUOTE IMPORTDATE) (IDATE "15-Jan-2026 11:08:15"))
|
||||
(DATATYPE TEDITHISTORYEVENT ((* ;; "Describes one event on the TEdit edit history list.") THACTION (*
|
||||
; "A keyword specifying what the event was") THPOINT (* ; "Was the selection to the left or right?")
|
||||
THLEN (* ; "The # of chars involved") THCH# (* ; "The starting ch#") THFIRSTPIECE (* ;
|
||||
@@ -660,9 +661,9 @@ REGIONPARENT FULLXPOINTER) (* ; "The parent node for this box, for sub-boxes") R
|
||||
$$VALUES)) (PROG1 (CAR $$VALUES) (\,@ (FOR V IN (CAR ARGS) collect (COND (V (BQUOTE (SETQ (\, V) (POP
|
||||
$$VALUES)))) (T (BQUOTE (SETQ $$VALUES (CDR $$VALUES))))))))))))
|
||||
(PUTPROPS TEDIT.VALUES MACRO (ARGS (BQUOTE (LIST (\,@ ARGS)))))
|
||||
(PUTPROP (QUOTE TEDIT-PAGE) (QUOTE IMPORTDATE) (IDATE "25-Dec-2025 15:07:57"))
|
||||
(PUTPROP (QUOTE TEDIT-ABBREV) (QUOTE IMPORTDATE) (IDATE "13-Jan-2026 17:51:55"))
|
||||
(PUTPROP (QUOTE TEDIT-TFBRAVO) (QUOTE IMPORTDATE) (IDATE " 7-Sep-2025 11:11:43"))
|
||||
(PUTPROP (QUOTE TEDIT-PAGE) (QUOTE IMPORTDATE) (IDATE "27-Jan-2026 10:30:27"))
|
||||
(PUTPROP (QUOTE TEDIT-ABBREV) (QUOTE IMPORTDATE) (IDATE "23-Jan-2026 15:49:26"))
|
||||
(PUTPROP (QUOTE TEDIT-TFBRAVO) (QUOTE IMPORTDATE) (IDATE "21-Jan-2026 12:15:57"))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL)))
|
||||
STOP
|
||||
|
||||
@@ -1,10 +1,10 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10 FORMAT UTF-8)
|
||||
|
||||
(FILECREATED "13-Oct-2025 13:44:47" {WMEDLEY}<library>virtualkeyboards>KEYBOARDCONFIGS.;5 59521
|
||||
(FILECREATED "19-Feb-2026 22:32:05" {WMEDLEY}<library>virtualkeyboards>KEYBOARDCONFIGS.;6 59604
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:PREVIOUS-DATE "13-Oct-2025 12:03:23" {WMEDLEY}<library>virtualkeyboards>KEYBOARDCONFIGS.;4)
|
||||
:PREVIOUS-DATE "13-Oct-2025 13:44:47" {WMEDLEY}<library>virtualkeyboards>KEYBOARDCONFIGS.;5)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT KEYBOARDCONFIGSCOMS)
|
||||
@@ -57,11 +57,11 @@
|
||||
(F3 (F3 ITALIC))
|
||||
(F4 (F4 UCASE))
|
||||
(F5 (F5 STRIKE))
|
||||
(F6 (F6 ""))
|
||||
(F6 (F6 "^"))
|
||||
(F7 (F7 SUBSCR))
|
||||
(F8 (F8 SMALL))
|
||||
(F9 (F9 MARGIN))
|
||||
(F10 (F10 "¬"))
|
||||
(F10 (F10 "_"))
|
||||
(F11 (F11 ""))
|
||||
(F12 (F12 ""))
|
||||
(LOCK ("CAPS" "LOCK"))
|
||||
@@ -115,7 +115,7 @@
|
||||
(THREE (|3| %# NLS))
|
||||
(FOUR (|4| $ NLS))
|
||||
(FIVE (|5| %% NLS))
|
||||
(SIX (|6| ^ NLS))
|
||||
(SIX (|6| ↑ NLS))
|
||||
(SEVEN (|7| & NLS))
|
||||
(EIGHT (|8| * NLS))
|
||||
(NINE (|9| %( NLS))))
|
||||
@@ -234,7 +234,7 @@
|
||||
NIL
|
||||
((%" (%' %" NLS))
|
||||
(+ (= + NLS))
|
||||
(- (- _ NLS))
|
||||
(- (- ← NLS))
|
||||
(%: (; %: NLS))
|
||||
(< (%, < NLS))
|
||||
(> (%. > NLS))
|
||||
@@ -255,13 +255,13 @@
|
||||
(NUMERIC/ (/ /))
|
||||
(NUMERIC0 (INS |0| NLS))
|
||||
(NUMERIC1 (END |1| NLS))
|
||||
(NUMERIC2 (¯ |2| NLS))
|
||||
(NUMERIC2 (↓ |2| NLS))
|
||||
(NUMERIC3 (PGDN |3| NLS))
|
||||
(NUMERIC4 (¬ |4| NLS))
|
||||
(NUMERIC4 (_ |4| NLS))
|
||||
(NUMERIC5 (|5| |5|))
|
||||
(NUMERIC6 (® |6| NLS))
|
||||
(NUMERIC6 (→ |6| NLS))
|
||||
(NUMERIC7 (HOME |7| NLS))
|
||||
(NUMERIC8 ( |8| NLS))
|
||||
(NUMERIC8 (^ |8| NLS))
|
||||
(NUMERIC9 (PGUP |9| NLS))
|
||||
(NUMERIC= (= =))
|
||||
(RETURN (CR CR))
|
||||
@@ -274,17 +274,17 @@
|
||||
(F3 (ITALIC NOTITALIC NLS))
|
||||
(F4 (UCASE LCASE NLS))
|
||||
(F5 (STRIKEOUT NOTSTRIKEOUT NLS))
|
||||
(F6 ("" "" NLS))
|
||||
(F6 ("^" "^" NLS))
|
||||
(F7 (SUBSCRIPT SUPERSCRIPT NLS))
|
||||
(F8 (SMALLER LARGER NLS))
|
||||
(F9 (MARGINS NOTMARGINS NLS))
|
||||
(F10 ("¬" "¬" NLS))
|
||||
(F10 ("_" "_" NLS))
|
||||
(F11 (F11 NOTF11 NLS))
|
||||
(F12 (F12 NOTF12 NLS)))
|
||||
((%` 45 B)
|
||||
(~ 45 T)
|
||||
(|6| 2 B)
|
||||
(^ 2 T)
|
||||
(↑ 2 T)
|
||||
(%% 0 T)
|
||||
(|5| 0 B)
|
||||
($ 1 T)
|
||||
@@ -523,7 +523,7 @@
|
||||
(> (346 46 29 33))
|
||||
(%: (362 82 29 33))
|
||||
(<-%| (426 82 63 33))
|
||||
(^ (450 118 29 33))
|
||||
(↑ (450 118 29 33))
|
||||
(DEL (498 154 29 33))
|
||||
(R (162 118 29 33))
|
||||
(T (194 118 29 33))
|
||||
@@ -556,7 +556,7 @@
|
||||
(LF (LF LF))
|
||||
(LOCK LOCKDOWN . LOCKUP)
|
||||
(\ (\ %| NLS))
|
||||
(^ (_ ^ NLS))
|
||||
(↑ (← ↑ NLS))
|
||||
({ (%[ { NLS))
|
||||
(} (%] } NLS)))
|
||||
((BLANK-MIDDLE 30)
|
||||
@@ -643,8 +643,8 @@
|
||||
(%: 43)
|
||||
(CR 44)
|
||||
(<-%| 44)
|
||||
(_ 45)
|
||||
(^ 45)
|
||||
(← 45)
|
||||
(↑ 45)
|
||||
(r 48)
|
||||
(R 48)
|
||||
(t 49)
|
||||
@@ -744,7 +744,7 @@
|
||||
NIL
|
||||
((%" (%' %" NLS))
|
||||
(+ (= + NLS))
|
||||
(- (- _ NLS))
|
||||
(- (- ← NLS))
|
||||
(ESC (ESC %| NLS))
|
||||
(%: (; %: NLS))
|
||||
(< (%, < NLS))
|
||||
@@ -757,7 +757,7 @@
|
||||
(~ (%` ~ NLS)))
|
||||
((%` 45)
|
||||
(~ 45)
|
||||
(^ 2)
|
||||
(↑ 2)
|
||||
(|6| 2)
|
||||
(w 18)
|
||||
(W 18)
|
||||
@@ -951,7 +951,7 @@
|
||||
NIL
|
||||
((%" (%' %" NLS))
|
||||
(+ (= + NLS))
|
||||
(- (- _ NLS))
|
||||
(- (- ← NLS))
|
||||
(%: (; %: NLS))
|
||||
(< (%, < NLS))
|
||||
(<-%| (CR CR))
|
||||
@@ -962,21 +962,21 @@
|
||||
(KEYBOARD METADOWN . METAUP)
|
||||
(LOCK LOCKDOWN . LOCKUP)
|
||||
(NEXT (2,22 2,62 NLS))
|
||||
(NUMERIC* (NUMLK ´ NLS))
|
||||
(NUMERIC* (NUMLK × NLS))
|
||||
(NUMERIC+ (HELP 2,45 NLS))
|
||||
(NUMERIC, (\ %, NLS))
|
||||
(NUMERIC- (SCRL - NLS))
|
||||
(NUMERIC. (%| 21 NLS))
|
||||
(NUMERIC/ (BREAK ¸ NLS))
|
||||
(NUMERIC/ (BREAK ÷ NLS))
|
||||
(NUMERIC0 (INS |0| NLS))
|
||||
(NUMERIC1 (END |1| NLS))
|
||||
(NUMERIC2 (¯ |2| NLS))
|
||||
(NUMERIC2 (↓ |2| NLS))
|
||||
(NUMERIC3 (PGDN |3| NLS))
|
||||
(NUMERIC4 (¬ |4| NLS))
|
||||
(NUMERIC4 (_ |4| NLS))
|
||||
(NUMERIC5 (% |5| NLS))
|
||||
(NUMERIC6 (® |6| NLS))
|
||||
(NUMERIC6 (→ |6| NLS))
|
||||
(NUMERIC7 (HOME |7| NLS))
|
||||
(NUMERIC8 ( |8| NLS))
|
||||
(NUMERIC8 (^ |8| NLS))
|
||||
(NUMERIC9 (PGUP |9| NLS))
|
||||
(%` (%` ~ NLS))
|
||||
({ (%[ { NLS))
|
||||
@@ -987,7 +987,7 @@
|
||||
(|4| 1)
|
||||
($ 1)
|
||||
(|6| 2)
|
||||
(^ 2)
|
||||
(↑ 2)
|
||||
(e 3)
|
||||
(E 3)
|
||||
(|7| 4)
|
||||
@@ -1233,7 +1233,7 @@
|
||||
(%. (%. > NLS))
|
||||
(/ (/ ? NLS))
|
||||
(\ (\ %| NLS))
|
||||
(- (- _ NLS))
|
||||
(- (- ← NLS))
|
||||
(%` (%` ~ NLS))
|
||||
(%[ (%[ { NLS))
|
||||
(%] (%] } NLS))
|
||||
@@ -1249,13 +1249,13 @@
|
||||
(NUMERIC/ (/ /))
|
||||
(NUMERIC0 (INS |0| NLS))
|
||||
(NUMERIC1 (END |1| NLS))
|
||||
(NUMERIC2 (¯ |2| NLS))
|
||||
(NUMERIC2 (↓ |2| NLS))
|
||||
(NUMERIC3 (PGDN |3| NLS))
|
||||
(NUMERIC4 (¬ |4| NLS))
|
||||
(NUMERIC4 (_ |4| NLS))
|
||||
(NUMERIC5 (|5| |5|))
|
||||
(NUMERIC6 (® |6| NLS))
|
||||
(NUMERIC6 (→ |6| NLS))
|
||||
(NUMERIC7 (HOME |7| NLS))
|
||||
(NUMERIC8 ( |8| NLS))
|
||||
(NUMERIC8 (^ |8| NLS))
|
||||
(NUMERIC9 (PGUP |9| NLS))
|
||||
(NUMERICENTER (CR CR))
|
||||
(RALT METADOWN . METAUP)
|
||||
@@ -1264,11 +1264,11 @@
|
||||
(F3 (ITALIC NOTITALIC NLS))
|
||||
(F4 (UCASE LCASE NLS))
|
||||
(F5 (STRIKEOUT NOTSTRIKEOUT NLS))
|
||||
(F6 ("" "" NLS))
|
||||
(F6 ("^" "^" NLS))
|
||||
(F7 (SUBSCRIPT SUPERSCRIPT NLS))
|
||||
(F8 (SMALLER LARGER NLS))
|
||||
(F9 (MARGINS NOTMARGINS NLS))
|
||||
(F10 ("¬" "¬" NLS))
|
||||
(F10 ("_" "_" NLS))
|
||||
(F11 (F11 NOTF11 NLS))
|
||||
(F12 (F12 NOTF12 NLS)))
|
||||
((%' 28 B)
|
||||
@@ -1276,7 +1276,7 @@
|
||||
(%, 27 B)
|
||||
(< 27 T)
|
||||
(- 10 B)
|
||||
(_ 10 T)
|
||||
(← 10 T)
|
||||
(> 42 T)
|
||||
(%. 42 B)
|
||||
(/ 12 B)
|
||||
@@ -1286,7 +1286,7 @@
|
||||
(%# 16 T)
|
||||
($ 1 T)
|
||||
(%% 0 T)
|
||||
(^ 4 T)
|
||||
(↑ 4 T)
|
||||
(* 53 T)
|
||||
(%( 22 T)
|
||||
(%) 8 T)
|
||||
@@ -1494,7 +1494,7 @@
|
||||
(M (370 42 29 29))
|
||||
(; (402 42 29 29))
|
||||
(%: (434 42 29 29))
|
||||
(_ (466 42 29 29))
|
||||
(← (466 42 29 29))
|
||||
(RSHIFT (498 42 53 29))
|
||||
(LINEFEED (554 42 29 29))
|
||||
(CONTROL (106 74 53 29))
|
||||
@@ -1559,7 +1559,7 @@
|
||||
(ONE (|1| + NLS))
|
||||
(TWO (|2| %" NLS))
|
||||
(THREE (|3| * NLS))
|
||||
(FOUR (|4| ‡ NLS))
|
||||
(FOUR (|4| NLS))
|
||||
(SIX (|6| & NLS))
|
||||
(SEVEN (|7| / NLS))
|
||||
(EIGHT (|8| %( NLS))
|
||||
@@ -1567,7 +1567,7 @@
|
||||
(%: (%. %: NLS))
|
||||
(; (%, ; NLS))
|
||||
(? (%' ? NLS))
|
||||
(AUMLAUT (… „ NLS))
|
||||
(AUMLAUT ( NLS))
|
||||
(CAPSLOCK CTRLDOWN . CTRLUP)
|
||||
(CONTROL LOCKDOWN . LOCKUP)
|
||||
(CR (CR CR))
|
||||
@@ -1591,10 +1591,10 @@
|
||||
(NUMERIC8 (|8| |8|))
|
||||
(NUMERIC9 (|9| |9|))
|
||||
(NUMERIC= (= =))
|
||||
(OUMLAUT (‚ ” NLS))
|
||||
(UUMLAUT (Š <20> NLS))
|
||||
(OUMLAUT ( NLS))
|
||||
(UUMLAUT ( NLS))
|
||||
(%[ (%] %[ NLS))
|
||||
(_ (- _ NLS))
|
||||
(← (- ← NLS))
|
||||
({ (< { NLS))
|
||||
(} (> } NLS)))
|
||||
((HELP 0)
|
||||
@@ -1658,7 +1658,7 @@
|
||||
(%. 49)
|
||||
(%: 49)
|
||||
(- 50)
|
||||
(_ 50)
|
||||
(← 50)
|
||||
(RSHIFT 51)
|
||||
(LINEFEED 52)
|
||||
(CONTROL 53)
|
||||
|
||||
Binary file not shown.
@@ -1,18 +1,17 @@
|
||||
(DEFINE-FILE-INFO §READTABLE "INTERLISP" §PACKAGE "INTERLISP")
|
||||
(FILECREATED "31-Jan-87 18:09:00" {ERIS}<LISPUSERS>LYRIC>BACKGROUNDMENU.;1 7367
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
previous date%: "31-Jan-86 11:36:13" {ERIS}<LISP>KOTO>LISPUSERS>BACKGROUNDMENU.;1)
|
||||
(FILECREATED "18-Feb-2026 16:20:10" {WMEDLEY}<lispusers>BACKGROUNDMENU.;2 7230
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:PREVIOUS-DATE "31-Jan-87 18:09:00" {WMEDLEY}<lispusers>BACKGROUNDMENU.;1)
|
||||
|
||||
(* "
|
||||
Copyright (c) 1985, 1986, 1987 by Xerox Corporation. All rights reserved.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT BACKGROUNDMENUCOMS)
|
||||
|
||||
(RPAQQ BACKGROUNDMENUCOMS ((INITVARS BackgroundMenuFixupMode BackgroundMenuSuperItem
|
||||
BackgroundMenuTopLevelItems)
|
||||
(FNS BkgMenu.add.item BkgMenu.fixup BkgMenu.move.item BkgMenu.remove.item
|
||||
(FNS BkgMenu.add.item BkgMenu.fixup BkgMenu.move.item BkgMenu.remove.item
|
||||
BkgMenu.rename.item BkgMenu.reorder.items BkgMenu.subitems
|
||||
\BkgMenu.locate \BkgMenu.locater \BkgMenu.remove.item
|
||||
\BkgMenu.scan.item.list \BkgMenu.unremove.item)))
|
||||
@@ -153,11 +152,10 @@ Copyright (c) 1985, 1986, 1987 by Xerox Corporation. All rights reserved.
|
||||
else (SETQ BackgroundMenuCommands (CONS (CAR item)
|
||||
BackgroundMenuCommands])
|
||||
)
|
||||
(PUTPROPS BACKGROUNDMENU COPYRIGHT ("Xerox Corporation" 1985 1986 1987))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (1008 7271 (BkgMenu.add.item 1018 . 1910) (BkgMenu.fixup 1912 . 3131) (BkgMenu.move.item
|
||||
3133 . 3557) (BkgMenu.remove.item 3559 . 3834) (BkgMenu.rename.item 3836 . 4128) (
|
||||
BkgMenu.reorder.items 4130 . 4505) (BkgMenu.subitems 4507 . 4907) (\BkgMenu.locate 4909 . 5520) (
|
||||
\BkgMenu.locater 5522 . 6089) (\BkgMenu.remove.item 6091 . 6378) (\BkgMenu.scan.item.list 6380 . 6877)
|
||||
(\BkgMenu.unremove.item 6879 . 7269)))))
|
||||
(FILEMAP (NIL (944 7207 (BkgMenu.add.item 954 . 1846) (BkgMenu.fixup 1848 . 3067) (BkgMenu.move.item
|
||||
3069 . 3493) (BkgMenu.remove.item 3495 . 3770) (BkgMenu.rename.item 3772 . 4064) (
|
||||
BkgMenu.reorder.items 4066 . 4441) (BkgMenu.subitems 4443 . 4843) (\BkgMenu.locate 4845 . 5456) (
|
||||
\BkgMenu.locater 5458 . 6025) (\BkgMenu.remove.item 6027 . 6314) (\BkgMenu.scan.item.list 6316 . 6813)
|
||||
(\BkgMenu.unremove.item 6815 . 7205)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,95 +1,88 @@
|
||||
(DEFINE-FILE-INFO §PACKAGE "INTERLISP" §READTABLE "INTERLISP" §BASE 10)
|
||||
(FILECREATED " 2-Apr-87 17:06:05" {ERIS}<LISPUSERS>LYRIC>COMMWINDOW.;3 49786
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
changes to%: (VARS REMOTE-CURSOR COMMWINDOWCOMS)
|
||||
(COURIERPROGRAMS COMMWINDOW)
|
||||
(FNS CLOSE-FRAME START-GET-BITS SEND-BITS FRAME-EVENT MAKE-FRAME)
|
||||
(FUNCTIONS \PILOTBITBLT)
|
||||
(FILECREATED "18-Feb-2026 16:21:29" {WMEDLEY}<lispusers>COMMWINDOW.;2 48680
|
||||
|
||||
previous date%: " 2-Apr-87 16:54:24" {ERIS}<LISPUSERS>LYRIC>COMMWINDOW.;2)
|
||||
:EDIT-BY rmk
|
||||
|
||||
:PREVIOUS-DATE " 2-Apr-87 17:06:05" {WMEDLEY}<lispusers>COMMWINDOW.;1)
|
||||
|
||||
(* "
|
||||
Copyright (c) 1986, 1900, 1987 by Xerox Corporation. All rights reserved.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT COMMWINDOWCOMS)
|
||||
|
||||
(RPAQQ COMMWINDOWCOMS (
|
||||
(RPAQQ COMMWINDOWCOMS
|
||||
(
|
||||
|
||||
(* ;;; "Viewer end")
|
||||
|
||||
(FNS CLOSE-FRAME GET-BITS START-GET-BITS)
|
||||
(FILES COURIERSERVE)
|
||||
|
||||
(FNS CLOSE-FRAME GET-BITS START-GET-BITS)
|
||||
(FILES COURIERSERVE)
|
||||
|
||||
|
||||
(* ;;; "Sender end")
|
||||
|
||||
(FNS SEND-BITS SEND-TILE LISTEN-TO-VIEWER MAPTILES SHUT-DOWN-VIEWER
|
||||
CHANGE-SENDER-UPDATE-MODE)
|
||||
(FUNCTIONS INCR \PILOTBITBLT)
|
||||
|
||||
|
||||
(* ;; "Controling update schemes")
|
||||
(FNS SEND-BITS SEND-TILE LISTEN-TO-VIEWER MAPTILES SHUT-DOWN-VIEWER CHANGE-SENDER-UPDATE-MODE
|
||||
)
|
||||
(FUNCTIONS INCR \PILOTBITBLT)
|
||||
|
||||
(* ;; "Controling update schemes")
|
||||
|
||||
(INITVARS (COMM.DEFAULT.TRANSMIT.TYPE 'SQUARE)
|
||||
(COMM.SEND.UNCHANGED.TILES T)
|
||||
(COMM.UPDATE.MOUSE.POSITION 'Sender))
|
||||
(GLOBALVARS COMM.DEFAULT.TRANSMIT.TYPE COMM.UPDATE.MOUSE.POSITION
|
||||
COMM.SEND.UNCHANGED.TILES)
|
||||
|
||||
(INITVARS (COMM.DEFAULT.TRANSMIT.TYPE 'SQUARE)
|
||||
(COMM.SEND.UNCHANGED.TILES T)
|
||||
(COMM.UPDATE.MOUSE.POSITION 'Sender))
|
||||
(GLOBALVARS COMM.DEFAULT.TRANSMIT.TYPE COMM.UPDATE.MOUSE.POSITION COMM.SEND.UNCHANGED.TILES)
|
||||
|
||||
|
||||
(* ;;; "Pruning out unchanged screen tiles")
|
||||
|
||||
(FNS PACKET-EQUAL GET-CACHED-PACKET PUT-CACHED-PACKET)
|
||||
|
||||
(FNS PACKET-EQUAL GET-CACHED-PACKET PUT-CACHED-PACKET)
|
||||
|
||||
|
||||
(* ;;; "Low level packet exchange code")
|
||||
|
||||
(CONSTANTS COMM.BAND.PACKET.TYPE COMM.CURSOR.PACKET.TYPE
|
||||
COMM.CURSOR.CLOSE.PACKET.TYPE COMM.SHUT.DOWN.PACKET.TYPE)
|
||||
(VARIABLES MAX-PACKET-BITS)
|
||||
(RECORDS COMM.XFER.PACKET)
|
||||
|
||||
(CONSTANTS COMM.BAND.PACKET.TYPE COMM.CURSOR.PACKET.TYPE COMM.CURSOR.CLOSE.PACKET.TYPE
|
||||
COMM.SHUT.DOWN.PACKET.TYPE)
|
||||
(VARIABLES MAX-PACKET-BITS)
|
||||
(RECORDS COMM.XFER.PACKET)
|
||||
|
||||
|
||||
(* ;;; "Packing and unpacking bitmaps into etherpackets")
|
||||
|
||||
(FNS BMTOPACKET PACKETTOBM)
|
||||
|
||||
(FNS BMTOPACKET PACKETTOBM)
|
||||
|
||||
|
||||
(* ;;; "Displaying the viewing machine's cursor")
|
||||
|
||||
(VARS REMOTE-CURSOR)
|
||||
(INITVARS (CURSORICON NIL))
|
||||
|
||||
(VARS REMOTE-CURSOR)
|
||||
(INITVARS (CURSORICON NIL))
|
||||
|
||||
|
||||
(* ;;; "Manipulating the frame that outlines the region being viewed")
|
||||
|
||||
(INITVARS (*FRAME-SHADE* GRAYSHADE))
|
||||
(FNS FRAME-EVENT MAKE-FRAME MOVE-FRAME SHAPE-FRAME SET-FRAME-TITLE)
|
||||
|
||||
(INITVARS (*FRAME-SHADE* GRAYSHADE))
|
||||
(FNS FRAME-EVENT MAKE-FRAME MOVE-FRAME SHAPE-FRAME SET-FRAME-TITLE)
|
||||
|
||||
|
||||
(* ;;; "Changing the system parameters")
|
||||
|
||||
(FNS MAKE-MENUS-WINDOW MODE-MENU)
|
||||
(VARS COMM-MODES)
|
||||
|
||||
(FNS MAKE-MENUS-WINDOW MODE-MENU)
|
||||
(VARS COMM-MODES)
|
||||
|
||||
|
||||
(* ;;; "Initialization")
|
||||
|
||||
(P (COURIER.START.SERVER))
|
||||
|
||||
(P (COURIER.START.SERVER))
|
||||
|
||||
|
||||
(* ;;; "Unused stuff, as far as I can tell")
|
||||
|
||||
(FNS FASTBITBLT)
|
||||
|
||||
(FNS FASTBITBLT)
|
||||
|
||||
|
||||
(* ;;; "System file dependencies")
|
||||
|
||||
(DECLARE%: DONTCOPY DOEVAL@COMPILE (FILES (LOADCOMP)
|
||||
LLDISPLAY LLETHER LLNS))
|
||||
(COURIERPROGRAMS COMMWINDOW)))
|
||||
(DECLARE%: DONTCOPY DOEVAL@COMPILE (FILES (LOADCOMP)
|
||||
LLDISPLAY LLETHER LLNS))
|
||||
(COURIERPROGRAMS COMMWINDOW)))
|
||||
|
||||
|
||||
|
||||
@@ -236,6 +229,7 @@ Copyright (c) 1986, 1900, 1987 by Xerox Corporation. All rights reserved.
|
||||
(LIST 'RETURN (LIST (NSOCKETNUMBER NS)
|
||||
(USERNAME])
|
||||
)
|
||||
|
||||
(FILESLOAD COURIERSERVE)
|
||||
|
||||
|
||||
@@ -446,19 +440,18 @@ Copyright (c) 1986, 1900, 1987 by Xerox Corporation. All rights reserved.
|
||||
(SETQ COMM.DEFAULT.TRANSMIT.TYPE NEW-MODE)))
|
||||
)
|
||||
|
||||
(DEFMACRO INCR (VAR START HEIGHT REPEATS UNTIL &REST FORMS)
|
||||
(DEFMACRO INCR (VAR START HEIGHT REPEATS UNTIL &REST FORMS)
|
||||
`(CL:DO ((REPEAT-COUNT 0 (+ REPEAT-COUNT 1)))
|
||||
((>= REPEAT-COUNT ,REPEATS))
|
||||
(CL:DO [(,VAR (+ ,START (CL:* REPEAT-COUNT ,HEIGHT))
|
||||
(+ ,VAR (CL:* ,REPEATS ,HEIGHT]
|
||||
(,UNTIL)
|
||||
,@FORMS)))
|
||||
|
||||
|
||||
(DEFMACRO \PILOTBITBLT (XCL-USER::TABLE &OPTIONAL (XCL-USER::N 0)) (CL:ASSERT (EQL XCL-USER::N 0))
|
||||
`((OPCODES PILOTBITBLT)
|
||||
,XCL-USER::TABLE 0))
|
||||
(CL:DO [(,VAR (+ ,START (CL:* REPEAT-COUNT ,HEIGHT))
|
||||
(+ ,VAR (CL:* ,REPEATS ,HEIGHT]
|
||||
(,UNTIL)
|
||||
,@FORMS)))
|
||||
|
||||
(DEFMACRO \PILOTBITBLT (XCL-USER::TABLE &OPTIONAL (XCL-USER::N 0))
|
||||
(CL:ASSERT (EQL XCL-USER::N 0))
|
||||
`((OPCODES PILOTBITBLT)
|
||||
,XCL-USER::TABLE 0))
|
||||
|
||||
|
||||
|
||||
@@ -525,12 +518,12 @@ Copyright (c) 1986, 1900, 1987 by Xerox Corporation. All rights reserved.
|
||||
|
||||
(RPAQQ COMM.SHUT.DOWN.PACKET.TYPE 4246)
|
||||
|
||||
|
||||
(CONSTANTS COMM.BAND.PACKET.TYPE COMM.CURSOR.PACKET.TYPE COMM.CURSOR.CLOSE.PACKET.TYPE
|
||||
COMM.SHUT.DOWN.PACKET.TYPE)
|
||||
)
|
||||
|
||||
(CL:DEFCONSTANT MAX-PACKET-BITS (CL:* 400 8) )
|
||||
|
||||
(CL:DEFCONSTANT MAX-PACKET-BITS (CL:* 400 8))
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(ACCESSFNS COMM.XFER.PACKET ((COMMPACKET (fetch (XIP XIPCONTENTS) of DATUM)))
|
||||
@@ -807,6 +800,7 @@ Copyright (c) 1986, 1900, 1987 by Xerox Corporation. All rights reserved.
|
||||
|
||||
(* ;;; "Initialization")
|
||||
|
||||
|
||||
(COURIER.START.SERVER)
|
||||
|
||||
|
||||
@@ -862,6 +856,7 @@ Copyright (c) 1986, 1900, 1987 by Xerox Corporation. All rights reserved.
|
||||
(* ;;; "System file dependencies")
|
||||
|
||||
(DECLARE%: DONTCOPY DOEVAL@COMPILE
|
||||
|
||||
(FILESLOAD (LOADCOMP)
|
||||
LLDISPLAY LLETHER LLNS)
|
||||
)
|
||||
@@ -885,14 +880,14 @@ Copyright (c) 1986, 1900, 1987 by Xerox Corporation. All rights reserved.
|
||||
ERRORS
|
||||
((ERROR 1 (STRING))
|
||||
(USE.COURIER 2 NIL)))
|
||||
(PUTPROPS COMMWINDOW COPYRIGHT ("Xerox Corporation" 1986 1900 1987))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (3203 13134 (CLOSE-FRAME 3213 . 3364) (GET-BITS 3366 . 11655) (START-GET-BITS 11657 .
|
||||
13132)) (13189 26236 (SEND-BITS 13199 . 16020) (SEND-TILE 16022 . 19145) (LISTEN-TO-VIEWER 19147 .
|
||||
20450) (MAPTILES 20452 . 25175) (SHUT-DOWN-VIEWER 25177 . 26046) (CHANGE-SENDER-UPDATE-MODE 26048 .
|
||||
26234)) (27219 29090 (PACKET-EQUAL 27229 . 28632) (GET-CACHED-PACKET 28634 . 28949) (PUT-CACHED-PACKET
|
||||
28951 . 29088)) (30529 34252 (BMTOPACKET 30539 . 32500) (PACKETTOBM 32502 . 34250)) (34556 38865 (
|
||||
FRAME-EVENT 34566 . 35224) (MAKE-FRAME 35226 . 37008) (MOVE-FRAME 37010 . 37280) (SHAPE-FRAME 37282 .
|
||||
38672) (SET-FRAME-TITLE 38674 . 38863)) (38915 45792 (MAKE-MENUS-WINDOW 38925 . 41284) (MODE-MENU
|
||||
41286 . 45790)) (45968 48955 (FASTBITBLT 45978 . 48953)))))
|
||||
(FILEMAP (NIL (2306 12237 (CLOSE-FRAME 2316 . 2467) (GET-BITS 2469 . 10758) (START-GET-BITS 10760 .
|
||||
12235)) (12293 25340 (SEND-BITS 12303 . 15124) (SEND-TILE 15126 . 18249) (LISTEN-TO-VIEWER 18251 .
|
||||
19554) (MAPTILES 19556 . 24279) (SHUT-DOWN-VIEWER 24281 . 25150) (CHANGE-SENDER-UPDATE-MODE 25152 .
|
||||
25338)) (25342 25656 (INCR 25342 . 25656)) (25658 25816 (\PILOTBITBLT 25658 . 25816)) (26181 28052 (
|
||||
PACKET-EQUAL 26191 . 27594) (GET-CACHED-PACKET 27596 . 27911) (PUT-CACHED-PACKET 27913 . 28050)) (
|
||||
29490 33213 (BMTOPACKET 29500 . 31461) (PACKETTOBM 31463 . 33211)) (33517 37826 (FRAME-EVENT 33527 .
|
||||
34185) (MAKE-FRAME 34187 . 35969) (MOVE-FRAME 35971 . 36241) (SHAPE-FRAME 36243 . 37633) (
|
||||
SET-FRAME-TITLE 37635 . 37824)) (37876 44753 (MAKE-MENUS-WINDOW 37886 . 40245) (MODE-MENU 40247 .
|
||||
44751)) (44930 47917 (FASTBITBLT 44940 . 47915)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
Binary file not shown.
116
lispusers/CROCK
116
lispusers/CROCK
@@ -1,43 +1,43 @@
|
||||
(DEFINE-FILE-INFO §READTABLE "INTERLISP" §PACKAGE "INTERLISP")
|
||||
(FILECREATED " 2-Apr-87 00:37:46" {ERIS}<LISPUSERS>LYRIC>CROCK.;2 17791
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
previous date%: "11-Jan-86 19:46:27" {PHYLUM}<LISPUSERS>LYRIC>CROCK.;1)
|
||||
(FILECREATED "18-Feb-2026 16:26:31" {WMEDLEY}<lispusers>CROCK.;2 17189
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:PREVIOUS-DATE " 2-Apr-87 00:37:46" {WMEDLEY}<lispusers>CROCK.;1)
|
||||
|
||||
(* "
|
||||
Copyright (c) 1984, 1985, 1986, 1987 by Xerox Corporation. All rights reserved.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT CROCKCOMS)
|
||||
|
||||
(RPAQQ CROCKCOMS ((* CROCK -- By Kelly Roach *)
|
||||
(FNS CROCK CROCK.BUTTONEVENTFN CROCK.CHANGE.STYLE CROCK.CLOSEFN CROCK.PROCESS
|
||||
CROCK.RESHAPEFN CROCK.ALARM CROCK.RING.ALARM CROCK.INIT)
|
||||
(INITVARS (CROCK.DEFAULT.STYLE '(HANDS T TIMES NIL RINGS NIL NUMBERS T))
|
||||
(CROCK.STYLE.MENU)
|
||||
(CROCK.ALARMS)
|
||||
(CROCK.DATEFORMAT '(DATEFORMAT NO.SECONDS))
|
||||
[CROCK.TUNE '((1000 . 1000)
|
||||
(800 . 1000)
|
||||
(600 . 1000)
|
||||
(500 . 1000)
|
||||
(400 . 1000)
|
||||
(NIL . 500)
|
||||
(440 . 1000)
|
||||
(484 . 1000)
|
||||
(540 . 1000)
|
||||
(600 . 1000)
|
||||
(2000 . 1000)
|
||||
(1600 . 1000)
|
||||
(1200 . 1000)
|
||||
(1000 . 1000)
|
||||
(800 . 1000)
|
||||
(NIL . 500)
|
||||
(880 . 1000)
|
||||
(968 . 1000)
|
||||
(1080 . 1000)
|
||||
(1188 . 1000]
|
||||
(CROCKWINDOW))))
|
||||
(RPAQQ CROCKCOMS
|
||||
((* CROCK -- By Kelly Roach *)
|
||||
(FNS CROCK CROCK.BUTTONEVENTFN CROCK.CHANGE.STYLE CROCK.CLOSEFN CROCK.PROCESS CROCK.RESHAPEFN
|
||||
CROCK.ALARM CROCK.RING.ALARM CROCK.INIT)
|
||||
(INITVARS (CROCK.DEFAULT.STYLE '(HANDS T TIMES NIL RINGS NIL NUMBERS T))
|
||||
(CROCK.STYLE.MENU)
|
||||
(CROCK.ALARMS)
|
||||
(CROCK.DATEFORMAT '(DATEFORMAT NO.SECONDS))
|
||||
[CROCK.TUNE '((1000 . 1000)
|
||||
(800 . 1000)
|
||||
(600 . 1000)
|
||||
(500 . 1000)
|
||||
(400 . 1000)
|
||||
(NIL . 500)
|
||||
(440 . 1000)
|
||||
(484 . 1000)
|
||||
(540 . 1000)
|
||||
(600 . 1000)
|
||||
(2000 . 1000)
|
||||
(1600 . 1000)
|
||||
(1200 . 1000)
|
||||
(1000 . 1000)
|
||||
(800 . 1000)
|
||||
(NIL . 500)
|
||||
(880 . 1000)
|
||||
(968 . 1000)
|
||||
(1080 . 1000)
|
||||
(1188 . 1000]
|
||||
(CROCKWINDOW))))
|
||||
|
||||
|
||||
|
||||
@@ -334,31 +334,31 @@ Copyright (c) 1984, 1985, 1986, 1987 by Xerox Corporation. All rights reserved.
|
||||
|
||||
(RPAQ? CROCK.DATEFORMAT '(DATEFORMAT NO.SECONDS))
|
||||
|
||||
(RPAQ? CROCK.TUNE '((1000 . 1000)
|
||||
(800 . 1000)
|
||||
(600 . 1000)
|
||||
(500 . 1000)
|
||||
(400 . 1000)
|
||||
(NIL . 500)
|
||||
(440 . 1000)
|
||||
(484 . 1000)
|
||||
(540 . 1000)
|
||||
(600 . 1000)
|
||||
(2000 . 1000)
|
||||
(1600 . 1000)
|
||||
(1200 . 1000)
|
||||
(1000 . 1000)
|
||||
(800 . 1000)
|
||||
(NIL . 500)
|
||||
(880 . 1000)
|
||||
(968 . 1000)
|
||||
(1080 . 1000)
|
||||
(1188 . 1000)))
|
||||
(RPAQ? CROCK.TUNE
|
||||
'((1000 . 1000)
|
||||
(800 . 1000)
|
||||
(600 . 1000)
|
||||
(500 . 1000)
|
||||
(400 . 1000)
|
||||
(NIL . 500)
|
||||
(440 . 1000)
|
||||
(484 . 1000)
|
||||
(540 . 1000)
|
||||
(600 . 1000)
|
||||
(2000 . 1000)
|
||||
(1600 . 1000)
|
||||
(1200 . 1000)
|
||||
(1000 . 1000)
|
||||
(800 . 1000)
|
||||
(NIL . 500)
|
||||
(880 . 1000)
|
||||
(968 . 1000)
|
||||
(1080 . 1000)
|
||||
(1188 . 1000)))
|
||||
|
||||
(RPAQ? CROCKWINDOW )
|
||||
(PUTPROPS CROCK COPYRIGHT ("Xerox Corporation" 1984 1985 1986 1987))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (1940 16814 (CROCK 1950 . 2520) (CROCK.BUTTONEVENTFN 2522 . 2811) (CROCK.CHANGE.STYLE
|
||||
2813 . 5626) (CROCK.CLOSEFN 5628 . 5790) (CROCK.PROCESS 5792 . 14290) (CROCK.RESHAPEFN 14292 . 14451)
|
||||
(CROCK.ALARM 14453 . 15681) (CROCK.RING.ALARM 15683 . 16424) (CROCK.INIT 16426 . 16812)))))
|
||||
(FILEMAP (NIL (1609 16483 (CROCK 1619 . 2189) (CROCK.BUTTONEVENTFN 2191 . 2480) (CROCK.CHANGE.STYLE
|
||||
2482 . 5295) (CROCK.CLOSEFN 5297 . 5459) (CROCK.PROCESS 5461 . 13959) (CROCK.RESHAPEFN 13961 . 14120)
|
||||
(CROCK.ALARM 14122 . 15350) (CROCK.RING.ALARM 15352 . 16093) (CROCK.INIT 16095 . 16481)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,14 +1,11 @@
|
||||
(DEFINE-FILE-INFO §READTABLE "INTERLISP" §PACKAGE "INTERLISP")
|
||||
(FILECREATED "13-Jan-87 01:23:25" {ERIS}<LISPUSERS>LISPCORE>DEFAULTICON.;1 4586
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
changes to%: (FNS \MAKEICONWINDOW)
|
||||
(FILECREATED "18-Feb-2026 16:26:48" {WMEDLEY}<lispusers>DEFAULTICON.;2 4702
|
||||
|
||||
previous date%: "19-Dec-85 01:24:06" {ERIS}<LISP>KOTO>LISPUSERS>DEFAULTICON.;1)
|
||||
:EDIT-BY rmk
|
||||
|
||||
:PREVIOUS-DATE "13-Jan-87 01:23:25" {WMEDLEY}<lispusers>DEFAULTICON.;1)
|
||||
|
||||
(* "
|
||||
Copyright (c) 1985, 1987 by Xerox Corporation. All rights reserved.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT DEFAULTICONCOMS)
|
||||
|
||||
@@ -16,137 +13,140 @@ Copyright (c) 1985, 1987 by Xerox Corporation. All rights reserved.
|
||||
(UGLYVARS \DEFAULTICON)
|
||||
(INITVARS (DEFAULTICON \DEFAULTICON))
|
||||
(FNS \MAKEICONWINDOW)))
|
||||
|
||||
(FILESLOAD ICONW)
|
||||
(READVARS \DEFAULTICON)
|
||||
(({(READBITMAP)(64 64
|
||||
"@@@@@@@@@@@@@@@@"
|
||||
"@@@@@@@@@@@@@@@@"
|
||||
"@@@@@@@@@@@@@@@@"
|
||||
"@@@@@@@@@@@@@@@@"
|
||||
"@@@@@@@@@@@@@@@@"
|
||||
"@@AOOOOOOOOOOH@@"
|
||||
"@@N@@@@@@@@@@G@@"
|
||||
"@C@@@@@@@@@@@@L@"
|
||||
"@D@@@@@@@@@@@@B@"
|
||||
"@H@@@@@@@@@@@@A@"
|
||||
"A@@@@@@@@@@@@@@H"
|
||||
"B@@@@@@@@@@@CO@D"
|
||||
"B@@@@@@@@@@@BDHD"
|
||||
"D@@@@@@@@@@@ABDB"
|
||||
"D@@@@@@@@@@@AODB"
|
||||
"D@@@@@@@@@@@ABLB"
|
||||
"D@@@@@@@@@@@ABDA"
|
||||
"H@@@@@@@@@@@ABDA"
|
||||
"H@@@@@@@@@@@AOHA"
|
||||
"H@@@@@@@@@@@@@@A"
|
||||
"H@@@@@@@@@@@@@@A"
|
||||
"H@@@@@@@@@@@@@@A"
|
||||
"H@@@@@@@@@@@@@@A"
|
||||
"H@@@@@@@@@@@@@@A"
|
||||
"H@@@@@@@@@@@@@@A"
|
||||
"H@@@@@@@@@@@@@@A"
|
||||
"H@@@@@@@@@@@@@@A"
|
||||
"H@@@@@@@@@@@@@@A"
|
||||
"H@@@@@@@@@@@@@@A"
|
||||
"H@@@@@@@@@@@@@@A"
|
||||
"H@@@@@@@@@@@@@@A"
|
||||
"H@@@@@@@@@@@@@@A"
|
||||
"H@@@@@@@@@@@@@@A"
|
||||
"H@@@@@@@@@@@@@@A"
|
||||
"H@@@@@@@@@@@@@@A"
|
||||
"H@@@@@@@@@@@@@@A"
|
||||
"H@@@@@@@@@@@@@@A"
|
||||
"H@@@@@@@@@@@@@@A"
|
||||
"H@@@@@@@@@@@@@@A"
|
||||
"H@@@@@@@@@@@@@@A"
|
||||
"H@@@@@@@@@@@@@@A"
|
||||
"H@@@@@@@@@@@@@@A"
|
||||
"H@@@@@@@@@@@@@@A"
|
||||
"H@@@@@@@@@@@@@@A"
|
||||
"H@@@@@@@@@@@@@@A"
|
||||
"H@@@@@@@@@@@@@@A"
|
||||
"H@@@@@@@@@@@@@@A"
|
||||
"H@@@@@@@@@@@@@@A"
|
||||
"H@@@@@@@@@@@@@@A"
|
||||
"H@@@@@@@@@@@@@@A"
|
||||
"H@@@@@@@@@@@@@@A"
|
||||
"H@@@@@@@@@@@@@@A"
|
||||
"H@@@@@@@@@@@@@@A"
|
||||
"D@@@@@@@@@@@@@@B"
|
||||
"D@@@@@@@@@@@@@@B"
|
||||
"D@@@@@@@@@@@@@@B"
|
||||
"B@@@@@@@@@@@@@@D"
|
||||
"B@@@@@@@@@@@@@@D"
|
||||
"A@@@@@@@@@@@@@@H"
|
||||
"@H@@@@@@@@@@@@A@"
|
||||
"@D@@@@@@@@@@@@B@"
|
||||
"@C@@@@@@@@@@@@L@"
|
||||
"@@N@@@@@@@@@@G@@"
|
||||
"@@AOOOOOOOOOOH@@")} {(READBITMAP)(64 64
|
||||
"@@@@@@@@@@@@@@@@"
|
||||
"@@@@@@@@@@@@@@@@"
|
||||
"@@@@@@@@@@@@@@@@"
|
||||
"@@@@@@@@@@@@@@@@"
|
||||
"@@@@@@@@@@@@@@@@"
|
||||
"@@AOOOOOOOOOOH@@"
|
||||
"@@OOOOOOOOOOOO@@"
|
||||
"@COOOOOOOOOOOOL@"
|
||||
"@GOOOOOOOOOOOON@"
|
||||
"@OOOOOOOOOOOOOO@"
|
||||
"AOOOOOOOOOOOOOOH"
|
||||
"COOOOOOOOOOOOOOL"
|
||||
"COOOOOOOOOOONDOL"
|
||||
"GOOOOOOOOOOOOBGN"
|
||||
"GOOOOOOOOOOOOOGN"
|
||||
"GOOOOOOOOOOOOBON"
|
||||
"GOOOOOOOOOOOOBGO"
|
||||
"OOOOOOOOOOOOOBGO"
|
||||
"OOOOOOOOOOOOOOOO"
|
||||
"OOOOOOOOOOOOOOOO"
|
||||
"OOOOOOOOOOOOOOOO"
|
||||
"OOOOOOOOOOOOOOOO"
|
||||
"OOOOOOOOOOOOOOOO"
|
||||
"OOOOOOOOOOOOOOOO"
|
||||
"OOOOOOOOOOOOOOOO"
|
||||
"OOOOOOOOOOOOOOOO"
|
||||
"OOOOOOOOOOOOOOOO"
|
||||
"OOOOOOOOOOOOOOOO"
|
||||
"OOOOOOOOOOOOOOOO"
|
||||
"OOOOOOOOOOOOOOOO"
|
||||
"OOOOOOOOOOOOOOOO"
|
||||
"OOOOOOOOOOOOOOOO"
|
||||
"OOOOOOOOOOOOOOOO"
|
||||
"OOOOOOOOOOOOOOOO"
|
||||
"OOOOOOOOOOOOOOOO"
|
||||
"OOOOOOOOOOOOOOOO"
|
||||
"OOOOOOOOOOOOOOOO"
|
||||
"OOOOOOOOOOOOOOOO"
|
||||
"OOOOOOOOOOOOOOOO"
|
||||
"OOOOOOOOOOOOOOOO"
|
||||
"OOOOOOOOOOOOOOOO"
|
||||
"OOOOOOOOOOOOOOOO"
|
||||
"OOOOOOOOOOOOOOOO"
|
||||
"OOOOOOOOOOOOOOOO"
|
||||
"OOOOOOOOOOOOOOOO"
|
||||
"OOOOOOOOOOOOOOOO"
|
||||
"OOOOOOOOOOOOOOOO"
|
||||
"OOOOOOOOOOOOOOOO"
|
||||
"OOOOOOOOOOOOOOOO"
|
||||
"OOOOOOOOOOOOOOOO"
|
||||
"OOOOOOOOOOOOOOOO"
|
||||
"OOOOOOOOOOOOOOOO"
|
||||
"OOOOOOOOOOOOOOOO"
|
||||
"GOOOOOOOOOOOOOON"
|
||||
"GOOOOOOOOOOOOOON"
|
||||
"GOOOOOOOOOOOOOON"
|
||||
"COOOOOOOOOOOOOOL"
|
||||
"COOOOOOOOOOOOOOL"
|
||||
"AOOOOOOOOOOOOOOH"
|
||||
"@OOOOOOOOOOOOOO@"
|
||||
"@GOOOOOOOOOOOON@"
|
||||
"@COOOOOOOOOOOOL@"
|
||||
"@@OOOOOOOOOOOO@@"
|
||||
"@@AOOOOOOOOOOH@@")} (5 6 52 46)))
|
||||
|
||||
(READVARS-FROM-STRINGS '(\DEFAULTICON)
|
||||
"(({(READBITMAP)(64 64
|
||||
%"@@@@@@@@@@@@@@@@%"
|
||||
%"@@@@@@@@@@@@@@@@%"
|
||||
%"@@@@@@@@@@@@@@@@%"
|
||||
%"@@@@@@@@@@@@@@@@%"
|
||||
%"@@@@@@@@@@@@@@@@%"
|
||||
%"@@AOOOOOOOOOOH@@%"
|
||||
%"@@N@@@@@@@@@@G@@%"
|
||||
%"@C@@@@@@@@@@@@L@%"
|
||||
%"@D@@@@@@@@@@@@B@%"
|
||||
%"@H@@@@@@@@@@@@A@%"
|
||||
%"A@@@@@@@@@@@@@@H%"
|
||||
%"B@@@@@@@@@@@CO@D%"
|
||||
%"B@@@@@@@@@@@BDHD%"
|
||||
%"D@@@@@@@@@@@ABDB%"
|
||||
%"D@@@@@@@@@@@AODB%"
|
||||
%"D@@@@@@@@@@@ABLB%"
|
||||
%"D@@@@@@@@@@@ABDA%"
|
||||
%"H@@@@@@@@@@@ABDA%"
|
||||
%"H@@@@@@@@@@@AOHA%"
|
||||
%"H@@@@@@@@@@@@@@A%"
|
||||
%"H@@@@@@@@@@@@@@A%"
|
||||
%"H@@@@@@@@@@@@@@A%"
|
||||
%"H@@@@@@@@@@@@@@A%"
|
||||
%"H@@@@@@@@@@@@@@A%"
|
||||
%"H@@@@@@@@@@@@@@A%"
|
||||
%"H@@@@@@@@@@@@@@A%"
|
||||
%"H@@@@@@@@@@@@@@A%"
|
||||
%"H@@@@@@@@@@@@@@A%"
|
||||
%"H@@@@@@@@@@@@@@A%"
|
||||
%"H@@@@@@@@@@@@@@A%"
|
||||
%"H@@@@@@@@@@@@@@A%"
|
||||
%"H@@@@@@@@@@@@@@A%"
|
||||
%"H@@@@@@@@@@@@@@A%"
|
||||
%"H@@@@@@@@@@@@@@A%"
|
||||
%"H@@@@@@@@@@@@@@A%"
|
||||
%"H@@@@@@@@@@@@@@A%"
|
||||
%"H@@@@@@@@@@@@@@A%"
|
||||
%"H@@@@@@@@@@@@@@A%"
|
||||
%"H@@@@@@@@@@@@@@A%"
|
||||
%"H@@@@@@@@@@@@@@A%"
|
||||
%"H@@@@@@@@@@@@@@A%"
|
||||
%"H@@@@@@@@@@@@@@A%"
|
||||
%"H@@@@@@@@@@@@@@A%"
|
||||
%"H@@@@@@@@@@@@@@A%"
|
||||
%"H@@@@@@@@@@@@@@A%"
|
||||
%"H@@@@@@@@@@@@@@A%"
|
||||
%"H@@@@@@@@@@@@@@A%"
|
||||
%"H@@@@@@@@@@@@@@A%"
|
||||
%"H@@@@@@@@@@@@@@A%"
|
||||
%"H@@@@@@@@@@@@@@A%"
|
||||
%"H@@@@@@@@@@@@@@A%"
|
||||
%"H@@@@@@@@@@@@@@A%"
|
||||
%"H@@@@@@@@@@@@@@A%"
|
||||
%"D@@@@@@@@@@@@@@B%"
|
||||
%"D@@@@@@@@@@@@@@B%"
|
||||
%"D@@@@@@@@@@@@@@B%"
|
||||
%"B@@@@@@@@@@@@@@D%"
|
||||
%"B@@@@@@@@@@@@@@D%"
|
||||
%"A@@@@@@@@@@@@@@H%"
|
||||
%"@H@@@@@@@@@@@@A@%"
|
||||
%"@D@@@@@@@@@@@@B@%"
|
||||
%"@C@@@@@@@@@@@@L@%"
|
||||
%"@@N@@@@@@@@@@G@@%"
|
||||
%"@@AOOOOOOOOOOH@@%")} {(READBITMAP)(64 64
|
||||
%"@@@@@@@@@@@@@@@@%"
|
||||
%"@@@@@@@@@@@@@@@@%"
|
||||
%"@@@@@@@@@@@@@@@@%"
|
||||
%"@@@@@@@@@@@@@@@@%"
|
||||
%"@@@@@@@@@@@@@@@@%"
|
||||
%"@@AOOOOOOOOOOH@@%"
|
||||
%"@@OOOOOOOOOOOO@@%"
|
||||
%"@COOOOOOOOOOOOL@%"
|
||||
%"@GOOOOOOOOOOOON@%"
|
||||
%"@OOOOOOOOOOOOOO@%"
|
||||
%"AOOOOOOOOOOOOOOH%"
|
||||
%"COOOOOOOOOOOOOOL%"
|
||||
%"COOOOOOOOOOONDOL%"
|
||||
%"GOOOOOOOOOOOOBGN%"
|
||||
%"GOOOOOOOOOOOOOGN%"
|
||||
%"GOOOOOOOOOOOOBON%"
|
||||
%"GOOOOOOOOOOOOBGO%"
|
||||
%"OOOOOOOOOOOOOBGO%"
|
||||
%"OOOOOOOOOOOOOOOO%"
|
||||
%"OOOOOOOOOOOOOOOO%"
|
||||
%"OOOOOOOOOOOOOOOO%"
|
||||
%"OOOOOOOOOOOOOOOO%"
|
||||
%"OOOOOOOOOOOOOOOO%"
|
||||
%"OOOOOOOOOOOOOOOO%"
|
||||
%"OOOOOOOOOOOOOOOO%"
|
||||
%"OOOOOOOOOOOOOOOO%"
|
||||
%"OOOOOOOOOOOOOOOO%"
|
||||
%"OOOOOOOOOOOOOOOO%"
|
||||
%"OOOOOOOOOOOOOOOO%"
|
||||
%"OOOOOOOOOOOOOOOO%"
|
||||
%"OOOOOOOOOOOOOOOO%"
|
||||
%"OOOOOOOOOOOOOOOO%"
|
||||
%"OOOOOOOOOOOOOOOO%"
|
||||
%"OOOOOOOOOOOOOOOO%"
|
||||
%"OOOOOOOOOOOOOOOO%"
|
||||
%"OOOOOOOOOOOOOOOO%"
|
||||
%"OOOOOOOOOOOOOOOO%"
|
||||
%"OOOOOOOOOOOOOOOO%"
|
||||
%"OOOOOOOOOOOOOOOO%"
|
||||
%"OOOOOOOOOOOOOOOO%"
|
||||
%"OOOOOOOOOOOOOOOO%"
|
||||
%"OOOOOOOOOOOOOOOO%"
|
||||
%"OOOOOOOOOOOOOOOO%"
|
||||
%"OOOOOOOOOOOOOOOO%"
|
||||
%"OOOOOOOOOOOOOOOO%"
|
||||
%"OOOOOOOOOOOOOOOO%"
|
||||
%"OOOOOOOOOOOOOOOO%"
|
||||
%"OOOOOOOOOOOOOOOO%"
|
||||
%"OOOOOOOOOOOOOOOO%"
|
||||
%"OOOOOOOOOOOOOOOO%"
|
||||
%"OOOOOOOOOOOOOOOO%"
|
||||
%"OOOOOOOOOOOOOOOO%"
|
||||
%"OOOOOOOOOOOOOOOO%"
|
||||
%"GOOOOOOOOOOOOOON%"
|
||||
%"GOOOOOOOOOOOOOON%"
|
||||
%"GOOOOOOOOOOOOOON%"
|
||||
%"COOOOOOOOOOOOOOL%"
|
||||
%"COOOOOOOOOOOOOOL%"
|
||||
%"AOOOOOOOOOOOOOOH%"
|
||||
%"@OOOOOOOOOOOOOO@%"
|
||||
%"@GOOOOOOOOOOOON@%"
|
||||
%"@COOOOOOOOOOOOL@%"
|
||||
%"@@OOOOOOOOOOOO@@%"
|
||||
%"@@AOOOOOOOOOOH@@%")} (5 6 52 46)))
|
||||
")
|
||||
|
||||
(RPAQ? DEFAULTICON \DEFAULTICON)
|
||||
(DEFINEQ
|
||||
@@ -175,7 +175,6 @@ Copyright (c) 1985, 1987 by Xerox Corporation. All rights reserved.
|
||||
(WINDOWPROP icon 'HEIGHT]
|
||||
icon])
|
||||
)
|
||||
(PUTPROPS DEFAULTICON COPYRIGHT ("Xerox Corporation" 1985 1987))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (3170 4498 (\MAKEICONWINDOW 3180 . 4496)))))
|
||||
(FILEMAP (NIL (3351 4679 (\MAKEICONWINDOW 3361 . 4677)))))
|
||||
STOP
|
||||
|
||||
@@ -1,17 +1,17 @@
|
||||
(DEFINE-FILE-INFO §READTABLE "INTERLISP" §PACKAGE "INTERLISP")
|
||||
(FILECREATED " 4-Mar-87 15:59:01" {PHYLUM}<LISPUSERS>LYRIC>DEFAULTSUBITEMFN.;1 1299
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
previous date%: "31-Jan-86 17:45:55" {PHYLUM}<LISP>KOTO>LISPUSERS>DEFAULTSUBITEMFN.;1)
|
||||
(FILECREATED "18-Feb-2026 16:28:38" {WMEDLEY}<lispusers>DEFAULTSUBITEMFN.;2 1229
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:PREVIOUS-DATE " 4-Mar-87 15:59:01" {WMEDLEY}<lispusers>DEFAULTSUBITEMFN.;1)
|
||||
|
||||
(* "
|
||||
Copyright (c) 1986, 1987 by Xerox Corporation. All rights reserved.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT DEFAULTSUBITEMFNCOMS)
|
||||
|
||||
(RPAQQ DEFAULTSUBITEMFNCOMS ((* * redefine the DEFAULTSUBITEMFN to add the EVAL keyword to the subitem menu field) (FNS DEFAULTSUBITEMFN))
|
||||
)
|
||||
(RPAQQ DEFAULTSUBITEMFNCOMS ((* * redefine the DEFAULTSUBITEMFN to add the EVAL keyword to the
|
||||
subitem menu field)
|
||||
(FNS DEFAULTSUBITEMFN)))
|
||||
(* * redefine the DEFAULTSUBITEMFN to add the EVAL keyword to the subitem menu field)
|
||||
|
||||
(DEFINEQ
|
||||
@@ -20,7 +20,6 @@ Copyright (c) 1986, 1987 by Xerox Corporation. All rights reserved.
|
||||
(LAMBDA (MENU ITEM) (* edited%: "31-Dec-85 16:41") (* rrb "17-Aug-84 17:24") (* default subitemfn for menus. Checks the fourth element of the item for an expression of the form (SUBITEMS a b c) or if the fourth element is (EVAL form) will return the value of form. MENU and ITEM will be available during the evaluation) (PROG (TEMP) (RETURN (if (AND (LISTP ITEM) (LISTP (SETQ TEMP (CDR ITEM))) (LISTP (SETQ TEMP (CDR TEMP))) (LISTP (SETQ TEMP (CDR TEMP)))) then (SELECTQ (CAR (SETQ TEMP (LISTP (CAR TEMP)))) (SUBITEMS (CDR TEMP)) (EVAL (EVAL (CADR TEMP))) NIL)))))
|
||||
)
|
||||
)
|
||||
(PUTPROPS DEFAULTSUBITEMFN COPYRIGHT ("Xerox Corporation" 1986 1987))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (606 1206 (DEFAULTSUBITEMFN 616 . 1204)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,26 +1,27 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED " 1-Feb-2026 13:03:18" {WMEDLEY}<lispusers>ISO8859IO.;19 23459
|
||||
(FILECREATED "22-Feb-2026 12:22:12" {WMEDLEY}<lispusers>ISO8859IO.;22 21861
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (FNS \MAKERECODEMAP MAKEISOFORMAT \8859OUTCHARFN \8859INCCODEFN \8859PEEKCCODEFN)
|
||||
:CHANGES-TO (FNS ISO1TOMSTRING MTOISO1STRING)
|
||||
(VARS ISO8859IOCOMS)
|
||||
|
||||
:PREVIOUS-DATE " 8-Aug-2021 13:22:31" {WMEDLEY}<lispusers>ISO8859IO.;11)
|
||||
:PREVIOUS-DATE " 2-Feb-2026 23:20:20" {WMEDLEY}<lispusers>ISO8859IO.;20)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT ISO8859IOCOMS)
|
||||
|
||||
(RPAQQ ISO8859IOCOMS
|
||||
(
|
||||
(* ;; "This package defines EXTERNALFORMATS for files that are encoded in either ISO8859/1, the standard IBM extended ascii, or the usual MAC encoding.")
|
||||
(* ;; "This package defines EXTERNALFORMATS for files that are encoded in ISIO8859/1, the standard IBM extended ascii, or the legacy MAC encoding.")
|
||||
|
||||
(COMS (* ; "ISO8859/1")
|
||||
(FNS \8859OUTCHARFN \8859INCCODEFN \8859PEEKCCODEFN)
|
||||
(GLOBALVARS *MCCSTOISO8859MAP* *ISO8859TOMCCSMAP*)
|
||||
(FNS MAKEISOFORMAT)
|
||||
(P (MAKEISOFORMAT)))
|
||||
[COMS (* ; "ISO8859/1")
|
||||
(FNS ISO1TOMCODE MTOISO1CODE \CREATE.ISO1.FORMAT)
|
||||
(FNS ISO1TOMSTRING MTOISO1STRING)
|
||||
(VARS ISO1TOMCCS)
|
||||
(GLOBALVARS ISO1TOMCCS)
|
||||
(DECLARE%: DONTEVAL@LOAD DOCOPY (P (\CREATE.ISO1.FORMAT]
|
||||
(COMS (* ; "IBM-PC Extended Ascii")
|
||||
(FNS \IBMOUTCHARFN \IBMINCCODEFN \IBMPEEKCCODEFN)
|
||||
(GLOBALVARS *XEROXTOIBMMAP* *IBMTOXEROXMAP*)
|
||||
@@ -37,7 +38,7 @@
|
||||
|
||||
|
||||
(* ;;
|
||||
"This package defines EXTERNALFORMATS for files that are encoded in either ISO8859/1, the standard IBM extended ascii, or the usual MAC encoding."
|
||||
"This package defines EXTERNALFORMATS for files that are encoded in ISIO8859/1, the standard IBM extended ascii, or the legacy MAC encoding."
|
||||
)
|
||||
|
||||
|
||||
@@ -47,152 +48,150 @@
|
||||
|
||||
(DEFINEQ
|
||||
|
||||
(\8859OUTCHARFN
|
||||
[LAMBDA (STREAM CHARCODE)
|
||||
(DECLARE (GLOBALVARS *XEROXTOISO8859MAP*)) (* ; "Edited 1-Feb-2026 10:11 by rmk")
|
||||
(* ; "Edited 8-Aug-2021 13:21 by rmk:")
|
||||
(* ; "Edited 7-Dec-95 14:34 by ")
|
||||
(* ; "Edited 7-Dec-95 14:32 by ")
|
||||
(ISO1TOMCODE
|
||||
[LAMBDA (ICODE) (* ; "Edited 5-Feb-2026 12:09 by rmk")
|
||||
(* ; "Edited 2-Feb-2026 23:14 by rmk")
|
||||
(* ; "Edited 7-Sep-2025 22:39 by rmk")
|
||||
(* ; "Edited 3-Sep-2025 10:21 by rmk")
|
||||
(* ; "Edited 7-Aug-2025 09:37 by rmk")
|
||||
|
||||
(* ;; "Converts CHARCODE from internal encoding to ISO8859 before printing.")
|
||||
(* ;; "ISO codes are 8bit, MCODES maybe not. Caller shouldn't pass a fat code.")
|
||||
|
||||
(* ;; "Unconverted codes are left unchanged (no error).")
|
||||
(OR [CAR (find PAIR in ISO1TOMCCS suchthat (EQ ICODE (CADR PAIR]
|
||||
ICODE])
|
||||
|
||||
(* ;; "If any remaining codes are out of charset 0, the streams external format will be used. ")
|
||||
(MTOISO1CODE
|
||||
[LAMBDA (MCODE) (* ; "Edited 5-Feb-2026 12:26 by rmk")
|
||||
(* ; "Edited 2-Feb-2026 22:58 by rmk")
|
||||
(OR (CADR (ASSOC MCODE ISO1TOMCCS))
|
||||
MCODE])
|
||||
|
||||
(IF (EQ CHARCODE (CHARCODE EOL))
|
||||
THEN (FREPLACE (STREAM CHARPOSITION) OF STREAM WITH 0)
|
||||
(\BOUTEOL STREAM)
|
||||
ELSE (CHANGE (FFETCH (STREAM CHARPOSITION) OF STREAM)
|
||||
(IPLUS16 1 DATUM))
|
||||
(\BOUT STREAM (IF (IGREATERP CHARCODE 127)
|
||||
THEN
|
||||
|
||||
(* ;; "We know that ISO doesn't have floating accents, so only singletons are returned. We also know that it agrees with MCCS on first 128, except for cirumflex and underscore")
|
||||
|
||||
(\RECODECCODE CHARCODE *MCCSTOISO8859MAP*)
|
||||
ELSE CHARCODE])
|
||||
|
||||
(\8859INCCODEFN
|
||||
[LAMBDA (STRM COUNTP) (* ; "Edited 1-Feb-2026 10:10 by rmk")
|
||||
(* ; "Edited 6-Aug-2021 16:10 by rmk:")
|
||||
(* ; "Edited 7-Dec-95 15:24 by ")
|
||||
(* ; "Edited 7-Dec-95 15:19 by ")
|
||||
(DECLARE (USEDFREE *BYTECOUNTER*))
|
||||
(CL:WHEN COUNTP (SETQ *BYTECOUNTER* 1))
|
||||
(\RECODECCODE (\BIN STRM)
|
||||
*ISO8859TOMCCSMAP*])
|
||||
|
||||
(\8859PEEKCCODEFN
|
||||
[LAMBDA (STRM NOERROR) (* ; "Edited 1-Feb-2026 10:10 by rmk")
|
||||
(* ; "Edited 5-May-2021 17:44 by rmk:")
|
||||
(* ; "Edited 3-Jan-96 14:21 by ")
|
||||
(* ; "Edited 7-Dec-95 15:51 by ")
|
||||
(* ; "Edited 7-Dec-95 15:19 by ")
|
||||
(\RECODECCODE (\PEEKCCODE STRM NOERROR)
|
||||
*ISO8859TOMCCSMAP*])
|
||||
)
|
||||
(DECLARE%: DOEVAL@COMPILE DONTCOPY
|
||||
|
||||
(GLOBALVARS *MCCSTOISO8859MAP* *ISO8859TOMCCSMAP*)
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
(MAKEISOFORMAT
|
||||
[LAMBDA NIL (* ; "Edited 1-Feb-2026 11:18 by rmk")
|
||||
(\CREATE.ISO1.FORMAT
|
||||
[LAMBDA NIL (* ; "Edited 5-Feb-2026 10:42 by rmk")
|
||||
(* ; "Edited 2-Feb-2026 23:37 by rmk")
|
||||
(* ; "Edited 1-Feb-2026 11:18 by rmk")
|
||||
(* ; "Edited 5-Aug-2021 22:15 by rmk:")
|
||||
(* ; "Edited 9-Mar-99 17:19 by rmk:")
|
||||
(* ; "Edited 7-Dec-95 16:24 by ")
|
||||
(* ; "Edited 7-Dec-95 16:20 by ")
|
||||
(LET [(MCCSTOISO '(("0,255" "0,136")
|
||||
("0,254" "0,137")
|
||||
("357,41" "0,240")
|
||||
("357,153" "0,246")
|
||||
("43,42" "0,250")
|
||||
("0,323" "0,251")
|
||||
("0,343" "0,252")
|
||||
("357,152" "0,254")
|
||||
("357,43" "0,255")
|
||||
("0,322" "0,256")
|
||||
("43,176" "0,257")
|
||||
("43,47" "0,264")
|
||||
("0,313" "0,270")
|
||||
("0,321" "0,271")
|
||||
("0,353" "0.272")
|
||||
("361,41" "0,300")
|
||||
("361,42" "0,301")
|
||||
("361,43" "0,302")
|
||||
("361,44" "0,303")
|
||||
("361,47" "0,304")
|
||||
("361,50" "0,305")
|
||||
("0,341" "0,306")
|
||||
("361,55" "0,307")
|
||||
("361,60" "0,310")
|
||||
("361,61" "0,311")
|
||||
("361,62" "0,312")
|
||||
("361,65" "0,313")
|
||||
("361,76" "0,314")
|
||||
("361,77" "0,315")
|
||||
("361,100" "0,316")
|
||||
("361,104" "0,317")
|
||||
("0,342" "0,320")
|
||||
("361,114" "0,321")
|
||||
("361,117" "0,322")
|
||||
("361,120" "0,323")
|
||||
("361,121" "0,324")
|
||||
("361,122" "0,325")
|
||||
("361,124" "0,326")
|
||||
("0,264" "0,327")
|
||||
("0,351" "0,330")
|
||||
("361,137" "0,331")
|
||||
("361,140" "0,332")
|
||||
("361,141" "0,333")
|
||||
("361,145" "0,334")
|
||||
("361,153" "0,335")
|
||||
("0,354" "0,336")
|
||||
("0,373" "0,337")
|
||||
("361,241" "0,340")
|
||||
("361,242" "0,341")
|
||||
("361,243" "0,342")
|
||||
("361,244" "0,343")
|
||||
("361,247" "0,344")
|
||||
("361,250" "0,345")
|
||||
("0,361" "0,346")
|
||||
("361,255" "0,347")
|
||||
("361,260" "0,350")
|
||||
("361,261" "0,351")
|
||||
("361,262" "0,352")
|
||||
("361,265" "0,353")
|
||||
("361,276" "0,354")
|
||||
("361,277" "0,355")
|
||||
("361,300" "0,356")
|
||||
("361,304" "0,357")
|
||||
("0,363" "0,360")
|
||||
("361,314" "0,361")
|
||||
("361,317" "0,362")
|
||||
("361,320" "0,363")
|
||||
("361,321" "0,364")
|
||||
("361,322" "0,365")
|
||||
("361,324" "0,366")
|
||||
("0,270" "0,367")
|
||||
("0,371" "0,370")
|
||||
("361,337" "0,371")
|
||||
("361,340" "0,372")
|
||||
("361,341" "0,373")
|
||||
("361,345" "0,374")
|
||||
("361,353" "0,375")
|
||||
("0,374" "0,376")
|
||||
("361,355" "0,377")
|
||||
("361,155" "Meta,170"]
|
||||
(SETQ *MCCSTOISO8859MAP* (\MAKERECODEMAP MCCSTOISO))
|
||||
(SETQ *ISO8859TOMCCSMAP* (\MAKERECODEMAP MCCSTOISO T)))
|
||||
(MAKE-EXTERNALFORMAT :ISO8859/1 (FUNCTION \8859INCCODEFN)
|
||||
(FUNCTION \8859PEEKCCODEFN)
|
||||
(FUNCTION \COMMONBACKCCODEFN)
|
||||
(FUNCTION \8859OUTCHARFN])
|
||||
(MAKE-EXTERNALFORMAT :ISO8859/1 [FUNCTION (LAMBDA (STREAM COUNTP)
|
||||
(ISO1TOMCODE (\THROUGHIN STREAM COUNTP]
|
||||
[FUNCTION (LAMBDA (STREAM NOERRORFLG)
|
||||
(ISO1TOMCODE (\PEEKBIN STREAM NOERRORFLG]
|
||||
(FUNCTION \THROUGHBACKCCODE)
|
||||
(FUNCTION NILL)
|
||||
(FUNCTION NILL)
|
||||
NIL NIL (FUNCTION MTOISO1STRING)
|
||||
NIL
|
||||
(FUNCTION NILL)
|
||||
(FUNCTION ISO1TOMSTRING])
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
(ISO1TOMSTRING
|
||||
[LAMBDA (ISTRING DESTRUCTIVE) (* ; "Edited 22-Feb-2026 12:21 by rmk")
|
||||
(* ; "Edited 5-Feb-2026 11:01 by rmk")
|
||||
(* ; "Edited 2-Feb-2026 23:46 by rmk")
|
||||
(* ; "Edited 2-Sep-2025 12:14 by rmk")
|
||||
(* ; "Edited 29-Apr-2025 13:08 by rmk")
|
||||
|
||||
(* ;; "Converts ISO8859/1 codes to MCCS codes in MSTRING.")
|
||||
|
||||
(for I ICODE (MSTRING _ (CL:IF DESTRUCTIVE
|
||||
ISTRING
|
||||
(CONCAT ISTRING))) from 1 while (SETQ ICODE (NTHCHARCODE ISTRING I))
|
||||
do (RPLCHARCODE MSTRING I (ISO1TOMCODE ICODE)) finally (RETURN MSTRING])
|
||||
|
||||
(MTOISO1STRING
|
||||
[LAMBDA (MSTRING DESTRUCTIVE) (* ; "Edited 22-Feb-2026 12:22 by rmk")
|
||||
(* ; "Edited 2-Feb-2026 23:47 by rmk")
|
||||
(* ; "Edited 2-Sep-2025 12:22 by rmk")
|
||||
(* ; "Edited 29-Apr-2025 13:08 by rmk")
|
||||
|
||||
(* ;; "Converts MCCS to ISO8859/1 codes in MSTRING.")
|
||||
|
||||
(for I MCODE (ISTRING _ (CL:IF DESTRUCTIVE
|
||||
MSTRING
|
||||
(CONCAT MSTRING))) from 1 while (SETQ MCODE (NTHCHARCODE MSTRING I))
|
||||
do (RPLCHARCODE ISTRING I (MTOISO1CODE MCODE)) finally (RETURN ISTRING])
|
||||
)
|
||||
|
||||
(MAKEISOFORMAT)
|
||||
(RPAQQ ISO1TOMCCS
|
||||
((94 8593)
|
||||
(95 8592)
|
||||
(169 8216)
|
||||
(170 8220)
|
||||
(172 95)
|
||||
(173 94)
|
||||
(174 8594)
|
||||
(175 8595)
|
||||
(180 215)
|
||||
(184 247)
|
||||
(185 8217)
|
||||
(186 8221)
|
||||
(193 768)
|
||||
(194 769)
|
||||
(195 770)
|
||||
(196 771)
|
||||
(197 772)
|
||||
(198 774)
|
||||
(199 775)
|
||||
(200 776)
|
||||
(202 778)
|
||||
(203 807)
|
||||
(204 818)
|
||||
(205 779)
|
||||
(206 808)
|
||||
(207 780)
|
||||
(208 8213)
|
||||
(209 185)
|
||||
(210 174)
|
||||
(211 169)
|
||||
(212 8482)
|
||||
(213 9834)
|
||||
(220 8539)
|
||||
(221 8540)
|
||||
(222 8541)
|
||||
(223 8542)
|
||||
(224 8486)
|
||||
(225 198)
|
||||
(226 208)
|
||||
(227 170)
|
||||
(228 294)
|
||||
(229 567)
|
||||
(230 306)
|
||||
(231 319)
|
||||
(232 321)
|
||||
(233 216)
|
||||
(234 338)
|
||||
(235 186)
|
||||
(236 222)
|
||||
(237 358)
|
||||
(238 330)
|
||||
(239 329)
|
||||
(240 312)
|
||||
(241 230)
|
||||
(242 273)
|
||||
(243 240)
|
||||
(244 295)
|
||||
(245 305)
|
||||
(246 307)
|
||||
(247 320)
|
||||
(248 322)
|
||||
(249 248)
|
||||
(250 339)
|
||||
(251 223)
|
||||
(252 254)
|
||||
(253 359)
|
||||
(254 331)))
|
||||
(DECLARE%: DOEVAL@COMPILE DONTCOPY
|
||||
|
||||
(GLOBALVARS ISO1TOMCCS)
|
||||
)
|
||||
(DECLARE%: DONTEVAL@LOAD DOCOPY
|
||||
|
||||
(\CREATE.ISO1.FORMAT)
|
||||
)
|
||||
|
||||
|
||||
|
||||
@@ -553,10 +552,10 @@
|
||||
(* ; "Edited 21-Jun-95 10:18 by rmk:")
|
||||
|
||||
(* ;; "Recodes a singleton charcode. Leaves everything else unchanged.")
|
||||
|
||||
(LET [(CSMAP (CL:SVREF MAPARRAY (LRSH CODE 8]
|
||||
(OR (AND CSMAP (CL:SVREF CSMAP (LOGAND CODE 255)))
|
||||
CODE])
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
|
||||
(LET [(CSMAP (CL:SVREF MAPARRAY (LRSH CODE 8]
|
||||
(OR (AND CSMAP (CL:SVREF CSMAP (LOGAND CODE 255)))
|
||||
CODE])
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (1834 4154 (ISO1TOMCODE 1844 . 2593) (MTOISO1CODE 2595 . 2885) (\CREATE.ISO1.FORMAT 2887
|
||||
|
||||
Binary file not shown.
@@ -1,41 +1,38 @@
|
||||
(DEFINE-FILE-INFO §READTABLE "INTERLISP" §PACKAGE "INTERLISP")
|
||||
(FILECREATED "19-Feb-87 10:40:43" {QV}<LFG>PARSER>NEXT>LAMBDATRAN.;2 9556
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
changes to%: (FNS FNTYP1 LTDWIMUSERFN LTSTKNAME NARGS)
|
||||
(FILECREATED "18-Feb-2026 16:30:17" {WMEDLEY}<lispusers>LAMBDATRAN.;2 9157
|
||||
|
||||
previous date%: "19-Feb-87 09:56:18" {QV}<LFG>PARSER>NEXT>LAMBDATRAN.;1)
|
||||
:EDIT-BY rmk
|
||||
|
||||
:PREVIOUS-DATE "19-Feb-87 10:40:43" {WMEDLEY}<lispusers>LAMBDATRAN.;1)
|
||||
|
||||
(* "
|
||||
Copyright (c) 1984, 1987 by Xerox Corporation. All rights reserved.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT LAMBDATRANCOMS)
|
||||
|
||||
(RPAQQ LAMBDATRANCOMS [(* Translation machinery for new LAMBDA words)
|
||||
(LOCALVARS . T)
|
||||
[DECLARE%: FIRST (P (VIRGINFN 'ARGLIST T)
|
||||
(MOVD? 'ARGLIST 'OLDARGLIST)
|
||||
(VIRGINFN 'NARGS T)
|
||||
(MOVD? 'NARGS 'OLDNARGS)
|
||||
(VIRGINFN 'ARGTYPE T)
|
||||
(MOVD? 'ARGTYPE 'OLDARGTYPE)
|
||||
(MOVD? 'NILL 'LTDWIMUSERFN]
|
||||
(FNS ARGLIST ARGTYPE FNTYP1 LTDWIMUSERFN LTSTKNAME NARGS)
|
||||
(ADDVARS (DWIMUSERFORMS (LTDWIMUSERFN)))
|
||||
(PROP VARTYPE LAMBDATRANFNS)
|
||||
(ALISTS (LAMBDATRANFNS))
|
||||
(PROP MACRO LTSTKNAME)
|
||||
(P (PUTHASH 'LTSTKNAME '(NIL) MSTEMPLATES))
|
||||
(P (RELINK 'WORLD))
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY (P (RESETSAVE DWIMIFYCOMPFLG T))
|
||||
(GLOBALVARS CLISPARRAY COMMENTFLG LAMBDASPLST LAMBDATRANFNS BOUNDPDUMMY
|
||||
))
|
||||
(DECLARE%: DONTCOPY (RECORDS LAMBDAWORD))
|
||||
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
|
||||
(ADDVARS (NLAMA)
|
||||
(NLAML LTSTKNAME)
|
||||
(LAMA])
|
||||
(RPAQQ LAMBDATRANCOMS
|
||||
[(* Translation machinery for new LAMBDA words)
|
||||
(LOCALVARS . T)
|
||||
[DECLARE%: FIRST (P (VIRGINFN 'ARGLIST T)
|
||||
(MOVD? 'ARGLIST 'OLDARGLIST)
|
||||
(VIRGINFN 'NARGS T)
|
||||
(MOVD? 'NARGS 'OLDNARGS)
|
||||
(VIRGINFN 'ARGTYPE T)
|
||||
(MOVD? 'ARGTYPE 'OLDARGTYPE)
|
||||
(MOVD? 'NILL 'LTDWIMUSERFN]
|
||||
(FNS ARGLIST ARGTYPE FNTYP1 LTDWIMUSERFN LTSTKNAME NARGS)
|
||||
(ADDVARS (DWIMUSERFORMS (LTDWIMUSERFN)))
|
||||
(PROP VARTYPE LAMBDATRANFNS)
|
||||
(ALISTS (LAMBDATRANFNS))
|
||||
(PROP MACRO LTSTKNAME)
|
||||
(P (PUTHASH 'LTSTKNAME '(NIL)
|
||||
MSTEMPLATES))
|
||||
(P (RELINK 'WORLD))
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY (P (RESETSAVE DWIMIFYCOMPFLG T))
|
||||
(GLOBALVARS CLISPARRAY COMMENTFLG LAMBDASPLST LAMBDATRANFNS BOUNDPDUMMY))
|
||||
(DECLARE%: DONTCOPY (RECORDS LAMBDAWORD))
|
||||
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
|
||||
(NLAML LTSTKNAME)
|
||||
(LAMA])
|
||||
|
||||
|
||||
|
||||
@@ -46,12 +43,19 @@ Copyright (c) 1984, 1987 by Xerox Corporation. All rights reserved.
|
||||
(LOCALVARS . T)
|
||||
)
|
||||
(DECLARE%: FIRST
|
||||
|
||||
(VIRGINFN 'ARGLIST T)
|
||||
|
||||
(MOVD? 'ARGLIST 'OLDARGLIST)
|
||||
|
||||
(VIRGINFN 'NARGS T)
|
||||
|
||||
(MOVD? 'NARGS 'OLDNARGS)
|
||||
|
||||
(VIRGINFN 'ARGTYPE T)
|
||||
|
||||
(MOVD? 'ARGTYPE 'OLDARGTYPE)
|
||||
|
||||
(MOVD? 'NILL 'LTDWIMUSERFN)
|
||||
)
|
||||
(DEFINEQ
|
||||
@@ -190,14 +194,18 @@ Copyright (c) 1984, 1987 by Xerox Corporation. All rights reserved.
|
||||
|
||||
(ADDTOVAR DWIMUSERFORMS (LTDWIMUSERFN))
|
||||
|
||||
(PUTPROPS LAMBDATRANFNS VARTYPE ALIST)
|
||||
(PUTPROPS LAMBDATRANFNS VARTYPE ALIST)
|
||||
|
||||
(ADDTOVAR LAMBDATRANFNS )
|
||||
|
||||
(PUTPROPS LTSTKNAME MACRO (X (CONS COMMENTFLG X)))
|
||||
(PUTHASH 'LTSTKNAME '(NIL) MSTEMPLATES)
|
||||
(PUTPROPS LTSTKNAME MACRO (X (CONS COMMENTFLG X)))
|
||||
|
||||
(PUTHASH 'LTSTKNAME '(NIL)
|
||||
MSTEMPLATES)
|
||||
|
||||
(RELINK 'WORLD)
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY
|
||||
|
||||
(RESETSAVE DWIMIFYCOMPFLG T)
|
||||
|
||||
(DECLARE%: DOEVAL@COMPILE DONTCOPY
|
||||
@@ -219,8 +227,7 @@ Copyright (c) 1984, 1987 by Xerox Corporation. All rights reserved.
|
||||
|
||||
(ADDTOVAR LAMA )
|
||||
)
|
||||
(PUTPROPS LAMBDATRAN COPYRIGHT ("Xerox Corporation" 1984 1987))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (2224 8821 (ARGLIST 2234 . 3188) (ARGTYPE 3190 . 3544) (FNTYP1 3546 . 4455) (
|
||||
LTDWIMUSERFN 4457 . 7957) (LTSTKNAME 7959 . 8483) (NARGS 8485 . 8819)))))
|
||||
(FILEMAP (NIL (1871 8468 (ARGLIST 1881 . 2835) (ARGTYPE 2837 . 3191) (FNTYP1 3193 . 4102) (
|
||||
LTDWIMUSERFN 4104 . 7604) (LTSTKNAME 7606 . 8130) (NARGS 8132 . 8466)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,128 +1,127 @@
|
||||
(DEFINE-FILE-INFO §READTABLE "XCL" §PACKAGE (DEFPACKAGE "LAYOUT-SEDIT" (§NICKNAMES "L-S")))
|
||||
(il:filecreated " 9-Jan-87 19:55:25" il:{eris}<lispusers>lispcore>layout-sedit.\;2 7190
|
||||
(DEFINE-FILE-INFO PACKAGE (DEFPACKAGE "LAYOUT-SEDIT" ( NICKNAMES "L-S")) READTABLE "XCL" BASE 10)
|
||||
|
||||
il:|changes| il:|to:| (il:variables user::*l-s-region-zero* user::*l-s-region-delta*
|
||||
user::*l-s-reuse-earlier-regions*)
|
||||
(il:functions get-region save-region user::use-l-s-regions
|
||||
user::stop-using-l-s-regions)
|
||||
(il:vars il:layout-seditcoms)
|
||||
(IL:FILECREATED "18-Feb-2026 16:36:18" IL:|{WMEDLEY}<lispusers>LAYOUT-SEDIT.;2| 5714
|
||||
|
||||
il:|previous| il:|date:| "26-Dec-86 19:42:46" il:{eris}<pavel>lisp>layout-sedit.\;2)
|
||||
:EDIT-BY IL:|rmk|
|
||||
|
||||
:CHANGES-TO (IL:VARS IL:LAYOUT-SEDITCOMS)
|
||||
(IL:VARIABLES *REGION-ALIST* USER::*L-S-REGION-ZERO* USER::*L-S-REGION-DELTA*
|
||||
USER::*L-S-REUSE-EARLIER-REGIONS*)
|
||||
(IL:FUNCTIONS USER::USE-L-S-REGIONS USER::STOP-USING-L-S-REGIONS REGION-PLUS
|
||||
GET-REGION SAVE-REGION)
|
||||
|
||||
:PREVIOUS-DATE " 9-Jan-87 19:55:25" IL:|{WMEDLEY}<lispusers>LAYOUT-SEDIT.;1|)
|
||||
|
||||
|
||||
; Copyright (c) 1986, 1987 by Pavel Curtis. All rights reserved.
|
||||
(IL:PRETTYCOMPRINT IL:LAYOUT-SEDITCOMS)
|
||||
|
||||
(il:prettycomprint il:layout-seditcoms)
|
||||
(IL:RPAQQ IL:LAYOUT-SEDITCOMS
|
||||
((IL:FUNCTIONS USER::USE-L-S-REGIONS USER::STOP-USING-L-S-REGIONS)
|
||||
(IL:VARIABLES *REGION-ALIST* USER::*L-S-REGION-ZERO* USER::*L-S-REGION-DELTA*
|
||||
USER::*L-S-REUSE-EARLIER-REGIONS*)
|
||||
(IL:FUNCTIONS REGION-PLUS)
|
||||
(IL:FUNCTIONS GET-REGION SAVE-REGION)
|
||||
(IL:DECLARE\: IL:DONTEVAL@LOAD IL:DONTEVAL@COMPILE IL:DOCOPY (IL:P (USER::USE-L-S-REGIONS)
|
||||
))
|
||||
|
||||
(IL:* IL:|;;| "Arrange to use the proper compiler and makefile environment ")
|
||||
|
||||
(il:rpaqq il:layout-seditcoms ((il:functions user::use-l-s-regions user::stop-using-l-s-regions)
|
||||
(il:variables *region-alist* user::*l-s-region-zero*
|
||||
user::*l-s-region-delta* user::*l-s-reuse-earlier-regions*)
|
||||
(il:functions region-plus)
|
||||
(il:functions get-region save-region)
|
||||
(il:declare\: il:donteval@load il:donteval@compile il:docopy
|
||||
(il:p (user::use-l-s-regions)))
|
||||
(il:* il:|;;|
|
||||
"Arrange to use the proper compiler and makefile environment ")
|
||||
(il:prop (il:filetype il:makefile-environment)
|
||||
il:layout-sedit)))
|
||||
(IL:PROP (IL:FILETYPE IL:MAKEFILE-ENVIRONMENT)
|
||||
IL:LAYOUT-SEDIT)))
|
||||
|
||||
(defun user::use-l-s-regions nil (assert (null il:|\\\\contexts|)
|
||||
nil "Close all open SEdit windows")
|
||||
(il:sedit.reset)
|
||||
(il:movd 'il:sedit.get.window.region 'old-get-region)
|
||||
(il:movd 'il:sedit.save.window.region 'old-save-region)
|
||||
(il:movd 'get-region 'il:sedit.get.window.region)
|
||||
(il:movd 'save-region 'il:sedit.save.window.region))
|
||||
(DEFUN USER::USE-L-S-REGIONS ()
|
||||
(ASSERT (NULL IL:|\\\\contexts|)
|
||||
NIL "Close all open SEdit windows")
|
||||
(IL:SEDIT.RESET)
|
||||
(IL:MOVD 'IL:SEDIT.GET.WINDOW.REGION 'OLD-GET-REGION)
|
||||
(IL:MOVD 'IL:SEDIT.SAVE.WINDOW.REGION 'OLD-SAVE-REGION)
|
||||
(IL:MOVD 'GET-REGION 'IL:SEDIT.GET.WINDOW.REGION)
|
||||
(IL:MOVD 'SAVE-REGION 'IL:SEDIT.SAVE.WINDOW.REGION))
|
||||
|
||||
(DEFUN USER::STOP-USING-L-S-REGIONS ()
|
||||
(ASSERT (NULL IL:|\\\\contexts|)
|
||||
NIL "Close all open SEdit windows")
|
||||
(IL:SEDIT.RESET)
|
||||
(IL:MOVD 'OLD-GET-REGION 'IL:SEDIT.GET.WINDOW.REGION)
|
||||
(IL:MOVD 'OLD-SAVE-REGION 'IL:SEDIT.SAVE.WINDOW.REGION))
|
||||
|
||||
(defun user::stop-using-l-s-regions nil (assert (null il:|\\\\contexts|)
|
||||
nil "Close all open SEdit windows")
|
||||
(il:sedit.reset)
|
||||
(il:movd 'old-get-region 'il:sedit.get.window.region)
|
||||
(il:movd 'old-save-region 'il:sedit.save.window.region))
|
||||
(DEFVAR *REGION-ALIST* NIL
|
||||
|
||||
(IL:* IL:|;;;| "An AList mapping a region to the SEdit context that currently owns it. The associations of regions no longer in use should have a CDR of NIL. The list is kept in reverse order, with the farthest region from *REGION-ZERO* at the front of the list. So as to allow experimentation by users, we maintain the invariant that the first association on the list never has a CDR of NIL. To reestablish that invariant, we sometimes POP the AList rather than set the CDR to NIL.")
|
||||
|
||||
(defvar *region-alist* nil
|
||||
)
|
||||
|
||||
(il:* il:|;;;| "An AList mapping a region to the SEdit context that currently owns it. The associations of regions no longer in use should have a CDR of NIL. The list is kept in reverse order, with the farthest region from *REGION-ZERO* at the front of the list. So as to allow experimentation by users, we maintain the invariant that the first association on the list never has a CDR of NIL. To reestablish that invariant, we sometimes POP the AList rather than set the CDR to NIL.")
|
||||
)
|
||||
|
||||
|
||||
(defvar user::*l-s-region-zero* (il:createregion 25 (- (truncate il:screenheight 2)
|
||||
(DEFVAR USER::*L-S-REGION-ZERO* (IL:CREATEREGION 25 (- (TRUNCATE IL:SCREENHEIGHT 2)
|
||||
19)
|
||||
(truncate il:screenwidth 2)
|
||||
(truncate il:screenheight 2))
|
||||
(TRUNCATE IL:SCREENWIDTH 2)
|
||||
(TRUNCATE IL:SCREENHEIGHT 2))
|
||||
|
||||
(il:* il:|;;;| "The region to be used by the first SEdit window. This works in conjunction with USER::*L-S-REGION-DELTA* to specify the region for each new SEdit window.")
|
||||
)
|
||||
(IL:* IL:|;;;| "The region to be used by the first SEdit window. This works in conjunction with USER::*L-S-REGION-DELTA* to specify the region for each new SEdit window.")
|
||||
|
||||
)
|
||||
|
||||
(defvar user::*l-s-region-delta* (il:createregion 11 -44 0 0) )
|
||||
(DEFVAR USER::*L-S-REGION-DELTA* (IL:CREATEREGION 11 -44 0 0))
|
||||
|
||||
(DEFVAR USER::*L-S-REUSE-EARLIER-REGIONS* NIL
|
||||
|
||||
(defvar user::*l-s-reuse-earlier-regions* nil
|
||||
(IL:* IL:|;;;| "If non-NIL, then earlier regions (i.e., those closer to USER::*L-S-REGION-ZERO* will get reused when free. Otherwise, new regions, farther from USER::*L-S-REGION-ZERO* than any currently in use, will be created.")
|
||||
|
||||
(il:* il:|;;;| "If non-NIL, then earlier regions (i.e., those closer to USER::*L-S-REGION-ZERO* will get reused when free. Otherwise, new regions, farther from USER::*L-S-REGION-ZERO* than any currently in use, will be created.")
|
||||
)
|
||||
)
|
||||
|
||||
(DEFUN REGION-PLUS (ONE TWO)
|
||||
(IL:CREATEREGION (+ (IL:FETCH (IL:REGION IL:LEFT) IL:OF ONE)
|
||||
(IL:FETCH (IL:REGION IL:LEFT) IL:OF TWO))
|
||||
(+ (IL:FETCH (IL:REGION IL:BOTTOM) IL:OF ONE)
|
||||
(IL:FETCH (IL:REGION IL:BOTTOM) IL:OF TWO))
|
||||
(+ (IL:FETCH (IL:REGION IL:WIDTH) IL:OF ONE)
|
||||
(IL:FETCH (IL:REGION IL:WIDTH) IL:OF TWO))
|
||||
(+ (IL:FETCH (IL:REGION IL:HEIGHT) IL:OF ONE)
|
||||
(IL:FETCH (IL:REGION IL:HEIGHT) IL:OF TWO))))
|
||||
|
||||
(defun region-plus (one two) (il:createregion (+ (il:fetch (il:region il:left) il:of one)
|
||||
(il:fetch (il:region il:left) il:of two))
|
||||
(+ (il:fetch (il:region il:bottom) il:of one)
|
||||
(il:fetch (il:region il:bottom) il:of two))
|
||||
(+ (il:fetch (il:region il:width) il:of one)
|
||||
(il:fetch (il:region il:width) il:of two))
|
||||
(+ (il:fetch (il:region il:height) il:of one)
|
||||
(il:fetch (il:region il:height) il:of two))))
|
||||
(DEFUN GET-REGION (CONTEXT)
|
||||
(LET ((PAIR (AND USER::*L-S-REUSE-EARLIER-REGIONS* (FIND NIL *REGION-ALIST* :KEY 'CDR))))
|
||||
(COND
|
||||
((NULL PAIR)
|
||||
(COND
|
||||
((NULL *REGION-ALIST*)
|
||||
(SETQ *REGION-ALIST* (LIST (CONS USER::*L-S-REGION-ZERO* CONTEXT)))
|
||||
USER::*L-S-REGION-ZERO*)
|
||||
(T (LET ((NEW-REGION (REGION-PLUS (CAR (FIRST *REGION-ALIST*))
|
||||
USER::*L-S-REGION-DELTA*)))
|
||||
(PUSH (CONS NEW-REGION CONTEXT)
|
||||
*REGION-ALIST*)
|
||||
NEW-REGION))))
|
||||
(T (SETF (CDR PAIR)
|
||||
CONTEXT)
|
||||
(CAR PAIR)))))
|
||||
|
||||
(DEFUN SAVE-REGION (CONTEXT)
|
||||
|
||||
(defun get-region (context) (let ((pair (and user::*l-s-reuse-earlier-regions* (find nil
|
||||
*region-alist*
|
||||
:key
|
||||
'cdr))))
|
||||
(cond
|
||||
((null pair)
|
||||
(cond
|
||||
((null *region-alist*)
|
||||
(setq *region-alist* (list (cons user::*l-s-region-zero*
|
||||
context)))
|
||||
user::*l-s-region-zero*)
|
||||
(t (let ((new-region (region-plus (car (first *region-alist*)
|
||||
)
|
||||
user::*l-s-region-delta*)))
|
||||
(push (cons new-region context)
|
||||
*region-alist*)
|
||||
new-region))))
|
||||
(t (setf (cdr pair)
|
||||
context)
|
||||
(car pair)))))
|
||||
(IL:* IL:|;;;| "The context is done with its region. Deallocate it.")
|
||||
|
||||
(LET ((PAIR (FIND CONTEXT *REGION-ALIST* :KEY 'CDR)))
|
||||
(IF (NULL PAIR)
|
||||
(WARN "An SEdit context is trying to give up an unallocated region.")
|
||||
(SETF (CDR PAIR)
|
||||
NIL))
|
||||
(SETQ *REGION-ALIST* (MEMBER-IF-NOT 'NULL *REGION-ALIST* :KEY 'CDR))))
|
||||
(IL:DECLARE\: IL:DONTEVAL@LOAD IL:DONTEVAL@COMPILE IL:DOCOPY
|
||||
|
||||
(defun save-region (context)
|
||||
|
||||
(il:* il:|;;;| "The context is done with its region. Deallocate it.")
|
||||
(let ((pair (find context *region-alist* :key 'cdr)))
|
||||
(if (null pair)
|
||||
(warn "An SEdit context is trying to give up an unallocated region.")
|
||||
(setf (cdr pair)
|
||||
nil))
|
||||
(setq *region-alist* (member-if-not 'null *region-alist* :key 'cdr))))
|
||||
|
||||
(il:declare\: il:donteval@load il:donteval@compile il:docopy
|
||||
(user::use-l-s-regions)
|
||||
(USER::USE-L-S-REGIONS)
|
||||
)
|
||||
|
||||
|
||||
|
||||
(il:* il:|;;| "Arrange to use the proper compiler and makefile environment ")
|
||||
(IL:* IL:|;;| "Arrange to use the proper compiler and makefile environment ")
|
||||
|
||||
|
||||
(il:putprops il:layout-sedit il:filetype compile-file)
|
||||
(IL:PUTPROPS IL:LAYOUT-SEDIT IL:FILETYPE COMPILE-FILE)
|
||||
|
||||
(il:putprops il:layout-sedit il:makefile-environment (:readtable "XCL" :package (xcl:defpackage
|
||||
(IL:PUTPROPS IL:LAYOUT-SEDIT IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE (XCL:DEFPACKAGE
|
||||
"LAYOUT-SEDIT"
|
||||
(:nicknames "L-S"))))
|
||||
(il:putprops il:layout-sedit il:copyright ("Pavel Curtis" 1986 1987))
|
||||
(il:declare\: il:dontcopy
|
||||
(il:filemap (nil)))
|
||||
il:stop
|
||||
(:NICKNAMES "L-S"))))
|
||||
(IL:DECLARE\: IL:DONTCOPY
|
||||
(IL:FILEMAP (NIL (1426 1788 (USER::USE-L-S-REGIONS 1426 . 1788)) (1790 2051 (USER::STOP-USING-L-S-REGIONS
|
||||
1790 . 2051)) (3443 4007 (REGION-PLUS 3443 . 4007)) (4009 4732 (GET-REGION 4009 . 4732)) (4734 5138 (
|
||||
SAVE-REGION 4734 . 5138)))))
|
||||
IL:STOP
|
||||
|
||||
@@ -1 +1,52 @@
|
||||
(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE "LAYOUT-SEDIT" ( NICKNAMES "L-S")))
(IL:FILECREATED " 9-Sep-94 13:47:35" ("compiled on " IL:|{DSK}<lispcore>lispusers>LAYOUT-SEDIT.;1|)
"28-Jul-94 17:28:46" IL:|bcompl'd| IL:|in| "Medley 25-Aug-94 ..." IL:|dated| "25-Aug-94 10:02:49")
(IL:FILECREATED " 9-Jan-87 19:55:25" IL:{ERIS}<LISPUSERS>LISPCORE>LAYOUT-SEDIT.\;2 7190 IL:|changes|
IL:|to:| (IL:VARIABLES USER::*L-S-REGION-ZERO* USER::*L-S-REGION-DELTA* USER::*L-S-REUSE-EARLIER-REGIONS*
) (IL:FUNCTIONS GET-REGION SAVE-REGION USER::USE-L-S-REGIONS USER::STOP-USING-L-S-REGIONS) (IL:VARS
IL:LAYOUT-SEDITCOMS) IL:|previous| IL:|date:| "26-Dec-86 19:42:46" IL:{ERIS}<PAVEL>LISP>LAYOUT-SEDIT.\;2
)
(IL:PRETTYCOMPRINT IL:LAYOUT-SEDITCOMS)
(IL:RPAQQ IL:LAYOUT-SEDITCOMS ((IL:FUNCTIONS USER::USE-L-S-REGIONS USER::STOP-USING-L-S-REGIONS) (
IL:VARIABLES *REGION-ALIST* USER::*L-S-REGION-ZERO* USER::*L-S-REGION-DELTA*
USER::*L-S-REUSE-EARLIER-REGIONS*) (IL:FUNCTIONS REGION-PLUS) (IL:FUNCTIONS GET-REGION SAVE-REGION) (
IL:DECLARE\: IL:DONTEVAL@LOAD IL:DONTEVAL@COMPILE IL:DOCOPY (IL:P (USER::USE-L-S-REGIONS))) (IL:*
IL:|;;| "Arrange to use the proper compiler and makefile environment ") (IL:PROP (IL:FILETYPE
IL:MAKEFILE-ENVIRONMENT) IL:LAYOUT-SEDIT)))
(DEFUN USER::USE-L-S-REGIONS NIL (ASSERT (NULL IL:|\\\\contexts|) NIL "Close all open SEdit windows")
(IL:SEDIT.RESET) (IL:MOVD (QUOTE IL:SEDIT.GET.WINDOW.REGION) (QUOTE OLD-GET-REGION)) (IL:MOVD (QUOTE
IL:SEDIT.SAVE.WINDOW.REGION) (QUOTE OLD-SAVE-REGION)) (IL:MOVD (QUOTE GET-REGION) (QUOTE
IL:SEDIT.GET.WINDOW.REGION)) (IL:MOVD (QUOTE SAVE-REGION) (QUOTE IL:SEDIT.SAVE.WINDOW.REGION)))
(DEFUN USER::STOP-USING-L-S-REGIONS NIL (ASSERT (NULL IL:|\\\\contexts|) NIL
"Close all open SEdit windows") (IL:SEDIT.RESET) (IL:MOVD (QUOTE OLD-GET-REGION) (QUOTE
IL:SEDIT.GET.WINDOW.REGION)) (IL:MOVD (QUOTE OLD-SAVE-REGION) (QUOTE IL:SEDIT.SAVE.WINDOW.REGION)))
(DEFVAR *REGION-ALIST* NIL (IL:* IL:|;;;|
"An AList mapping a region to the SEdit context that currently owns it. The associations of regions no longer in use should have a CDR of NIL. The list is kept in reverse order, with the farthest region from *REGION-ZERO* at the front of the list. So as to allow experimentation by users, we maintain the invariant that the first association on the list never has a CDR of NIL. To reestablish that invariant, we sometimes POP the AList rather than set the CDR to NIL."
))
(DEFVAR USER::*L-S-REGION-ZERO* (IL:CREATEREGION 25 (- (TRUNCATE IL:SCREENHEIGHT 2) 19) (TRUNCATE
IL:SCREENWIDTH 2) (TRUNCATE IL:SCREENHEIGHT 2)) (IL:* IL:|;;;|
"The region to be used by the first SEdit window. This works in conjunction with USER::*L-S-REGION-DELTA* to specify the region for each new SEdit window."
))
(DEFVAR USER::*L-S-REGION-DELTA* (IL:CREATEREGION 11 -44 0 0))
(DEFVAR USER::*L-S-REUSE-EARLIER-REGIONS* NIL (IL:* IL:|;;;|
"If non-NIL, then earlier regions (i.e., those closer to USER::*L-S-REGION-ZERO* will get reused when free. Otherwise, new regions, farther from USER::*L-S-REGION-ZERO* than any currently in use, will be created."
))
(DEFUN REGION-PLUS (ONE TWO) (IL:CREATEREGION (+ (IL:FETCH (IL:REGION IL:LEFT) IL:OF ONE) (IL:FETCH (
IL:REGION IL:LEFT) IL:OF TWO)) (+ (IL:FETCH (IL:REGION IL:BOTTOM) IL:OF ONE) (IL:FETCH (IL:REGION
IL:BOTTOM) IL:OF TWO)) (+ (IL:FETCH (IL:REGION IL:WIDTH) IL:OF ONE) (IL:FETCH (IL:REGION IL:WIDTH) IL:OF
TWO)) (+ (IL:FETCH (IL:REGION IL:HEIGHT) IL:OF ONE) (IL:FETCH (IL:REGION IL:HEIGHT) IL:OF TWO))))
(DEFUN GET-REGION (CONTEXT) (LET ((PAIR (AND USER::*L-S-REUSE-EARLIER-REGIONS* (FIND NIL
*REGION-ALIST* :KEY (QUOTE CDR))))) (COND ((NULL PAIR) (COND ((NULL *REGION-ALIST*) (SETQ
*REGION-ALIST* (LIST (CONS USER::*L-S-REGION-ZERO* CONTEXT))) USER::*L-S-REGION-ZERO*) (T (LET ((
NEW-REGION (REGION-PLUS (CAR (FIRST *REGION-ALIST*)) USER::*L-S-REGION-DELTA*))) (PUSH (CONS
NEW-REGION CONTEXT) *REGION-ALIST*) NEW-REGION)))) (T (SETF (CDR PAIR) CONTEXT) (CAR PAIR)))))
(DEFUN SAVE-REGION (CONTEXT) (IL:* IL:|;;;| "The context is done with its region. Deallocate it.") (
LET ((PAIR (FIND CONTEXT *REGION-ALIST* :KEY (QUOTE CDR)))) (IF (NULL PAIR) (WARN
"An SEdit context is trying to give up an unallocated region.") (SETF (CDR PAIR) NIL)) (SETQ
*REGION-ALIST* (MEMBER-IF-NOT (QUOTE NULL) *REGION-ALIST* :KEY (QUOTE CDR)))))
(USER::USE-L-S-REGIONS)
(IL:PUTPROPS IL:LAYOUT-SEDIT IL:FILETYPE COMPILE-FILE)
(IL:PUTPROPS IL:LAYOUT-SEDIT IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE (XCL:DEFPACKAGE
"LAYOUT-SEDIT" (:NICKNAMES "L-S"))))
(IL:PUTPROPS IL:LAYOUT-SEDIT IL:COPYRIGHT ("Pavel Curtis" 1986 1987))
NIL
|
||||
(DEFINE-FILE-INFO PACKAGE (DEFPACKAGE "LAYOUT-SEDIT" ( NICKNAMES "L-S")) READTABLE "XCL" BASE 10)
|
||||
|
||||
(IL:FILECREATED "18-Feb-2026 16:39:44" ("compiled on " IL:|{WMEDLEY}<lispusers>LAYOUT-SEDIT.;2|)
|
||||
"18-Feb-2026 16:37:55" IL:|bcompl'd| IL:|in| "FULL 18-Feb-2026 ..." IL:|dated| "18-Feb-2026 16:38:04")
|
||||
(IL:FILECREATED "18-Feb-2026 16:36:18" IL:|{WMEDLEY}<lispusers>LAYOUT-SEDIT.;2| 5714 :EDIT-BY IL:|rmk|
|
||||
:CHANGES-TO (IL:VARS IL:LAYOUT-SEDITCOMS) (IL:VARIABLES *REGION-ALIST* USER::*L-S-REGION-ZERO*
|
||||
USER::*L-S-REGION-DELTA* USER::*L-S-REUSE-EARLIER-REGIONS*) (IL:FUNCTIONS USER::USE-L-S-REGIONS
|
||||
USER::STOP-USING-L-S-REGIONS REGION-PLUS GET-REGION SAVE-REGION) :PREVIOUS-DATE " 9-Jan-87 19:55:25"
|
||||
IL:|{WMEDLEY}<lispusers>LAYOUT-SEDIT.;1|)
|
||||
(IL:PRETTYCOMPRINT IL:LAYOUT-SEDITCOMS)
|
||||
(IL:RPAQQ IL:LAYOUT-SEDITCOMS ((IL:FUNCTIONS USER::USE-L-S-REGIONS USER::STOP-USING-L-S-REGIONS) (
|
||||
IL:VARIABLES *REGION-ALIST* USER::*L-S-REGION-ZERO* USER::*L-S-REGION-DELTA*
|
||||
USER::*L-S-REUSE-EARLIER-REGIONS*) (IL:FUNCTIONS REGION-PLUS) (IL:FUNCTIONS GET-REGION SAVE-REGION) (
|
||||
IL:DECLARE\: IL:DONTEVAL@LOAD IL:DONTEVAL@COMPILE IL:DOCOPY (IL:P (USER::USE-L-S-REGIONS))) (IL:*
|
||||
IL:|;;| "Arrange to use the proper compiler and makefile environment ") (IL:PROP (IL:FILETYPE
|
||||
IL:MAKEFILE-ENVIRONMENT) IL:LAYOUT-SEDIT)))
|
||||
(DEFUN USER::USE-L-S-REGIONS NIL (ASSERT (NULL IL:|\\\\contexts|) NIL "Close all open SEdit windows")
|
||||
(IL:SEDIT.RESET) (IL:MOVD (QUOTE IL:SEDIT.GET.WINDOW.REGION) (QUOTE OLD-GET-REGION)) (IL:MOVD (QUOTE
|
||||
IL:SEDIT.SAVE.WINDOW.REGION) (QUOTE OLD-SAVE-REGION)) (IL:MOVD (QUOTE GET-REGION) (QUOTE
|
||||
IL:SEDIT.GET.WINDOW.REGION)) (IL:MOVD (QUOTE SAVE-REGION) (QUOTE IL:SEDIT.SAVE.WINDOW.REGION)))
|
||||
(DEFUN USER::STOP-USING-L-S-REGIONS NIL (ASSERT (NULL IL:|\\\\contexts|) NIL
|
||||
"Close all open SEdit windows") (IL:SEDIT.RESET) (IL:MOVD (QUOTE OLD-GET-REGION) (QUOTE
|
||||
IL:SEDIT.GET.WINDOW.REGION)) (IL:MOVD (QUOTE OLD-SAVE-REGION) (QUOTE IL:SEDIT.SAVE.WINDOW.REGION)))
|
||||
(DEFVAR *REGION-ALIST* NIL (IL:* IL:|;;;|
|
||||
"An AList mapping a region to the SEdit context that currently owns it. The associations of regions no longer in use should have a CDR of NIL. The list is kept in reverse order, with the farthest region from *REGION-ZERO* at the front of the list. So as to allow experimentation by users, we maintain the invariant that the first association on the list never has a CDR of NIL. To reestablish that invariant, we sometimes POP the AList rather than set the CDR to NIL."
|
||||
))
|
||||
(DEFVAR USER::*L-S-REGION-ZERO* (IL:CREATEREGION 25 (- (TRUNCATE IL:SCREENHEIGHT 2) 19) (TRUNCATE
|
||||
IL:SCREENWIDTH 2) (TRUNCATE IL:SCREENHEIGHT 2)) (IL:* IL:|;;;|
|
||||
"The region to be used by the first SEdit window. This works in conjunction with USER::*L-S-REGION-DELTA* to specify the region for each new SEdit window."
|
||||
))
|
||||
(DEFVAR USER::*L-S-REGION-DELTA* (IL:CREATEREGION 11 -44 0 0))
|
||||
(DEFVAR USER::*L-S-REUSE-EARLIER-REGIONS* NIL (IL:* IL:|;;;|
|
||||
"If non-NIL, then earlier regions (i.e., those closer to USER::*L-S-REGION-ZERO* will get reused when free. Otherwise, new regions, farther from USER::*L-S-REGION-ZERO* than any currently in use, will be created."
|
||||
))
|
||||
(DEFUN REGION-PLUS (ONE TWO) (IL:CREATEREGION (+ (IL:FETCH (IL:REGION IL:LEFT) IL:OF ONE) (IL:FETCH (
|
||||
IL:REGION IL:LEFT) IL:OF TWO)) (+ (IL:FETCH (IL:REGION IL:BOTTOM) IL:OF ONE) (IL:FETCH (IL:REGION
|
||||
IL:BOTTOM) IL:OF TWO)) (+ (IL:FETCH (IL:REGION IL:WIDTH) IL:OF ONE) (IL:FETCH (IL:REGION IL:WIDTH) IL:OF
|
||||
TWO)) (+ (IL:FETCH (IL:REGION IL:HEIGHT) IL:OF ONE) (IL:FETCH (IL:REGION IL:HEIGHT) IL:OF TWO))))
|
||||
(DEFUN GET-REGION (CONTEXT) (LET ((PAIR (AND USER::*L-S-REUSE-EARLIER-REGIONS* (FIND NIL
|
||||
*REGION-ALIST* :KEY (QUOTE CDR))))) (COND ((NULL PAIR) (COND ((NULL *REGION-ALIST*) (SETQ
|
||||
*REGION-ALIST* (LIST (CONS USER::*L-S-REGION-ZERO* CONTEXT))) USER::*L-S-REGION-ZERO*) (T (LET ((
|
||||
NEW-REGION (REGION-PLUS (CAR (FIRST *REGION-ALIST*)) USER::*L-S-REGION-DELTA*))) (PUSH (CONS
|
||||
NEW-REGION CONTEXT) *REGION-ALIST*) NEW-REGION)))) (T (SETF (CDR PAIR) CONTEXT) (CAR PAIR)))))
|
||||
(DEFUN SAVE-REGION (CONTEXT) (IL:* IL:|;;;| "The context is done with its region. Deallocate it.") (
|
||||
LET ((PAIR (FIND CONTEXT *REGION-ALIST* :KEY (QUOTE CDR)))) (IF (NULL PAIR) (WARN
|
||||
"An SEdit context is trying to give up an unallocated region.") (SETF (CDR PAIR) NIL)) (SETQ
|
||||
*REGION-ALIST* (MEMBER-IF-NOT (QUOTE NULL) *REGION-ALIST* :KEY (QUOTE CDR)))))
|
||||
(USER::USE-L-S-REGIONS)
|
||||
(IL:PUTPROPS IL:LAYOUT-SEDIT IL:FILETYPE COMPILE-FILE)
|
||||
(IL:PUTPROPS IL:LAYOUT-SEDIT IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE (XCL:DEFPACKAGE
|
||||
"LAYOUT-SEDIT" (:NICKNAMES "L-S"))))
|
||||
NIL
|
||||
|
||||
@@ -1,32 +1,27 @@
|
||||
(DEFINE-FILE-INFO §READTABLE "INTERLISP" §PACKAGE "INTERLISP")
|
||||
(FILECREATED " 2-Feb-87 10:38:19" {ERIS}<LISPUSERS>LYRIC>PHONE-DIRECTORY.;1 9029
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
changes to%: (VARS PHONE-DIRECTORYCOMS)
|
||||
(FILECREATED "18-Feb-2026 16:27:33" {WMEDLEY}<lispusers>PHONE-DIRECTORY.;2 8485
|
||||
|
||||
previous date%: " 9-Jan-87 19:45:25" {ERIS}<LISPUSERS>KOTO>PHONE-DIRECTORY.;3)
|
||||
:EDIT-BY rmk
|
||||
|
||||
:PREVIOUS-DATE " 2-Feb-87 10:38:19" {WMEDLEY}<lispusers>PHONE-DIRECTORY.;1)
|
||||
|
||||
(* "
|
||||
Copyright (c) 1986, 1987 by Xerox Corporation. All rights reserved.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT PHONE-DIRECTORYCOMS)
|
||||
|
||||
(RPAQQ PHONE-DIRECTORYCOMS ((FNS Cache-Phone-Directory-Files Let-your-fingers-do-the-walking
|
||||
Phone-Directory-Kill-Proc Phone-Window-ButtonEventFn Lookup-Person
|
||||
Phone-Window-WhenOpenedFn)
|
||||
(VARS fingersIconMask fingersIconBM)
|
||||
(INITVARS (*Cached-Phone-Directory-Files* NIL)
|
||||
(*Phone-Directory-Pos* (create POSITION XCOORD _ 15 YCOORD _
|
||||
(DIFFERENCE SCREENHEIGHT 75)))
|
||||
(*Phone-Directory-Region* (CREATEREGION 15 (DIFFERENCE
|
||||
SCREENHEIGHT 258
|
||||
)
|
||||
400 250)))
|
||||
(GLOBALVARS *Cached-Phone-Directory-Files* *Phone-Directory-Pos*
|
||||
*Phone-Directory-Region* fingersIconMask fingersIconBM)
|
||||
(FILES GREP)
|
||||
(P (Let-your-fingers-do-the-walking))))
|
||||
(RPAQQ PHONE-DIRECTORYCOMS
|
||||
((FNS Cache-Phone-Directory-Files Let-your-fingers-do-the-walking Phone-Directory-Kill-Proc
|
||||
Phone-Window-ButtonEventFn Lookup-Person Phone-Window-WhenOpenedFn)
|
||||
(VARS fingersIconMask fingersIconBM)
|
||||
(INITVARS (*Cached-Phone-Directory-Files* NIL)
|
||||
(*Phone-Directory-Pos* (create POSITION XCOORD _ 15 YCOORD _ (DIFFERENCE SCREENHEIGHT
|
||||
75)))
|
||||
(*Phone-Directory-Region* (CREATEREGION 15 (DIFFERENCE SCREENHEIGHT 258)
|
||||
400 250)))
|
||||
(GLOBALVARS *Cached-Phone-Directory-Files* *Phone-Directory-Pos* *Phone-Directory-Region*
|
||||
fingersIconMask fingersIconBM)
|
||||
(FILES GREP)
|
||||
(P (Let-your-fingers-do-the-walking))))
|
||||
(DEFINEQ
|
||||
|
||||
(Cache-Phone-Directory-Files
|
||||
@@ -139,11 +134,12 @@ Copyright (c) 1986, 1987 by Xerox Corporation. All rights reserved.
|
||||
(GLOBALVARS *Cached-Phone-Directory-Files* *Phone-Directory-Pos* *Phone-Directory-Region*
|
||||
fingersIconMask fingersIconBM)
|
||||
)
|
||||
|
||||
(FILESLOAD GREP)
|
||||
(Let-your-fingers-do-the-walking)
|
||||
(PUTPROPS PHONE-DIRECTORY COPYRIGHT ("Xerox Corporation" 1986 1987))
|
||||
|
||||
(Let-your-fingers-do-the-walking)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (1649 6373 (Cache-Phone-Directory-Files 1659 . 2954) (Let-your-fingers-do-the-walking
|
||||
2956 . 4251) (Phone-Directory-Kill-Proc 4253 . 4684) (Phone-Window-ButtonEventFn 4686 . 5362) (
|
||||
Lookup-Person 5364 . 5976) (Phone-Window-WhenOpenedFn 5978 . 6371)))))
|
||||
(FILEMAP (NIL (1168 5892 (Cache-Phone-Directory-Files 1178 . 2473) (Let-your-fingers-do-the-walking
|
||||
2475 . 3770) (Phone-Directory-Kill-Proc 3772 . 4203) (Phone-Window-ButtonEventFn 4205 . 4881) (
|
||||
Lookup-Person 4883 . 5495) (Phone-Window-WhenOpenedFn 5497 . 5890)))))
|
||||
STOP
|
||||
|
||||
@@ -1,15 +1,11 @@
|
||||
(DEFINE-FILE-INFO §READTABLE "INTERLISP" §PACKAGE "INTERLISP")
|
||||
(FILECREATED " 9-Jan-87 16:47:16" {ERIS}<LISPCORE>LIBRARY>SKETCHCOLOR.;2 4779
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
changes to%: (VARS BLACKSHADE16 DARKGRAY16 MEDIUMGRAY16 LIGHTGRAY16 WHITESHADE16 REDTEXTURE
|
||||
GREENTEXTURE BLUETEXTURE SKETCHCOLORCOMS)
|
||||
(FILECREATED "18-Feb-2026 16:28:03" {WMEDLEY}<lispusers>SKETCHCOLOR.;2 4732
|
||||
|
||||
previous date%: "29-Oct-85 14:44:30" {ERIS}<LISPCORE>LIBRARY>SKETCHCOLOR.;1)
|
||||
:EDIT-BY rmk
|
||||
|
||||
:PREVIOUS-DATE " 9-Jan-87 16:47:16" {WMEDLEY}<lispusers>SKETCHCOLOR.;1)
|
||||
|
||||
(* "
|
||||
Copyright (c) 1985, 1987 by Xerox Corporation. All rights reserved.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT SKETCHCOLORCOMS)
|
||||
|
||||
@@ -75,25 +71,30 @@ Copyright (c) 1985, 1987 by Xerox Corporation. All rights reserved.
|
||||
)
|
||||
|
||||
(RPAQQ SKETCHINCOLORFLG T)
|
||||
|
||||
(FILESLOAD COLOR STYLESHEET)
|
||||
|
||||
(PUTPROPS \FILLCIRCLE.DISPLAY READVICE [NIL (BEFORE NIL (COND ((LISTP TEXTURE)
|
||||
(COND ((TEXTUREP (CAR TEXTURE))
|
||||
(SETQ TEXTURE (CAR TEXTURE)))
|
||||
(T (SETQ TEXTURE
|
||||
(TEXTUREOFCOLOR
|
||||
(CADR TEXTURE])
|
||||
[XCL:REINSTALL-ADVICE '\FILLCIRCLE.DISPLAY :BEFORE '((:LAST (COND
|
||||
((LISTP TEXTURE)
|
||||
(COND
|
||||
((TEXTUREP (CAR TEXTURE))
|
||||
(SETQ TEXTURE (CAR TEXTURE)))
|
||||
(T (SETQ TEXTURE
|
||||
(TEXTUREOFCOLOR (CADR TEXTURE]
|
||||
|
||||
[XCL:REINSTALL-ADVICE '\POLYSHADE.DISPLAY :BEFORE '((:LAST (COND
|
||||
((LISTP FILL.SHADE)
|
||||
(COND
|
||||
((TEXTUREP (CAR FILL.SHADE))
|
||||
(SETQ FILL.SHADE (CAR FILL.SHADE))
|
||||
)
|
||||
(T (SETQ FILL.SHADE
|
||||
(TEXTUREOFCOLOR (CADR
|
||||
FILL.SHADE
|
||||
]
|
||||
|
||||
(PUTPROPS \POLYSHADE.DISPLAY READVICE [NIL (BEFORE NIL (COND ((LISTP FILL.SHADE)
|
||||
(COND ((TEXTUREP (CAR FILL.SHADE))
|
||||
(SETQ FILL.SHADE (CAR FILL.SHADE
|
||||
)))
|
||||
(T (SETQ FILL.SHADE
|
||||
(TEXTUREOFCOLOR
|
||||
(CADR FILL.SHADE])
|
||||
(READVISE \FILLCIRCLE.DISPLAY \POLYSHADE.DISPLAY)
|
||||
(PUTPROPS SKETCHCOLOR COPYRIGHT ("Xerox Corporation" 1985 1987))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (771 3368 (COLORTEXTURETEST 781 . 2128) (LEVELTEXTURE 2130 . 2662) (PRIMARYTEXTURE 2664
|
||||
. 3366)))))
|
||||
(FILEMAP (NIL (547 3144 (COLORTEXTURETEST 557 . 1904) (LEVELTEXTURE 1906 . 2438) (PRIMARYTEXTURE 2440
|
||||
. 3142)))))
|
||||
STOP
|
||||
|
||||
@@ -1,16 +1,18 @@
|
||||
(DEFINE-FILE-INFO §READTABLE "INTERLISP" §PACKAGE "INTERLISP")
|
||||
(FILECREATED "17-Mar-87 17:03:54" {DSK}<XAVIER>TRANSOR.;16 44778
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
changes to%: (VARS TRANSORCOMS)
|
||||
(FNS PRECH1 TRANSOUT)
|
||||
(FILECREATED "18-Feb-2026 21:57:19" {WMEDLEY}<lispusers>TRANSOR.;2 43458
|
||||
|
||||
previous date%: "17-Mar-87 17:00:04" {DSK}<XAVIER>TRANSOR.;15)
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (VARS TRANSORCOMS)
|
||||
|
||||
:PREVIOUS-DATE "17-Mar-87 17:03:54" {WMEDLEY}<lispusers>TRANSOR.;1)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT TRANSORCOMS)
|
||||
|
||||
(RPAQQ TRANSORCOMS
|
||||
((FNS TRANSOR TRANSOR-PROCEED TRANSORFORM TRANSORFNS TRANSFORM TRANSIT TRANXT TRANSEXIT
|
||||
(RPAQQ TRANSORCOMS
|
||||
[(FNS TRANSOR TRANSOR-PROCEED TRANSORFORM TRANSORFNS TRANSFORM TRANSIT TRANXT TRANSEXIT
|
||||
KEEPLIST TRANSERR TRANSOUT PPASS1 TRANSLIST TRANSLIST1 PREMTEXT WACHADOON PRECH PRECH1
|
||||
PRECH2 RETAIL LNC PRESCAN)
|
||||
TRANSORMACROS TRANSOREMARKS TRANSORGLOBALS
|
||||
@@ -18,8 +20,10 @@
|
||||
(TESTRAN)
|
||||
(USERMACROS (APPEND TRANSORMACROS USERMACROS))
|
||||
(GLOBALVARS (APPEND TRANSORGLOBALS GLOBALVARS))
|
||||
(EDITCOMSA (UNION '(NLAM NLAMIT DOTHESE DOTHIS XFORMER CONTINUE) EDITCOMSA))
|
||||
(EDITCOMSL (UNION '(REMARK) EDITCOMSL))
|
||||
(EDITCOMSA (UNION '(NLAM NLAMIT DOTHESE DOTHIS XFORMER CONTINUE)
|
||||
EDITCOMSA))
|
||||
(EDITCOMSL (UNION '(REMARK)
|
||||
EDITCOMSL))
|
||||
(TRANSITCONSES '(ORR NIL XFORMER))
|
||||
(PRESCARRAY (ARRAY 127 127)))
|
||||
(INITVARS (NLISTPCOMS)
|
||||
@@ -36,10 +40,9 @@
|
||||
(BLKLIBRARY TAILP MEMB LAST LENGTH ASSOC GETP))
|
||||
(NIL PRESCAN (GLOBALVARS PRESCARRAY)))
|
||||
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
|
||||
(NLAML TRANSERR KEEPLIST
|
||||
(NLAML TRANSERR KEEPLIST
|
||||
TRANSOR-PROCEED)
|
||||
(LAMA)))
|
||||
(EDITHIST TRANSOR)))
|
||||
(LAMA])
|
||||
(DEFINEQ
|
||||
|
||||
(TRANSOR
|
||||
@@ -861,52 +864,49 @@ TRANSOR made a translation error: " T)
|
||||
(RETURN (CLOSEF OUTF)))))
|
||||
)
|
||||
|
||||
(RPAQQ TRANSORMACROS ((REMARK (TXT)
|
||||
(E (KEEPLIST TXT)
|
||||
T))
|
||||
(NLAM NIL (E (SETQQ WHERETOGONEXT NLAMIT)
|
||||
T))
|
||||
[NLAMIT NIL (ORR NX !NX ((E (TRANSEXIT]
|
||||
(DOTHESE NIL (E (TRANSOR-PROCEED DOTHESE)
|
||||
T)
|
||||
NLAM)
|
||||
(DOTHIS NIL (E (TRANSOR-PROCEED DOTHIS)
|
||||
T)
|
||||
NLAM)
|
||||
(XFORMER NIL (E (TRANSERR TRANSFORMATIONERROR "FAULTY TRANSFORMATION"
|
||||
(CURRENTFORM CURRENTCOMS))
|
||||
T))))
|
||||
(RPAQQ TRANSORMACROS
|
||||
((REMARK (TXT)
|
||||
(E (KEEPLIST TXT)
|
||||
T))
|
||||
(NLAM NIL (E (SETQQ WHERETOGONEXT NLAMIT)
|
||||
T))
|
||||
[NLAMIT NIL (ORR NX !NX ((E (TRANSEXIT]
|
||||
(DOTHESE NIL (E (TRANSOR-PROCEED DOTHESE)
|
||||
T)
|
||||
NLAM)
|
||||
(DOTHIS NIL (E (TRANSOR-PROCEED DOTHIS)
|
||||
T)
|
||||
NLAM)
|
||||
(XFORMER NIL (E (TRANSERR TRANSFORMATIONERROR "FAULTY TRANSFORMATION" (CURRENTFORM
|
||||
CURRENTCOMS))
|
||||
T))))
|
||||
|
||||
(RPAQQ TRANSOREMARKS ((TRANSFORMATIONERROR (* The TRANSFORMATIONS specified for this form failed to
|
||||
work properly. The TTY message %'FAULTY TRANSFORMATION'
|
||||
was printed, any commands remaining in the
|
||||
transformation after the erroneous one were skipped,
|
||||
and translation continued as if the transformation had
|
||||
been normally completed. The user should treat the
|
||||
translated form with caution and amend his
|
||||
transformation to avoid future problems.))
|
||||
(TRANSERROR (* TRANSOR got confused at this point. The TTY message %'SHOW JIM
|
||||
GOODWIN' was printed and translation continued with the next
|
||||
form, but the user should treat the compromised area of code
|
||||
with caution.))
|
||||
(BLAMBDA1 (* Non-atomic CAR of form, but not an open lambda. Either a
|
||||
parenthesis error or computed CAR of form. Computed CAR of form is
|
||||
no longer legal in BBN-LISP; APPLY* is used instead. If computed
|
||||
CAR of form was intended, the translation to APPLY* will run ok.
|
||||
See manual for discussion of APPLY*.))
|
||||
(BLAMBDA2 (* Open LAMBDA with wrong number of args. What can it mean?))
|
||||
(BLAMBDA3 (* Lambda-expression without forms. What can it mean?))
|
||||
(ILLCAR (* Illegal data-type encountered as CAR of form Expression treated as
|
||||
list of forms.))
|
||||
(TAILP/DOTHIS (* When the transormacro DOTHIS is executed at a TAILP position,
|
||||
TRANSOR does a 1 command first, assuming that the current
|
||||
position is a list of forms and CAR of it is the form
|
||||
intended. The user should make sure that this is what was
|
||||
intended by the TRANSFORMATIONS which called DOTHIS, i.e. the
|
||||
TRANSFORMATIONS for the form containing this one.))))
|
||||
(RPAQQ TRANSOREMARKS
|
||||
((TRANSFORMATIONERROR (* The TRANSFORMATIONS specified for this form failed to work properly.
|
||||
The TTY message %'FAULTY TRANSFORMATION' was printed, any commands
|
||||
remaining in the transformation after the erroneous one were skipped,
|
||||
and translation continued as if the transformation had been normally
|
||||
completed. The user should treat the translated form with caution and
|
||||
amend his transformation to avoid future problems.))
|
||||
(TRANSERROR (* TRANSOR got confused at this point. The TTY message %'SHOW JIM GOODWIN' was
|
||||
printed and translation continued with the next form, but the user should
|
||||
treat the compromised area of code with caution.))
|
||||
(BLAMBDA1 (* Non-atomic CAR of form, but not an open lambda. Either a parenthesis error or
|
||||
computed CAR of form. Computed CAR of form is no longer legal in BBN-LISP;
|
||||
APPLY* is used instead. If computed CAR of form was intended, the translation to
|
||||
APPLY* will run ok. See manual for discussion of APPLY*.))
|
||||
(BLAMBDA2 (* Open LAMBDA with wrong number of args. What can it mean?))
|
||||
(BLAMBDA3 (* Lambda-expression without forms. What can it mean?))
|
||||
(ILLCAR (* Illegal data-type encountered as CAR of form Expression treated as list of forms.)
|
||||
)
|
||||
(TAILP/DOTHIS (* When the transormacro DOTHIS is executed at a TAILP position, TRANSOR does a
|
||||
1 command first, assuming that the current position is a list of forms and
|
||||
CAR of it is the form intended. The user should make sure that this is what
|
||||
was intended by the TRANSFORMATIONS which called DOTHIS, i.e. the
|
||||
TRANSFORMATIONS for the form containing this one.))))
|
||||
|
||||
(RPAQQ TRANSORGLOBALS (USERNOTES USERNOTES TESTFORM TESTFORM TRANSFORMATIONS TRANSFORMATIONS
|
||||
XFORMSFNS XFORMSVARS XFORMSVARS DUMPFILE TRANSFORMATIONS TRANSFORMATIONS
|
||||
XFORMSFNS XFORMSVARS XFORMSVARS DUMPFILE TRANSFORMATIONS TRANSFORMATIONS
|
||||
TRANSFORMATIONS TRANSFORMATIONS))
|
||||
|
||||
(RPAQQ MAXLOOP 1530)
|
||||
@@ -917,9 +917,11 @@ TRANSOR made a translation error: " T)
|
||||
|
||||
(RPAQ GLOBALVARS (APPEND TRANSORGLOBALS GLOBALVARS))
|
||||
|
||||
(RPAQ EDITCOMSA (UNION '(NLAM NLAMIT DOTHESE DOTHIS XFORMER CONTINUE) EDITCOMSA))
|
||||
(RPAQ EDITCOMSA (UNION '(NLAM NLAMIT DOTHESE DOTHIS XFORMER CONTINUE)
|
||||
EDITCOMSA))
|
||||
|
||||
(RPAQ EDITCOMSL (UNION '(REMARK) EDITCOMSL))
|
||||
(RPAQ EDITCOMSL (UNION '(REMARK)
|
||||
EDITCOMSL))
|
||||
|
||||
(RPAQQ TRANSITCONSES (ORR NIL XFORMER))
|
||||
|
||||
@@ -932,7 +934,7 @@ TRANSOR made a translation error: " T)
|
||||
(RPAQ? TRANSOUTREADTABLE FILERDTBL)
|
||||
(DECLARE%: DOEVAL@LOAD DOEVAL@COMPILE DONTCOPY
|
||||
|
||||
(PUTPROPS TAILP BLKLIBRARYDEF [LAMBDA (.BLKVAR.X .BLKVAR.Y)
|
||||
(PUTPROPS TAILP BLKLIBRARYDEF [LAMBDA (.BLKVAR.X .BLKVAR.Y)
|
||||
(* True if .BLKVAR.X is A tail of .BLKVAR.Y .BLKVAR.X and
|
||||
.BLKVAR.Y non-null.)
|
||||
(* Included with editor for block compilation purposes.)
|
||||
@@ -944,15 +946,19 @@ TRANSOR made a translation error: " T)
|
||||
(GO LP])
|
||||
)
|
||||
|
||||
(PUTPROPS TRANSOR FILEGROUP (TRANSOR TSET))
|
||||
(PUTPROPS TRANSOR FILEGROUP (TRANSOR TSET))
|
||||
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
|
||||
|
||||
(BLOCK%: PRECHBLOCK PRECH PRECH1 PRECH2 RETAIL LNC (ENTRIES PRECH)
|
||||
(BLKLIBRARY TAILP MEMB LAST LENGTH ASSOC GETP))
|
||||
|
||||
(BLOCK%: TRANSITBLOCK TRANSIT WACHADOON (ENTRIES TRANSIT WACHADOON)
|
||||
(GLOBALVARS WACHADID WHENTODOIT TRANSITCONSES LAMBDACOMS NLISTPCOMS)
|
||||
(BLKLIBRARY TAILP MEMB LAST LENGTH ASSOC GETP))
|
||||
|
||||
(BLOCK%: TRANXTBLOCK TRANXT (ENTRIES TRANXT)
|
||||
(BLKLIBRARY TAILP MEMB LAST LENGTH ASSOC GETP))
|
||||
|
||||
(BLOCK%: NIL PRESCAN (GLOBALVARS PRESCARRAY))
|
||||
)
|
||||
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
|
||||
@@ -963,23 +969,11 @@ TRANSOR made a translation error: " T)
|
||||
|
||||
(ADDTOVAR LAMA )
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
|
||||
(ADDTOVAR EDITHISTALIST (TRANSOR (" 5-Feb-87 16:18:06" DJVB {DSK}<XAVIER>TRANSOR.;11 (TRANSOR)
|
||||
(FIXED TO WORK WITH NEW FILE RULES IN LYRIC))
|
||||
(" 6-Feb-87 15:24:20" DJVB {DSK}<XAVIER>TRANSOR.;12 (TRANSOR))
|
||||
(" 6-Mar-87 14:41:26" DJVB {DSK}<XAVIER>TRANSOR.;13
|
||||
(TRANSOR TRANSOR-PROCEED TRANSORFORM TRANSORFNS TRANSFORM
|
||||
RETAIL))
|
||||
("17-Mar-87 17:01:53" DJVB {DSK}<XAVIER>TRANSOR.;15 (PRECH1 TRANSOUT)
|
||||
(ADDED SPLIT READ/WRITE READTABLES AND PP FOR DEFUN))))
|
||||
)
|
||||
(PUTPROPS TRANSOR COPYRIGHT (NONE))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (2231 38324 (TRANSOR 2241 . 6284) (TRANSOR-PROCEED 6286 . 9093) (TRANSORFORM 9095 . 9527
|
||||
) (TRANSORFNS 9529 . 10225) (TRANSFORM 10227 . 11965) (TRANSIT 11967 . 14735) (TRANXT 14737 . 17950) (
|
||||
TRANSEXIT 17952 . 18262) (KEEPLIST 18264 . 19224) (TRANSERR 19226 . 19990) (TRANSOUT 19992 . 22436) (
|
||||
PPASS1 22438 . 22679) (TRANSLIST 22681 . 23700) (TRANSLIST1 23702 . 23934) (PREMTEXT 23936 . 24641) (
|
||||
WACHADOON 24643 . 25114) (PRECH 25116 . 25609) (PRECH1 25611 . 27779) (PRECH2 27781 . 28727) (RETAIL
|
||||
28729 . 29976) (LNC 29978 . 30841) (PRESCAN 30843 . 38322)))))
|
||||
(FILEMAP (NIL (2262 38355 (TRANSOR 2272 . 6315) (TRANSOR-PROCEED 6317 . 9124) (TRANSORFORM 9126 . 9558
|
||||
) (TRANSORFNS 9560 . 10256) (TRANSFORM 10258 . 11996) (TRANSIT 11998 . 14766) (TRANXT 14768 . 17981) (
|
||||
TRANSEXIT 17983 . 18293) (KEEPLIST 18295 . 19255) (TRANSERR 19257 . 20021) (TRANSOUT 20023 . 22467) (
|
||||
PPASS1 22469 . 22710) (TRANSLIST 22712 . 23731) (TRANSLIST1 23733 . 23965) (PREMTEXT 23967 . 24672) (
|
||||
WACHADOON 24674 . 25145) (PRECH 25147 . 25640) (PRECH1 25642 . 27810) (PRECH2 27812 . 28758) (RETAIL
|
||||
28760 . 30007) (LNC 30009 . 30872) (PRESCAN 30874 . 38353)))))
|
||||
STOP
|
||||
|
||||
@@ -1,25 +1,19 @@
|
||||
(DEFINE-FILE-INFO §PACKAGE "XCL-USER" §READTABLE "XCL")
|
||||
(IL:FILECREATED "13-Apr-87 17:38:17" IL:{DSK}<XAVIER>LOADTRAN.\;9 2045
|
||||
(DEFINE-FILE-INFO PACKAGE "XCL-USER" READTABLE "XCL" BASE 10)
|
||||
|
||||
IL:|changes| IL:|to:| (IL:VARS IL:LOADTRANCOMS STOP)
|
||||
(IL:FUNCTIONS MYLOAD I.S.OPR PRETTYCOMPRINT SETTEMPLATE DEFINE-FILE-INFO
|
||||
)
|
||||
(IL:FNS PRETTYCOMPRINT SETTEMPLATE)
|
||||
(IL:FILECREATED "18-Feb-2026 22:58:35" IL:|{WMEDLEY}<lispusers>TRANSOR-LOADTRAN.;2| 1561
|
||||
|
||||
IL:|previous| IL:|date:| " 6-Apr-87 16:57:48" IL:{DSK}<XAVIER>LOADTRAN.\;1)
|
||||
:EDIT-BY IL:|rmk|)
|
||||
|
||||
|
||||
; Copyright (c) 1987 by System Development Corp.. All rights reserved.
|
||||
(IL:PRETTYCOMPRINT IL:TRANSOR-LOADTRANCOMS)
|
||||
|
||||
(IL:PRETTYCOMPRINT IL:LOADTRANCOMS)
|
||||
|
||||
(IL:RPAQQ IL:LOADTRANCOMS ((IL:VARS STOP)
|
||||
(IL:FNS PRETTYCOMPRINT SETTEMPLATE)
|
||||
(IL:FUNCTIONS DEFINE-FILE-INFO I.S.OPR MYLOAD)
|
||||
(IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY
|
||||
IL:COMPILERVARS (IL:ADDVARS (IL:NLAMA PRETTYCOMPRINT)
|
||||
(IL:NLAML)
|
||||
(IL:LAMA SETTEMPLATE)))))
|
||||
(IL:RPAQQ IL:TRANSOR-LOADTRANCOMS ((IL:VARS STOP)
|
||||
(IL:FNS PRETTYCOMPRINT SETTEMPLATE)
|
||||
(IL:FUNCTIONS DEFINE-FILE-INFO I.S.OPR MYLOAD)
|
||||
(IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY
|
||||
IL:COMPILERVARS (IL:ADDVARS (IL:NLAMA PRETTYCOMPRINT)
|
||||
(IL:NLAML)
|
||||
(IL:LAMA SETTEMPLATE)))))
|
||||
|
||||
(IL:RPAQQ STOP STOP)
|
||||
(IL:DEFINEQ
|
||||
@@ -33,17 +27,17 @@
|
||||
(BLOCK SETTEMPLATE (NILL))))
|
||||
)
|
||||
|
||||
(DEFUN DEFINE-FILE-INFO (&REST ARGS) (NILL))
|
||||
(DEFUN DEFINE-FILE-INFO (&REST ARGS)
|
||||
(NILL))
|
||||
|
||||
(DEFUN I.S.OPR (X)
|
||||
(NILL))
|
||||
|
||||
(DEFUN I.S.OPR (X) (NILL))
|
||||
|
||||
|
||||
(DEFUN MYLOAD (FILE) (LET ((FILE (OPEN FILE :DIRECTION :INPUT)))
|
||||
(UNWIND-PROTECT (IL:\\CML-LOAD FILE T *TERMINAL-IO* (FIND-PACKAGE
|
||||
"XCL-USER"))
|
||||
(CLOSE FILE))))
|
||||
|
||||
(DEFUN MYLOAD (FILE)
|
||||
(LET ((FILE (OPEN FILE :DIRECTION :INPUT)))
|
||||
(UNWIND-PROTECT
|
||||
(IL:\\CML-LOAD FILE T *TERMINAL-IO* (FIND-PACKAGE "XCL-USER"))
|
||||
(CLOSE FILE))))
|
||||
(IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS
|
||||
|
||||
(IL:ADDTOVAR IL:NLAMA PRETTYCOMPRINT)
|
||||
@@ -52,7 +46,7 @@
|
||||
|
||||
(IL:ADDTOVAR IL:LAMA SETTEMPLATE)
|
||||
)
|
||||
(IL:PUTPROPS IL:LOADTRAN IL:COPYRIGHT ("System Development Corp." 1987))
|
||||
(IL:DECLARE\: IL:DONTCOPY
|
||||
(IL:FILEMAP (NIL (1134 1357 (PRETTYCOMPRINT 1147 . 1283) (SETTEMPLATE 1285 . 1355)))))
|
||||
(IL:FILEMAP (NIL (830 1053 (PRETTYCOMPRINT 843 . 979) (SETTEMPLATE 981 . 1051)) (1055 1106 (
|
||||
DEFINE-FILE-INFO 1055 . 1106)) (1108 1141 (I.S.OPR 1108 . 1141)) (1143 1341 (MYLOAD 1143 . 1341)))))
|
||||
IL:STOP
|
||||
|
||||
Binary file not shown.
Binary file not shown.
@@ -1,20 +1,15 @@
|
||||
(DEFINE-FILE-INFO §PACKAGE "INTERLISP" §READTABLE "INTERLISP" §BASE 10)
|
||||
(FILECREATED " 7-Dec-86 17:26:23" {ERIS}<LISPUSERS>LISPCORE>UNBOXEDOPS.;7 12906
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
changes to%: (OPTIMIZERS UFREMAINDER2 UFREMAINDER)
|
||||
(FNS UFREMAINDER)
|
||||
(VARS UNBOXEDOPSCOMS)
|
||||
(FILECREATED "18-Feb-2026 16:17:02" {WMEDLEY}<lispusers>UNBOXEDOPS.;2 10856
|
||||
|
||||
previous date%: " 3-Nov-86 20:30:24" {ERIS}<LISPUSERS>LISPCORE>UNBOXEDOPS.;6)
|
||||
:EDIT-BY rmk
|
||||
|
||||
:PREVIOUS-DATE " 7-Dec-86 17:26:23" {WMEDLEY}<lispusers>UNBOXEDOPS.;1)
|
||||
|
||||
(* "
|
||||
Copyright (c) 1986 by Xerox Corporation. All rights reserved.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT UNBOXEDOPSCOMS)
|
||||
|
||||
(RPAQQ UNBOXEDOPSCOMS
|
||||
(RPAQQ UNBOXEDOPSCOMS
|
||||
[(FNS UFABS UFEQP UFGEQ UFGREATERP UFIX UFLEQ UFLESSP UFMAX UFMIN UFMINUS UFREMAINDER)
|
||||
(OPTIMIZERS UFABS UFABS1 UFEQP UFEQP2 UFGEQ UFGEQ2 UFGREATERP UFGREATERP2 UFIX UFIX1 UFLEQ
|
||||
UFLEQ2 UFLESSP UFLESSP2 UFMAX UFMAX2 UFMIN UFMIN2 UFMINUS UFMINUS1 UFREMAINDER)
|
||||
@@ -81,178 +76,168 @@ Copyright (c) 1986 by Xerox Corporation. All rights reserved.
|
||||
FY])
|
||||
)
|
||||
|
||||
(DEFOPTIMIZER UFABS (&OPTIONAL (ARG1 NIL ARG1GIVEN)
|
||||
&REST RESTARGS &WHOLE ORIGINAL) (if (OR (NOT ARG1GIVEN)
|
||||
RESTARGS)
|
||||
then (PRINTOUT T "************" T)
|
||||
(PRINTOUT T
|
||||
"Illegal args to UFABS" %,
|
||||
%, ORIGINAL T)
|
||||
(PRINTOUT T "************" T))
|
||||
(LIST 'UFABS1 ARG1))
|
||||
(DEFOPTIMIZER UFABS (&OPTIONAL (ARG1 NIL ARG1GIVEN)
|
||||
&REST RESTARGS &WHOLE ORIGINAL)
|
||||
(if (OR (NOT ARG1GIVEN)
|
||||
RESTARGS)
|
||||
then (PRINTOUT T "************" T)
|
||||
(PRINTOUT T "Illegal args to UFABS" %, %, ORIGINAL T)
|
||||
(PRINTOUT T "************" T))
|
||||
(LIST 'UFABS1 ARG1))
|
||||
|
||||
(DEFOPTIMIZER UFABS1 (X)
|
||||
`[\FLOATBOX ((OPCODES UBFLOAT1 2)
|
||||
(\FLOATUNBOX ,X])
|
||||
|
||||
(DEFOPTIMIZER UFABS1 (X) `[\FLOATBOX ((OPCODES UBFLOAT1 2)
|
||||
(\FLOATUNBOX ,X])
|
||||
|
||||
|
||||
(DEFOPTIMIZER UFEQP (&WHOLE ORIGINAL &OPTIONAL (ARG1 NIL ARG1GIVEN)
|
||||
(DEFOPTIMIZER UFEQP (&WHOLE ORIGINAL &OPTIONAL (ARG1 NIL ARG1GIVEN)
|
||||
(ARG2 NIL ARG2GIVEN)
|
||||
&REST RESTARGS) (if (OR (NOT ARG1GIVEN)
|
||||
(NOT ARG2GIVEN)
|
||||
RESTARGS)
|
||||
then (PRINTOUT T "************" T)
|
||||
(PRINTOUT T "Illegal args to UFEQP" %, %,
|
||||
ORIGINAL T)
|
||||
(PRINTOUT T "************" T))
|
||||
(LIST 'UFEQP2 ARG1 ARG2))
|
||||
&REST RESTARGS)
|
||||
(if (OR (NOT ARG1GIVEN)
|
||||
(NOT ARG2GIVEN)
|
||||
RESTARGS)
|
||||
then (PRINTOUT T "************" T)
|
||||
(PRINTOUT T "Illegal args to UFEQP" %, %, ORIGINAL T)
|
||||
(PRINTOUT T "************" T))
|
||||
(LIST 'UFEQP2 ARG1 ARG2))
|
||||
|
||||
(DEFOPTIMIZER UFEQP2 (X Y)
|
||||
`(EQ (\FLOATUNBOX (FDIFFERENCE ,X ,Y))
|
||||
NIL))
|
||||
|
||||
(DEFOPTIMIZER UFEQP2 (X Y) `(EQ (\FLOATUNBOX (FDIFFERENCE ,X ,Y))
|
||||
NIL))
|
||||
|
||||
|
||||
(DEFOPTIMIZER UFGEQ (&WHOLE ORIGINAL &OPTIONAL (ARG1 NIL ARG1GIVEN)
|
||||
(DEFOPTIMIZER UFGEQ (&WHOLE ORIGINAL &OPTIONAL (ARG1 NIL ARG1GIVEN)
|
||||
(ARG2 NIL ARG2GIVEN)
|
||||
&REST RESTARGS) (if (OR (NOT ARG1GIVEN)
|
||||
(NOT ARG2GIVEN)
|
||||
RESTARGS)
|
||||
then (PRINTOUT T "************" T)
|
||||
(PRINTOUT T "Illegal args to UFGEQ" %, %,
|
||||
ORIGINAL T)
|
||||
(PRINTOUT T "************" T))
|
||||
(LIST 'UFGEQ2 ARG1 ARG2))
|
||||
&REST RESTARGS)
|
||||
(if (OR (NOT ARG1GIVEN)
|
||||
(NOT ARG2GIVEN)
|
||||
RESTARGS)
|
||||
then (PRINTOUT T "************" T)
|
||||
(PRINTOUT T "Illegal args to UFGEQ" %, %, ORIGINAL T)
|
||||
(PRINTOUT T "************" T))
|
||||
(LIST 'UFGEQ2 ARG1 ARG2))
|
||||
|
||||
(DEFOPTIMIZER UFGEQ2 (X Y)
|
||||
`[NOT ((OPCODES SWAP UBFLOAT2 5)
|
||||
(\FLOATUNBOX ,X)
|
||||
(\FLOATUNBOX ,Y])
|
||||
|
||||
(DEFOPTIMIZER UFGEQ2 (X Y) `[NOT ((OPCODES SWAP UBFLOAT2 5)
|
||||
(\FLOATUNBOX ,X)
|
||||
(\FLOATUNBOX ,Y])
|
||||
|
||||
|
||||
(DEFOPTIMIZER UFGREATERP (&WHOLE ORIGINAL &OPTIONAL (ARG1 NIL ARG1GIVEN)
|
||||
(DEFOPTIMIZER UFGREATERP (&WHOLE ORIGINAL &OPTIONAL (ARG1 NIL ARG1GIVEN)
|
||||
(ARG2 NIL ARG2GIVEN)
|
||||
&REST RESTARGS) (if (OR (NOT ARG1GIVEN)
|
||||
(NOT ARG2GIVEN)
|
||||
RESTARGS)
|
||||
then (PRINTOUT T "************" T)
|
||||
(PRINTOUT T "Illegal args to UFGREATERP" %,
|
||||
%, ORIGINAL T)
|
||||
(PRINTOUT T "************" T))
|
||||
(LIST 'UFGREATERP2 ARG1 ARG2))
|
||||
&REST RESTARGS)
|
||||
(if (OR (NOT ARG1GIVEN)
|
||||
(NOT ARG2GIVEN)
|
||||
RESTARGS)
|
||||
then (PRINTOUT T "************" T)
|
||||
(PRINTOUT T "Illegal args to UFGREATERP" %, %, ORIGINAL T)
|
||||
(PRINTOUT T "************" T))
|
||||
(LIST 'UFGREATERP2 ARG1 ARG2))
|
||||
|
||||
(DEFOPTIMIZER UFGREATERP2 (X Y)
|
||||
`((OPCODES UBFLOAT2 5)
|
||||
(\FLOATUNBOX ,X)
|
||||
(\FLOATUNBOX ,Y)))
|
||||
|
||||
(DEFOPTIMIZER UFGREATERP2 (X Y) `((OPCODES UBFLOAT2 5)
|
||||
(\FLOATUNBOX ,X)
|
||||
(\FLOATUNBOX ,Y)))
|
||||
(DEFOPTIMIZER UFIX (&WHOLE ORIGINAL &OPTIONAL (ARG1 NIL ARG1GIVEN)
|
||||
&REST RESTARGS)
|
||||
(if (OR (NOT ARG1GIVEN)
|
||||
RESTARGS)
|
||||
then (PRINTOUT T "************" T)
|
||||
(PRINTOUT T "Illegal args to UFIX" %, %, ORIGINAL T)
|
||||
(PRINTOUT T "************" T))
|
||||
(LIST 'UFIX1 ARG1))
|
||||
|
||||
(DEFOPTIMIZER UFIX1 (X)
|
||||
`((OPCODES UBFLOAT1 4)
|
||||
(\FLOATUNBOX ,X)))
|
||||
|
||||
(DEFOPTIMIZER UFIX (&WHOLE ORIGINAL &OPTIONAL (ARG1 NIL ARG1GIVEN)
|
||||
&REST RESTARGS) (if (OR (NOT ARG1GIVEN)
|
||||
RESTARGS)
|
||||
then (PRINTOUT T "************" T)
|
||||
(PRINTOUT T "Illegal args to UFIX" %, %, ORIGINAL
|
||||
T)
|
||||
(PRINTOUT T "************" T))
|
||||
(LIST 'UFIX1 ARG1))
|
||||
|
||||
|
||||
(DEFOPTIMIZER UFIX1 (X) `((OPCODES UBFLOAT1 4)
|
||||
(\FLOATUNBOX ,X)))
|
||||
|
||||
|
||||
(DEFOPTIMIZER UFLEQ (&WHOLE ORIGINAL &OPTIONAL (ARG1 NIL ARG1GIVEN)
|
||||
(DEFOPTIMIZER UFLEQ (&WHOLE ORIGINAL &OPTIONAL (ARG1 NIL ARG1GIVEN)
|
||||
(ARG2 NIL ARG2GIVEN)
|
||||
&REST RESTARGS) (if (OR (NOT ARG1GIVEN)
|
||||
(NOT ARG2GIVEN)
|
||||
RESTARGS)
|
||||
then (PRINTOUT T "************" T)
|
||||
(PRINTOUT T "Illegal args to UFLEQ" %, %,
|
||||
ORIGINAL T)
|
||||
(PRINTOUT T "************" T))
|
||||
(LIST 'UFLEQ2 ARG1 ARG2))
|
||||
&REST RESTARGS)
|
||||
(if (OR (NOT ARG1GIVEN)
|
||||
(NOT ARG2GIVEN)
|
||||
RESTARGS)
|
||||
then (PRINTOUT T "************" T)
|
||||
(PRINTOUT T "Illegal args to UFLEQ" %, %, ORIGINAL T)
|
||||
(PRINTOUT T "************" T))
|
||||
(LIST 'UFLEQ2 ARG1 ARG2))
|
||||
|
||||
(DEFOPTIMIZER UFLEQ2 (X Y)
|
||||
`[NOT ((OPCODES UBFLOAT2 5)
|
||||
(\FLOATUNBOX ,X)
|
||||
(\FLOATUNBOX ,Y])
|
||||
|
||||
(DEFOPTIMIZER UFLEQ2 (X Y) `[NOT ((OPCODES UBFLOAT2 5)
|
||||
(DEFOPTIMIZER UFLESSP (&WHOLE ORIGINAL &OPTIONAL (ARG1 NIL ARG1GIVEN)
|
||||
(ARG2 NIL ARG2GIVEN)
|
||||
&REST RESTARGS)
|
||||
(if (OR (NOT ARG1GIVEN)
|
||||
(NOT ARG2GIVEN)
|
||||
RESTARGS)
|
||||
then (PRINTOUT T "************" T)
|
||||
(PRINTOUT T "Illegal args to UFLESSP" %, %, ORIGINAL T)
|
||||
(PRINTOUT T "************" T))
|
||||
(LIST 'UFLESSP2 ARG1 ARG2))
|
||||
|
||||
(DEFOPTIMIZER UFLESSP2 (X Y)
|
||||
`((OPCODES SWAP UBFLOAT2 5)
|
||||
(\FLOATUNBOX ,X)
|
||||
(\FLOATUNBOX ,Y)))
|
||||
|
||||
(DEFOPTIMIZER UFMAX (&OPTIONAL (ARG1 NIL ARG1GIVEN)
|
||||
(ARG2 NIL ARG2GIVEN)
|
||||
&REST RESTARGS)
|
||||
(if (NOT ARG1GIVEN)
|
||||
then 'MIN.FLOAT
|
||||
elseif (NOT ARG2GIVEN)
|
||||
then `(FLOAT %, ARG1)
|
||||
elseif RESTARGS
|
||||
then `(UFMAX (UFMAX2 %, ARG1 %, ARG2)
|
||||
., RESTARGS)
|
||||
else (LIST 'UFMAX2 ARG1 ARG2)))
|
||||
|
||||
(DEFOPTIMIZER UFMAX2 (X Y)
|
||||
`[\FLOATBOX ((OPCODES UBFLOAT2 6)
|
||||
(\FLOATUNBOX ,X)
|
||||
(\FLOATUNBOX ,Y])
|
||||
|
||||
|
||||
(DEFOPTIMIZER UFLESSP (&WHOLE ORIGINAL &OPTIONAL (ARG1 NIL ARG1GIVEN)
|
||||
(ARG2 NIL ARG2GIVEN)
|
||||
&REST RESTARGS) (if (OR (NOT ARG1GIVEN)
|
||||
(NOT ARG2GIVEN)
|
||||
RESTARGS)
|
||||
then (PRINTOUT T "************" T)
|
||||
(PRINTOUT T "Illegal args to UFLESSP" %, %,
|
||||
ORIGINAL T)
|
||||
(PRINTOUT T "************" T))
|
||||
(LIST 'UFLESSP2 ARG1 ARG2))
|
||||
|
||||
|
||||
(DEFOPTIMIZER UFLESSP2 (X Y) `((OPCODES SWAP UBFLOAT2 5)
|
||||
(\FLOATUNBOX ,X)
|
||||
(\FLOATUNBOX ,Y)))
|
||||
|
||||
|
||||
(DEFOPTIMIZER UFMAX (&OPTIONAL (ARG1 NIL ARG1GIVEN)
|
||||
(DEFOPTIMIZER UFMIN (&OPTIONAL (ARG1 NIL ARG1GIVEN)
|
||||
(ARG2 NIL ARG2GIVEN)
|
||||
&REST RESTARGS) (if (NOT ARG1GIVEN)
|
||||
then 'MIN.FLOAT
|
||||
elseif (NOT ARG2GIVEN)
|
||||
then `(FLOAT %, ARG1)
|
||||
elseif RESTARGS
|
||||
then `(UFMAX (UFMAX2 %, ARG1 %, ARG2)
|
||||
., RESTARGS)
|
||||
else (LIST 'UFMAX2 ARG1 ARG2)))
|
||||
&REST RESTARGS)
|
||||
(if (NOT ARG1GIVEN)
|
||||
then 'MAX.FLOAT
|
||||
elseif (NOT ARG2GIVEN)
|
||||
then `(FLOAT %, ARG1)
|
||||
elseif RESTARGS
|
||||
then `(UFMIN (UFMIN2 %, ARG1 %, ARG2)
|
||||
., RESTARGS)
|
||||
else (LIST 'UFMIN2 ARG1 ARG2)))
|
||||
|
||||
(DEFOPTIMIZER UFMIN2 (X Y)
|
||||
`[\FLOATBOX ((OPCODES UBFLOAT2 7)
|
||||
(\FLOATUNBOX ,X)
|
||||
(\FLOATUNBOX ,Y])
|
||||
|
||||
(DEFOPTIMIZER UFMAX2 (X Y) `[\FLOATBOX ((OPCODES UBFLOAT2 6)
|
||||
(\FLOATUNBOX ,X)
|
||||
(\FLOATUNBOX ,Y])
|
||||
(DEFOPTIMIZER UFMINUS (&WHOLE ORIGINAL &OPTIONAL (ARG1 NIL ARG1GIVEN)
|
||||
&REST RESTARGS)
|
||||
(if (OR (NOT ARG1GIVEN)
|
||||
RESTARGS)
|
||||
then (PRINTOUT T "************" T)
|
||||
(PRINTOUT T "Illegal args to UFMINUS" %, %, ORIGINAL T)
|
||||
(PRINTOUT T "************" T))
|
||||
(LIST 'UFMINUS1 ARG1))
|
||||
|
||||
(DEFOPTIMIZER UFMINUS1 (X)
|
||||
`[\FLOATBOX ((OPCODES UBFLOAT1 3)
|
||||
(\FLOATUNBOX ,X])
|
||||
|
||||
(DEFOPTIMIZER UFMIN (&OPTIONAL (ARG1 NIL ARG1GIVEN)
|
||||
(ARG2 NIL ARG2GIVEN)
|
||||
&REST RESTARGS) (if (NOT ARG1GIVEN)
|
||||
then 'MAX.FLOAT
|
||||
elseif (NOT ARG2GIVEN)
|
||||
then `(FLOAT %, ARG1)
|
||||
elseif RESTARGS
|
||||
then `(UFMIN (UFMIN2 %, ARG1 %, ARG2)
|
||||
., RESTARGS)
|
||||
else (LIST 'UFMIN2 ARG1 ARG2)))
|
||||
(DEFOPTIMIZER UFREMAINDER (X Y)
|
||||
(CL:IF (AND (OR (CL:CONSTANTP X)
|
||||
(CL:SYMBOLP X))
|
||||
(OR (CL:CONSTANTP Y)
|
||||
(CL:SYMBOLP Y)))
|
||||
`(FDIFFERENCE ,X (FTIMES [FLOAT (UFIX (FQUOTIENT ,X ,Y]
|
||||
,Y))
|
||||
'COMPILER:PASS))
|
||||
|
||||
|
||||
(DEFOPTIMIZER UFMIN2 (X Y) `[\FLOATBOX ((OPCODES UBFLOAT2 7)
|
||||
(\FLOATUNBOX ,X)
|
||||
(\FLOATUNBOX ,Y])
|
||||
|
||||
|
||||
(DEFOPTIMIZER UFMINUS (&WHOLE ORIGINAL &OPTIONAL (ARG1 NIL ARG1GIVEN)
|
||||
&REST RESTARGS) (if (OR (NOT ARG1GIVEN)
|
||||
RESTARGS)
|
||||
then (PRINTOUT T "************" T)
|
||||
(PRINTOUT T "Illegal args to UFMINUS" %, %,
|
||||
ORIGINAL T)
|
||||
(PRINTOUT T "************" T))
|
||||
(LIST 'UFMINUS1 ARG1))
|
||||
|
||||
|
||||
(DEFOPTIMIZER UFMINUS1 (X) `[\FLOATBOX ((OPCODES UBFLOAT1 3)
|
||||
(\FLOATUNBOX ,X])
|
||||
|
||||
|
||||
(DEFOPTIMIZER UFREMAINDER (X Y) (CL:IF (AND (OR (CL:CONSTANTP X)
|
||||
(CL:SYMBOLP X))
|
||||
(OR (CL:CONSTANTP Y)
|
||||
(CL:SYMBOLP Y)))
|
||||
`(FDIFFERENCE ,X (FTIMES [FLOAT (UFIX (FQUOTIENT ,X
|
||||
,Y]
|
||||
,Y))
|
||||
'COMPILER:PASS))
|
||||
|
||||
|
||||
(PUTPROPS UNBOXEDOPS FILETYPE CL:COMPILE-FILE)
|
||||
(PUTPROPS UNBOXEDOPS FILETYPE CL:COMPILE-FILE)
|
||||
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
|
||||
(DECLARE%: DOEVAL@COMPILE DONTCOPY
|
||||
|
||||
@@ -267,9 +252,8 @@ Copyright (c) 1986 by Xerox Corporation. All rights reserved.
|
||||
|
||||
(ADDTOVAR LAMA UFMIN UFMAX)
|
||||
)
|
||||
(PUTPROPS UNBOXEDOPS COPYRIGHT ("Xerox Corporation" 1986))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (1185 3385 (UFABS 1195 . 1316) (UFEQP 1318 . 1441) (UFGEQ 1443 . 1565) (UFGREATERP 1567
|
||||
. 1700) (UFIX 1702 . 1821) (UFLEQ 1823 . 1945) (UFLESSP 1947 . 2074) (UFMAX 2076 . 2478) (UFMIN 2480
|
||||
. 2879) (UFMINUS 2881 . 3006) (UFREMAINDER 3008 . 3383)))))
|
||||
(FILEMAP (NIL (983 3183 (UFABS 993 . 1114) (UFEQP 1116 . 1239) (UFGEQ 1241 . 1363) (UFGREATERP 1365 .
|
||||
1498) (UFIX 1500 . 1619) (UFLEQ 1621 . 1743) (UFLESSP 1745 . 1872) (UFMAX 1874 . 2276) (UFMIN 2278 .
|
||||
2677) (UFMINUS 2679 . 2804) (UFREMAINDER 2806 . 3181)))))
|
||||
STOP
|
||||
|
||||
BIN
lispusers/UNBOXEDOPS.DFASL
Normal file
BIN
lispusers/UNBOXEDOPS.DFASL
Normal file
Binary file not shown.
@@ -1,19 +1,17 @@
|
||||
(DEFINE-FILE-INFO §PACKAGE "INTERLISP" §READTABLE "XCL" §BASE 10)
|
||||
(filecreated "18-Dec-86 19:03:25" {eris}<lispcore>internal>library>whocalls.\;2 4500
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
|
||||
|
||||
|changes| |to:| (fns distribute.callinfo distribute-call-info-for-symbol)
|
||||
(vars whocallscoms)
|
||||
(FILECREATED "18-Feb-2026 16:08:45" |{WMEDLEY}<lispusers>WHOCALLS.;2| 4272
|
||||
|
||||
|previous| |date:| " 7-Nov-86 02:47:11" {eris}<lispusers>lispcore>whocalls.\;2)
|
||||
:EDIT-BY |rmk|
|
||||
|
||||
:PREVIOUS-DATE "18-Dec-86 19:03:25" |{WMEDLEY}<lispusers>WHOCALLS.;1|)
|
||||
|
||||
|
||||
; Copyright (c) 1986 by Xerox Corporation. All rights reserved.
|
||||
(PRETTYCOMPRINT WHOCALLSCOMS)
|
||||
|
||||
(prettycomprint whocallscoms)
|
||||
|
||||
(rpaqq whocallscoms ((fns whocalls whocalls1 distribute.callinfo distribute-call-info-for-symbol)
|
||||
(prop proptype calledby usedfreeby usedglobalby boundby)))
|
||||
(defineq
|
||||
(RPAQQ WHOCALLSCOMS ((FNS WHOCALLS WHOCALLS1 DISTRIBUTE.CALLINFO DISTRIBUTE-CALL-INFO-FOR-SYMBOL)
|
||||
(PROP PROPTYPE CALLEDBY USEDFREEBY USEDGLOBALBY BOUNDBY)))
|
||||
(DEFINEQ
|
||||
|
||||
(WHOCALLS
|
||||
(LAMBDA (CALLEE USAGE)
|
||||
@@ -78,15 +76,14 @@
|
||||
x))))))
|
||||
)
|
||||
|
||||
(putprops calledby proptype ignore)
|
||||
(PUTPROPS CALLEDBY PROPTYPE IGNORE)
|
||||
|
||||
(putprops usedfreeby proptype ignore)
|
||||
(PUTPROPS USEDFREEBY PROPTYPE IGNORE)
|
||||
|
||||
(putprops usedglobalby proptype ignore)
|
||||
(PUTPROPS USEDGLOBALBY PROPTYPE IGNORE)
|
||||
|
||||
(putprops boundby proptype ignore)
|
||||
(putprops whocalls copyright ("Xerox Corporation" 1986))
|
||||
(declare\: dontcopy
|
||||
(filemap (nil (653 4251 (whocalls 663 . 2057) (whocalls1 2059 . 3191) (distribute.callinfo 3193 . 3419
|
||||
) (distribute-call-info-for-symbol 3421 . 4249)))))
|
||||
stop
|
||||
(PUTPROPS BOUNDBY PROPTYPE IGNORE)
|
||||
(DECLARE\: DONTCOPY
|
||||
(FILEMAP (NIL (466 4064 (WHOCALLS 476 . 1870) (WHOCALLS1 1872 . 3004) (DISTRIBUTE.CALLINFO 3006 . 3232
|
||||
) (DISTRIBUTE-CALL-INFO-FOR-SYMBOL 3234 . 4062)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,14 +1,11 @@
|
||||
(DEFINE-FILE-INFO §PACKAGE "INTERLISP" §READTABLE "INTERLISP" §BASE 10)
|
||||
(FILECREATED "22-Dec-86 18:42:34" {ERIS}<LISPUSERS>LISPCORE>COMPILEBANG.;3 3465
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
changes to%: (FNS COMPILE!)
|
||||
(FILECREATED "18-Feb-2026 16:23:37" {WMEDLEY}<lispusers>compilebang.;2 3232
|
||||
|
||||
previous date%: "18-Nov-86 22:23:43" {ERIS}<LISPUSERS>LISPCORE>COMPILEBANG.;2)
|
||||
:EDIT-BY rmk
|
||||
|
||||
:PREVIOUS-DATE "22-Dec-86 18:42:34" {WMEDLEY}<lispusers>compilebang.;1)
|
||||
|
||||
(* "
|
||||
Copyright (c) 1982, 1983, 1984, 1986 by Xerox Corporation. All rights reserved.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT COMPILEBANGCOMS)
|
||||
|
||||
@@ -63,23 +60,22 @@ Copyright (c) 1982, 1983, 1984, 1986 by Xerox Corporation. All rights reserved.
|
||||
NIL NIL T))
|
||||
(T C))))
|
||||
|
||||
(ADDTOVAR USERMACROS [C NIL (ORR (UP 1)
|
||||
NIL)
|
||||
(ORR ((E (COMPILE! (OR (LISTP (%##))
|
||||
(%## !0))
|
||||
T T T)))
|
||||
((E 'C?])
|
||||
(ADDTOVAR USERMACROS
|
||||
[C NIL (ORR (UP 1)
|
||||
NIL)
|
||||
(ORR ((E (COMPILE! (OR (LISTP (%##))
|
||||
(%## !0))
|
||||
T T T)))
|
||||
((E 'C?])
|
||||
|
||||
(ADDTOVAR EDITCOMSA C)
|
||||
|
||||
(DEFCOMMAND (C :EVAL) (&REST LISPXLINE) (COND
|
||||
(LISPXLINE (COMPILE! (CAR LISPXLINE)
|
||||
(DEFCOMMAND (C :EVAL) (&REST LISPXLINE) (COND
|
||||
(LISPXLINE (COMPILE! (CAR LISPXLINE)
|
||||
NIL NIL T))
|
||||
(T C)))
|
||||
|
||||
|
||||
(PUTPROPS COMPILEBANG FILETYPE CL:COMPILE-FILE)
|
||||
(PUTPROPS COMPILEBANG COPYRIGHT ("Xerox Corporation" 1982 1983 1984 1986))
|
||||
(PUTPROPS COMPILEBANG FILETYPE CL:COMPILE-FILE)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (622 2567 (COMPILE! 632 . 2565)))))
|
||||
(FILEMAP (NIL (506 2451 (COMPILE! 516 . 2449)))))
|
||||
STOP
|
||||
|
||||
@@ -8,6 +8,7 @@ main() {
|
||||
|
||||
cmfile="-"
|
||||
cat >"${initfile}" <<-"EOF"
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10 FORMAT UTF-8)
|
||||
(* "make init files; this file is loaded as a 'greet' file by scripts/loadup-init.sh")
|
||||
|
||||
(SETQ MEDLEYDIR NIL)
|
||||
|
||||
196
sources/ADISPLAY
196
sources/ADISPLAY
@@ -1,14 +1,10 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10 FORMAT UTF-8)
|
||||
|
||||
(FILECREATED " 8-Jul-2025 20:19:58"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>working-medley>sources>ADISPLAY.;14 244883
|
||||
(FILECREATED "19-Feb-2026 12:09:16" {WMEDLEY}<sources>ADISPLAY.;15 244850
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (VARS ADISPLAYCOMS)
|
||||
|
||||
:PREVIOUS-DATE "19-Dec-2023 11:23:08"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>working-medley>sources>ADISPLAY.;13)
|
||||
:PREVIOUS-DATE " 8-Jul-2025 20:19:58" {WMEDLEY}<sources>ADISPLAY.;14)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT ADISPLAYCOMS)
|
||||
@@ -130,7 +126,7 @@
|
||||
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(RECORD REGION (LEFT BOTTOM WIDTH HEIGHT)
|
||||
LEFT _ -16383 BOTTOM _ -16383 WIDTH _ 32767 HEIGHT _ 32767
|
||||
LEFT ← -16383 BOTTOM ← -16383 WIDTH ← 32767 HEIGHT ← 32767
|
||||
[ACCESSFNS ((TOP (IPLUS (fetch (REGION BOTTOM) of DATUM)
|
||||
(fetch (REGION HEIGHT) of DATUM)
|
||||
-1))
|
||||
@@ -150,7 +146,7 @@
|
||||
(BITMAPHEIGHT WORD)
|
||||
(BITMAPWIDTH WORD)
|
||||
(BITMAPBITSPERPIXEL WORD))
|
||||
BITMAPBITSPERPIXEL _ 1 (BLOCKRECORD BITMAP ((BitMapHiLoc WORD)
|
||||
BITMAPBITSPERPIXEL ← 1 (BLOCKRECORD BITMAP ((BitMapHiLoc WORD)
|
||||
(BitMapLoLoc WORD))
|
||||
(* ; "overlay initial pointer")
|
||||
)
|
||||
@@ -398,7 +394,7 @@
|
||||
(T (printout T "******** " BITMAP " is not a BITMAP." T)
|
||||
(RETURN NIL)))
|
||||
(printout FILE "(" .P2 (BITMAPWIDTH BM)
|
||||
%, .P2 (BITMAPHEIGHT BM)) (* ;
|
||||
%, .P2 (BITMAPHEIGHT BM)) (* ;
|
||||
"if the number of bits per pixel is not 1, write it out.")
|
||||
(COND
|
||||
((NEQ (BITSPERPIXEL BM)
|
||||
@@ -431,7 +427,7 @@
|
||||
(* ;; "Print this bitmap in the preferred way.")
|
||||
|
||||
(LET* ((WIDTH (BITMAPWIDTH BITMAP))
|
||||
(HEIGHT (BITMAPHEIGHT BITMAP))
|
||||
(HEIGHT (BITMAPHEIGHT BITMAP))
|
||||
(BITS-PER-PIXEL (BITSPERPIXEL BITMAP))
|
||||
(BASE (fetch BITMAPBASE of BITMAP))
|
||||
(QUAD-CHARS-PER-ROW (FOLDHI (CL:* WIDTH BITS-PER-PIXEL)
|
||||
@@ -712,20 +708,20 @@
|
||||
NIL)
|
||||
((CURSORP DEFAULTCARET)
|
||||
(create CARET1
|
||||
CURSOR _ DEFAULTCARET))
|
||||
CURSOR ← DEFAULTCARET))
|
||||
(T (ERROR "DEFAULTCARET is not a cursor"
|
||||
DEFAULTCARET))))
|
||||
(OFF NIL)
|
||||
(COND
|
||||
((CURSORP NEWCARET)
|
||||
(create CARET1
|
||||
CURSOR _ NEWCARET))
|
||||
CURSOR ← NEWCARET))
|
||||
(T (LISPERROR "ILLEGAL ARG" NEWCARET])])
|
||||
|
||||
(\CARET.CREATE
|
||||
[LAMBDA (CURSOR) (* jds "11-Jul-85 19:38")
|
||||
(create CARET1
|
||||
CURSOR _ (OR CURSOR DEFAULTCARET])
|
||||
CURSOR ← (OR CURSOR DEFAULTCARET])
|
||||
|
||||
(\CARET.DOWN
|
||||
[LAMBDA (STREAM INTERVAL UNLESSOCCLUDED) (* lmm " 4-May-84 18:15")
|
||||
@@ -815,7 +811,7 @@
|
||||
(LET ((OCARET \CARET.UP))
|
||||
(COND
|
||||
([AND OCARET CARET (DISPLAYSTREAMP (OR STREAM (SETQ STREAM (TTYDISPLAYSTREAM]
|
||||
(for (OC _ OCARET) by (fetch (CARET1 NEXT) of OC)
|
||||
(for (OC ← OCARET) by (fetch (CARET1 NEXT) of OC)
|
||||
do (COND
|
||||
[(NULL OC)
|
||||
(RETURN (COND
|
||||
@@ -1008,10 +1004,10 @@
|
||||
[LAMBDA (LEFT BOTTOM WIDTH HEIGHT) (* rrb "17-JUN-83 08:56")
|
||||
(* ; "creates a region structure.")
|
||||
(create REGION
|
||||
LEFT _ LEFT
|
||||
BOTTOM _ BOTTOM
|
||||
WIDTH _ WIDTH
|
||||
HEIGHT _ HEIGHT])
|
||||
LEFT ← LEFT
|
||||
BOTTOM ← BOTTOM
|
||||
WIDTH ← WIDTH
|
||||
HEIGHT ← HEIGHT])
|
||||
|
||||
(REGIONP
|
||||
[LAMBDA (X) (* rrb "29-Jun-84 18:00")
|
||||
@@ -1029,11 +1025,11 @@
|
||||
(* ;; "this is documented as returning a very large region. This one covers the entire FIXP range so should work for many purposes. rrb")
|
||||
|
||||
(create REGION
|
||||
LEFT _ (SUB1 MIN.FIXP)
|
||||
BOTTOM _ (SUB1 MIN.FIXP)
|
||||
WIDTH _ (PLUS (TIMES 2 MAX.FIXP)
|
||||
LEFT ← (SUB1 MIN.FIXP)
|
||||
BOTTOM ← (SUB1 MIN.FIXP)
|
||||
WIDTH ← (PLUS (TIMES 2 MAX.FIXP)
|
||||
4)
|
||||
HEIGHT _ (PLUS (TIMES 2 MAX.FIXP)
|
||||
HEIGHT ← (PLUS (TIMES 2 MAX.FIXP)
|
||||
4)))
|
||||
(T (PROG (REG LFT RGHT BTTM TP)
|
||||
(SETQ REG (ARG REGIONS 1))
|
||||
@@ -1062,10 +1058,10 @@
|
||||
((AND (IGEQ RGHT LFT)
|
||||
(IGEQ TP BTTM))
|
||||
(create REGION
|
||||
LEFT _ LFT
|
||||
BOTTOM _ BTTM
|
||||
WIDTH _ (ADD1 (IDIFFERENCE RGHT LFT))
|
||||
HEIGHT _ (ADD1 (IDIFFERENCE TP BTTM])
|
||||
LEFT ← LFT
|
||||
BOTTOM ← BTTM
|
||||
WIDTH ← (ADD1 (IDIFFERENCE RGHT LFT))
|
||||
HEIGHT ← (ADD1 (IDIFFERENCE TP BTTM])
|
||||
|
||||
(UNIONREGIONS
|
||||
[LAMBDA REGIONS (* rrb "30-Dec-85 17:07")
|
||||
@@ -1099,10 +1095,10 @@
|
||||
TP)
|
||||
(SETQ TP (fetch (REGION PTOP) of REG]
|
||||
(RETURN (create REGION
|
||||
LEFT _ LFT
|
||||
BOTTOM _ BTTM
|
||||
WIDTH _ (DIFFERENCE RGHT LFT)
|
||||
HEIGHT _ (DIFFERENCE TP BTTM])
|
||||
LEFT ← LFT
|
||||
BOTTOM ← BTTM
|
||||
WIDTH ← (DIFFERENCE RGHT LFT)
|
||||
HEIGHT ← (DIFFERENCE TP BTTM])
|
||||
|
||||
(REGIONSINTERSECTP
|
||||
[LAMBDA (REGION1 REGION2) (* rrb "16-AUG-81 08:29")
|
||||
@@ -1233,11 +1229,11 @@
|
||||
(* ;; "returns the region taken up by STR if it were printed at the current position of STREAM")
|
||||
|
||||
(create REGION
|
||||
LEFT _ (DSPXPOSITION NIL STREAM)
|
||||
BOTTOM _ (IDIFFERENCE (DSPYPOSITION NIL STREAM)
|
||||
LEFT ← (DSPXPOSITION NIL STREAM)
|
||||
BOTTOM ← (IDIFFERENCE (DSPYPOSITION NIL STREAM)
|
||||
(FONTPROP STREAM 'DESCENT))
|
||||
WIDTH _ (STRINGWIDTH STR STREAM PRIN2FLG RDTBL)
|
||||
HEIGHT _ (FONTPROP STREAM 'HEIGHT])
|
||||
WIDTH ← (STRINGWIDTH STR STREAM PRIN2FLG RDTBL)
|
||||
HEIGHT ← (FONTPROP STREAM 'HEIGHT])
|
||||
)
|
||||
|
||||
|
||||
@@ -1443,8 +1439,8 @@
|
||||
(SETQ BRUSHARRAY (ARRAY 16 'POINTER NIL 1))
|
||||
(for X from 1 to 16 do (SETA BRUSHARRAY X (APPLY* BRUSHFN X]
|
||||
(push \BrushAList (CONS BRUSHNAME (create BRUSHITEM
|
||||
BRUSHARRAY _ BRUSHARRAY
|
||||
CREATEMETHOD _ BRUSHFN)))
|
||||
BRUSHARRAY ← BRUSHARRAY
|
||||
CREATEMETHOD ← BRUSHFN)))
|
||||
(push KNOWN.BRUSHES BRUSHNAME])
|
||||
)
|
||||
|
||||
@@ -1506,12 +1502,12 @@
|
||||
CBottom)
|
||||
(SETQ BITMAP (ffetch DDDestination of DD))
|
||||
(SETQ BIGBMLIST (fetch (BIGBM BIGBMLIST) of BITMAP))
|
||||
(SETQ HEIGHT (BITMAPHEIGHT BITMAP))
|
||||
(SETQ HEIGHT (BITMAPHEIGHT BITMAP))
|
||||
(SETQ ClippingTop (ffetch DDClippingTop of DD))
|
||||
(SETQ ClippingBottom (ffetch DDClippingBottom of DD))
|
||||
(SETQ BM (GetNewFragment BIGBMLIST))
|
||||
(while (AND BM (IGREATERP HEIGHT ClippingBottom))
|
||||
do (SETQ BOTTOM (IDIFFERENCE HEIGHT (BITMAPHEIGHT BM)))
|
||||
do (SETQ BOTTOM (IDIFFERENCE HEIGHT (BITMAPHEIGHT BM)))
|
||||
[SETQ CTop (COND
|
||||
((IGREATERP ClippingTop HEIGHT)
|
||||
(IDIFFERENCE HEIGHT BOTTOM))
|
||||
@@ -1576,7 +1572,7 @@
|
||||
(SUB1 (ffetch DDClippingTop of DD))
|
||||
DISPLAYSTREAM COLOR))
|
||||
(T (PROG ((BIGBMLIST (fetch (BIGBM BIGBMLIST) of BITMAP))
|
||||
(HEIGHT (BITMAPHEIGHT BITMAP))
|
||||
(HEIGHT (BITMAPHEIGHT BITMAP))
|
||||
BOTTOM BM CTop CBottom (ClippingTop (ffetch DDClippingTop of DD))
|
||||
(ClippingBottom (ffetch DDClippingBottom of DD))
|
||||
(YY1 (\DSPTRANSFORMY (OR (FIXP Y1)
|
||||
@@ -1587,7 +1583,7 @@
|
||||
DD)))
|
||||
(SETQ BM (GetNewFragment BIGBMLIST))
|
||||
(while (AND BM (IGREATERP HEIGHT ClippingBottom))
|
||||
do (SETQ BOTTOM (IDIFFERENCE HEIGHT (BITMAPHEIGHT BM)))
|
||||
do (SETQ BOTTOM (IDIFFERENCE HEIGHT (BITMAPHEIGHT BM)))
|
||||
[SETQ CTop (COND
|
||||
((IGREATERP ClippingTop HEIGHT)
|
||||
(IDIFFERENCE HEIGHT BOTTOM))
|
||||
@@ -2038,7 +2034,7 @@
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(PUTPROPS .DRAWLINEX. MACRO [(MODE)
|
||||
(bind (NY _ 0) for PT from 1 to PIXELSINX
|
||||
(bind (NY ← 0) for PT from 1 to PIXELSINX
|
||||
do (* ; "main loop")
|
||||
[replace (BITMAPWORD BITS) of FIRSTADDR
|
||||
with (SELECTQ MODE
|
||||
@@ -2068,7 +2064,7 @@
|
||||
(SETQ MASK 32768])
|
||||
|
||||
(PUTPROPS .DRAWLINEY. MACRO [(MODE)
|
||||
(bind (NX _ 0) for PT from 1 to PIXELSINY
|
||||
(bind (NX ← 0) for PT from 1 to PIXELSINY
|
||||
do (* ; "main loop")
|
||||
[replace (BITMAPWORD BITS) of FIRSTADDR
|
||||
with (SELECTQ MODE
|
||||
@@ -2295,9 +2291,9 @@
|
||||
|
||||
(RETURN (for ANGLE from STARTANGLE to (PLUS STARTANGLE ANGLESIZE (QUOTIENT ANGLEINCR 5.0))
|
||||
by ANGLEINCR collect (create POSITION
|
||||
XCOORD _ [FIXR (PLUS CENTERX (TIMES RADIUS
|
||||
XCOORD ← [FIXR (PLUS CENTERX (TIMES RADIUS
|
||||
(COS ANGLE]
|
||||
YCOORD _ (FIXR (PLUS CENTERY (TIMES RADIUS
|
||||
YCOORD ← (FIXR (PLUS CENTERY (TIMES RADIUS
|
||||
(SIN ANGLE])
|
||||
|
||||
(\DRAWELLIPSE.DISPLAY
|
||||
@@ -2609,7 +2605,7 @@
|
||||
((EQ (fetch (BRUSH BRUSHSHAPE) of BRUSH)
|
||||
'ROUND)
|
||||
BRUSH)
|
||||
(T (create BRUSH using BRUSH BRUSHSHAPE _ 'ROUND]
|
||||
(T (create BRUSH using BRUSH BRUSHSHAPE ← 'ROUND]
|
||||
(SETQ COLOR (fetch (BRUSH BRUSHCOLOR) of PTBRUSH))
|
||||
(for PTAIL on POINTS while (CDR PTAIL) do (\DRAWLINE.DISPLAY STREAM (fetch (POSITION XCOORD
|
||||
)
|
||||
@@ -2991,15 +2987,15 @@
|
||||
(ELT DDY I]
|
||||
(SETQ SPLINE
|
||||
(create SPLINE
|
||||
%#KNOTS _ %#KNOTS
|
||||
SPLINEX _ X
|
||||
SPLINEY _ Y
|
||||
SPLINEDX _ DX
|
||||
SPLINEDY _ DY
|
||||
SPLINEDDX _ DDX
|
||||
SPLINEDDY _ DDY
|
||||
SPLINEDDDX _ DDDX
|
||||
SPLINEDDDY _ DDDY))
|
||||
%#KNOTS ← %#KNOTS
|
||||
SPLINEX ← X
|
||||
SPLINEY ← Y
|
||||
SPLINEDX ← DX
|
||||
SPLINEDY ← DY
|
||||
SPLINEDDX ← DDX
|
||||
SPLINEDDY ← DDY
|
||||
SPLINEDDDX ← DDDX
|
||||
SPLINEDDDY ← DDDY))
|
||||
(RETURN SPLINE])
|
||||
|
||||
(\CURVE
|
||||
@@ -3187,7 +3183,7 @@
|
||||
(SETQ POINTSPERSEG 64)
|
||||
(SETQ NPOINTS (UNFOLD NSEGS 64]
|
||||
(SETQ D1 (FQUOTIENT 1.0 NPOINTS)) (* ;
|
||||
"Set up ÿ&Eÿ t, ÿ&Eÿ t**2 and ÿ&Eÿ t**3, for computing the next point.")
|
||||
"Set up Δt, Δt**2 and Δt**3, for computing the next point.")
|
||||
(SETQ D2 (FTIMES D1 D1))
|
||||
(SETQ D3 (FTIMES D2 D1))
|
||||
(SETQ D3X (FTIMES D3 DDDX))
|
||||
@@ -3219,11 +3215,11 @@
|
||||
(SETQ PERSEG (FQUOTIENT 1.0 NSEGS))
|
||||
(LOADPOLY XPOLY X/PRIME/POLY DDDX DDX DX X0)
|
||||
(LOADPOLY YPOLY Y/PRIME/POLY DDDY DDY DY Y0)
|
||||
(bind (TT _ 0.0)
|
||||
(DDDX/PER/SEG _ (FTIMES DDDX PERSEG))
|
||||
(DDDY/PER/SEG _ (FTIMES DDDY PERSEG))
|
||||
[D3XFACTOR _ (FTIMES D3 DDDX (CONSTANT (FQUOTIENT 1.0 6.0]
|
||||
[D3YFACTOR _ (FTIMES D3 DDDY (CONSTANT (FQUOTIENT 1.0 6.0] for I
|
||||
(bind (TT ← 0.0)
|
||||
(DDDX/PER/SEG ← (FTIMES DDDX PERSEG))
|
||||
(DDDY/PER/SEG ← (FTIMES DDDY PERSEG))
|
||||
[D3XFACTOR ← (FTIMES D3 DDDX (CONSTANT (FQUOTIENT 1.0 6.0]
|
||||
[D3YFACTOR ← (FTIMES D3 DDDY (CONSTANT (FQUOTIENT 1.0 6.0] for I
|
||||
from 0 to (SUB1 NSEGS)
|
||||
do
|
||||
(* ;;
|
||||
@@ -4224,9 +4220,9 @@
|
||||
(SETQ Min (FDIFFERENCE (FTIMES L 2)
|
||||
Max))
|
||||
(RETURN (create RGB
|
||||
RED _ (\HLSVALUEFN Min Max H)
|
||||
GREEN _ (\HLSVALUEFN Min Max (IDIFFERENCE H 120))
|
||||
BLUE _ (\HLSVALUEFN Min Max (IDIFFERENCE H 240])
|
||||
RED ← (\HLSVALUEFN Min Max H)
|
||||
GREEN ← (\HLSVALUEFN Min Max (IDIFFERENCE H 120))
|
||||
BLUE ← (\HLSVALUEFN Min Max (IDIFFERENCE H 240])
|
||||
|
||||
(\HLSVALUEFN
|
||||
[LAMBDA (MIN MAX HUE) (* rrb "25-OCT-82 10:47")
|
||||
@@ -4424,40 +4420,40 @@
|
||||
(ADDTOVAR LAMA UNIONREGIONS INTERSECTREGIONS)
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (10589 10783 (SCREENREGIONP 10599 . 10781)) (12227 19588 (\BBTCURVEPT 12237 . 19586)) (
|
||||
19589 29405 (CREATETEXTUREFROMBITMAP 19599 . 21529) (PRINTBITMAP 21531 . 22882) (PRINT-BITMAPS-NICELY
|
||||
22884 . 26735) (PRINTCURSOR 26737 . 27770) (\WRITEBITMAP 27772 . 29403)) (29448 31996 (\GETINTEGERPART
|
||||
29458 . 31003) (\CONVERTTOFRACTION 31005 . 31994)) (32133 33005 (CURSORP 32143 . 32362) (CURSORBITMAP
|
||||
32364 . 32410) (CreateCursorBitMap 32412 . 33003)) (37367 46290 (CARET 37377 . 39137) (\CARET.CREATE
|
||||
39139 . 39317) (\CARET.DOWN 39319 . 40671) (\CARET.FLASH? 40673 . 42367) (\CARET.SHOW 42369 . 42938) (
|
||||
CARETRATE 42940 . 43598) (\CARET.FLASH.AGAIN 43600 . 44766) (\CARET.FLASH.MULTIPLE 44768 . 45291) (
|
||||
\CARET.FLASH 45293 . 46288)) (46291 51363 (\MEDW.CARET.SHOW 46301 . 51361)) (51727 53562 (
|
||||
\AREAVISIBLE? 51737 . 52661) (\REGIONOVERLAPAREAP 52663 . 53208) (\AREAINREGIONP 53210 . 53560)) (
|
||||
53611 66087 (CREATEREGION 53621 . 53957) (REGIONP 53959 . 54105) (INTERSECTREGIONS 54107 . 56877) (
|
||||
UNIONREGIONS 56879 . 59030) (REGIONSINTERSECTP 59032 . 59640) (SUBREGIONP 59642 . 60287) (EXTENDREGION
|
||||
60289 . 62446) (EXTENDREGIONBOTTOM 62448 . 63090) (EXTENDREGIONLEFT 63092 . 63711) (EXTENDREGIONRIGHT
|
||||
63713 . 64266) (EXTENDREGIONTOP 64268 . 64809) (INSIDEP 64811 . 65579) (STRINGREGION 65581 . 66085))
|
||||
(66332 71606 (\BRUSHBITMAP 66342 . 68059) (\GETBRUSH 68061 . 68372) (\GETBRUSHBBT 68374 . 70402) (
|
||||
\InitCurveBrushes 70404 . 71470) (\BrushFromWidth 71472 . 71604)) (71607 74674 (\MAKEBRUSH.DIAGONAL
|
||||
71617 . 71897) (\MAKEBRUSH.HORIZONTAL 71899 . 72293) (\MAKEBRUSH.VERTICAL 72295 . 72607) (
|
||||
\MAKEBRUSH.SQUARE 72609 . 72886) (\MAKEBRUSH.ROUND 72888 . 74672)) (74675 75840 (INSTALLBRUSH 74685 .
|
||||
75838)) (76241 87643 (\DRAWLINE.DISPLAY 76251 . 86358) (RELMOVETO 86360 . 86747) (MOVETOUPPERLEFT
|
||||
86749 . 87641)) (87644 111129 (\CLIPANDDRAWLINE 87654 . 94100) (\CLIPANDDRAWLINE1 94102 . 105850) (
|
||||
\CLIPCODE 105852 . 107226) (\LEASTPTAT 107228 . 107826) (\GREATESTPTAT 107828 . 108456) (\DRAWLINE1
|
||||
108458 . 109574) (\DRAWLINE.UFN 109576 . 111127)) (115659 161706 (\DRAWCIRCLE.DISPLAY 115669 . 124482)
|
||||
(\DRAWARC.DISPLAY 124484 . 124774) (\DRAWARC.GENERIC 124776 . 125529) (\COMPUTE.ARC.POINTS 125531 .
|
||||
127796) (\DRAWELLIPSE.DISPLAY 127798 . 143467) (\DRAWCURVE.DISPLAY 143469 . 145758) (
|
||||
\DRAWPOINT.DISPLAY 145760 . 146956) (\DRAWPOLYGON.DISPLAY 146958 . 150486) (\LINEWITHBRUSH 150488 .
|
||||
161704)) (161707 193399 (LOADPOLY 161717 . 162277) (PARAMETRICSPLINE 162279 . 172476) (\CURVE 172478
|
||||
. 178080) (\CURVE2 178082 . 189413) (\CURVEEND 189415 . 189897) (\CURVESLOPE 189899 . 192382) (
|
||||
\CURVESTART 192384 . 192708) (\FDIFS/FROM/DERIVS 192710 . 193397)) (205928 220264 (\FILLCIRCLE.DISPLAY
|
||||
205938 . 216686) (\LINEBLT 216688 . 220262)) (220308 221930 (SCREENBITMAP 220318 . 220795) (BITMAPP
|
||||
220797 . 221031) (BITSPERPIXEL 221033 . 221928)) (222571 223564 (DSPFILL 222581 . 223264) (INVERTW
|
||||
223266 . 223562)) (223565 227208 (\DSPCOLOR.DISPLAY 223575 . 224872) (\DSPBACKCOLOR.DISPLAY 224874 .
|
||||
226253) (DSPEOLFN 226255 . 227206)) (227641 232295 (DSPCLEOL 227651 . 228527) (DSPRUBOUTCHAR 228529 .
|
||||
228961) (\DSPMOVELR 228963 . 232293)) (232425 233543 (\CURSOR.DEFPRINT 232435 . 233541)) (233955
|
||||
242529 (TEXTUREOFCOLOR 233965 . 235227) (\PRIMARYTEXTURE 235229 . 235811) (\LEVELTEXTURE 235813 .
|
||||
236314) (INSURE.B&W.TEXTURE 236316 . 237711) (INSURE.RGB.COLOR 237713 . 239141) (\LOOKUPCOLORNAME
|
||||
239143 . 239413) (RGBP 239415 . 240180) (HLSP 240182 . 240557) (HLSTORGB 240559 . 241699) (\HLSVALUEFN
|
||||
241701 . 242527)))))
|
||||
(FILEMAP (NIL (10493 10687 (SCREENREGIONP 10503 . 10685)) (12131 19492 (\BBTCURVEPT 12141 . 19490)) (
|
||||
19493 29301 (CREATETEXTUREFROMBITMAP 19503 . 21433) (PRINTBITMAP 21435 . 22782) (PRINT-BITMAPS-NICELY
|
||||
22784 . 26631) (PRINTCURSOR 26633 . 27666) (\WRITEBITMAP 27668 . 29299)) (29344 31892 (\GETINTEGERPART
|
||||
29354 . 30899) (\CONVERTTOFRACTION 30901 . 31890)) (32029 32901 (CURSORP 32039 . 32258) (CURSORBITMAP
|
||||
32260 . 32306) (CreateCursorBitMap 32308 . 32899)) (37263 46194 (CARET 37273 . 39037) (\CARET.CREATE
|
||||
39039 . 39219) (\CARET.DOWN 39221 . 40573) (\CARET.FLASH? 40575 . 42269) (\CARET.SHOW 42271 . 42840) (
|
||||
CARETRATE 42842 . 43500) (\CARET.FLASH.AGAIN 43502 . 44670) (\CARET.FLASH.MULTIPLE 44672 . 45195) (
|
||||
\CARET.FLASH 45197 . 46192)) (46195 51267 (\MEDW.CARET.SHOW 46205 . 51265)) (51631 53466 (
|
||||
\AREAVISIBLE? 51641 . 52565) (\REGIONOVERLAPAREAP 52567 . 53112) (\AREAINREGIONP 53114 . 53464)) (
|
||||
53515 66031 (CREATEREGION 53525 . 53869) (REGIONP 53871 . 54017) (INTERSECTREGIONS 54019 . 56805) (
|
||||
UNIONREGIONS 56807 . 58966) (REGIONSINTERSECTP 58968 . 59576) (SUBREGIONP 59578 . 60223) (EXTENDREGION
|
||||
60225 . 62382) (EXTENDREGIONBOTTOM 62384 . 63026) (EXTENDREGIONLEFT 63028 . 63647) (EXTENDREGIONRIGHT
|
||||
63649 . 64202) (EXTENDREGIONTOP 64204 . 64745) (INSIDEP 64747 . 65515) (STRINGREGION 65517 . 66029))
|
||||
(66276 71550 (\BRUSHBITMAP 66286 . 68003) (\GETBRUSH 68005 . 68316) (\GETBRUSHBBT 68318 . 70346) (
|
||||
\InitCurveBrushes 70348 . 71414) (\BrushFromWidth 71416 . 71548)) (71551 74618 (\MAKEBRUSH.DIAGONAL
|
||||
71561 . 71841) (\MAKEBRUSH.HORIZONTAL 71843 . 72237) (\MAKEBRUSH.VERTICAL 72239 . 72551) (
|
||||
\MAKEBRUSH.SQUARE 72553 . 72830) (\MAKEBRUSH.ROUND 72832 . 74616)) (74619 75788 (INSTALLBRUSH 74629 .
|
||||
75786)) (76189 87575 (\DRAWLINE.DISPLAY 76199 . 86290) (RELMOVETO 86292 . 86679) (MOVETOUPPERLEFT
|
||||
86681 . 87573)) (87576 111061 (\CLIPANDDRAWLINE 87586 . 94032) (\CLIPANDDRAWLINE1 94034 . 105782) (
|
||||
\CLIPCODE 105784 . 107158) (\LEASTPTAT 107160 . 107758) (\GREATESTPTAT 107760 . 108388) (\DRAWLINE1
|
||||
108390 . 109506) (\DRAWLINE.UFN 109508 . 111059)) (115595 161648 (\DRAWCIRCLE.DISPLAY 115605 . 124418)
|
||||
(\DRAWARC.DISPLAY 124420 . 124710) (\DRAWARC.GENERIC 124712 . 125465) (\COMPUTE.ARC.POINTS 125467 .
|
||||
127736) (\DRAWELLIPSE.DISPLAY 127738 . 143407) (\DRAWCURVE.DISPLAY 143409 . 145698) (
|
||||
\DRAWPOINT.DISPLAY 145700 . 146896) (\DRAWPOLYGON.DISPLAY 146898 . 150428) (\LINEWITHBRUSH 150430 .
|
||||
161646)) (161649 193360 (LOADPOLY 161659 . 162219) (PARAMETRICSPLINE 162221 . 172436) (\CURVE 172438
|
||||
. 178040) (\CURVE2 178042 . 189374) (\CURVEEND 189376 . 189858) (\CURVESLOPE 189860 . 192343) (
|
||||
\CURVESTART 192345 . 192669) (\FDIFS/FROM/DERIVS 192671 . 193358)) (205889 220225 (\FILLCIRCLE.DISPLAY
|
||||
205899 . 216647) (\LINEBLT 216649 . 220223)) (220269 221891 (SCREENBITMAP 220279 . 220756) (BITMAPP
|
||||
220758 . 220992) (BITSPERPIXEL 220994 . 221889)) (222532 223525 (DSPFILL 222542 . 223225) (INVERTW
|
||||
223227 . 223523)) (223526 227169 (\DSPCOLOR.DISPLAY 223536 . 224833) (\DSPBACKCOLOR.DISPLAY 224835 .
|
||||
226214) (DSPEOLFN 226216 . 227167)) (227602 232256 (DSPCLEOL 227612 . 228488) (DSPRUBOUTCHAR 228490 .
|
||||
228922) (\DSPMOVELR 228924 . 232254)) (232386 233504 (\CURSOR.DEFPRINT 232396 . 233502)) (233916
|
||||
242496 (TEXTUREOFCOLOR 233926 . 235188) (\PRIMARYTEXTURE 235190 . 235772) (\LEVELTEXTURE 235774 .
|
||||
236275) (INSURE.B&W.TEXTURE 236277 . 237672) (INSURE.RGB.COLOR 237674 . 239102) (\LOOKUPCOLORNAME
|
||||
239104 . 239374) (RGBP 239376 . 240141) (HLSP 240143 . 240518) (HLSTORGB 240520 . 241666) (\HLSVALUEFN
|
||||
241668 . 242494)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
80
sources/ATBL
80
sources/ATBL
@@ -1,12 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "24-Apr-2025 21:52:35" {WMEDLEY}<sources>ATBL.;33 91754
|
||||
(FILECREATED "25-Feb-2026 12:02:51" {WMEDLEY}<sources>ATBL.;35 92262
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (FNS \ATBLSET EQUAL-READER-ENVIRONMENT)
|
||||
:CHANGES-TO (VARS ATBLCOMS)
|
||||
|
||||
:PREVIOUS-DATE "26-Dec-2021 14:32:50" {WMEDLEY}<sources>ATBL.;32)
|
||||
:PREVIOUS-DATE "24-Apr-2025 21:52:35" {WMEDLEY}<sources>ATBL.;33)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT ATBLCOMS)
|
||||
@@ -56,12 +56,13 @@
|
||||
(CONSTANTS * READCLASSES)
|
||||
(CONSTANTS * READMACROWAKEUPS)
|
||||
(CONSTANTS * READMACROESCAPES)
|
||||
(RECORDS READCODE READMACRODEF READTABLEP))
|
||||
(RECORDS READCODE READMACRODEF READTABLEP)
|
||||
(RECORDS READER-ENVIRONMENT))
|
||||
(GLOBALVARS \ORIGREADTABLE \READTABLEHASH \ORIGTERMTABLE))
|
||||
(INITRECORDS READTABLEP))
|
||||
(INITRECORDS READTABLEP)
|
||||
(INITRECORDS READER-ENVIRONMENT))
|
||||
[COMS (INITVARS (\READTABLEHASH))
|
||||
(FNS \ATBLSET)
|
||||
(INITRECORDS READER-ENVIRONMENT)
|
||||
(* ;
|
||||
"Definition is on CMLREAD, need it here to initialize *OLD-INTERLISP-READ-ENVIRONMENT*")
|
||||
(FNS MAKE-READER-ENVIRONMENT EQUAL-READER-ENVIRONMENT SET-READER-ENVIRONMENT)
|
||||
@@ -1691,6 +1692,19 @@
|
||||
(READTABLEP 8 (BITS . 7))
|
||||
(READTABLEP 10 POINTER))
|
||||
'12)
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(DATATYPE READER-ENVIRONMENT (REPACKAGE REREADTABLE REBASE REPACKAGEFORM REFORMAT REREADTABLEFORM))
|
||||
)
|
||||
|
||||
(/DECLAREDATATYPE 'READER-ENVIRONMENT '(POINTER POINTER POINTER POINTER POINTER POINTER)
|
||||
'((READER-ENVIRONMENT 0 POINTER)
|
||||
(READER-ENVIRONMENT 2 POINTER)
|
||||
(READER-ENVIRONMENT 4 POINTER)
|
||||
(READER-ENVIRONMENT 6 POINTER)
|
||||
(READER-ENVIRONMENT 8 POINTER)
|
||||
(READER-ENVIRONMENT 10 POINTER))
|
||||
'12)
|
||||
|
||||
(* "END EXPORTED DEFINITIONS")
|
||||
|
||||
@@ -1726,6 +1740,15 @@
|
||||
(READTABLEP 10 POINTER))
|
||||
'12)
|
||||
|
||||
(/DECLAREDATATYPE 'READER-ENVIRONMENT '(POINTER POINTER POINTER POINTER POINTER POINTER)
|
||||
'((READER-ENVIRONMENT 0 POINTER)
|
||||
(READER-ENVIRONMENT 2 POINTER)
|
||||
(READER-ENVIRONMENT 4 POINTER)
|
||||
(READER-ENVIRONMENT 6 POINTER)
|
||||
(READER-ENVIRONMENT 8 POINTER)
|
||||
(READER-ENVIRONMENT 10 POINTER))
|
||||
'12)
|
||||
|
||||
(RPAQ? \READTABLEHASH )
|
||||
(DEFINEQ
|
||||
|
||||
@@ -1813,15 +1836,6 @@
|
||||
NIL])
|
||||
)
|
||||
|
||||
(/DECLAREDATATYPE 'READER-ENVIRONMENT '(POINTER POINTER POINTER POINTER POINTER POINTER)
|
||||
'((READER-ENVIRONMENT 0 POINTER)
|
||||
(READER-ENVIRONMENT 2 POINTER)
|
||||
(READER-ENVIRONMENT 4 POINTER)
|
||||
(READER-ENVIRONMENT 6 POINTER)
|
||||
(READER-ENVIRONMENT 8 POINTER)
|
||||
(READER-ENVIRONMENT 10 POINTER))
|
||||
'12)
|
||||
|
||||
|
||||
|
||||
(* ; "Definition is on CMLREAD, need it here to initialize *OLD-INTERLISP-READ-ENVIRONMENT*")
|
||||
@@ -1922,22 +1936,22 @@
|
||||
(ADDTOVAR LAMA READTABLEPROP)
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (17619 28771 (GETSYNTAX 17629 . 22460) (SETSYNTAX 22462 . 23535) (SYNTAXP 23537 . 26034)
|
||||
(\COPYSYNTAX 26036 . 26753) (\GETCHARCODE 26755 . 27043) (\SETFATSYNCODE 27045 . 28336) (
|
||||
\MAPCHARTABLE 28338 . 28769)) (28804 43770 (CONTROL 28814 . 29066) (COPYTERMTABLE 29068 . 29435) (
|
||||
DELETECONTROL 29437 . 32078) (GETDELETECONTROL 32080 . 33042) (ECHOCHAR 33044 . 34485) (ECHOCONTROL
|
||||
34487 . 34944) (ECHOMODE 34946 . 35192) (GETECHOMODE 35194 . 35358) (GETCONTROL 35360 . 35526) (
|
||||
GETTERMTABLE 35528 . 35595) (RAISE 35597 . 36023) (GETRAISE 36025 . 36187) (RESETTERMTABLE 36189 .
|
||||
37273) (SETTERMTABLE 37275 . 37509) (TERMTABLEP 37511 . 37672) (\GETTERMSYNTAX 37674 . 37945) (
|
||||
\GTTERMTABLE 37947 . 38283) (\ORIGTERMTABLE 38285 . 41895) (\SETTERMSYNTAX 41897 . 42532) (
|
||||
\TERMCLASSTOCODE 42534 . 42963) (\TERMCODETOCLASS 42965 . 43352) (\LITCHECK 43354 . 43768)) (46281
|
||||
70105 (COPYREADTABLE 46291 . 46489) (FIND-READTABLE 46491 . 46638) (IN-READTABLE 46640 . 46800) (
|
||||
ESCAPE 46802 . 47055) (GETBRK 47057 . 47195) (GETREADTABLE 47197 . 47333) (GETSEPR 47335 . 47473) (
|
||||
READMACROS 47475 . 47738) (READTABLEP 47740 . 47903) (READTABLEPROP 47905 . 53063) (RESETREADTABLE
|
||||
53065 . 57312) (SETBRK 57314 . 58924) (SETREADTABLE 58926 . 59114) (SETSEPR 59116 . 60658) (
|
||||
\GETREADSYNTAX 60660 . 63350) (\GTREADTABLE 63352 . 63577) (\GTREADTABLE1 63579 . 63835) (
|
||||
\ORIGREADTABLE 63837 . 65745) (\READCLASSTOCODE 65747 . 66198) (\SETMACROSYNTAX 66200 . 67995) (
|
||||
\SETREADSYNTAX 67997 . 69058) (\READTABLEP.DEFPRINT 69060 . 70103)) (82937 87494 (\ATBLSET 82947 .
|
||||
87492)) (87941 91385 (MAKE-READER-ENVIRONMENT 87951 . 89608) (EQUAL-READER-ENVIRONMENT 89610 . 90787)
|
||||
(SET-READER-ENVIRONMENT 90789 . 91383)))))
|
||||
(FILEMAP (NIL (17652 28804 (GETSYNTAX 17662 . 22493) (SETSYNTAX 22495 . 23568) (SYNTAXP 23570 . 26067)
|
||||
(\COPYSYNTAX 26069 . 26786) (\GETCHARCODE 26788 . 27076) (\SETFATSYNCODE 27078 . 28369) (
|
||||
\MAPCHARTABLE 28371 . 28802)) (28837 43803 (CONTROL 28847 . 29099) (COPYTERMTABLE 29101 . 29468) (
|
||||
DELETECONTROL 29470 . 32111) (GETDELETECONTROL 32113 . 33075) (ECHOCHAR 33077 . 34518) (ECHOCONTROL
|
||||
34520 . 34977) (ECHOMODE 34979 . 35225) (GETECHOMODE 35227 . 35391) (GETCONTROL 35393 . 35559) (
|
||||
GETTERMTABLE 35561 . 35628) (RAISE 35630 . 36056) (GETRAISE 36058 . 36220) (RESETTERMTABLE 36222 .
|
||||
37306) (SETTERMTABLE 37308 . 37542) (TERMTABLEP 37544 . 37705) (\GETTERMSYNTAX 37707 . 37978) (
|
||||
\GTTERMTABLE 37980 . 38316) (\ORIGTERMTABLE 38318 . 41928) (\SETTERMSYNTAX 41930 . 42565) (
|
||||
\TERMCLASSTOCODE 42567 . 42996) (\TERMCODETOCLASS 42998 . 43385) (\LITCHECK 43387 . 43801)) (46314
|
||||
70138 (COPYREADTABLE 46324 . 46522) (FIND-READTABLE 46524 . 46671) (IN-READTABLE 46673 . 46833) (
|
||||
ESCAPE 46835 . 47088) (GETBRK 47090 . 47228) (GETREADTABLE 47230 . 47366) (GETSEPR 47368 . 47506) (
|
||||
READMACROS 47508 . 47771) (READTABLEP 47773 . 47936) (READTABLEPROP 47938 . 53096) (RESETREADTABLE
|
||||
53098 . 57345) (SETBRK 57347 . 58957) (SETREADTABLE 58959 . 59147) (SETSEPR 59149 . 60691) (
|
||||
\GETREADSYNTAX 60693 . 63383) (\GTREADTABLE 63385 . 63610) (\GTREADTABLE1 63612 . 63868) (
|
||||
\ORIGREADTABLE 63870 . 65778) (\READCLASSTOCODE 65780 . 66231) (\SETMACROSYNTAX 66233 . 68028) (
|
||||
\SETREADSYNTAX 68030 . 69091) (\READTABLEP.DEFPRINT 69093 . 70136)) (83789 88346 (\ATBLSET 83799 .
|
||||
88344)) (88449 91893 (MAKE-READER-ENVIRONMENT 88459 . 90116) (EQUAL-READER-ENVIRONMENT 90118 . 91295)
|
||||
(SET-READER-ENVIRONMENT 91297 . 91891)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,12 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "23-Apr-2025 23:39:10" {WMEDLEY}<sources>BOOTSTRAP.;61 47417
|
||||
(FILECREATED "25-Feb-2026 15:03:24" {WMEDLEY}<sources>BOOTSTRAP.;69 47041
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (FNS PRINT-READER-ENVIRONMENT \DO-DEFINE-FILE-INFO)
|
||||
:CHANGES-TO (FNS MAKE-DEFINE-FILE-INFO-ENV READ-READER-ENVIRONMENT)
|
||||
|
||||
:PREVIOUS-DATE "27-Sep-2021 10:25:31" {WMEDLEY}<sources>BOOTSTRAP.;59)
|
||||
:PREVIOUS-DATE "25-Feb-2026 13:52:00" {WMEDLEY}<sources>BOOTSTRAP.;66)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT BOOTSTRAPCOMS)
|
||||
@@ -365,15 +365,15 @@
|
||||
|
||||
(\LOAD-STREAM
|
||||
[LAMBDA (STREAM LDFLG PRINTFLG LOAD-VERBOSE-STREAM PACKAGE)
|
||||
(DECLARE (SPECVARS LDFLG PRINTFLG LOAD-VERBOSE-STREAM))
|
||||
(* ; "Edited 17-Jul-2021 21:58 by rmk:")
|
||||
(DECLARE (SPECVARS LDFLG PRINTFLG LOAD-VERBOSE-STREAM)) (* ; "Edited 25-Feb-2026 13:46 by rmk")
|
||||
(* ; "Edited 17-Jul-2021 21:58 by rmk:")
|
||||
|
||||
(* ;;; "Internal function that loads from an already open stream. LOAD-VERBOSE-STREAM if non-nil is the stream to which to print %"file created%" messages and such. Similarly, PRINTFLG, if non-nil, is the stream to which to print the value of each expression.")
|
||||
(* ;;; "Internal function that loads from an already open stream. LOAD-VERBOSE-STREAM if non-nil is the stream to which to print %"file created%" messages and such. Similarly, PRINTFLG, if non-nil, is the stream to which to print the value of each expression.")
|
||||
|
||||
(PROG ((*STANDARD-INPUT* STREAM)
|
||||
(FILE (FULLNAME STREAM))
|
||||
(*PACKAGE* *PACKAGE*)
|
||||
(*READTABLE* (PROG1 FILERDTBL (* ; "This initial value important for SKIPSEPRCODES below, but *READTABLE* gets reset appropriately before anything else is read")
|
||||
(*READTABLE* (PROG1 FILERDTBL (* ; "This initial value important for SKIPSEPRCODES below, but *READTABLE* gets reset appropriately before anything else is read")
|
||||
))
|
||||
(DFNFLG DFNFLG)
|
||||
(BUILDMAPFLG BUILDMAPFLG)
|
||||
@@ -385,176 +385,168 @@
|
||||
FILEMAP FNADRLST ROOTNAME TEM FILECREATEDLST LOADA MAYBEWANTFILEMAP INTERLISP-P
|
||||
FILECREATEDLOC)
|
||||
(DECLARE (SPECVARS DFNFLG BUILDMAPFLG FILEPKGFLG ADDSPELLFLG LISPXHIST FILECREATEDLST
|
||||
DEFINEDENV FILECREATEDLOC FILE))
|
||||
DEFINEDENV FILECREATEDLOC FILE))
|
||||
(if (AND LOAD-VERBOSE-STREAM FILE)
|
||||
then (LISPXTERPRI LOAD-VERBOSE-STREAM)
|
||||
(if (NEQ LOAD-VERBOSE-STREAM T)
|
||||
then (* ;
|
||||
"CL:LOAD says to prefix this stuff with comment marker")
|
||||
(PRIN1 "; Loading " LOAD-VERBOSE-STREAM))
|
||||
(* ;
|
||||
"Might use EXEC-FORMAT here except that it isn't defined early in loadup")
|
||||
(LISPXPRIN1 FILE LOAD-VERBOSE-STREAM)
|
||||
(LISPXTERPRI LOAD-VERBOSE-STREAM))
|
||||
(if (NEQ LOAD-VERBOSE-STREAM T)
|
||||
then (* ;
|
||||
"CL:LOAD says to prefix this stuff with comment marker")
|
||||
(PRIN1 "; Loading " LOAD-VERBOSE-STREAM))
|
||||
(* ;
|
||||
"Might use EXEC-FORMAT here except that it isn't defined early in loadup")
|
||||
(LISPXPRIN1 FILE LOAD-VERBOSE-STREAM)
|
||||
(LISPXTERPRI LOAD-VERBOSE-STREAM))
|
||||
(if (EQ (SETQ DFNFLG LDFLG)
|
||||
'SYSLOAD)
|
||||
'SYSLOAD)
|
||||
then (SETQ DFNFLG T)
|
||||
(SETQ ADDSPELLFLG NIL)
|
||||
(SETQ BUILDMAPFLG NIL)
|
||||
(SETQ FILEPKGFLG NIL)
|
||||
(SETQ LISPXHIST NIL))
|
||||
(SETQ ADDSPELLFLG NIL)
|
||||
(SETQ BUILDMAPFLG NIL)
|
||||
(SETQ FILEPKGFLG NIL)
|
||||
(SETQ LISPXHIST NIL))
|
||||
(if LISPXHIST
|
||||
then (* ;
|
||||
"Want UNDOSAVE to keep saving regardless of how many undosaves are involved")
|
||||
(if (SETQ LOADA (FMEMB 'SIDE LISPXHIST))
|
||||
then (FRPLACA (CADR LOADA)
|
||||
-1)
|
||||
else (LISPXPUT 'SIDE (LIST -1)
|
||||
NIL LISPXHIST)))
|
||||
then (* ;
|
||||
"Want UNDOSAVE to keep saving regardless of how many undosaves are involved")
|
||||
(if (SETQ LOADA (FMEMB 'SIDE LISPXHIST))
|
||||
then (FRPLACA (CADR LOADA)
|
||||
-1)
|
||||
else (LISPXPUT 'SIDE (LIST -1)
|
||||
NIL LISPXHIST)))
|
||||
(if (EQ (SETQ TEM (SKIPSEPRCODES STREAM))
|
||||
FASL:SIGNATURE)
|
||||
then (* ;
|
||||
"FASL file handled by FASL loader")
|
||||
(FASL:PROCESS-FILE STREAM)
|
||||
[LET [(MANAGED-FILE-P (GET (SETQ ROOTNAME (ROOTFILENAME FILE T))
|
||||
'FILEDATES]
|
||||
(if (NOT (MEMB FILE LOADEDFILELST))
|
||||
then (* ;
|
||||
"Keep track of every file loaded.")
|
||||
(SETQ LOADEDFILELST (CONS FILE LOADEDFILELST)))
|
||||
(if MANAGED-FILE-P
|
||||
then (if (EQ LDFLG 'SYSLOAD)
|
||||
then
|
||||
FASL:SIGNATURE)
|
||||
then (* ; "FASL file handled by FASL loader")
|
||||
(FASL:PROCESS-FILE STREAM)
|
||||
[LET [(MANAGED-FILE-P (GET (SETQ ROOTNAME (ROOTFILENAME FILE T))
|
||||
'FILEDATES]
|
||||
(if (NOT (MEMB FILE LOADEDFILELST))
|
||||
then (* ; "Keep track of every file loaded.")
|
||||
(SETQ LOADEDFILELST (CONS FILE LOADEDFILELST)))
|
||||
(if MANAGED-FILE-P
|
||||
then (if (EQ LDFLG 'SYSLOAD)
|
||||
then
|
||||
(* ;;
|
||||
"Don't notice DFASL's when you are coming from CL:LOAD, and the user didn't specify a load flag")
|
||||
|
||||
(* ;;
|
||||
"Don't notice DFASL's when you are coming from CL:LOAD, and the user didn't specify a load flag")
|
||||
|
||||
(if (NOT (MEMB ROOTNAME SYSFILES))
|
||||
then (SETQ SYSFILES (NCONC1 SYSFILES
|
||||
ROOTNAME)))
|
||||
(SMASHFILECOMS ROOTNAME)
|
||||
elseif FILEPKGFLG
|
||||
then (ADDFILE ROOTNAME 'Compiled]
|
||||
(RETURN FILE)
|
||||
(if (NOT (MEMB ROOTNAME SYSFILES))
|
||||
then (SETQ SYSFILES (NCONC1 SYSFILES ROOTNAME)))
|
||||
(SMASHFILECOMS ROOTNAME)
|
||||
elseif FILEPKGFLG
|
||||
then (ADDFILE ROOTNAME 'Compiled]
|
||||
(RETURN FILE)
|
||||
elseif (NEQ TEM (CHARCODE "("))
|
||||
then (RETURN (\CML-LOAD STREAM PRINTFLG LOAD-VERBOSE-STREAM PACKAGE)))
|
||||
(if (AND BUILDMAPFLG (RANDACCESSP STREAM))
|
||||
then (SETQ MAYBEWANTFILEMAP T))
|
||||
|
||||
(* ;; "Get the environment from the DEFINE-FILE-INFO expression. This is read in the DEFINE-FILE-INFO-ENVIRONMENT.")
|
||||
(* ;; "Get the environment from the DEFINE-FILE-INFO expression. This is read in the DEFINE-FILE-INFO-ENVIRONMENT.")
|
||||
|
||||
(SETQ DEFINEDENV (READ-READER-ENVIRONMENT STREAM *OLD-INTERLISP-READ-ENVIRONMENT*))
|
||||
(SETQ DEFINEDENV (READ-READER-ENVIRONMENT STREAM))
|
||||
(CL:WHEN PACKAGE
|
||||
|
||||
(* ;; "Caller better really mean it--overrides what's on file! But we don't want to smash what the reader returned, couldbe the old-interlisp-file-env.")
|
||||
(* ;; "Caller better really mean it--overrides what's on file! But we don't want to smash what the reader returned, couldbe the old-interlisp-file-env.")
|
||||
|
||||
[SETQ DEFINEDENV (CREATE READER-ENVIRONMENT USING DEFINEDENV REPACKAGE _
|
||||
(SETQ *PACKAGE*
|
||||
(\DTEST PACKAGE 'PACKAGE])
|
||||
(SETQ *PACKAGE* (\DTEST PACKAGE
|
||||
'PACKAGE])
|
||||
|
||||
(* ;; "At this point we have the environment for the file, the external format is set. We now read/interpret all the other forms.")
|
||||
(* ;; "At this point we have the environment for the file, the external format is set. We now read/interpret all the other forms.")
|
||||
|
||||
(WITH-READER-ENVIRONMENT DEFINEDENV
|
||||
(PROG (ADR)
|
||||
LP (if FILEMAP
|
||||
then (* ;
|
||||
"need to build map, so read carefully")
|
||||
(SETQ LOADA (SKIPSEPRCODES STREAM))
|
||||
(if (OR (SYNTAXP LOADA 'LEFTPAREN)
|
||||
(SYNTAXP LOADA 'LEFTBRACKET))
|
||||
then (* ; "See if we have a DEFINEQ")
|
||||
(SETQ ADR (GETFILEPTR STREAM))
|
||||
(READCCODE STREAM) (* ; "Eat paren")
|
||||
(if (EQ (RATOM STREAM)
|
||||
'DEFINEQ)
|
||||
then (SETQ FNADRLST (TCONC NIL ADR))
|
||||
(TCONC FNADRLST NIL)
|
||||
(TCONC FILEMAP (CAR FNADRLST))
|
||||
(GO DEFQLP))
|
||||
(* ; "Not a DEFINEQ, so back out")
|
||||
(SETFILEPTR STREAM ADR)))
|
||||
then (* ;
|
||||
"need to build map, so read carefully")
|
||||
(SETQ LOADA (SKIPSEPRCODES STREAM))
|
||||
(if (OR (SYNTAXP LOADA 'LEFTPAREN)
|
||||
(SYNTAXP LOADA 'LEFTBRACKET))
|
||||
then (* ; "See if we have a DEFINEQ")
|
||||
(SETQ ADR (GETFILEPTR STREAM))
|
||||
(READCCODE STREAM) (* ; "Eat paren")
|
||||
(if (EQ (RATOM STREAM)
|
||||
'DEFINEQ)
|
||||
then (SETQ FNADRLST (TCONC NIL ADR))
|
||||
(TCONC FNADRLST NIL)
|
||||
(TCONC FILEMAP (CAR FNADRLST))
|
||||
(GO DEFQLP)) (* ; "Not a DEFINEQ, so back out")
|
||||
(SETFILEPTR STREAM ADR)))
|
||||
(SELECTQ (SETQ LOADA (READ STREAM))
|
||||
((STOP NIL)
|
||||
(if (EQ LDFLG 'SYSLOAD)
|
||||
then (if (NOT (MEMB (SETQ ROOTNAME
|
||||
(ROOTFILENAME FILE
|
||||
(CDR FILECREATEDLST)))
|
||||
SYSFILES))
|
||||
then (SETQ SYSFILES (NCONC1 SYSFILES
|
||||
ROOTNAME)))
|
||||
(SMASHFILECOMS ROOTNAME)
|
||||
elseif FILEPKGFLG
|
||||
then
|
||||
((STOP NIL)
|
||||
(if (EQ LDFLG 'SYSLOAD)
|
||||
then (if (NOT (MEMB (SETQ ROOTNAME (ROOTFILENAME FILE (CDR
|
||||
FILECREATEDLST
|
||||
)))
|
||||
SYSFILES))
|
||||
then (SETQ SYSFILES (NCONC1 SYSFILES ROOTNAME)))
|
||||
(SMASHFILECOMS ROOTNAME)
|
||||
elseif FILEPKGFLG
|
||||
then
|
||||
|
||||
(* ;; "Do not want any items that are added to FILEPKGCHANGES as a result of being mentioned in this file to remain on FILEPKGCHANGES. Also, we want items mentioned earlier to be deleted if they are taken care of by this file. The extra argument to ADDFILE allows it to restore FILEPKGCHANGES to the intersection of its current value and its previous value.")
|
||||
(* ;; "Do not want any items that are added to FILEPKGCHANGES as a result of being mentioned in this file to remain on FILEPKGCHANGES. Also, we want items mentioned earlier to be deleted if they are taken care of by this file. The extra argument to ADDFILE allows it to restore FILEPKGCHANGES to the intersection of its current value and its previous value.")
|
||||
|
||||
(ADDFILE FILE T PRLST FILECREATEDLST))
|
||||
[if FILEMAP
|
||||
then (PUTFILEMAP FILE (CAR FILEMAP)
|
||||
FILECREATEDLST DEFINEDENV NIL FILECREATEDLOC)
|
||||
(if UPDATEMAPFLG
|
||||
then (SETFILEPTR STREAM ADR)
|
||||
(* ;
|
||||
"address of last expression read. good hint for finding filemap")
|
||||
(UPDATEFILEMAP STREAM (CAR FILEMAP]
|
||||
(if (NOT (MEMB FILE LOADEDFILELST))
|
||||
then (/SETTOPVAL 'LOADEDFILELST (CONS FILE LOADEDFILELST)))
|
||||
(RETURN))
|
||||
NIL)
|
||||
(ADDFILE FILE T PRLST FILECREATEDLST))
|
||||
[if FILEMAP
|
||||
then (PUTFILEMAP FILE (CAR FILEMAP)
|
||||
FILECREATEDLST DEFINEDENV NIL FILECREATEDLOC)
|
||||
(if UPDATEMAPFLG
|
||||
then (SETFILEPTR STREAM ADR)
|
||||
(* ;
|
||||
"address of last expression read. good hint for finding filemap")
|
||||
(UPDATEFILEMAP STREAM (CAR FILEMAP]
|
||||
(if (NOT (MEMB FILE LOADEDFILELST))
|
||||
then (/SETTOPVAL 'LOADEDFILELST (CONS FILE LOADEDFILELST)))
|
||||
(RETURN))
|
||||
NIL)
|
||||
[if (LISTP LOADA)
|
||||
then
|
||||
(SELECTQ (CAR LOADA)
|
||||
(FILECREATED (if MAYBEWANTFILEMAP
|
||||
then (* ; "See if we have a valid file map")
|
||||
(SETQ ADR (GETFILEPTR STREAM))
|
||||
(if [AND (FIXP (SETQ TEM (CADDDR LOADA)))
|
||||
[SETQ TEM (CAR (NLSETQ (SETFILEPTR STREAM
|
||||
TEM)
|
||||
(READ STREAM]
|
||||
(EQ (CAR TEM)
|
||||
'FILEMAP)
|
||||
(NULL (CAR (SETQ TEM (CADR TEM]
|
||||
then (* ; "Has ok map")
|
||||
(PUTFILEMAP FILE TEM NIL DEFINEDENV)
|
||||
else (* ;
|
||||
"Need to build a file map as we go")
|
||||
(SETQ FILEMAP (TCONC NIL NIL)))
|
||||
(SETFILEPTR STREAM ADR)
|
||||
(SETQ MAYBEWANTFILEMAP NIL))
|
||||
(SETQ LOADA (\EVAL LOADA)))
|
||||
(SETQ LOADA (\EVAL LOADA)))
|
||||
else (* ;
|
||||
"Atom found. Compiled code definition.")
|
||||
(if ADDSPELLFLG
|
||||
then (ADDSPELL LOADA))
|
||||
(if FILEMAP
|
||||
then (SETQ ADR (GETFILEPTR STREAM)))
|
||||
(LAPRD LOADA)
|
||||
(if FILEMAP
|
||||
then (TCONC FILEMAP (CONS ADR (CONS (GETFILEPTR STREAM)
|
||||
LOADA]
|
||||
(FILECREATED (if MAYBEWANTFILEMAP
|
||||
then (* ; "See if we have a valid file map")
|
||||
(SETQ ADR (GETFILEPTR STREAM))
|
||||
(if [AND (FIXP (SETQ TEM (CADDDR LOADA)))
|
||||
[SETQ TEM (CAR (NLSETQ (SETFILEPTR STREAM
|
||||
TEM)
|
||||
(READ STREAM]
|
||||
(EQ (CAR TEM)
|
||||
'FILEMAP)
|
||||
(NULL (CAR (SETQ TEM (CADR TEM]
|
||||
then (* ; "Has ok map")
|
||||
(PUTFILEMAP FILE TEM NIL DEFINEDENV)
|
||||
else (* ; "Need to build a file map as we go")
|
||||
(SETQ FILEMAP (TCONC NIL NIL)))
|
||||
(SETFILEPTR STREAM ADR)
|
||||
(SETQ MAYBEWANTFILEMAP NIL))
|
||||
(SETQ LOADA (\EVAL LOADA)))
|
||||
(SETQ LOADA (\EVAL LOADA)))
|
||||
else (* ;
|
||||
"Atom found. Compiled code definition.")
|
||||
(if ADDSPELLFLG
|
||||
then (ADDSPELL LOADA))
|
||||
(if FILEMAP
|
||||
then (SETQ ADR (GETFILEPTR STREAM)))
|
||||
(LAPRD LOADA)
|
||||
(if FILEMAP
|
||||
then (TCONC FILEMAP (CONS ADR (CONS (GETFILEPTR STREAM)
|
||||
LOADA]
|
||||
LP1 (if PRINTFLG
|
||||
then (PRINT LOADA PRINTFLG))
|
||||
(GO LP)
|
||||
DEFQLP
|
||||
(SELCHARQ (SKIPSEPRCODES STREAM)
|
||||
((%) %]) (* ; "Closes DEFINEQ.")
|
||||
((%) %]) (* ; "Closes DEFINEQ.")
|
||||
(READCCODE STREAM)
|
||||
(if FNADRLST
|
||||
then (RPLACA (CDAR FNADRLST)
|
||||
(GETFILEPTR STREAM)))
|
||||
(* ;
|
||||
"FNADRLST is a TCONC format list, hence want to RPLACA CDAR, not just CDR.")
|
||||
(GETFILEPTR STREAM)))
|
||||
(* ;
|
||||
"FNADRLST is a TCONC format list, hence want to RPLACA CDAR, not just CDR.")
|
||||
(SETQ LOADA (DEFINE (DREVERSE LOADA)))
|
||||
(GO LP1))
|
||||
((%( %[) (* ;
|
||||
"another function/definition pair")
|
||||
((%( %[) (* ; "another function/definition pair")
|
||||
(SETQ ADR (GETFILEPTR STREAM))
|
||||
(SETQ LOADA (CONS (READ STREAM)
|
||||
LOADA))
|
||||
[if FNADRLST
|
||||
then (TCONC FNADRLST (CONS (CAAR LOADA)
|
||||
(CONS ADR (GETFILEPTR STREAM]
|
||||
(CONS ADR (GETFILEPTR STREAM]
|
||||
(GO DEFQLP))
|
||||
NIL)
|
||||
(ERROR "illegal argument in defineq")))
|
||||
@@ -808,20 +800,22 @@
|
||||
(TERPRI STREAM)))])
|
||||
|
||||
(READ-READER-ENVIRONMENT
|
||||
[LAMBDA (STREAM DEFAULTENV RETURNFORM) (* ; "Edited 26-Sep-2021 23:31 by rmk:")
|
||||
[LAMBDA (STREAM DEFAULTENV RETURNFORM) (* ; "Edited 25-Feb-2026 14:15 by rmk")
|
||||
(* ; "Edited 26-Sep-2021 23:31 by rmk:")
|
||||
|
||||
(* ;; "Starting environment is the old interlisp file, just for the seprchar scans.")
|
||||
|
||||
(* ;; "On exit, if the stream begins with a DEFINE-FILE-INFO expression, it is positioned just after that expression. If not, it is left at its starting position. ")
|
||||
|
||||
(* ;; "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))
|
||||
ARGS
|
||||
(ENV DEFAULTENV)
|
||||
(*READTABLE* (FETCH (READER-ENVIRONMENT REREADTABLE) OF
|
||||
*OLD-INTERLISP-READ-ENVIRONMENT*
|
||||
)))
|
||||
(*READTABLE* (FETCH (READER-ENVIRONMENT REREADTABLE) OF *OLD-INTERLISP-READ-ENVIRONMENT*)))
|
||||
(DECLARE (SPECVARS *READTABLE*))
|
||||
(SETFILEPTR STREAM 0) (* ; "Hope we are RANDACCESSP")
|
||||
(SELCHARQ (SKIPSEPRCODES STREAM)
|
||||
(";" (* ; "Assume it's a common lisp file")
|
||||
(\EXTERNALFORMAT STREAM (FETCH (READER-ENVIRONMENT REFORMAT) OF
|
||||
@@ -831,24 +825,21 @@
|
||||
("(" (\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 (STREQUAL "DEFINE-FILE-INFO" (RSTRING STREAM))
|
||||
THEN
|
||||
(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")
|
||||
(SETFILEPTR STREAM START))
|
||||
(SETQ ARGS (CL:READ-DELIMITED-LIST (CHARCODE ")")
|
||||
STREAM))
|
||||
(SETQ ENV (\DO-DEFINE-FILE-INFO STREAM ARGS))
|
||||
else (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))
|
||||
@@ -856,25 +847,26 @@
|
||||
DEFAULTENV])
|
||||
|
||||
(MAKE-DEFINE-FILE-INFO-ENV
|
||||
[LAMBDA NIL (* ; "Edited 29-Jul-2021 20:29 by rmk:")
|
||||
[LAMBDA NIL (* ; "Edited 25-Feb-2026 15:03 by rmk")
|
||||
(* ; "Edited 29-Jul-2021 20:29 by rmk:")
|
||||
|
||||
(* ;; "Makes the reader environment and read table used for printing and reading the DEFINE-FILE-INFO expression. Like the OLD-INTERLISP-FILE, but : is the preferred package delim")
|
||||
(* ;; "Makes the reader environment and read table used for printing and reading the DEFINE-FILE-INFO expression. Like the OLD-INTERLISP-FILE, but : is the preferred package delim")
|
||||
|
||||
(LET [(RTBL (COPYREADTABLE (FETCH REREADTABLE OF *OLD-INTERLISP-READ-ENVIRONMENT*]
|
||||
|
||||
(* ;;
|
||||
"But this is all rather silly: Why not just have ordinary Interlisp atoms for the key words. ")
|
||||
(* (READTABLEPROP RTBL
|
||||
(QUOTE PACKAGECHAR)
|
||||
(CHARCODE %:)))
|
||||
(* ;;
|
||||
"But this is all rather silly: Why not just have ordinary Interlisp atoms for the key words. ")
|
||||
(* (READTABLEPROP RTBL
|
||||
(QUOTE PACKAGECHAR) (CHARCODE %:)))
|
||||
(SETSYNTAX (CHARCODE %:)
|
||||
'PACKAGEDELIM RTBL) (* ;
|
||||
"In transition: read : but don't yet put it out")
|
||||
'PACKAGEDELIM RTBL)
|
||||
(replace (READTABLEP PACKAGECHAR) of RTBL with (CHARCODE %:))
|
||||
(* ;
|
||||
"Use : instead of ^^ for printing too")
|
||||
|
||||
(* ;; "The INTERLISP package doesn't exist in bootstrap, the REPACKAGE field is filled in in PACKAGE-ENABLE in PACKAGE-STARTUP")
|
||||
(* ;; "The INTERLISP package doesn't exist in bootstrap, the REPACKAGE field is filled in in PACKAGE-ENABLE in PACKAGE-STARTUP")
|
||||
|
||||
(CREATE READER-ENVIRONMENT USING *OLD-INTERLISP-READ-ENVIRONMENT* REREADTABLE _ RTBL
|
||||
])
|
||||
(CREATE READER-ENVIRONMENT USING *OLD-INTERLISP-READ-ENVIRONMENT* REREADTABLE _ RTBL])
|
||||
)
|
||||
|
||||
(RPAQ? *DEFINE-FILE-INFO-ENV* (MAKE-DEFINE-FILE-INFO-ENV))
|
||||
@@ -977,13 +969,13 @@
|
||||
(ADDTOVAR LAMA )
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (4617 14289 (GETPROP 4627 . 5199) (SETATOMVAL 5201 . 5330) (RPAQQ 5332 . 5385) (RPAQ
|
||||
5387 . 5699) (RPAQ? 5701 . 6071) (MOVD 6073 . 7937) (MOVD? 7939 . 8369) (SELECTQ 8371 . 8558) (
|
||||
SELECTQ1 8560 . 8902) (NCONC1 8904 . 9100) (PUTPROP 9102 . 10586) (PROPNAMES 10588 . 10779) (ADDPROP
|
||||
10781 . 12844) (REMPROP 12846 . 13700) (MEMB 13702 . 13961) (CLOSEF? 13963 . 14287)) (14362 34926 (
|
||||
LOAD 14372 . 15541) (\LOAD-STREAM 15543 . 28617) (FILECREATED 28619 . 30037) (FILECREATED1 30039 .
|
||||
31147) (PRETTYCOMPRINT 31149 . 31634) (BOOTSTRAP-NAMEFIELD 31636 . 32596) (PUTPROPS 32598 . 32966) (
|
||||
DECLARE%: 32968 . 33100) (DECLARE%:1 33102 . 33974) (ROOTFILENAME 33976 . 34924)) (34964 45363 (
|
||||
DEFINE-FILE-INFO 34974 . 35409) (\DO-DEFINE-FILE-INFO 35411 . 39554) (PRINT-READER-ENVIRONMENT 39556
|
||||
. 41308) (READ-READER-ENVIRONMENT 41310 . 44085) (MAKE-DEFINE-FILE-INFO-ENV 44087 . 45361)))))
|
||||
(FILEMAP (NIL (4621 14293 (GETPROP 4631 . 5203) (SETATOMVAL 5205 . 5334) (RPAQQ 5336 . 5389) (RPAQ
|
||||
5391 . 5703) (RPAQ? 5705 . 6075) (MOVD 6077 . 7941) (MOVD? 7943 . 8373) (SELECTQ 8375 . 8562) (
|
||||
SELECTQ1 8564 . 8906) (NCONC1 8908 . 9104) (PUTPROP 9106 . 10590) (PROPNAMES 10592 . 10783) (ADDPROP
|
||||
10785 . 12848) (REMPROP 12850 . 13704) (MEMB 13706 . 13965) (CLOSEF? 13967 . 14291)) (14366 34343 (
|
||||
LOAD 14376 . 15545) (\LOAD-STREAM 15547 . 28034) (FILECREATED 28036 . 29454) (FILECREATED1 29456 .
|
||||
30564) (PRETTYCOMPRINT 30566 . 31051) (BOOTSTRAP-NAMEFIELD 31053 . 32013) (PUTPROPS 32015 . 32383) (
|
||||
DECLARE%: 32385 . 32517) (DECLARE%:1 32519 . 33391) (ROOTFILENAME 33393 . 34341)) (34381 44987 (
|
||||
DEFINE-FILE-INFO 34391 . 34826) (\DO-DEFINE-FILE-INFO 34828 . 38971) (PRINT-READER-ENVIRONMENT 38973
|
||||
. 40725) (READ-READER-ENVIRONMENT 40727 . 43553) (MAKE-DEFINE-FILE-INFO-ENV 43555 . 44985)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
270
sources/CLISP
270
sources/CLISP
@@ -1,18 +1,11 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
(FILECREATED "16-May-90 12:27:02" {DSK}<usr>local>lde>lispcore>sources>CLISP.;2 45083
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10 FORMAT UTF-8)
|
||||
|
||||
changes to%: (VARS CLISPCOMS)
|
||||
(FILECREATED "19-Feb-2026 12:00:55" {WMEDLEY}<sources>CLISP.;2 44501
|
||||
|
||||
previous date%: "26-Nov-86 12:32:58" {DSK}<usr>local>lde>lispcore>sources>CLISP.;1)
|
||||
:EDIT-BY rmk
|
||||
|
||||
:PREVIOUS-DATE "16-May-90 12:27:02" {WMEDLEY}<sources>CLISP.;1)
|
||||
|
||||
(* ; "
|
||||
Copyright (c) 1982, 1983, 1984, 1985, 1986, 1990 by Venue & Xerox Corporation. All rights reserved.
|
||||
The following program was created in 1982 but has not been published
|
||||
within the meaning of the copyright law, is furnished under license,
|
||||
and may not be used, copied and/or disclosed except in accordance
|
||||
with the terms of said license.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT CLISPCOMS)
|
||||
|
||||
@@ -57,16 +50,16 @@ with the terms of said license.
|
||||
(COMS (* CLISP props)
|
||||
(PROP CLISPTYPE %')
|
||||
[E (SETQQ CLISPCHARS
|
||||
(^ * / + - = _ %: %' ~ +- ~= < > @ ! ¬ ))
|
||||
(↑ * / + - = ← %: %' ~ +- ~= < > @ ! _ ^))
|
||||
(CLISPDEC '(STANDARD MIXED]
|
||||
[VARS (CLISPFLG T)
|
||||
(CLISPCHARS '(^ * / + - = _ %: %' ~ +- ~= < > @ ! ¬ ]
|
||||
(CLISPCHARS '(↑ * / + - = ← %: %' ~ +- ~= < > @ ! _ ^]
|
||||
(INITVARS (CLISPHELPFLG T)
|
||||
(TREATASCLISPFLG)
|
||||
(CLISPINFIXSPLST)
|
||||
(CLISPCHARRAY (MAKEBITTABLE CLISPCHARS))
|
||||
[LEFT.ARROWS.BITTABLE (MAKEBITTABLE '(_ ¬]
|
||||
(LEFT.ARROW '_)
|
||||
[LEFT.ARROWS.BITTABLE (MAKEBITTABLE '(← _]
|
||||
(LEFT.ARROW '←)
|
||||
(CLISPISWORDSPLST)
|
||||
(CLISPLASTSUB (CONS))
|
||||
(CHECKCARATOMFLG)
|
||||
@@ -74,7 +67,7 @@ with the terms of said license.
|
||||
(CLISPARITHCLASSLST '(INTEGER FIXED MIXED FLOATING))
|
||||
(DWIMINMACROSFLG NIL))
|
||||
(IFPROP (CLISPTYPE LISPFN UNARYOP CLISPCLASS CLISPCLASSDEF CLISPNEG CLISPBRACKET)
|
||||
^ * / + - = _ ¬ %: %' ~ +- ~= < > @ !)
|
||||
^ ↑ * / + - = ← _ %: %' ~ +- ~= < > @ !)
|
||||
(VARS DECLWORDS)
|
||||
(IFPROP (CLISPTYPE LISPFN UNARYOP CLISPINFIX CLISPCLASS CLISPCLASSDEF CLISPNEG
|
||||
BROADSCOPE)
|
||||
@@ -160,34 +153,14 @@ with the terms of said license.
|
||||
|
||||
(RPAQ? RPARKEY 0)
|
||||
|
||||
(RPAQ? WTFIXCHCONLST '(NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL
|
||||
NIL NIL))
|
||||
(RPAQ? WTFIXCHCONLST '(NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL
|
||||
NIL))
|
||||
|
||||
(RPAQ? WTFIXCHCONLST1 '(NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL
|
||||
NIL NIL))
|
||||
(RPAQ? WTFIXCHCONLST1 '(NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL
|
||||
NIL))
|
||||
|
||||
(ADDTOVAR EDITMACROS
|
||||
(FIX9 (X N)
|
||||
(BIND (E (SETQ %#1 (EDITFPAT 'X))
|
||||
T)
|
||||
(IF (NOT (ATOM (%##)))
|
||||
(1))
|
||||
(COMS (SPLIT89 RPARKEY N))
|
||||
(I F RPARKEY T)
|
||||
(E [SETQ %#2 (ADD1 (LENGTH (CAR L]
|
||||
T)
|
||||
!0 MARK (LPQ [IF (OR (NULL %#1)
|
||||
(NOT (EDIT4E %#1 (%## 1]
|
||||
UP
|
||||
(E (SETQ %#3 (LENGTH (CAR L)))
|
||||
T)
|
||||
(I RI 1 (MINUS %#2))
|
||||
(E (SETQ %#2 %#3)
|
||||
T)
|
||||
1 !0)
|
||||
__
|
||||
(DELETE NX)))
|
||||
(FIX9 NIL (FIX9))
|
||||
(FIX8 NIL (FIX8))
|
||||
(FIX8 (X N)
|
||||
(BIND (E (SETQ %#1 (EDITFPAT 'X))
|
||||
T)
|
||||
@@ -206,14 +179,34 @@ with the terms of said license.
|
||||
UP
|
||||
(RO 1)
|
||||
!0)))
|
||||
(FIX8 NIL (FIX8)))
|
||||
(FIX9 NIL (FIX9))
|
||||
(FIX9 (X N)
|
||||
(BIND (E (SETQ %#1 (EDITFPAT 'X))
|
||||
T)
|
||||
(IF (NOT (ATOM (%##)))
|
||||
(1))
|
||||
(COMS (SPLIT89 RPARKEY N))
|
||||
(I F RPARKEY T)
|
||||
(E [SETQ %#2 (ADD1 (LENGTH (CAR L]
|
||||
T)
|
||||
!0 MARK (LPQ [IF (OR (NULL %#1)
|
||||
(NOT (EDIT4E %#1 (%## 1]
|
||||
UP
|
||||
(E (SETQ %#3 (LENGTH (CAR L)))
|
||||
T)
|
||||
(I RI 1 (MINUS %#2))
|
||||
(E (SETQ %#2 %#3)
|
||||
T)
|
||||
1 !0)
|
||||
←←
|
||||
(DELETE NX))))
|
||||
|
||||
(ADDTOVAR DWIMUSERFORMS )
|
||||
|
||||
(ADDTOVAR LAMBDASPLST LAMBDA NLAMBDA)
|
||||
|
||||
(ADDTOVAR OKREEVALST AND OR PROGN SAVESETQ CAR CDR ADD1 SUB1 CONS LIST EQ EQUAL PRINT PRIN1
|
||||
APPEND NEQ NOT NULL)
|
||||
(ADDTOVAR OKREEVALST AND OR PROGN SAVESETQ CAR CDR ADD1 SUB1 CONS LIST EQ EQUAL PRINT PRIN1 APPEND
|
||||
NEQ NOT NULL)
|
||||
|
||||
(ADDTOVAR NOFIXFNSLST )
|
||||
|
||||
@@ -266,6 +259,17 @@ with the terms of said license.
|
||||
(ADDTOVAR DWIMEQUIVLST )
|
||||
|
||||
(ADDTOVAR EDITMACROS
|
||||
(CLISP%: NIL (BIND (E (COND ((SETQ %#1 (AND CLISPARRAY (GETHASH (%##)
|
||||
CLISPARRAY)))
|
||||
(SETQQ COM CLISP%:)
|
||||
(EDITE %#1))
|
||||
(T (PRIN1 '"not translated.
|
||||
" T)))
|
||||
T)))
|
||||
(NOCLISP COMS (RESETVAR CLISPTRANFLG NIL . COMS))
|
||||
(NOCLISP NIL (NOCLISP TTY%:))
|
||||
(!DW NIL (RESETVAR CLISPRETRANFLG T DW))
|
||||
(PPT NIL (RESETVAR PRETTYTRANFLG T PP))
|
||||
(DW NIL (BIND (E (PROGN (SETQ %#1 (%##))
|
||||
(AND (CDR L)
|
||||
(%## !0 (E (SETQ %#2 L)
|
||||
@@ -280,18 +284,7 @@ with the terms of said license.
|
||||
(IF (LISTP %#3)
|
||||
(1)
|
||||
NIL))
|
||||
NIL)))
|
||||
(PPT NIL (RESETVAR PRETTYTRANFLG T PP))
|
||||
(!DW NIL (RESETVAR CLISPRETRANFLG T DW))
|
||||
(NOCLISP NIL (NOCLISP TTY%:))
|
||||
(NOCLISP COMS (RESETVAR CLISPTRANFLG NIL . COMS))
|
||||
(CLISP%: NIL (BIND (E (COND ((SETQ %#1 (AND CLISPARRAY (GETHASH (%##)
|
||||
CLISPARRAY)))
|
||||
(SETQQ COM CLISP%:)
|
||||
(EDITE %#1))
|
||||
(T (PRIN1 '"not translated.
|
||||
" T)))
|
||||
T))))
|
||||
NIL))))
|
||||
|
||||
(ADDTOVAR EDITCOMSA PPT DW !DW CLISP%:)
|
||||
|
||||
@@ -304,7 +297,7 @@ with the terms of said license.
|
||||
|
||||
(RPAQQ CLISPFLG T)
|
||||
|
||||
(RPAQQ CLISPCHARS (^ * / + - = _ %: %' ~ +- ~= < > @ ! ¬ ))
|
||||
(RPAQQ CLISPCHARS (↑ * / + - = ← %: %' ~ +- ~= < > @ ! _ ^))
|
||||
|
||||
(RPAQ? CLISPHELPFLG T)
|
||||
|
||||
@@ -314,9 +307,9 @@ with the terms of said license.
|
||||
|
||||
(RPAQ? CLISPCHARRAY (MAKEBITTABLE CLISPCHARS))
|
||||
|
||||
(RPAQ? LEFT.ARROWS.BITTABLE (MAKEBITTABLE '(_ ¬)))
|
||||
(RPAQ? LEFT.ARROWS.BITTABLE (MAKEBITTABLE '(← _)))
|
||||
|
||||
(RPAQ? LEFT.ARROW '_)
|
||||
(RPAQ? LEFT.ARROW '←)
|
||||
|
||||
(RPAQ? CLISPISWORDSPLST )
|
||||
|
||||
@@ -330,10 +323,10 @@ with the terms of said license.
|
||||
|
||||
(RPAQ? DWIMINMACROSFLG NIL)
|
||||
|
||||
(PUTPROPS CLISPTYPE 6)
|
||||
|
||||
(PUTPROPS ^ CLISPTYPE 6)
|
||||
|
||||
(PUTPROPS ↑ CLISPTYPE 6)
|
||||
|
||||
(PUTPROPS * CLISPTYPE 4)
|
||||
|
||||
(PUTPROPS / CLISPTYPE 4)
|
||||
@@ -344,9 +337,9 @@ with the terms of said license.
|
||||
|
||||
(PUTPROPS = CLISPTYPE -20)
|
||||
|
||||
(PUTPROPS _ CLISPTYPE (8 . -12))
|
||||
(PUTPROPS ← CLISPTYPE (8 . -12))
|
||||
|
||||
(PUTPROPS ¬ CLISPTYPE (8 . -12))
|
||||
(PUTPROPS _ CLISPTYPE (8 . -12))
|
||||
|
||||
(PUTPROPS %: CLISPTYPE (14 . 13))
|
||||
|
||||
@@ -360,10 +353,10 @@ with the terms of said license.
|
||||
|
||||
(PUTPROPS > CLISPTYPE BRACKET)
|
||||
|
||||
(PUTPROPS LISPFN EXPT)
|
||||
|
||||
(PUTPROPS ^ LISPFN EXPT)
|
||||
|
||||
(PUTPROPS ↑ LISPFN EXPT)
|
||||
|
||||
(PUTPROPS * LISPFN TIMES)
|
||||
|
||||
(PUTPROPS / LISPFN QUOTIENT)
|
||||
@@ -374,9 +367,9 @@ with the terms of said license.
|
||||
|
||||
(PUTPROPS = LISPFN EQ)
|
||||
|
||||
(PUTPROPS _ LISPFN SETQ)
|
||||
(PUTPROPS ← LISPFN SETQ)
|
||||
|
||||
(PUTPROPS ¬ LISPFN SETQ)
|
||||
(PUTPROPS _ LISPFN SETQ)
|
||||
|
||||
(PUTPROPS %' LISPFN QUOTE)
|
||||
|
||||
@@ -750,7 +743,7 @@ with the terms of said license.
|
||||
|
||||
(PUTPROPS OR CLISPINFIX or)
|
||||
|
||||
(PUTPROPS SETQ CLISPINFIX _)
|
||||
(PUTPROPS SETQ CLISPINFIX ←)
|
||||
|
||||
(PUTPROPS IPLUS CLISPINFIX +)
|
||||
|
||||
@@ -780,7 +773,7 @@ with the terms of said license.
|
||||
|
||||
(PUTPROPS GREATERP CLISPINFIX gt)
|
||||
|
||||
(PUTPROPS EXPT CLISPINFIX ^)
|
||||
(PUTPROPS EXPT CLISPINFIX ↑)
|
||||
|
||||
(PUTPROPS LT CLISPCLASS LT)
|
||||
|
||||
@@ -931,7 +924,7 @@ with the terms of said license.
|
||||
(PUTPROPS SETA SETFN (ELT))
|
||||
|
||||
(DEFOPTIMIZER CLISP% (X &REST Y)
|
||||
X)
|
||||
X)
|
||||
|
||||
(PUTPROPS AND CLISPWORD T)
|
||||
|
||||
@@ -1146,83 +1139,82 @@ with the terms of said license.
|
||||
(PUTPROPS while CLISPWORD (FORWORD . while))
|
||||
|
||||
(PUTPROPS always I.S.OPR ((COND ((NULL BODY)
|
||||
(SETQ $$VAL NIL)
|
||||
(GO $$OUT)))
|
||||
BIND
|
||||
(SETQ $$VAL T)))
|
||||
(SETQ $$VAL NIL)
|
||||
(GO $$OUT)))
|
||||
BIND
|
||||
(SETQ $$VAL T)))
|
||||
|
||||
(PUTPROPS collect I.S.OPR ((SETQ $$VAL (NCONC1 $$VAL BODY))))
|
||||
|
||||
(PUTPROPS count I.S.OPR ((AND BODY (SETQ $$VAL (ADD1 $$VAL)))
|
||||
BIND
|
||||
($$VAL _ 0)))
|
||||
BIND
|
||||
($$VAL ← 0)))
|
||||
|
||||
(PUTPROPS do I.S.OPR (BODY))
|
||||
|
||||
(PUTPROPS fcollect I.S.OPR [(= SUBPAIR '(VAR1 VAR2)
|
||||
(LIST (GETDUMMYVAR T)
|
||||
(GETDUMMYVAR T))
|
||||
'(PROGN (SETQ VAR1 BODY)
|
||||
(COND [VAR2 (FRPLACD VAR2 (SETQ VAR2 (LIST VAR1]
|
||||
(T (SETQ $$VAL (SETQ VAR2 (LIST VAR1])
|
||||
(LIST (GETDUMMYVAR T)
|
||||
(GETDUMMYVAR T))
|
||||
'(PROGN (SETQ VAR1 BODY)
|
||||
(COND [VAR2 (FRPLACD VAR2 (SETQ VAR2 (LIST VAR1]
|
||||
(T (SETQ $$VAL (SETQ VAR2 (LIST VAR1])
|
||||
|
||||
(PUTPROPS inside I.S.OPR [NIL = SUBST (GETDUMMYVAR)
|
||||
'VAR
|
||||
'(bind (VAR _ BODY)
|
||||
eachtime
|
||||
(COND ((NULL VAR)
|
||||
(GO $$OUT))
|
||||
((NLISTP VAR)
|
||||
(SETQ I.V. VAR)
|
||||
(SETQ VAR NIL))
|
||||
(T (SETQ I.V. (CAR VAR))
|
||||
(SETQ VAR (CDR VAR])
|
||||
'VAR
|
||||
'(bind (VAR ← BODY)
|
||||
eachtime
|
||||
(COND ((NULL VAR)
|
||||
(GO $$OUT))
|
||||
((NLISTP VAR)
|
||||
(SETQ I.V. VAR)
|
||||
(SETQ VAR NIL))
|
||||
(T (SETQ I.V. (CAR VAR))
|
||||
(SETQ VAR (CDR VAR])
|
||||
|
||||
(PUTPROPS join I.S.OPR ((SETQ $$VAL (NCONC $$VAL BODY))))
|
||||
|
||||
(PUTPROPS largest I.S.OPR [NIL = SUBST (GETDUMMYVAR)
|
||||
'$$TEMP
|
||||
'(BIND $$EXTREME $$TEMP DO (SETQ $$TEMP BODY)
|
||||
(COND ((OR (NULL $$EXTREME)
|
||||
(GREATERP $$TEMP $$EXTREME))
|
||||
(SETQ $$EXTREME $$TEMP)
|
||||
(SETQ $$VAL I.V.])
|
||||
'$$TEMP
|
||||
'(BIND $$EXTREME $$TEMP DO (SETQ $$TEMP BODY)
|
||||
(COND ((OR (NULL $$EXTREME)
|
||||
(GREATERP $$TEMP $$EXTREME))
|
||||
(SETQ $$EXTREME $$TEMP)
|
||||
(SETQ $$VAL I.V.])
|
||||
|
||||
(PUTPROPS never I.S.OPR ((COND (BODY (SETQ $$VAL NIL)
|
||||
(GO $$OUT)))
|
||||
BIND
|
||||
($$VAL _ T)))
|
||||
(GO $$OUT)))
|
||||
BIND
|
||||
($$VAL ← T)))
|
||||
|
||||
(PUTPROPS old I.S.OPR MODIFIER)
|
||||
|
||||
(PUTPROPS smallest I.S.OPR [NIL = SUBST (GETDUMMYVAR)
|
||||
'$$TEMP
|
||||
'(BIND $$EXTREME $$TEMP DO (SETQ $$TEMP BODY)
|
||||
(COND ((OR (NULL $$EXTREME)
|
||||
(LESSP $$TEMP $$EXTREME))
|
||||
(SETQ $$EXTREME $$TEMP)
|
||||
(SETQ $$VAL I.V.])
|
||||
'$$TEMP
|
||||
'(BIND $$EXTREME $$TEMP DO (SETQ $$TEMP BODY)
|
||||
(COND ((OR (NULL $$EXTREME)
|
||||
(LESSP $$TEMP $$EXTREME))
|
||||
(SETQ $$EXTREME $$TEMP)
|
||||
(SETQ $$VAL I.V.])
|
||||
|
||||
(PUTPROPS sum I.S.OPR ((SETQ $$VAL (PLUS $$VAL BODY))
|
||||
BIND
|
||||
($$VAL _ 0)))
|
||||
BIND
|
||||
($$VAL ← 0)))
|
||||
|
||||
(PUTPROPS thereis I.S.OPR [(COND (BODY (SETQ $$VAL (OR I.V. T))
|
||||
(GO $$OUT])
|
||||
(GO $$OUT])
|
||||
|
||||
(ADDTOVAR I.S.OPRLST ALWAYS AS BIND BY COLLECT COUNT DECLARE DECLARE%: DO EACHTIME FCOLLECT
|
||||
FINALLY FIND FIRST FOR FROM IN INSIDE ISTHERE JOIN LARGEST NEVER OLD
|
||||
ON ORIGINAL REPEATUNTIL REPEATWHILE SMALLEST SUCHTHAT SUM THEREIS THRU
|
||||
TO UNLESS UNTIL WHEN WHERE WHILE always as bind by collect count
|
||||
declare declare%: do eachtime fcollect finally find first for from in
|
||||
inside isthere join largest never old on original repeatuntil
|
||||
repeatwhile smallest suchthat sum thereis thru to unless until when
|
||||
where while)
|
||||
(ADDTOVAR I.S.OPRLST ALWAYS AS BIND BY COLLECT COUNT DECLARE DECLARE%: DO EACHTIME FCOLLECT FINALLY
|
||||
FIND FIRST FOR FROM IN INSIDE ISTHERE JOIN LARGEST NEVER OLD ON ORIGINAL
|
||||
REPEATUNTIL REPEATWHILE SMALLEST SUCHTHAT SUM THEREIS THRU TO UNLESS UNTIL
|
||||
WHEN WHERE WHILE always as bind by collect count declare declare%: do
|
||||
eachtime fcollect finally find first for from in inside isthere join
|
||||
largest never old on original repeatuntil repeatwhile smallest suchthat
|
||||
sum thereis thru to unless until when where while)
|
||||
|
||||
(ADDTOVAR CLISPFORWORDSPLST ALWAYS AS BIND BY COLLECT COUNT DECLARE DECLARE%: DO EACHTIME
|
||||
FCOLLECT FINALLY FIND FIRST FOR FROM IN INSIDE ISTHERE JOIN
|
||||
LARGEST NEVER OLD ON ORIGINAL REPEATUNTIL REPEATWHILE SMALLEST
|
||||
SUCHTHAT SUM THEREIS THRU TO UNLESS UNTIL WHEN WHERE WHILE)
|
||||
(ADDTOVAR CLISPFORWORDSPLST ALWAYS AS BIND BY COLLECT COUNT DECLARE DECLARE%: DO EACHTIME FCOLLECT
|
||||
FINALLY FIND FIRST FOR FROM IN INSIDE ISTHERE JOIN LARGEST NEVER
|
||||
OLD ON ORIGINAL REPEATUNTIL REPEATWHILE SMALLEST SUCHTHAT SUM
|
||||
THEREIS THRU TO UNLESS UNTIL WHEN WHERE WHILE)
|
||||
|
||||
(RPAQQ CLISPDUMMYFORVARS ($$TEM0 $$TEM1 $$TEM2 $$TEM3 $$TEM4 $$TEM5 $$TEM6))
|
||||
|
||||
@@ -1241,17 +1233,18 @@ with the terms of said license.
|
||||
(DEFINEQ
|
||||
|
||||
(DUMPI.S.OPRS
|
||||
[NLAMBDA X (* lmm "14-Aug-84 18:34")
|
||||
|
||||
(* Dump I.S.OPRS definitions. -
|
||||
redefined to dump out same case as given)
|
||||
|
||||
[NLAMBDA X (* lmm "14-Aug-84 18:34")
|
||||
(* Dump I.S.OPRS definitions.
|
||||
-
|
||||
redefined to dump out same case as
|
||||
given)
|
||||
(for Y in X collect (OR (GETDEF.I.S.OPR Y)
|
||||
(PROG1 NIL (LISPXPRINT (LIST 'I.S.OPR Y 'not 'defined)
|
||||
T T])
|
||||
(PROG1 NIL
|
||||
(LISPXPRINT (LIST 'I.S.OPR Y 'not 'defined)
|
||||
T T))])
|
||||
|
||||
(GETDEF.I.S.OPR
|
||||
[LAMBDA (Y) (* lmm "14-Aug-84 18:34")
|
||||
[LAMBDA (Y) (* lmm "14-Aug-84 18:34")
|
||||
(PROG (TEM BODY EVALFLG)
|
||||
(RETURN
|
||||
(CONS 'I.S.OPR
|
||||
@@ -1279,9 +1272,9 @@ with the terms of said license.
|
||||
[(CDR BODY)
|
||||
(COND
|
||||
(EVALFLG (SHOULDNT)))
|
||||
|
||||
(* somehow there was an = in front of the i.s.type and not in front of the
|
||||
others. this shouldnt happen)
|
||||
|
||||
(* somehow there was an = in front of the i.s.type and not in front of the
|
||||
others. this shouldnt happen)
|
||||
|
||||
(LIST (KWOTE (CDR BODY]
|
||||
(EVALFLG '(NIL T]
|
||||
@@ -1298,11 +1291,11 @@ with the terms of said license.
|
||||
|
||||
|
||||
(ADDTOVAR DURATIONCLISPWORDS (TIMERUNITS timerUnits timerunits)
|
||||
(USINGBOX usingBox usingbox)
|
||||
(USINGTIMER usingTimer usingtimer)
|
||||
(FORDURATION forDuration forduration DURING during)
|
||||
(RESOURCENAME resourceName resourcename)
|
||||
(UNTILDATE untilDate untildate))
|
||||
(USINGBOX usingBox usingbox)
|
||||
(USINGTIMER usingTimer usingtimer)
|
||||
(FORDURATION forDuration forduration DURING during)
|
||||
(RESOURCENAME resourceName resourcename)
|
||||
(UNTILDATE untilDate untildate))
|
||||
|
||||
(PUTPROPS TIMERUNITS CLISPWORD (FORWORD . timerUnits))
|
||||
|
||||
@@ -1477,7 +1470,6 @@ with the terms of said license.
|
||||
|
||||
(ADDTOVAR LAMA )
|
||||
)
|
||||
(PUTPROPS CLISP COPYRIGHT ("Venue & Xerox Corporation" T 1982 1983 1984 1985 1986 1990))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (37614 40224 (DUMPI.S.OPRS 37624 . 38032) (GETDEF.I.S.OPR 38034 . 40222)))))
|
||||
(FILEMAP (NIL (36881 39751 (DUMPI.S.OPRS 36891 . 37559) (GETDEF.I.S.OPR 37561 . 39749)))))
|
||||
STOP
|
||||
|
||||
BIN
sources/CLISP.DFASL
Normal file
BIN
sources/CLISP.DFASL
Normal file
Binary file not shown.
File diff suppressed because one or more lines are too long
@@ -1,18 +1,14 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
(DEFINE-FILE-INFO :PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10)
|
||||
|
||||
(FILECREATED "24-Sep-2023 14:11:25" {WMEDLEY}<sources>CMLCOMPILE.;2 22597
|
||||
(FILECREATED "25-Feb-2026 23:03:38" {WMEDLEY}<sources>CMLCOMPILE.;4 25235
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (FNS COMPILE-IN-CORE)
|
||||
:CHANGES-TO (FNS FAKE-COMPILE-FILE)
|
||||
|
||||
:PREVIOUS-DATE " 2-Jul-90 20:24:02" {WMEDLEY}<sources>CMLCOMPILE.;1)
|
||||
:PREVIOUS-DATE "25-Feb-2026 19:50:29" {WMEDLEY}<sources>CMLCOMPILE.;3)
|
||||
|
||||
|
||||
(* ; "
|
||||
Copyright (c) 1985-1987, 1990 by Venue & Xerox Corporation.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT CMLCOMPILECOMS)
|
||||
|
||||
(RPAQQ CMLCOMPILECOMS
|
||||
@@ -46,8 +42,111 @@ Copyright (c) 1985-1987, 1990 by Venue & Xerox Corporation.
|
||||
(DEFINEQ
|
||||
|
||||
(FAKE-COMPILE-FILE
|
||||
(CL:LAMBDA (FILENAME &KEY LAP REDEFINE OUTPUT-FILE (SAVE-EXPRS T) (COMPILER-OUTPUT T) (PROCESS-ENTIRE-FILE NIL PEFP)) (* ; "Edited 29-Jun-90 19:19 by nm") (LET (COMPILE.FILE.AFTER VALUE COMPILE.FILE.VALUE (NLAML NLAML) (NLAMA NLAMA) (LAMS LAMS) (LAMA LAMA) (DFNFLG NIL)) (DECLARE (CL:SPECIAL COMPILE.FILE.AFTER COMPILE.FILE.VALUE NLAML NLAMA LAMS LAMA DFNFLG)) (RESETLST (RESETSAVE NIL (LIST (QUOTE RESETUNDO)) (RESETUNDO)) (RESETSAVE COUTFILE COMPILER-OUTPUT) (RESETSAVE STRF REDEFINE) (RESETSAVE SVFLG (AND SAVE-EXPRS REDEFINE (QUOTE DEFER))) (RESETSAVE LAPFLG LAP) (LET ((*PACKAGE* *INTERLISP-PACKAGE*) (*READ-BASE* 10) (LOCALVARS SYSLOCALVARS) (SPECVARS T) STREAM LSTFIL ROOTNAME INTERLISP-FORMAT ENV FORM) (DECLARE (CL:SPECIAL *PACKAGE* *READ-BASE* LOCALVARS SPECVARS LSTFIL)) (RESETSAVE NIL (LIST (FUNCTION CLOSEF?) (SETQ STREAM (OPENSTREAM FILENAME (QUOTE INPUT))))) (CL:MULTIPLE-VALUE-SETQ (ENV FORM) (\PARSE-FILE-HEADER STREAM (QUOTE RETURN) T)) (SETQ INTERLISP-FORMAT (AND ENV (NEQ ENV *COMMON-LISP-READ-ENVIRONMENT*))) (if (NOT PEFP) then (SETQ PROCESS-ENTIRE-FILE INTERLISP-FORMAT)) (if LAP then (SETQ LSTFIL COUTFILE)) (SETQ FILENAME (FULLNAME STREAM)) (RESETSAVE NIL (LIST (FUNCTION COMPILE.FILE.RESET) (SETQ OUTPUT-FILE (OPENSTREAM (OR OUTPUT-FILE (PACKFILENAME.STRING (QUOTE VERSION) NIL (QUOTE EXTENSION) COMPILE.EXT (QUOTE BODY) FILENAME)) (QUOTE OUTPUT) (QUOTE NEW) (QUOTE ((TYPE BINARY))))) STREAM (ROOTFILENAME FILENAME))) (if OUTPUT-FILE then (RESETSAVE LCFIL OUTPUT-FILE) (PRINT-COMPILE-HEADER (LIST STREAM) (QUOTE ("COMPILE-FILEd")) ENV)) (WITH-READER-ENVIRONMENT ENV (PROG ((DEFERRED.EXPRESSIONS NIL) (*PRINT-ARRAY* T) (*PRINT-LEVEL* NIL) (*PRINT-LENGTH* NIL) (FIRSTFORMS NIL) (AFTERS NIL) (SCRATCH.LCOM (QUOTE {CORE}SCRATCH.LCOM)) DUMMYFILE TEMPVAL) (DECLARE (CL:SPECIAL DEFERRED.EXPRESSIONS *PRINT-ARRAY* *PRINT-LEVEL* *PRINT-LENGTH* FIRSTFORMS AFTERS DEFERS)) (* ; "Edited by TT (11-June-90 : for AR#11185) all contents of file are read, and each forms are compiled.(This reading method is for supporting %"FIRST%", %"NOTFIRST%" tag.)") (RESETSAVE NIL (LIST (FUNCTION CLOSEF?) (SETQ DUMMYFILE (OPENSTREAM SCRATCH.LCOM (QUOTE BOTH) (QUOTE NEW))))) LPDUMP (if (EQUAL (CAR FORM) (QUOTE RPAQQ)) then (* ; "This is the support method of %"COMPILERVARS%" (2-July-1990 TT)") (SETQ TEMPVAL (CADDR FORM)) (if (SETQ TEMPVAL (ASSOC (QUOTE DECLARE%:) TEMPVAL)) then (if (SETQ TEMPVAL (FMEMB (QUOTE COMPILERVARS) (FMEMB (QUOTE DOEVAL@COMPILE) TEMPVAL))) then (SETQ DFNFLG T) (if (SETQ TEMPVAL (FMEMB (QUOTE ADDVARS) (SETQ TEMPVAL (CADR TEMPVAL)))) then (CL:DOLIST (ARG (CDR TEMPVAL)) (APPLY (QUOTE ADDTOVAR) ARG)))))) (COMPILE-FILE-EXPRESSION FORM DUMMYFILE NIL PROCESS-ENTIRE-FILE) (SKIPSEPRCODES STREAM) (if (EOFP STREAM) then (CLOSEF STREAM) (for FORM in FIRSTFORMS do (COMPILE-FILE-EXPRESSION FORM OUTPUT-FILE NIL PROCESS-ENTIRE-FILE T)) (COPYBYTES DUMMYFILE OUTPUT-FILE 0 (GETFILEPTR DUMMYFILE)) (CLOSEF? DUMMYFILE) (DELFILE (FULLNAME DUMMYFILE)) (AND PROCESS-ENTIRE-FILE (for EXP in (REVERSE DEFERRED.EXPRESSIONS) do (APPLY* (CAR EXP) (CDR EXP) OUTPUT-FILE))) (for FORM in AFTERS do (COMPILE-FILE-EXPRESSION FORM OUTPUT-FILE NIL PROCESS-ENTIRE-FILE T)) (RETURN)) (SETQ FORM (READ STREAM)) (GO LPDUMP)) (PRINT NIL OUTPUT-FILE)) (SETQ COMPILE.FILE.VALUE (CLOSEF OUTPUT-FILE)))) (* ; "Do these after UNDONLSETQ entered") (MAPC (REVERSE COMPILE.FILE.AFTER) (FUNCTION EVAL)) COMPILE.FILE.VALUE))
|
||||
)
|
||||
(CL:LAMBDA
|
||||
(FILENAME &KEY LAP REDEFINE OUTPUT-FILE (SAVE-EXPRS T)
|
||||
(COMPILER-OUTPUT T)
|
||||
(PROCESS-ENTIRE-FILE NIL PEFP)) (* ; "Edited 25-Feb-2026 23:02 by rmk")
|
||||
(* ; "Edited 29-Jun-90 19:19 by nm")
|
||||
(LET
|
||||
(COMPILE.FILE.AFTER VALUE COMPILE.FILE.VALUE (NLAML NLAML)
|
||||
(NLAMA NLAMA)
|
||||
(LAMS LAMS)
|
||||
(LAMA LAMA)
|
||||
(DFNFLG NIL))
|
||||
(DECLARE (CL:SPECIAL COMPILE.FILE.AFTER COMPILE.FILE.VALUE NLAML NLAMA LAMS LAMA DFNFLG))
|
||||
(RESETLST
|
||||
(RESETSAVE NIL (LIST 'RESETUNDO)
|
||||
(RESETUNDO))
|
||||
(RESETSAVE COUTFILE COMPILER-OUTPUT)
|
||||
(RESETSAVE STRF REDEFINE)
|
||||
(RESETSAVE SVFLG (AND SAVE-EXPRS REDEFINE 'DEFER))
|
||||
(RESETSAVE LAPFLG LAP)
|
||||
(LET
|
||||
((*PACKAGE* *INTERLISP-PACKAGE*)
|
||||
(*READ-BASE* 10)
|
||||
(LOCALVARS SYSLOCALVARS)
|
||||
(SPECVARS T)
|
||||
STREAM LSTFIL ROOTNAME INTERLISP-FORMAT ENV FORM)
|
||||
(DECLARE (CL:SPECIAL *PACKAGE* *READ-BASE* LOCALVARS SPECVARS LSTFIL))
|
||||
[RESETSAVE NIL (LIST (FUNCTION CLOSEF?)
|
||||
(SETQ STREAM (OPENSTREAM FILENAME 'INPUT]
|
||||
(CL:MULTIPLE-VALUE-SETQ (ENV FORM)
|
||||
(\PARSE-FILE-HEADER STREAM 'RETURN T))
|
||||
(SETQ INTERLISP-FORMAT (AND ENV (NEQ ENV *COMMON-LISP-READ-ENVIRONMENT*)))
|
||||
(if (NOT PEFP)
|
||||
then (SETQ PROCESS-ENTIRE-FILE INTERLISP-FORMAT))
|
||||
(if LAP
|
||||
then (SETQ LSTFIL COUTFILE))
|
||||
(SETQ FILENAME (FULLNAME STREAM))
|
||||
(RESETSAVE NIL (LIST (FUNCTION COMPILE.FILE.RESET)
|
||||
[SETQ OUTPUT-FILE (OPENSTREAM (OR OUTPUT-FILE (PACKFILENAME.STRING
|
||||
'VERSION NIL
|
||||
'EXTENSION COMPILE.EXT
|
||||
'BODY FILENAME))
|
||||
'OUTPUT
|
||||
'NEW
|
||||
`((TYPE BINARY)
|
||||
(:EXTERNAL-FORMAT ,ENV]
|
||||
STREAM
|
||||
(ROOTFILENAME FILENAME)))
|
||||
(if OUTPUT-FILE
|
||||
then (RESETSAVE LCFIL OUTPUT-FILE)
|
||||
(PRINT-COMPILE-HEADER (LIST STREAM)
|
||||
'("COMPILE-FILEd")
|
||||
ENV))
|
||||
(WITH-READER-ENVIRONMENT ENV
|
||||
(PROG ((DEFERRED.EXPRESSIONS NIL)
|
||||
(*PRINT-ARRAY* T)
|
||||
(*PRINT-LEVEL* NIL)
|
||||
(*PRINT-LENGTH* NIL)
|
||||
(FIRSTFORMS NIL)
|
||||
(AFTERS NIL)
|
||||
(SCRATCH.LCOM '{CORE}SCRATCH.LCOM)
|
||||
DUMMYFILE TEMPVAL)
|
||||
(DECLARE (CL:SPECIAL DEFERRED.EXPRESSIONS *PRINT-ARRAY* *PRINT-LEVEL*
|
||||
*PRINT-LENGTH* FIRSTFORMS AFTERS DEFERS))
|
||||
(* ; "Edited by TT (11-June-90 : for AR#11185) all contents of file are read, and each forms are compiled.(This reading method is for supporting %"FIRST%", %"NOTFIRST%" tag.)")
|
||||
[RESETSAVE NIL (LIST (FUNCTION CLOSEF?)
|
||||
(SETQ DUMMYFILE (OPENSTREAM SCRATCH.LCOM 'BOTH 'NEW
|
||||
`((:EXTERNAL-FORMAT ,ENV]
|
||||
LPDUMP
|
||||
[if (EQUAL (CAR FORM)
|
||||
'RPAQQ)
|
||||
then (* ;
|
||||
"This is the support method of %"COMPILERVARS%" (2-July-1990 TT)")
|
||||
(SETQ TEMPVAL (CADDR FORM))
|
||||
(if (SETQ TEMPVAL (ASSOC 'DECLARE%: TEMPVAL))
|
||||
then (if (SETQ TEMPVAL (FMEMB 'COMPILERVARS (FMEMB 'DOEVAL@COMPILE
|
||||
TEMPVAL)))
|
||||
then (SETQ DFNFLG T)
|
||||
(if [SETQ TEMPVAL (FMEMB 'ADDVARS (SETQ TEMPVAL
|
||||
(CADR TEMPVAL]
|
||||
then (CL:DOLIST (ARG (CDR TEMPVAL))
|
||||
(APPLY 'ADDTOVAR ARG))]
|
||||
(COMPILE-FILE-EXPRESSION FORM DUMMYFILE NIL PROCESS-ENTIRE-FILE)
|
||||
(SKIPSEPRCODES STREAM)
|
||||
(if (EOFP STREAM)
|
||||
then (CLOSEF STREAM)
|
||||
(for FORM in FIRSTFORMS do (COMPILE-FILE-EXPRESSION FORM OUTPUT-FILE NIL
|
||||
PROCESS-ENTIRE-FILE T))
|
||||
(COPYBYTES DUMMYFILE OUTPUT-FILE 0 (GETFILEPTR DUMMYFILE))
|
||||
(CLOSEF? DUMMYFILE)
|
||||
(DELFILE (FULLNAME DUMMYFILE))
|
||||
(CL:WHEN PROCESS-ENTIRE-FILE
|
||||
(for EXP in (REVERSE DEFERRED.EXPRESSIONS)
|
||||
do (APPLY* (CAR EXP)
|
||||
(CDR EXP)
|
||||
OUTPUT-FILE)))
|
||||
(for FORM in AFTERS do (COMPILE-FILE-EXPRESSION FORM OUTPUT-FILE NIL
|
||||
PROCESS-ENTIRE-FILE T))
|
||||
(RETURN))
|
||||
(SETQ FORM (READ STREAM))
|
||||
(GO LPDUMP))
|
||||
(PRINT NIL OUTPUT-FILE))
|
||||
(SETQ COMPILE.FILE.VALUE (CLOSEF OUTPUT-FILE)))) (* ; "Do these after UNDONLSETQ entered")
|
||||
(MAPC (REVERSE COMPILE.FILE.AFTER)
|
||||
(FUNCTION EVAL))
|
||||
COMPILE.FILE.VALUE)))
|
||||
|
||||
(INTERLISP-FORMAT-P
|
||||
[LAMBDA (STREAM) (* bvm%: " 3-Aug-86 14:01")
|
||||
@@ -302,14 +401,13 @@ Copyright (c) 1985-1987, 1990 by Venue & Xerox Corporation.
|
||||
|
||||
(ADDTOVAR LAMA FAKE-COMPILE-FILE)
|
||||
)
|
||||
(PUTPROPS CMLCOMPILE COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1990))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (1636 2253 (CL:DISASSEMBLE 1636 . 2253)) (2254 17523 (FAKE-COMPILE-FILE 2264 . 5700) (
|
||||
INTERLISP-FORMAT-P 5702 . 5920) (INTERLISP-NLAMBDA-FUNCTION-P 5922 . 6156) (COMPILE-FILE-EXPRESSION
|
||||
6158 . 9508) (COMPILE-FILE-WALK-FUNCTION 9510 . 9757) (ARGTYPE.STATE 9759 . 9919) (
|
||||
COMPILE.CHECK.ARGTYPE 9921 . 11913) (COMPILE.FILE.DEFINEQ 11915 . 12408) (
|
||||
COMPILE-FILE-SETF-SYMBOL-FUNCTION 12410 . 13004) (COMPILE-FILE-EX/IMPORT 13006 . 13334) (
|
||||
COMPILE.FILE.APPLY 13336 . 13596) (COMPILE.FILE.RESET 13598 . 14459) (COMPILE-IN-CORE 14461 . 17521))
|
||||
(17524 19253 (COMPILE-FILE-SCAN-FIRST 17534 . 19251)) (19796 21163 (COMPILE-FILE-DECLARE%: 19796 .
|
||||
21163)) (21164 22228 (NEWDEFC 21174 . 22226)))))
|
||||
(FILEMAP (NIL (1569 2186 (CL:DISASSEMBLE 1569 . 2186)) (2187 20243 (FAKE-COMPILE-FILE 2197 . 8420) (
|
||||
INTERLISP-FORMAT-P 8422 . 8640) (INTERLISP-NLAMBDA-FUNCTION-P 8642 . 8876) (COMPILE-FILE-EXPRESSION
|
||||
8878 . 12228) (COMPILE-FILE-WALK-FUNCTION 12230 . 12477) (ARGTYPE.STATE 12479 . 12639) (
|
||||
COMPILE.CHECK.ARGTYPE 12641 . 14633) (COMPILE.FILE.DEFINEQ 14635 . 15128) (
|
||||
COMPILE-FILE-SETF-SYMBOL-FUNCTION 15130 . 15724) (COMPILE-FILE-EX/IMPORT 15726 . 16054) (
|
||||
COMPILE.FILE.APPLY 16056 . 16316) (COMPILE.FILE.RESET 16318 . 17179) (COMPILE-IN-CORE 17181 . 20241))
|
||||
(20244 21973 (COMPILE-FILE-SCAN-FIRST 20254 . 21971)) (22516 23883 (COMPILE-FILE-DECLARE%: 22516 .
|
||||
23883)) (23884 24948 (NEWDEFC 23894 . 24946)))))
|
||||
STOP
|
||||
|
||||
BIN
sources/CMLCOMPILE.DFASL
Normal file
BIN
sources/CMLCOMPILE.DFASL
Normal file
Binary file not shown.
130
sources/CMLREAD
130
sources/CMLREAD
@@ -1,12 +1,13 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10 FORMAT UTF-8)
|
||||
|
||||
(FILECREATED "24-Apr-2025 21:59:48" {WMEDLEY}<sources>CMLREAD.;17 12829
|
||||
(FILECREATED "25-Feb-2026 11:51:19" {WMEDLEY}<sources>CMLREAD.;24 12180
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (VARS CMLREADCOMS)
|
||||
(FUNCTIONS WITH-READER-ENVIRONMENT)
|
||||
|
||||
:PREVIOUS-DATE "23-Sep-2024 11:55:33" {WMEDLEY}<sources>CMLREAD.;16)
|
||||
:PREVIOUS-DATE "25-Feb-2026 09:25:29" {WMEDLEY}<sources>CMLREAD.;21)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT CMLREADCOMS)
|
||||
@@ -26,18 +27,14 @@
|
||||
(DWIMINMACROSFLG))
|
||||
(VARIABLES *READ-DEFAULT-FLOAT-FORMAT*)
|
||||
(GLOBALVARS CMLRDTBL READ-LINE-RDTBL))
|
||||
[COMS
|
||||
(* ;; "Crude means to aid reading and printing things in same reader environment. There are some fns and an INITRECORDS for this on ATBL to get it early in the loadup")
|
||||
|
||||
(RECORDS READER-ENVIRONMENT)
|
||||
(FUNCTIONS WITH-READER-ENVIRONMENT)
|
||||
(ADDVARS (SYSSPECVARS *PACKAGE* *READTABLE* *READ-BASE* *PRINT-BASE*))
|
||||
[COMS (FUNCTIONS WITH-READER-ENVIRONMENT)
|
||||
(PROP INFO WITH-READER-ENVIRONMENT)
|
||||
(ADDVARS (SYSSPECVARS *PACKAGE* *READTABLE* *READ-BASE* *PRINT-BASE*))
|
||||
(GLOBALVARS *COMMON-LISP-READ-ENVIRONMENT*)
|
||||
(INITVARS (*COMMON-LISP-READ-ENVIRONMENT* (create READER-ENVIRONMENT REPACKAGE _
|
||||
(INITVARS (*COMMON-LISP-READ-ENVIRONMENT* (create READER-ENVIRONMENT REPACKAGE ←
|
||||
(CL:FIND-PACKAGE "USER")
|
||||
REREADTABLE _ CMLRDTBL REBASE _ 10
|
||||
REFORMAT _ :MCCS]
|
||||
REREADTABLE ← CMLRDTBL REBASE ← 10
|
||||
REFORMAT ← :MCCS]
|
||||
(PROP FILETYPE CMLREAD)
|
||||
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
|
||||
(ADDVARS (NLAMA)
|
||||
@@ -53,48 +50,48 @@
|
||||
|
||||
(CL:COPY-READTABLE
|
||||
[CL:LAMBDA (&OPTIONAL (FROM-READTABLE *READTABLE*)
|
||||
TO-READTABLE) (* bvm%: "13-Oct-86 15:21")
|
||||
TO-READTABLE) (* bvm%: "13-Oct-86 15:21")
|
||||
(* ;
|
||||
"If FROM-READTABLE is NIL, then a copy of a standard Common Lisp readtable is made.")
|
||||
"If FROM-READTABLE is NIL, then a copy of a standard Common Lisp readtable is made.")
|
||||
(if (AND (NULL FROM-READTABLE)
|
||||
(NULL TO-READTABLE))
|
||||
then (* ; "just make a brand new one")
|
||||
(CMLRDTBL)
|
||||
(NULL TO-READTABLE))
|
||||
then (* ; "just make a brand new one")
|
||||
(CMLRDTBL)
|
||||
else (SETQ FROM-READTABLE (\DTEST (OR FROM-READTABLE (CMLRDTBL))
|
||||
'READTABLEP))
|
||||
(if TO-READTABLE
|
||||
then (RESETREADTABLE (\DTEST TO-READTABLE 'READTABLEP)
|
||||
FROM-READTABLE)
|
||||
TO-READTABLE
|
||||
else (COPYREADTABLE FROM-READTABLE])
|
||||
'READTABLEP))
|
||||
(if TO-READTABLE
|
||||
then (RESETREADTABLE (\DTEST TO-READTABLE 'READTABLEP)
|
||||
FROM-READTABLE)
|
||||
TO-READTABLE
|
||||
else (COPYREADTABLE FROM-READTABLE])
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
(CL:READ-LINE
|
||||
[CL:LAMBDA (&OPTIONAL STREAM (EOF-ERRORP T)
|
||||
EOF-VALUE RECURSIVE-P) (* ; "Edited 31-Mar-87 18:36 by bvm:")
|
||||
EOF-VALUE RECURSIVE-P) (* ; "Edited 31-Mar-87 18:36 by bvm:")
|
||||
|
||||
(* ;;
|
||||
"Returns a line of text read from the STREAM as a string, discarding the newline character.")
|
||||
"Returns a line of text read from the STREAM as a string, discarding the newline character.")
|
||||
|
||||
(CL:SETQ STREAM (\GETSTREAM STREAM 'INPUT))
|
||||
(if (AND (NULL EOF-ERRORP)
|
||||
(NULL RECURSIVE-P)
|
||||
(\EOFP STREAM))
|
||||
(NULL RECURSIVE-P)
|
||||
(\EOFP STREAM))
|
||||
then EOF-VALUE
|
||||
else (LET ((RESULT (RSTRING STREAM READ-LINE-RDTBL)))
|
||||
(if (\EOFP STREAM)
|
||||
then (CL:VALUES RESULT T)
|
||||
else (* ; "consume the eol")
|
||||
(READCCODE STREAM)
|
||||
(CL:VALUES RESULT NIL])
|
||||
(if (\EOFP STREAM)
|
||||
then (CL:VALUES RESULT T)
|
||||
else (* ; "consume the eol")
|
||||
(READCCODE STREAM)
|
||||
(CL:VALUES RESULT NIL])
|
||||
|
||||
(CL:READ-CHAR
|
||||
[CL:LAMBDA (&OPTIONAL (STREAM *STANDARD-INPUT*)
|
||||
(EOF-ERRORP T)
|
||||
EOF-VALUE RECURSIVE-P) (* ; "Edited 14-Dec-86 20:41 by bvm:")
|
||||
EOF-VALUE RECURSIVE-P) (* ; "Edited 14-Dec-86 20:41 by bvm:")
|
||||
|
||||
(* ;; "Inputs a character from STREAM and returns it.")
|
||||
(* ;; "Inputs a character from STREAM and returns it.")
|
||||
|
||||
(LET [(STREAM (\GETSTREAM STREAM 'INPUT]
|
||||
(COND
|
||||
@@ -105,10 +102,10 @@
|
||||
(T (CL:CODE-CHAR (READCCODE STREAM])
|
||||
|
||||
(CL:UNREAD-CHAR
|
||||
(CL:LAMBDA (CHARACTER &OPTIONAL (INPUT-STREAM *STANDARD-INPUT*))
|
||||
(* ; "Edited 23-Jun-2021 13:05 by rmk:")
|
||||
(CL:LAMBDA (CHARACTER &OPTIONAL (INPUT-STREAM *STANDARD-INPUT*))
|
||||
(* ; "Edited 23-Jun-2021 13:05 by rmk:")
|
||||
|
||||
(* ;; "Puts the CHARACTER back on the front of the input STREAM. According to the manual, `One may apply UNREAD-CHAR only to the character most recently read from INPUT-STREAM.'")
|
||||
(* ;; "Puts the CHARACTER back on the front of the input STREAM. According to the manual, `One may apply UNREAD-CHAR only to the character most recently read from INPUT-STREAM.'")
|
||||
|
||||
(\BACKCCODE (\GETSTREAM INPUT-STREAM 'INPUT))
|
||||
NIL))
|
||||
@@ -153,7 +150,7 @@
|
||||
else (\ILLEGAL.ARG PEEK-TYPE])
|
||||
|
||||
(CL:LISTEN
|
||||
(CL:LAMBDA (&OPTIONAL STREAM) (* ; "Edited 14-Apr-87 16:49 by bvm:")
|
||||
(CL:LAMBDA (&OPTIONAL STREAM) (* ; "Edited 14-Apr-87 16:49 by bvm:")
|
||||
|
||||
(* ;; "Returns T if a character is available on the given STREAM ")
|
||||
|
||||
@@ -162,7 +159,7 @@
|
||||
|
||||
(CL:READ-CHAR-NO-HANG
|
||||
(CL:LAMBDA (&OPTIONAL STREAM (EOF-ERRORP T)
|
||||
EOF-VALUE RECURSIVE-P) (* ; "Edited 14-Apr-87 16:40 by bvm:")
|
||||
EOF-VALUE RECURSIVE-P) (* ; "Edited 14-Apr-87 16:40 by bvm:")
|
||||
|
||||
(* ;; "Returns the next character from the STREAM if one is available, or NIL. However, if STREAM is at eof, do eof handling.")
|
||||
|
||||
@@ -170,13 +167,13 @@
|
||||
((READP STREAM T) (* ; "there is input, get it")
|
||||
(CL:READ-CHAR STREAM EOF-ERRORP EOF-VALUE RECURSIVE-P))
|
||||
((NOT (EOFP STREAM)) (* ;
|
||||
"there could be more input, so don't wait, return NIL")
|
||||
"there could be more input, so don't wait, return NIL")
|
||||
NIL)
|
||||
(EOF-ERRORP (\EOF.ACTION STREAM))
|
||||
(T EOF-VALUE))))
|
||||
|
||||
(CL:CLEAR-INPUT
|
||||
[CL:LAMBDA (&OPTIONAL (STREAM *STANDARD-INPUT*)) (* bvm%: "13-Oct-86 15:46")
|
||||
[CL:LAMBDA (&OPTIONAL (STREAM *STANDARD-INPUT*)) (* bvm%: "13-Oct-86 15:46")
|
||||
|
||||
(* ;; "Clears any buffered input associated with the Stream.")
|
||||
|
||||
@@ -200,7 +197,7 @@
|
||||
|
||||
(CL:READ-BYTE
|
||||
[CL:LAMBDA (BINARY-INPUT-STREAM &OPTIONAL (EOF-ERRORP T)
|
||||
EOF-VALUE) (* bvm%: "13-Oct-86 15:49")
|
||||
EOF-VALUE) (* bvm%: "13-Oct-86 15:49")
|
||||
|
||||
(* ;; "Returns the next byte of the BINARY-INPUT-STREAM")
|
||||
|
||||
@@ -211,7 +208,7 @@
|
||||
(\BIN STREAM))])
|
||||
|
||||
(CL:WRITE-BYTE
|
||||
(CL:LAMBDA (INTEGER BINARY-OUTPUT-STREAM) (* bvm%: "13-Oct-86 15:49")
|
||||
(CL:LAMBDA (INTEGER BINARY-OUTPUT-STREAM) (* bvm%: "13-Oct-86 15:49")
|
||||
|
||||
(* ;; "Outputs the INTEGER to the binary BINARY-OUTPUT-STREAM")
|
||||
|
||||
@@ -236,47 +233,30 @@
|
||||
(GLOBALVARS CMLRDTBL READ-LINE-RDTBL)
|
||||
)
|
||||
|
||||
|
||||
|
||||
(* ;;
|
||||
"Crude means to aid reading and printing things in same reader environment. There are some fns and an INITRECORDS for this on ATBL to get it early in the loadup"
|
||||
)
|
||||
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(DATATYPE READER-ENVIRONMENT (REPACKAGE REREADTABLE REBASE REPACKAGEFORM REFORMAT REREADTABLEFORM))
|
||||
)
|
||||
|
||||
(/DECLAREDATATYPE 'READER-ENVIRONMENT '(POINTER POINTER POINTER POINTER POINTER POINTER)
|
||||
'((READER-ENVIRONMENT 0 POINTER)
|
||||
(READER-ENVIRONMENT 2 POINTER)
|
||||
(READER-ENVIRONMENT 4 POINTER)
|
||||
(READER-ENVIRONMENT 6 POINTER)
|
||||
(READER-ENVIRONMENT 8 POINTER)
|
||||
(READER-ENVIRONMENT 10 POINTER))
|
||||
'12)
|
||||
|
||||
(DEFMACRO WITH-READER-ENVIRONMENT (ENV . BODY)
|
||||
(DEFMACRO WITH-READER-ENVIRONMENT (ENV . BODY) (* ; "Edited 25-Feb-2026 09:23 by rmk")
|
||||
`((CL:LAMBDA (E)
|
||||
(CL:WHEN (\GETSTREAM E 'INPUT T)
|
||||
(SETQ E (READ-READER-ENVIRONMENT STREAM)))
|
||||
(\DTEST E 'READER-ENVIRONMENT)
|
||||
(LET ((*PACKAGE* (ffetch (READER-ENVIRONMENT REPACKAGE) of E))
|
||||
(*READTABLE* (ffetch (READER-ENVIRONMENT REREADTABLE) of E))
|
||||
(*READ-BASE* (ffetch (READER-ENVIRONMENT REBASE) of E))
|
||||
(*PRINT-BASE* (ffetch (READER-ENVIRONMENT REBASE) of E)))
|
||||
,@BODY))
|
||||
(\DTEST ,ENV 'READER-ENVIRONMENT)))
|
||||
|
||||
(ADDTOVAR SYSSPECVARS *PACKAGE* *READTABLE* *READ-BASE* *PRINT-BASE*)
|
||||
,ENV))
|
||||
|
||||
(PUTPROPS WITH-READER-ENVIRONMENT INFO EVAL)
|
||||
|
||||
(ADDTOVAR SYSSPECVARS *PACKAGE* *READTABLE* *READ-BASE* *PRINT-BASE*)
|
||||
(DECLARE%: DOEVAL@COMPILE DONTCOPY
|
||||
|
||||
(GLOBALVARS *COMMON-LISP-READ-ENVIRONMENT*)
|
||||
)
|
||||
|
||||
(RPAQ? *COMMON-LISP-READ-ENVIRONMENT* (create READER-ENVIRONMENT REPACKAGE _ (CL:FIND-PACKAGE "USER")
|
||||
REREADTABLE _ CMLRDTBL REBASE _ 10 REFORMAT _ :MCCS))
|
||||
(RPAQ? *COMMON-LISP-READ-ENVIRONMENT* (create READER-ENVIRONMENT REPACKAGE ← (CL:FIND-PACKAGE "USER")
|
||||
REREADTABLE ← CMLRDTBL REBASE ← 10 REFORMAT ← :MCCS))
|
||||
|
||||
(PUTPROPS CMLREAD FILETYPE CL:COMPILE-FILE)
|
||||
(PUTPROPS CMLREAD FILETYPE :FAKE-COMPILE-FILE)
|
||||
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
|
||||
|
||||
(ADDTOVAR NLAMA )
|
||||
@@ -287,9 +267,9 @@
|
||||
CL:UNREAD-CHAR CL:READ-CHAR CL:READ-LINE CL:COPY-READTABLE)
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (2380 3365 (CL:COPY-READTABLE 2390 . 3363)) (3366 10574 (CL:READ-LINE 3376 . 4248) (
|
||||
CL:READ-CHAR 4250 . 4800) (CL:UNREAD-CHAR 4802 . 5263) (CL:PEEK-CHAR 5265 . 7559) (CL:LISTEN 7561 .
|
||||
7826) (CL:READ-CHAR-NO-HANG 7828 . 8600) (CL:CLEAR-INPUT 8602 . 8839) (CL:READ-FROM-STRING 8841 . 9861
|
||||
) (CL:READ-BYTE 9863 . 10316) (CL:WRITE-BYTE 10318 . 10572)) (11568 12041 (WITH-READER-ENVIRONMENT
|
||||
11568 . 12041)))))
|
||||
(FILEMAP (NIL (2210 3182 (CL:COPY-READTABLE 2220 . 3180)) (3183 10389 (CL:READ-LINE 3193 . 4049) (
|
||||
CL:READ-CHAR 4051 . 4605) (CL:UNREAD-CHAR 4607 . 5068) (CL:PEEK-CHAR 5070 . 7364) (CL:LISTEN 7366 .
|
||||
7635) (CL:READ-CHAR-NO-HANG 7637 . 8415) (CL:CLEAR-INPUT 8417 . 8654) (CL:READ-FROM-STRING 8656 . 9676
|
||||
) (CL:READ-BYTE 9678 . 10131) (CL:WRITE-BYTE 10133 . 10387)) (10728 11381 (WITH-READER-ENVIRONMENT
|
||||
10728 . 11381)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,12 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
(DEFINE-FILE-INFO :PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10)
|
||||
|
||||
(FILECREATED "24-Apr-2025 22:04:20" {WMEDLEY}<sources>COMPILE.;6 76628
|
||||
(FILECREATED "26-Feb-2026 10:41:28" {WMEDLEY}<sources>COMPILE.;9 77027
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (FNS BCOMPL.BODY BRECOMPILE)
|
||||
:CHANGES-TO (FNS BRECOMPILE)
|
||||
|
||||
:PREVIOUS-DATE "24-Sep-2023 13:59:34" {WMEDLEY}<sources>COMPILE.;5)
|
||||
:PREVIOUS-DATE "26-Feb-2026 00:46:08" {WMEDLEY}<sources>COMPILE.;8)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT COMPILECOMS)
|
||||
@@ -104,7 +104,8 @@
|
||||
CFILE NOBLOCKSFLG OPTIONSSET)))])
|
||||
|
||||
(BCOMPL.BODY
|
||||
[LAMBDA (STREAMS CFILE NOBLOCKSFLG OPTIONSSET) (* ; "Edited 24-Apr-2025 22:03 by rmk")
|
||||
[LAMBDA (STREAMS CFILE NOBLOCKSFLG OPTIONSSET) (* ; "Edited 26-Feb-2026 00:43 by rmk")
|
||||
(* ; "Edited 24-Apr-2025 22:03 by rmk")
|
||||
(* ; "Edited 5-Jul-2021 13:46 by rmk:")
|
||||
|
||||
(* ;;; "STREAMS is a list of streams. Compile everything on them, dumping to CFILE (default first stream.dcom). NOBLOCKSFLG means TCOMPL instead of BCOMPL. OPTIONSSET is true if the Listing? question has already been asked.")
|
||||
@@ -146,7 +147,7 @@
|
||||
(RESETSAVE NIL (LIST 'CLOSEF STREAM))
|
||||
(RESETSAVE (INPUT STREAM)) (* ;
|
||||
"Needs to be primary input for some of the filepkg expressions to work")
|
||||
(WITH-READER-ENVIRONMENT *OLD-INTERLISP-READ-ENVIRONMENT*
|
||||
(WITH-READER-ENVIRONMENT *DEFINE-FILE-INFO-ENV*
|
||||
(until (OR (NULL (SETQ TEM (READ STREAM)))
|
||||
(EQ TEM 'STOP))
|
||||
do (CL:WHEN (EQ (CAR (LISTP TEM))
|
||||
@@ -491,7 +492,9 @@
|
||||
(SETQ BLOCKS (NCONC1 BLOCKS X))))
|
||||
|
||||
(BRECOMPILE
|
||||
[LAMBDA (FILES CFILE FNS NOBLOCKSFLG) (* ; "Edited 24-Apr-2025 22:04 by rmk")
|
||||
[LAMBDA (FILES CFILE FNS NOBLOCKSFLG) (* ; "Edited 26-Feb-2026 10:35 by rmk")
|
||||
(* ; "Edited 24-Feb-2026 10:00 by rmk")
|
||||
(* ; "Edited 24-Apr-2025 22:04 by rmk")
|
||||
(* ; "Edited 5-Jul-2021 09:28 by rmk:")
|
||||
|
||||
(* ;;; "FNS is a list of functions to be recompiled. The object is to make a file that looks exactly like that produced by BCOMPL except to greatly reduce the work by copying from CFILE the compiled definitions those functions not being recompiled.")
|
||||
@@ -632,6 +635,7 @@
|
||||
(DECLARE (CL:SPECIAL FILECREATEDLOC))
|
||||
(* ; " used by LOADFNSCAN")
|
||||
(WITH-READER-ENVIRONMENT ENV
|
||||
(\EXTERNALFORMAT STREAM ENV)
|
||||
(create COMPFILEDESCR
|
||||
COMPFILESTREAM _ STREAM
|
||||
COMPFILEENV _ ENV
|
||||
@@ -653,8 +657,7 @@
|
||||
(* ;
|
||||
"Start writing the compiled file. Use environment of one of the source files--usually the only one")
|
||||
(if LCFIL
|
||||
then (\EXTERNALFORMAT LCFIL (OR (LISTGET DESTINATIONENV :FORMAT)
|
||||
:MCCS))
|
||||
then (\EXTERNALFORMAT LCFIL (OR DESTINATIONENV :MCCS))
|
||||
(PRINT-COMPILE-HEADER
|
||||
FILES
|
||||
[CONS (if NOBLOCKSFLG
|
||||
@@ -851,27 +854,31 @@
|
||||
(T (GO LP])
|
||||
|
||||
(BRECOMPILE3
|
||||
(LAMBDA (FN FILEMAPLST COREOK) (* bvm%: "29-Aug-86 22:07")
|
||||
|
||||
(* * "returns definition of FN, either from in core, or from the file.")
|
||||
[LAMBDA (FN FILEMAPLST COREOK) (* ; "Edited 24-Feb-2026 09:59 by rmk")
|
||||
(* bvm%: "29-Aug-86 22:07")
|
||||
|
||||
(* ;;; "returns definition of FN, either from in core, or from the file.")
|
||||
|
||||
(LET (DEF STREAM)
|
||||
(COND
|
||||
((AND COREOK (EXPRP (SETQ DEF (VIRGINFN FN T)))) (* "Value is of the form (FN DEF FLG) where FLG=T means the definition was obtained from in core, so that it is ok to do spelling correction.")
|
||||
([AND COREOK (EXPRP (SETQ DEF (VIRGINFN FN T]
|
||||
|
||||
(* ;; "Value is of the form (FN DEF FLG) where FLG=T means the definition was obtained from in core, so that it is ok to do spelling correction.")
|
||||
|
||||
(LIST FN DEF T))
|
||||
(T (for FILEDESCR in FILEMAPLST
|
||||
when (PROGN (SETQ STREAM (fetch COMPFILESTREAM of FILEDESCR))
|
||||
when [PROGN (SETQ STREAM (fetch COMPFILESTREAM of FILEDESCR))
|
||||
(for Y in (CDR (fetch COMPFILEMAP of FILEDESCR))
|
||||
thereis (SETQ DEF (FASSOC FN (CDDR Y)))))
|
||||
thereis (SETQ DEF (FASSOC FN (CDDR Y]
|
||||
do (SETFILEPTR STREAM (CADR DEF))
|
||||
(SETQ DEF (WITH-READER-ENVIRONMENT (fetch COMPFILEENV of FILEDESCR)
|
||||
(READ STREAM))) (*
|
||||
"TEM is an arg to DEFINEQ, of the form (fn def)")
|
||||
(READ STREAM))) (* ;
|
||||
"TEM is an arg to DEFINEQ, of the form (fn def)")
|
||||
(COND
|
||||
((NEQ FN (CAR DEF))
|
||||
(ERROR '"filemap does not agree with contents of" (FULLNAME STREAM)
|
||||
T)))
|
||||
(RETURN DEF)))))))
|
||||
(RETURN DEF])
|
||||
|
||||
(BLOCKCOMPILE
|
||||
[LAMBDA (BLKNAME BLKFNS ENTRIES FLG) (* ; "Edited 6-Dec-86 03:59 by lmm")
|
||||
@@ -1518,14 +1525,14 @@
|
||||
(ADDTOVAR LAMA )
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (3379 73129 (BCOMPL 3389 . 5039) (BCOMPL.BODY 5041 . 11639) (PRINT-COMPILE-HEADER 11641
|
||||
. 12704) (RESETOPENFILES 12706 . 13059) (BCOMPL1A 13061 . 19074) (BCOMPL2 19076 . 25891) (BCOMPL3
|
||||
25893 . 27242) (BLOCK%: 27244 . 27876) (BRECOMPILE 27878 . 42562) (BRECOMPILE1 42564 . 48416) (
|
||||
BRECOMPILE2 48418 . 49220) (BRECOMPILE3 49222 . 50598) (BLOCKCOMPILE 50600 . 52460) (BLOCKCOMPILE1
|
||||
52462 . 57547) (COMPSET 57549 . 60246) (COMPSETREAD 60248 . 61559) (COMPSETY 61561 . 61685) (COMPSETF
|
||||
61687 . 61853) (RCOMP3 61855 . 63562) (TCOMPL 63564 . 63863) (RECOMPILE 63865 . 63948) (RECOMP? 63950
|
||||
. 64410) (COMPILE 64412 . 66401) (COMPILE1 66403 . 66991) (COMPILE1A 66993 . 68640) (
|
||||
SHOULD-BE-DWIMIFIED? 68642 . 69331) (COMPEM 69333 . 70057) (GETCFILE 70059 . 71790) (SPECVARS 71792 .
|
||||
72347) (LOCALVARS 72349 . 72923) (GLOBALVARS 72925 . 73127)) (75479 76428 (COMPILEMODE 75489 . 76426))
|
||||
(FILEMAP (NIL (3367 73528 (BCOMPL 3377 . 5027) (BCOMPL.BODY 5029 . 11726) (PRINT-COMPILE-HEADER 11728
|
||||
. 12791) (RESETOPENFILES 12793 . 13146) (BCOMPL1A 13148 . 19161) (BCOMPL2 19163 . 25978) (BCOMPL3
|
||||
25980 . 27329) (BLOCK%: 27331 . 27963) (BRECOMPILE 27965 . 42866) (BRECOMPILE1 42868 . 48720) (
|
||||
BRECOMPILE2 48722 . 49524) (BRECOMPILE3 49526 . 50997) (BLOCKCOMPILE 50999 . 52859) (BLOCKCOMPILE1
|
||||
52861 . 57946) (COMPSET 57948 . 60645) (COMPSETREAD 60647 . 61958) (COMPSETY 61960 . 62084) (COMPSETF
|
||||
62086 . 62252) (RCOMP3 62254 . 63961) (TCOMPL 63963 . 64262) (RECOMPILE 64264 . 64347) (RECOMP? 64349
|
||||
. 64809) (COMPILE 64811 . 66800) (COMPILE1 66802 . 67390) (COMPILE1A 67392 . 69039) (
|
||||
SHOULD-BE-DWIMIFIED? 69041 . 69730) (COMPEM 69732 . 70456) (GETCFILE 70458 . 72189) (SPECVARS 72191 .
|
||||
72746) (LOCALVARS 72748 . 73322) (GLOBALVARS 73324 . 73526)) (75878 76827 (COMPILEMODE 75888 . 76825))
|
||||
)))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
2438
sources/DWIMIFY
2438
sources/DWIMIFY
File diff suppressed because it is too large
Load Diff
Binary file not shown.
@@ -1,13 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10 FORMAT UTF-8)
|
||||
|
||||
(FILECREATED " 9-Feb-2026 15:54:22" {WMEDLEY}<sources>EXTERNALFORMAT.;120 47422
|
||||
(FILECREATED "22-Feb-2026 12:29:38" {WMEDLEY}<sources>EXTERNALFORMAT.;124 45411
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (VARS EXTERNALFORMATCOMS)
|
||||
(FNS \CREATE.THROUGH16.EXTERNALFORMAT \CREATE.THROUGH.EXTERNALFORMAT)
|
||||
|
||||
:PREVIOUS-DATE " 6-Feb-2026 23:21:32" {WMEDLEY}<sources>EXTERNALFORMAT.;116)
|
||||
:PREVIOUS-DATE "20-Feb-2026 09:18:35" {WMEDLEY}<sources>EXTERNALFORMAT.;123)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT EXTERNALFORMATCOMS)
|
||||
@@ -23,9 +22,6 @@
|
||||
(EXPORT (GLOBALVARS *EXTERNALFORMATS* *DEFAULT-EXTERNALFORMAT*))
|
||||
(INITVARS (*EXTERNALFORMATS* NIL)
|
||||
(*DEFAULT-EXTERNALFORMAT* :MCCS))
|
||||
(COMS (FNS SYSTEM-EXTERNALFORMAT MTOSYSSTRING SYSTOMSTRING)
|
||||
(EXPORT (GLOBALVARS *SYSTEM-EXTERNALFORMAT*))
|
||||
(INITVARS (*SYSTEM-EXTERNALFORMAT* :UTF-8)))
|
||||
(DECLARE%: DONTEVAL@LOAD DOCOPY (P (DEFPRINT 'EXTERNALFORMAT (FUNCTION
|
||||
\EXTERNALFORMAT.DEFPRINT
|
||||
]
|
||||
@@ -243,18 +239,18 @@
|
||||
(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
|
||||
MCCSTOFORMATBYTESFN _ MCCSTOFORMATBYTESFN
|
||||
FORMATBYTESTOMCCSFN _ FORMATBYTESTOMCCSFN
|
||||
FORMATCHARSETFN _ (OR FORMATCHARSETFN (FUNCTION NILL])
|
||||
NAME ← NAME
|
||||
INCCODEFN ← INCCODEFN
|
||||
PEEKCCODEFN ← PEEKCCODEFN
|
||||
BACKCCODEFN ← BACKCCODEFN
|
||||
OUTCHARFN ← OUTCHARFN
|
||||
FORMATBYTESTREAMFN ← FORMATBYTESTREAMFN
|
||||
EOLVALID ← EOL
|
||||
EOL ← (OR EOL LF.EOLC)
|
||||
UNSTABLE ← UNSTABLE
|
||||
MCCSTOFORMATBYTESFN ← MCCSTOFORMATBYTESFN
|
||||
FORMATBYTESTOMCCSFN ← FORMATBYTESTOMCCSFN
|
||||
FORMATCHARSETFN ← (OR FORMATCHARSETFN (FUNCTION NILL])
|
||||
|
||||
(\EXTERNALFORMAT.DEFPRINT
|
||||
[LAMBDA (EXTERNALFORMAT STREAM) (* ; "Edited 2-Jul-2022 11:40 by rmk")
|
||||
@@ -268,7 +264,7 @@
|
||||
(DEFINEQ
|
||||
|
||||
(\INSTALL.EXTERNALFORMAT
|
||||
[LAMBDA (EXTFORMAT/NAME EXTERNALFORMAT) (* ; "Edited 5-Aug-2021 14:22 by rmk:")
|
||||
[LAMBDA (EXTFORMAT/NAME EXTERNALFORMAT) (* ; "Edited 5-Aug-2021 14:22 by rmk:")
|
||||
|
||||
(* ;;; "Register an instance of the datatype EXTERNALFORMAT.")
|
||||
|
||||
@@ -277,25 +273,23 @@
|
||||
(LET (NAME)
|
||||
(IF EXTERNALFORMAT
|
||||
THEN
|
||||
(* ;; "Backwards compatibility")
|
||||
|
||||
(* ;; "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))
|
||||
(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)))
|
||||
(SETQ NAME (FETCH (EXTERNALFORMAT NAME) OF EXTERNALFORMAT)))
|
||||
(IF (type? EXTERNALFORMAT EXTERNALFORMAT)
|
||||
THEN (\REMOVE.EXTERNALFORMAT NAME)
|
||||
(push *EXTERNALFORMATS* EXTERNALFORMAT)
|
||||
(push *EXTERNALFORMATS* EXTERNALFORMAT)
|
||||
ELSE (ERROR "INVALID EXTERNALFORMAT " EXTERNALFORMAT))
|
||||
EXTERNALFORMAT])
|
||||
|
||||
(\REMOVE.EXTERNALFORMAT
|
||||
[LAMBDA (NAME/EXTFORMAT) (* ; "Edited 5-May-2021 15:42 by rmk:")
|
||||
[LAMBDA (NAME/EXTFORMAT) (* ; "Edited 5-May-2021 15:42 by rmk:")
|
||||
|
||||
(* ;;; "Deregisters external format EXTERNALFORMAT .")
|
||||
|
||||
@@ -303,9 +297,8 @@
|
||||
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)))
|
||||
SUCHTHAT (EQ NAME/EXTFORMAT (FETCH (EXTERNALFORMAT NAME)
|
||||
OF EF)))
|
||||
*EXTERNALFORMATS*])
|
||||
|
||||
(FIND-FORMAT
|
||||
@@ -330,41 +323,6 @@
|
||||
(RPAQ? *EXTERNALFORMATS* NIL)
|
||||
|
||||
(RPAQ? *DEFAULT-EXTERNALFORMAT* :MCCS)
|
||||
(DEFINEQ
|
||||
|
||||
(SYSTEM-EXTERNALFORMAT
|
||||
[LAMBDA NIL (* ; "Edited 6-Feb-2026 11:29 by rmk")
|
||||
(* ; "Edited 31-Jan-2026 18:51 by rmk")
|
||||
(* ; "Edited 10-Oct-2022 11:55 by lmm")
|
||||
(* ; "Edited 7-Jul-2022 10:41 by rmk")
|
||||
|
||||
(* ;; "Returns the name, sets the global. For now, UTF-8 or through, could be something else.")
|
||||
|
||||
(fetch (EXTERNALFORMAT NAME) of (SETQ *SYSTEM-EXTERNALFORMAT*
|
||||
(FIND-FORMAT (FOR X IN '("LC¬CTYPE" "LC¬ALL" "LANG")
|
||||
WHEN (STRPOS ".UTF-8" (UNIX-GETENV X))
|
||||
DO (RETURN :UTF-8) FINALLY (RETURN :THROUGH])
|
||||
|
||||
(MTOSYSSTRING
|
||||
[LAMBDA (MSTRING) (* ; "Edited 6-Feb-2026 00:20 by rmk")
|
||||
(MCCSTOFORMATBYTES *SYSTEM-EXTERNALFORMAT* (MKSTRING MSTRING])
|
||||
|
||||
(SYSTOMSTRING
|
||||
[LAMBDA (SYSTRING) (* ; "Edited 5-Feb-2026 23:36 by rmk")
|
||||
|
||||
(* ;; "SYSSTRING is presumably shared with Unix, guarantee a copy on the way out")
|
||||
|
||||
(CONCAT (FORMATBYTESTOMCCS *SYSTEM-EXTERNALFORMAT* SYSTRING])
|
||||
)
|
||||
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: DOEVAL@COMPILE DONTCOPY
|
||||
|
||||
(GLOBALVARS *SYSTEM-EXTERNALFORMAT*)
|
||||
)
|
||||
|
||||
(* "END EXPORTED DEFINITIONS")
|
||||
|
||||
|
||||
(RPAQ? *SYSTEM-EXTERNALFORMAT* :UTF-8)
|
||||
(DECLARE%: DONTEVAL@LOAD DOCOPY
|
||||
|
||||
(DEFPRINT 'EXTERNALFORMAT (FUNCTION \EXTERNALFORMAT.DEFPRINT))
|
||||
@@ -730,41 +688,41 @@
|
||||
(* ;; "Defines the NULL device, an infinite source or sink")
|
||||
|
||||
(\DEFINEDEVICE 'NULL (create FDEV
|
||||
DEVICENAME _ 'NULL
|
||||
RANDOMACCESSP _ T
|
||||
NODIRECTORIES _ T
|
||||
CLOSEFILE _ (FUNCTION NILL)
|
||||
DELETEFILE _ (FUNCTION NILL)
|
||||
OPENFILE _ (FUNCTION \NULL.OPENFILE)
|
||||
REOPENFILE _ (FUNCTION \NULL.OPENFILE)
|
||||
BIN _ (FUNCTION \EOF.ACTION)
|
||||
BOUT _ (FUNCTION NILL)
|
||||
PEEKBIN _ [FUNCTION (LAMBDA (STREAM NOERRORFLG)
|
||||
DEVICENAME ← 'NULL
|
||||
RANDOMACCESSP ← T
|
||||
NODIRECTORIES ← T
|
||||
CLOSEFILE ← (FUNCTION NILL)
|
||||
DELETEFILE ← (FUNCTION NILL)
|
||||
OPENFILE ← (FUNCTION \NULL.OPENFILE)
|
||||
REOPENFILE ← (FUNCTION \NULL.OPENFILE)
|
||||
BIN ← (FUNCTION \EOF.ACTION)
|
||||
BOUT ← (FUNCTION NILL)
|
||||
PEEKBIN ← [FUNCTION (LAMBDA (STREAM NOERRORFLG)
|
||||
(AND (NULL NOERRORFLG)
|
||||
(BIN STREAM]
|
||||
READP _ (FUNCTION NILL)
|
||||
BACKFILEPTR _ (FUNCTION NILL)
|
||||
EOFP _ (FUNCTION TRUE)
|
||||
RENAMEFILE _ (FUNCTION NILL)
|
||||
GETFILENAME _ (FUNCTION NILL)
|
||||
EVENTFN _ (FUNCTION NILL)
|
||||
BLOCKIN _ (FUNCTION \EOF.ACTION)
|
||||
BLOCKOUT _ (FUNCTION NILL)
|
||||
GENERATEFILES _ (FUNCTION \NULLFILEGENERATOR)
|
||||
GETFILEPTR _ (FUNCTION ZERO)
|
||||
GETEOFPTR _ (FUNCTION ZERO)
|
||||
SETFILEPTR _ (FUNCTION NILL)
|
||||
GETFILEINFO _ (FUNCTION NILL)
|
||||
SETFILEINFO _ (FUNCTION NILL)
|
||||
SETEOFPTR _ (FUNCTION NILL])
|
||||
READP ← (FUNCTION NILL)
|
||||
BACKFILEPTR ← (FUNCTION NILL)
|
||||
EOFP ← (FUNCTION TRUE)
|
||||
RENAMEFILE ← (FUNCTION NILL)
|
||||
GETFILENAME ← (FUNCTION NILL)
|
||||
EVENTFN ← (FUNCTION NILL)
|
||||
BLOCKIN ← (FUNCTION \EOF.ACTION)
|
||||
BLOCKOUT ← (FUNCTION NILL)
|
||||
GENERATEFILES ← (FUNCTION \NULLFILEGENERATOR)
|
||||
GETFILEPTR ← (FUNCTION ZERO)
|
||||
GETEOFPTR ← (FUNCTION ZERO)
|
||||
SETFILEPTR ← (FUNCTION NILL)
|
||||
GETFILEINFO ← (FUNCTION NILL)
|
||||
SETFILEINFO ← (FUNCTION NILL)
|
||||
SETEOFPTR ← (FUNCTION NILL])
|
||||
|
||||
(\NULL.OPENFILE
|
||||
[LAMBDA (NAME ACCESS RECOG PARAMETERS DEVICE OLDSTREAM) (* bvm%: "30-Jan-85 22:05")
|
||||
(OR OLDSTREAM (create STREAM
|
||||
USERCLOSEABLE _ T
|
||||
ACCESS _ ACCESS
|
||||
FULLFILENAME _ NIL
|
||||
DEVICE _ DEVICE])
|
||||
USERCLOSEABLE ← T
|
||||
ACCESS ← ACCESS
|
||||
FULLFILENAME ← NIL
|
||||
DEVICE ← DEVICE])
|
||||
)
|
||||
(DECLARE%: DONTEVAL@LOAD DOCOPY
|
||||
|
||||
@@ -883,15 +841,14 @@
|
||||
(\CREATE.THROUGH16.EXTERNALFORMAT)
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (7446 15343 (\EXTERNALFORMAT 7456 . 12055) (MAKE-EXTERNALFORMAT 12057 . 14870) (
|
||||
\EXTERNALFORMAT.DEFPRINT 14872 . 15341)) (15344 18385 (\INSTALL.EXTERNALFORMAT 15354 . 16803) (
|
||||
\REMOVE.EXTERNALFORMAT 16805 . 17636) (FIND-FORMAT 17638 . 18383)) (18628 20078 (SYSTEM-EXTERNALFORMAT
|
||||
18638 . 19586) (MTOSYSSTRING 19588 . 19785) (SYSTOMSTRING 19787 . 20076)) (20442 34717 (\OUTCHAR
|
||||
20452 . 21669) (\INCCODE 21671 . 22824) (\BACKCCODE 22826 . 24505) (\BACKCCODE.EOLC 24507 . 26697) (
|
||||
\PEEKCCODE 26699 . 27024) (\PEEKCCODE.EOLC 27026 . 27405) (\INCCODE.EOLC 27407 . 29206) (
|
||||
\FORMATBYTESTREAM 29208 . 31652) (\CHECKEOLC.CRLF 31654 . 34715)) (34718 38634 (MCCSTOFORMATBYTES
|
||||
34728 . 37127) (FORMATBYTESTOMCCS 37129 . 38632)) (40045 42281 (\NULLDEVICE 40055 . 41957) (
|
||||
\NULL.OPENFILE 41959 . 42279)) (42371 47286 (\CREATE.THROUGH.EXTERNALFORMAT 42381 . 44050) (
|
||||
\CREATE.THROUGH16.EXTERNALFORMAT 44052 . 46243) (\THROUGHIN 46245 . 46669) (\THROUGHBACKCCODE 46671 .
|
||||
46942) (\THROUGHOUTCHARFN 46944 . 47284)))))
|
||||
(FILEMAP (NIL (7168 15089 (\EXTERNALFORMAT 7178 . 11777) (MAKE-EXTERNALFORMAT 11779 . 14616) (
|
||||
\EXTERNALFORMAT.DEFPRINT 14618 . 15087)) (15090 17955 (\INSTALL.EXTERNALFORMAT 15100 . 16457) (
|
||||
\REMOVE.EXTERNALFORMAT 16459 . 17206) (FIND-FORMAT 17208 . 17953)) (18373 32648 (\OUTCHAR 18383 .
|
||||
19600) (\INCCODE 19602 . 20755) (\BACKCCODE 20757 . 22436) (\BACKCCODE.EOLC 22438 . 24628) (\PEEKCCODE
|
||||
24630 . 24955) (\PEEKCCODE.EOLC 24957 . 25336) (\INCCODE.EOLC 25338 . 27137) (\FORMATBYTESTREAM 27139
|
||||
. 29583) (\CHECKEOLC.CRLF 29585 . 32646)) (32649 36565 (MCCSTOFORMATBYTES 32659 . 35058) (
|
||||
FORMATBYTESTOMCCS 35060 . 36563)) (37976 40270 (\NULLDEVICE 37986 . 39938) (\NULL.OPENFILE 39940 .
|
||||
40268)) (40360 45275 (\CREATE.THROUGH.EXTERNALFORMAT 40370 . 42039) (\CREATE.THROUGH16.EXTERNALFORMAT
|
||||
42041 . 44232) (\THROUGHIN 44234 . 44658) (\THROUGHBACKCCODE 44660 . 44931) (\THROUGHOUTCHARFN 44933
|
||||
. 45273)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
128
sources/FILEPKG
128
sources/FILEPKG
@@ -1,14 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "27-Sep-2025 19:56:28"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>working-medley>sources>FILEPKG.;53 274937
|
||||
(FILECREATED "25-Feb-2026 10:07:03" {WMEDLEY}<sources>FILEPKG.;61 275774
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (FNS COMPILE-FILE?)
|
||||
:CHANGES-TO (FNS FILEGETDEF.FNS)
|
||||
|
||||
:PREVIOUS-DATE "24-Apr-2025 11:18:44"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>working-medley>sources>FILEPKG.;52)
|
||||
:PREVIOUS-DATE "23-Feb-2026 00:54:21" {WMEDLEY}<sources>FILEPKG.;59)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT FILEPKGCOMS)
|
||||
@@ -2910,18 +2908,20 @@ compiling " T)
|
||||
NIL) finally (RETURN 'NOBIND])
|
||||
|
||||
(FILEGETDEF.FNS
|
||||
[LAMBDA (NAME TYPE SOURCE OPTIONS) (* bvm%: "29-Aug-86 22:30")
|
||||
[LAMBDA (NAME TYPE SOURCE OPTIONS) (* ; "Edited 25-Feb-2026 10:06 by rmk")
|
||||
(* ; "Edited 23-Feb-2026 00:37 by rmk")
|
||||
(* bvm%: "29-Aug-86 22:30")
|
||||
(LET (MAP ENV)
|
||||
(COND
|
||||
[(AND (EQMEMB 'FAST OPTIONS)
|
||||
(PROGN (CL:MULTIPLE-VALUE-SETQ (ENV MAP)
|
||||
(GET-ENVIRONMENT-AND-FILEMAP SOURCE))
|
||||
MAP))
|
||||
(CL:UNLESS (OPENP SOURCE)
|
||||
[RESETSAVE NIL (LIST 'CLOSEF? (SETQ SOURCE (OPENSTREAM SOURCE 'INPUT 'OLD])
|
||||
(\EXTERNALFORMAT SOURCE ENV)
|
||||
(for PAIR MAPLOC in (CDR MAP) when [SETQ MAPLOC (CADR (ASSOC NAME (CDDR PAIR]
|
||||
do [OR (OPENP SOURCE)
|
||||
(RESETSAVE NIL (LIST 'CLOSEF? (SETQ SOURCE (OPENSTREAM SOURCE 'INPUT
|
||||
'OLD]
|
||||
(SETFILEPTR SOURCE MAPLOC)
|
||||
do (SETFILEPTR SOURCE MAPLOC)
|
||||
(RETURN (WITH-READER-ENVIRONMENT ENV
|
||||
[COND
|
||||
((EQMEMB 'ARGLIST OPTIONS)
|
||||
@@ -2931,7 +2931,12 @@ compiling " T)
|
||||
(LIST (READ SOURCE)
|
||||
(READ SOURCE)))
|
||||
(T (CADR (READ SOURCE])]
|
||||
(T (CADR (FASSOC NAME (LOADEFS NAME SOURCE])
|
||||
(T
|
||||
(* ;; "RMK: The NLSETQ is because LOADFNS for FNS seems to disregard NOERROR and crash out when the target is FUNCTIONS, like WITH-READER-ENVIRONMENT")
|
||||
|
||||
(CADR (FASSOC NAME (CL:IF (EQMEMB 'NOERROR OPTIONS)
|
||||
[CAR (NLSETQ (LOADFNS NAME SOURCE 'GETDEF]
|
||||
(LOADFNS NAME SOURCE 'GETDEF))])
|
||||
|
||||
(FILEPKGCOMS.PUTDEF
|
||||
[LAMBDA (NAME TYPE DEFINITION REASON) (* lmm "15-Jul-85 11:29")
|
||||
@@ -3335,7 +3340,8 @@ compiling " T)
|
||||
(RETFROM 'GETDEFCOM])
|
||||
|
||||
(GETDEFCURRENT
|
||||
[LAMBDA (NAME TYPE OPTIONS) (* ; "Edited 2-May-87 19:00 by Pavel")
|
||||
[LAMBDA (NAME TYPE OPTIONS) (* ; "Edited 23-Feb-2026 00:27 by rmk")
|
||||
(* ; "Edited 2-May-87 19:00 by Pavel")
|
||||
(* ;
|
||||
"Gets the current definition--source=0")
|
||||
(LET
|
||||
@@ -3422,6 +3428,7 @@ compiling " T)
|
||||
(RESETSAVE PRETTYFLG)
|
||||
(RESETSAVE FONTCHANGEFLG)
|
||||
[RESETSAVE (OUTPUT (SETQ FILE (OPENSTREAM '{NODIRCORE} 'BOTH]
|
||||
(\EXTERNALFORMAT FILE *OLD-INTERLISP-READ-ENVIRONMENT*)
|
||||
(PRETTYDEFCOMS COMS)
|
||||
(SETFILEPTR FILE 0)
|
||||
[SETQ DEF
|
||||
@@ -4689,11 +4696,14 @@ compiling " T)
|
||||
(AND RETURNFLG (LIST FORM])
|
||||
|
||||
(IMPORTFILESCAN
|
||||
[LAMBDA (FILE RETURNFLG) (* bvm%: "24-Oct-86 19:31")
|
||||
(WITH-READER-ENVIRONMENT (GET-ENVIRONMENT-AND-FILEMAP FILE)
|
||||
(while (FFILEPOS BEGINEXPORTDEFSTRING FILE NIL NIL NIL T) bind DEF
|
||||
join (until (EQUAL (SETQ DEF (READ FILE))
|
||||
ENDEXPORTDEFFORM) join (IMPORTEVAL DEF RETURNFLG))))])
|
||||
[LAMBDA (FILE RETURNFLG) (* ; "Edited 22-Feb-2026 18:20 by rmk")
|
||||
(* bvm%: "24-Oct-86 19:31")
|
||||
(LET ((ENV (GET-ENVIRONMENT-AND-FILEMAP FILE)))
|
||||
(WITH-READER-ENVIRONMENT ENV
|
||||
(\EXTERNALFORMAT FILE ENV)
|
||||
(while (FFILEPOS BEGINEXPORTDEFSTRING FILE NIL NIL NIL T) bind DEF
|
||||
join (until (EQUAL (SETQ DEF (READ FILE))
|
||||
ENDEXPORTDEFFORM) join (IMPORTEVAL DEF RETURNFLG))))])
|
||||
|
||||
(CHECKIMPORTS
|
||||
[LAMBDA (FILES NOASKFLG) (* rmk%: "19-FEB-83 16:31")
|
||||
@@ -4868,46 +4878,46 @@ compiling " T)
|
||||
(ADDTOVAR LAMA FILEPKGTYPE FILEPKGCOM FILEPKGCHANGES)
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (18974 20647 (SEARCHPRETTYTYPELST 18984 . 19953) (PRETTYDEFMACROS 19955 . 20391) (
|
||||
FILEPKGCOMPROPS 20393 . 20645)) (21460 55859 (CLEANUP 21470 . 22860) (COMPILEFILES 22862 . 23138) (
|
||||
COMPILEFILES0 23140 . 23953) (CONTINUEDIT 23955 . 25332) (MAKEFILE 25334 . 37060) (FILECHANGES 37062
|
||||
. 39826) (FILEPKG.MERGECHANGES 39828 . 40463) (FILEPKG.CHANGEDFNS 40465 . 40777) (MAKEFILE1 40779 .
|
||||
44991) (COMPILE-FILE? 44993 . 46687) (MAKEFILES 46689 . 48217) (ADDFILE 48219 . 50762) (ADDFILE0 50764
|
||||
. 54888) (LISTFILES 54890 . 55857)) (56531 90330 (FILEPKGCHANGES 56541 . 57720) (GETFILEPKGTYPE 57722
|
||||
. 60672) (MARKASCHANGED 60674 . 62305) (FILECOMS 62307 . 62691) (WHEREIS 62693 . 64435) (
|
||||
SMASHFILECOMS 64437 . 64665) (FILEFNSLST 64667 . 64833) (FILECOMSLST 64835 . 65321) (UPDATEFILES 65323
|
||||
. 69821) (INFILECOMS? 69823 . 71666) (INFILECOMTAIL 71668 . 72786) (INFILECOMS 72788 . 72949) (
|
||||
INFILECOM 72951 . 82969) (INFILECOMSVALS 82971 . 83278) (INFILECOMSVAL 83280 . 84288) (INFILECOMSPROP
|
||||
84290 . 85083) (IFCPROPS 85085 . 86165) (IFCEXPRTYPE 86167 . 86783) (IFCPROPSCAN 86785 . 87746) (
|
||||
IFCDECLARE 87748 . 89007) (INFILEPAIRS 89009 . 89308) (INFILECOMSMACRO 89310 . 90328)) (90365 121051 (
|
||||
FILES? 90375 . 92486) (FILES?1 92488 . 93190) (FILES?PRINTLST 93192 . 93974) (ADDTOFILES? 93976 .
|
||||
104519) (ADDTOFILE 104521 . 105437) (WHATIS 105439 . 107415) (ADDTOCOMS 107417 . 108955) (ADDTOCOM
|
||||
108957 . 115444) (ADDTOCOM1 115446 . 116617) (ADDNEWCOM 116619 . 117669) (MAKENEWCOM 117671 . 119518)
|
||||
(DEFAULTMAKENEWCOM 119520 . 121049)) (121121 123938 (MERGEINSERT 121131 . 123474) (MERGEINSERT1 123476
|
||||
. 123936)) (124092 125453 (ADDTOFILEKEYLST 124102 . 125451)) (125570 136371 (DELFROMFILES 125580 .
|
||||
126410) (DELFROMCOMS 126412 . 128091) (DELFROMCOM 128093 . 133858) (DELFROMCOM1 133860 . 134659) (
|
||||
REMOVEITEM 134661 . 135537) (MOVETOFILE 135539 . 136369)) (136585 138956 (SAVEPUT 136595 . 138954)) (
|
||||
139081 147324 (UNMARKASCHANGED 139091 . 140575) (PREEDITFN 140577 . 143058) (POSTEDITPROPS 143060 .
|
||||
145354) (POSTEDITALISTS 145356 . 147322)) (147469 166939 (ALISTS.GETDEF 147479 . 147858) (
|
||||
ALISTS.WHENCHANGED 147860 . 148506) (CLEARCLISPARRAY 148508 . 149686) (EXPRESSIONS.WHENCHANGED 149688
|
||||
. 150066) (MAKEALISTCOMS 150068 . 151083) (MAKEFILESCOMS 151085 . 152415) (MAKELISPXMACROSCOMS 152417
|
||||
. 154435) (MAKEPROPSCOMS 154437 . 155063) (MAKEUSERMACROSCOMS 155065 . 156882) (PROPS.WHENCHANGED
|
||||
156884 . 157505) (FILEGETDEF.LISPXMACROS 157507 . 158806) (FILEGETDEF.ALISTS 158808 . 159399) (
|
||||
FILEGETDEF.RECORDS 159401 . 160328) (FILEGETDEF.PROPS 160330 . 161125) (FILEGETDEF.MACROS 161127 .
|
||||
162009) (FILEGETDEF.VARS 162011 . 162614) (FILEGETDEF.FNS 162616 . 163856) (FILEPKGCOMS.PUTDEF 163858
|
||||
. 165800) (FILES.PUTDEF 165802 . 166670) (VARS.PUTDEF 166672 . 166815) (FILES.WHENCHANGED 166817 .
|
||||
166937)) (168961 176192 (RENAME 168971 . 170416) (CHANGECALLERS 170418 . 176190)) (176193 224102 (
|
||||
SHOWDEF 176203 . 177400) (COPYDEF 177402 . 180150) (GETDEF 180152 . 182695) (GETDEFCOM 182697 . 183663
|
||||
) (GETDEFCOM0 183665 . 184858) (GETDEFCURRENT 184860 . 191172) (GETDEFERR 191174 . 192444) (
|
||||
GETDEFFROMFILE 192446 . 196675) (GETDEFSAVED 196677 . 197765) (PUTDEF 197767 . 198474) (EDITDEF 198476
|
||||
. 199459) (DEFAULT.EDITDEF 199461 . 202299) (EDITDEF.FILES 202301 . 202506) (LOADDEF 202508 . 202684)
|
||||
(DWIMDEF 202686 . 203540) (DELDEF 203542 . 206436) (DELFROMLIST 206438 . 206942) (HASDEF 206944 .
|
||||
213181) (GETFILEDEF 213183 . 213695) (SAVEDEF 213697 . 215385) (UNSAVEDEF 215387 . 216283) (
|
||||
COMPAREDEFS 216285 . 220091) (COMPARE 220093 . 220797) (TYPESOF 220799 . 224100)) (224252 232500 (
|
||||
FILEPKGCOM 224262 . 229038) (FILEPKGTYPE 229040 . 232498)) (244533 262222 (FINDCALLERS 244543 . 245173
|
||||
) (EDITCALLERS 245175 . 256106) (EDITFROMFILE 256108 . 261537) (FINDATS 261539 . 261811) (LOOKIN
|
||||
261813 . 262220)) (262223 263894 (SEPRCASE 262233 . 263892)) (264411 269414 (IMPORTFILE 264421 .
|
||||
265391) (IMPORTEVAL 265393 . 266279) (IMPORTFILESCAN 266281 . 266694) (CHECKIMPORTS 266696 . 267952) (
|
||||
GATHEREXPORTS 267954 . 268822) (\DUMPEXPORTS 268824 . 269412)) (269752 271822 (CLEARFILEPKG 269762 .
|
||||
271820)))))
|
||||
(FILEMAP (NIL (18893 20566 (SEARCHPRETTYTYPELST 18903 . 19872) (PRETTYDEFMACROS 19874 . 20310) (
|
||||
FILEPKGCOMPROPS 20312 . 20564)) (21379 55778 (CLEANUP 21389 . 22779) (COMPILEFILES 22781 . 23057) (
|
||||
COMPILEFILES0 23059 . 23872) (CONTINUEDIT 23874 . 25251) (MAKEFILE 25253 . 36979) (FILECHANGES 36981
|
||||
. 39745) (FILEPKG.MERGECHANGES 39747 . 40382) (FILEPKG.CHANGEDFNS 40384 . 40696) (MAKEFILE1 40698 .
|
||||
44910) (COMPILE-FILE? 44912 . 46606) (MAKEFILES 46608 . 48136) (ADDFILE 48138 . 50681) (ADDFILE0 50683
|
||||
. 54807) (LISTFILES 54809 . 55776)) (56450 90249 (FILEPKGCHANGES 56460 . 57639) (GETFILEPKGTYPE 57641
|
||||
. 60591) (MARKASCHANGED 60593 . 62224) (FILECOMS 62226 . 62610) (WHEREIS 62612 . 64354) (
|
||||
SMASHFILECOMS 64356 . 64584) (FILEFNSLST 64586 . 64752) (FILECOMSLST 64754 . 65240) (UPDATEFILES 65242
|
||||
. 69740) (INFILECOMS? 69742 . 71585) (INFILECOMTAIL 71587 . 72705) (INFILECOMS 72707 . 72868) (
|
||||
INFILECOM 72870 . 82888) (INFILECOMSVALS 82890 . 83197) (INFILECOMSVAL 83199 . 84207) (INFILECOMSPROP
|
||||
84209 . 85002) (IFCPROPS 85004 . 86084) (IFCEXPRTYPE 86086 . 86702) (IFCPROPSCAN 86704 . 87665) (
|
||||
IFCDECLARE 87667 . 88926) (INFILEPAIRS 88928 . 89227) (INFILECOMSMACRO 89229 . 90247)) (90284 120970 (
|
||||
FILES? 90294 . 92405) (FILES?1 92407 . 93109) (FILES?PRINTLST 93111 . 93893) (ADDTOFILES? 93895 .
|
||||
104438) (ADDTOFILE 104440 . 105356) (WHATIS 105358 . 107334) (ADDTOCOMS 107336 . 108874) (ADDTOCOM
|
||||
108876 . 115363) (ADDTOCOM1 115365 . 116536) (ADDNEWCOM 116538 . 117588) (MAKENEWCOM 117590 . 119437)
|
||||
(DEFAULTMAKENEWCOM 119439 . 120968)) (121040 123857 (MERGEINSERT 121050 . 123393) (MERGEINSERT1 123395
|
||||
. 123855)) (124011 125372 (ADDTOFILEKEYLST 124021 . 125370)) (125489 136290 (DELFROMFILES 125499 .
|
||||
126329) (DELFROMCOMS 126331 . 128010) (DELFROMCOM 128012 . 133777) (DELFROMCOM1 133779 . 134578) (
|
||||
REMOVEITEM 134580 . 135456) (MOVETOFILE 135458 . 136288)) (136504 138875 (SAVEPUT 136514 . 138873)) (
|
||||
139000 147243 (UNMARKASCHANGED 139010 . 140494) (PREEDITFN 140496 . 142977) (POSTEDITPROPS 142979 .
|
||||
145273) (POSTEDITALISTS 145275 . 147241)) (147388 167392 (ALISTS.GETDEF 147398 . 147777) (
|
||||
ALISTS.WHENCHANGED 147779 . 148425) (CLEARCLISPARRAY 148427 . 149605) (EXPRESSIONS.WHENCHANGED 149607
|
||||
. 149985) (MAKEALISTCOMS 149987 . 151002) (MAKEFILESCOMS 151004 . 152334) (MAKELISPXMACROSCOMS 152336
|
||||
. 154354) (MAKEPROPSCOMS 154356 . 154982) (MAKEUSERMACROSCOMS 154984 . 156801) (PROPS.WHENCHANGED
|
||||
156803 . 157424) (FILEGETDEF.LISPXMACROS 157426 . 158725) (FILEGETDEF.ALISTS 158727 . 159318) (
|
||||
FILEGETDEF.RECORDS 159320 . 160247) (FILEGETDEF.PROPS 160249 . 161044) (FILEGETDEF.MACROS 161046 .
|
||||
161928) (FILEGETDEF.VARS 161930 . 162533) (FILEGETDEF.FNS 162535 . 164309) (FILEPKGCOMS.PUTDEF 164311
|
||||
. 166253) (FILES.PUTDEF 166255 . 167123) (VARS.PUTDEF 167125 . 167268) (FILES.WHENCHANGED 167270 .
|
||||
167390)) (169414 176645 (RENAME 169424 . 170869) (CHANGECALLERS 170871 . 176643)) (176646 224749 (
|
||||
SHOWDEF 176656 . 177853) (COPYDEF 177855 . 180603) (GETDEF 180605 . 183148) (GETDEFCOM 183150 . 184116
|
||||
) (GETDEFCOM0 184118 . 185311) (GETDEFCURRENT 185313 . 191819) (GETDEFERR 191821 . 193091) (
|
||||
GETDEFFROMFILE 193093 . 197322) (GETDEFSAVED 197324 . 198412) (PUTDEF 198414 . 199121) (EDITDEF 199123
|
||||
. 200106) (DEFAULT.EDITDEF 200108 . 202946) (EDITDEF.FILES 202948 . 203153) (LOADDEF 203155 . 203331)
|
||||
(DWIMDEF 203333 . 204187) (DELDEF 204189 . 207083) (DELFROMLIST 207085 . 207589) (HASDEF 207591 .
|
||||
213828) (GETFILEDEF 213830 . 214342) (SAVEDEF 214344 . 216032) (UNSAVEDEF 216034 . 216930) (
|
||||
COMPAREDEFS 216932 . 220738) (COMPARE 220740 . 221444) (TYPESOF 221446 . 224747)) (224899 233147 (
|
||||
FILEPKGCOM 224909 . 229685) (FILEPKGTYPE 229687 . 233145)) (245180 262869 (FINDCALLERS 245190 . 245820
|
||||
) (EDITCALLERS 245822 . 256753) (EDITFROMFILE 256755 . 262184) (FINDATS 262186 . 262458) (LOOKIN
|
||||
262460 . 262867)) (262870 264541 (SEPRCASE 262880 . 264539)) (265058 270251 (IMPORTFILE 265068 .
|
||||
266038) (IMPORTEVAL 266040 . 266926) (IMPORTFILESCAN 266928 . 267531) (CHECKIMPORTS 267533 . 268789) (
|
||||
GATHEREXPORTS 268791 . 269659) (\DUMPEXPORTS 269661 . 270249)) (270589 272659 (CLEARFILEPKG 270599 .
|
||||
272657)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,12 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED " 7-Aug-2025 10:11:01" {WMEDLEY}<sources>FILESETS.;24 6210
|
||||
(FILECREATED "23-Feb-2026 10:32:36" {WMEDLEY}<sources>FILESETS.;32 6226
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (VARS 0LISPSET)
|
||||
|
||||
:PREVIOUS-DATE "10-Jun-2025 18:00:09" {WMEDLEY}<sources>FILESETS.;23)
|
||||
:PREVIOUS-DATE "23-Feb-2026 09:36:51" {WMEDLEY}<sources>FILESETS.;31)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT FILESETSCOMS)
|
||||
@@ -48,10 +48,10 @@
|
||||
|
||||
(RPAQQ FILESETS (0LISPSET 1LISPSET 2LISPSET 3LISPSET))
|
||||
|
||||
(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 IOCHAR MCCS LLCHAR LLSTK
|
||||
LLDATATYPE LLKEY LLTIMER))
|
||||
(RPAQQ 0LISPSET (PACKAGE-CONVERSION-TABLE LLFAULT LLSUBRS LLBFS LLNEW FILEIO LLARRAYELT
|
||||
EXTERNALFORMAT IOCHAR UNICODE-FORMATS IMAGEIO LLBASIC LLGC LLINTERP LLMVS
|
||||
DEFSTRUCT-RUN-TIME SETF-RUNTIME CMLSEQBASICS LLARITH LLFLOAT LLBIGNUM LLREAD
|
||||
MCCS LLCHAR LLSTK LLDATATYPE LLKEY LLTIMER))
|
||||
|
||||
(RPAQQ 1LISPSET
|
||||
(ASTACK DTDECLARE ATBL LLCODE ACODE COREIO AOFD ADIR PMAP VANILLADISK ATERM APRINT ABASIC
|
||||
|
||||
618
sources/FONT
618
sources/FONT
File diff suppressed because it is too large
Load Diff
Binary file not shown.
@@ -1,20 +1,19 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
(FILECREATED "15-Sep-94 11:08:59" {DSK}<lispcore>sources>LLARRAYELT.;7 155360
|
||||
|
||||
changes to%: (RECORDS ARRAYP)
|
||||
(FILECREATED "22-Feb-2026 13:54:48" {WMEDLEY}<sources>LLARRAYELT.;2 169614
|
||||
|
||||
previous date%: "28-Jul-94 13:41:50" {DSK}<lispcore>sources>LLARRAYELT.;6)
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (VARS LLARRAYELTCOMS)
|
||||
|
||||
:PREVIOUS-DATE "15-Sep-94 11:08:59" {WMEDLEY}<sources>LLARRAYELT.;1)
|
||||
|
||||
(* ; "
|
||||
Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994 by Venue & Xerox Corporation. All rights reserved.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT LLARRAYELTCOMS)
|
||||
|
||||
(RPAQQ LLARRAYELTCOMS
|
||||
(RPAQQ LLARRAYELTCOMS
|
||||
[(COMS (* ;
|
||||
"Because we use the UNLESSINEW macro in this file, we need it when compiling.")
|
||||
"Because we use the UNLESSINEW macro in this file, we need it when compiling.")
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY (FILES (SOURCE)
|
||||
RENAMEMACROS)))
|
||||
(PROPS (LLARRAYELT FILETYPE))
|
||||
@@ -26,6 +25,10 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992,
|
||||
(FNS HARRAY HASHARRAY HARRAYP HARRAYPROP HARRAYSIZE CLRHASH MAPHASH GETHASH PUTHASH
|
||||
CL::PUTHASH REMHASH \HASHRECLAIM \HASHACCESS REHASH \COPYHARRAYP
|
||||
\HASHTABLE.DEFPRINT)
|
||||
(COMS (* ; "Originally on MACHINEINDEPENDENT")
|
||||
(FNS DMPHASH HASHOVERFLOW)
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY (MACROS HASHOVERFLOW.ARRAYTEST
|
||||
HASHOVERFLOW.UPDATEARRAY)))
|
||||
(FNS STRINGHASHBITS STRING-EQUAL-HASHBITS)
|
||||
(FNS \STRINGHASHBITS-UFN \STRING-EQUAL-HASHBITS-UFN)
|
||||
(DECLARE%: DONTCOPY (EXPORT (RECORDS HARRAYP)
|
||||
@@ -44,7 +47,7 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992,
|
||||
(DECLARE%: DONTCOPY (MACROS EQPTR BUCKETINDEX FREEBLOCKCHAIN.N)
|
||||
(CONSTANTS \MAXBUCKETINDEX)
|
||||
(* ;
|
||||
"\ADDBASE2 and \ADDBASE4 do \ADDBASE of 2*N and 4*N without boxing")
|
||||
"\ADDBASE2 and \ADDBASE4 do \ADDBASE of 2*N and 4*N without boxing")
|
||||
(EXPORT (MACROS \ADDBASE2 \ADDBASE4 HUNKSIZEFROMNUMBER \BYTELT \BYTESETA
|
||||
\WORDELT)
|
||||
(CONSTANTS * BLOCKGCTYPECONSTANTS)
|
||||
@@ -77,7 +80,7 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992,
|
||||
(FNS \ALLOCHUNK)
|
||||
(VARS \HUNK.PTRSIZES)
|
||||
(* ;
|
||||
"Compiler needs \HUNK.PTRSIZES for creating closure environments")
|
||||
"Compiler needs \HUNK.PTRSIZES for creating closure environments")
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY (EXPORT (MACROS HUNKSIZEFROMNUMBER))
|
||||
(CONSTANTS \HUNK.UNBOXEDSIZES \HUNK.CODESIZES \HUNK.PTRSIZES)
|
||||
(GLOBALVARS \HUNKING? \UNBOXEDHUNK.TYPENUM.TABLE \CODEHUNK.TYPENUM.TABLE
|
||||
@@ -152,7 +155,7 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992,
|
||||
RENAMEMACROS)
|
||||
)
|
||||
|
||||
(PUTPROPS LLARRAYELT FILETYPE :BCOMPL)
|
||||
(PUTPROPS LLARRAYELT FILETYPE :BCOMPL)
|
||||
|
||||
|
||||
|
||||
@@ -407,8 +410,8 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992,
|
||||
(DECLARE%: DONTCOPY
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
[PUTPROPS ARRAYSIZE DMACRO ((A)
|
||||
(ffetch (ARRAYP LENGTH) of (\DTEST A 'ARRAYP]
|
||||
(PUTPROPS ARRAYSIZE DMACRO [(A)
|
||||
(ffetch (ARRAYP LENGTH) of (\DTEST A 'ARRAYP])
|
||||
)
|
||||
)
|
||||
(DEFINEQ
|
||||
@@ -996,6 +999,108 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992,
|
||||
"Return T to say we printed it ourselves")
|
||||
T])
|
||||
)
|
||||
|
||||
|
||||
|
||||
(* ; "Originally on MACHINEINDEPENDENT")
|
||||
|
||||
(DEFINEQ
|
||||
|
||||
(DMPHASH
|
||||
[NLAMBDA L (* rmk%: " 6-Apr-84 14:30")
|
||||
(MAPC L (FUNCTION (LAMBDA (ARRAYNAME)
|
||||
(DECLARE (SPECVARS ARRAYNAME))
|
||||
(ERSETQ (PROG ((A (EVALV ARRAYNAME 'DMPHASH))
|
||||
AP)
|
||||
[PRINT (LIST 'RPAQ ARRAYNAME
|
||||
(COND
|
||||
[(LISTP A)
|
||||
(SETQ AP (CAR A))
|
||||
(LIST 'CONS [LIST 'HARRAY (HARRAYSIZE AP)
|
||||
(KWOTE (HARRAYPROP
|
||||
AP
|
||||
'OVERFLOW]
|
||||
(KWOTE (CDR A]
|
||||
(T (LIST 'HASHARRAY (HARRAYSIZE A)
|
||||
(KWOTE (HARRAYPROP AP 'OVERFLOW]
|
||||
(MAPHASH (OR AP A)
|
||||
(FUNCTION (LAMBDA (VAL ITEM)
|
||||
(PRINT (LIST 'PUTHASH (KWOTE ITEM)
|
||||
(KWOTE VAL)
|
||||
ARRAYNAME])
|
||||
|
||||
(HASHOVERFLOW
|
||||
[LAMBDA (HARRAY) (* ; "Edited 26-Feb-91 13:16 by jds")
|
||||
|
||||
(* ;; "Should be called from PUTHASH on hash overflow, but for implementations where PUTHASH calls ERRORX directly, may be called from ERRORX2 when the offender is a listp. HARRAY is guaranteed to be either HARRAYP or (LIST HARRAYP)")
|
||||
|
||||
(PROG ((OLDARRAY (HASHOVERFLOW.ARRAYTEST HARRAY))
|
||||
NEWARRAY NEWSIZE OLDNUMKEYS OVACTION NEWOVFLW)
|
||||
[COND
|
||||
((LISTP HARRAY)
|
||||
(SETQ OVACTION (CDR HARRAY))
|
||||
|
||||
(* ;; "Get OVERFLOW method from original HARRAY since it would erroneously be ERROR if we got the method from the coerced OLDARRAY")
|
||||
|
||||
(SETQ NEWOVFLW 'ERROR))
|
||||
(T (SETQ OVACTION (SETQ NEWOVFLW (HARRAYPROP OLDARRAY 'OVERFLOW]
|
||||
(SETQ OLDNUMKEYS (HARRAYPROP OLDARRAY 'NUMKEYS))
|
||||
|
||||
(* ;; "Compute the new array size:")
|
||||
|
||||
[SETQ NEWSIZE (SELECTQ OVACTION
|
||||
(NIL
|
||||
(* ;; "SIZE*1.5 --- favor to bbn, since pdp-11 doesnt have floatng point, and LRSH on other systems might be faster than IQUOTIENT")
|
||||
|
||||
(* ;;
|
||||
"[32749 IS THE BIGGEST PRIME < 32765, THE LIMIT ON ARRAY SIZES]")
|
||||
|
||||
[IMAX (+ OLDNUMKEYS 3)
|
||||
(IMIN 32749 (+ OLDNUMKEYS (LRSH (CL:1+ OLDNUMKEYS)
|
||||
1])
|
||||
(ERROR (do (ERRORX (LIST 26 HARRAY))))
|
||||
(if (FLOATP OVACTION)
|
||||
then [IMAX (+ OLDNUMKEYS 3)
|
||||
(IMIN 32760 (FIXR (FTIMES OLDNUMKEYS OVACTION]
|
||||
elseif (FIXP OVACTION)
|
||||
then (IMAX (+ OLDNUMKEYS 3)
|
||||
(IMIN 32749 (+ OLDNUMKEYS OVACTION)))
|
||||
elseif [AND (FNTYP OVACTION)
|
||||
(NUMBERP (SETQ OVACTION (APPLY* OVACTION HARRAY]
|
||||
then (if (FLOATP OVACTION)
|
||||
then (* ;
|
||||
"recompute NUMKEYS since OVACTION might have removed keys")
|
||||
[IMAX (+ (SETQ OLDNUMKEYS (HARRAYPROP OLDARRAY
|
||||
'NUMKEYS))
|
||||
3)
|
||||
(IMIN 32749 (FIXR (FTIMES OLDNUMKEYS OVACTION]
|
||||
else OVACTION)
|
||||
else (* ; "Default: multiply by 1.5")
|
||||
(SETQ OLDNUMKEYS (HARRAYPROP OLDARRAY 'NUMKEYS))
|
||||
(IMAX (+ OLDNUMKEYS 3)
|
||||
(IMIN 32749 (+ OLDNUMKEYS (LRSH (CL:1+ OLDNUMKEYS)
|
||||
1]
|
||||
[SETQ NEWARRAY (REHASH OLDARRAY (HASHARRAY NEWSIZE NEWOVFLW (HARRAYPROP OLDARRAY
|
||||
'HASHBITSFN)
|
||||
(HARRAYPROP OLDARRAY 'EQUIVFN]
|
||||
(HASHOVERFLOW.UPDATEARRAY HARRAY NEWARRAY OLDARRAY)
|
||||
(RETURN HARRAY])
|
||||
)
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
[PROGN (PUTPROPS HASHOVERFLOW.ARRAYTEST MACRO [(HARRAY)
|
||||
(CAR (OR (LISTP HARRAY)
|
||||
(ERRORX (LIST 27 HARRAY])
|
||||
(PUTPROPS HASHOVERFLOW.ARRAYTEST DMACRO ((HARRAY)
|
||||
(\DTEST HARRAY 'HARRAYP)))]
|
||||
|
||||
[PROGN (PUTPROPS HASHOVERFLOW.UPDATEARRAY MACRO ((HARRAY NEWARRAY OLDARRAY)
|
||||
(FRPLACA HARRAY NEWARRAY)))
|
||||
(PUTPROPS HASHOVERFLOW.UPDATEARRAY DMACRO ((HARRAY NEWARRAY OLDARRAY)
|
||||
(\COPYHARRAYP NEWARRAY OLDARRAY)))]
|
||||
)
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
(STRINGHASHBITS
|
||||
@@ -1048,20 +1153,20 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992,
|
||||
(DECLARE%: DONTCOPY
|
||||
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(DATATYPE HARRAYP ((NULLSLOTS WORD) (* ;
|
||||
"Number of NIL-NIL slots, which break chains")
|
||||
(LASTINDEX WORD) (* ; "Slot offset of last slot. Used in probe computations computations. Microcode support for \ADDBASE4 would help")
|
||||
(HARRAYPBASE POINTER)
|
||||
(RECLAIMABLE FLAG) (* ;
|
||||
"True if keys can go away when no other refs")
|
||||
(OVERFLOWACTION POINTER)
|
||||
(NUMSLOTS WORD) (* ;
|
||||
"The maximum number of logical slots--returned by HARRAYSIZE")
|
||||
(NUMKEYS WORD) (* ;
|
||||
"The number of distinct keys in the array")
|
||||
(HASHBITSFN POINTER)
|
||||
(EQUIVFN POINTER)
|
||||
(HASHUSERDATA POINTER)))
|
||||
(DATATYPE HARRAYP ((NULLSLOTS WORD) (* ;
|
||||
"Number of NIL-NIL slots, which break chains")
|
||||
(LASTINDEX WORD) (* ; "Slot offset of last slot. Used in probe computations computations. Microcode support for \ADDBASE4 would help")
|
||||
(HARRAYPBASE POINTER)
|
||||
(RECLAIMABLE FLAG) (* ;
|
||||
"True if keys can go away when no other refs")
|
||||
(OVERFLOWACTION POINTER)
|
||||
(NUMSLOTS WORD) (* ;
|
||||
"The maximum number of logical slots--returned by HARRAYSIZE")
|
||||
(NUMKEYS WORD) (* ;
|
||||
"The number of distinct keys in the array")
|
||||
(HASHBITSFN POINTER)
|
||||
(EQUIVFN POINTER)
|
||||
(HASHUSERDATA POINTER)))
|
||||
)
|
||||
|
||||
(/DECLAREDATATYPE 'HARRAYP '(WORD WORD POINTER FLAG POINTER WORD WORD POINTER POINTER POINTER)
|
||||
@@ -1078,14 +1183,14 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992,
|
||||
'14)
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
[PUTPROPS \EQHASHINGBITS MACRO (OPENLAMBDA (X) (* ;
|
||||
"Spread out objects whose low bits are in small arithmetic progression, esp atoms")
|
||||
(LOGXOR (\HILOC X)
|
||||
(LOGXOR (LLSH (LOGAND (\LOLOC X)
|
||||
8191)
|
||||
3)
|
||||
(LRSH (\LOLOC X)
|
||||
9]
|
||||
(PUTPROPS \EQHASHINGBITS MACRO [OPENLAMBDA (X) (* ;
|
||||
"Spread out objects whose low bits are in small arithmetic progression, esp atoms")
|
||||
(LOGXOR (\HILOC X)
|
||||
(LOGXOR (LLSH (LOGAND (\LOLOC X)
|
||||
8191)
|
||||
3)
|
||||
(LRSH (\LOLOC X)
|
||||
9])
|
||||
)
|
||||
|
||||
(* "END EXPORTED DEFINITIONS")
|
||||
@@ -1094,21 +1199,20 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992,
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(BLOCKRECORD HASHSLOT ((KEY POINTER)
|
||||
(VALUE POINTER))
|
||||
[ACCESSFNS ((NEXTSLOT (\ADDBASE DATUM (UNFOLD WORDSPERCELL CELLSPERSLOT])
|
||||
(VALUE POINTER))
|
||||
[ACCESSFNS ((NEXTSLOT (\ADDBASE DATUM (UNFOLD WORDSPERCELL CELLSPERSLOT])
|
||||
)
|
||||
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
[PUTPROPS \FIRSTINDEX MACRO ((BITS APTR1)
|
||||
(IREMAINDER BITS (ADD1 (fetch (HARRAYP LASTINDEX) of APTR1]
|
||||
(PUTPROPS \FIRSTINDEX MACRO [(BITS APTR1)
|
||||
(IREMAINDER BITS (ADD1 (fetch (HARRAYP LASTINDEX) of APTR1])
|
||||
|
||||
(PUTPROPS \HASHSLOT MACRO (= . \ADDBASE4))
|
||||
(PUTPROPS \HASHSLOT MACRO (= . \ADDBASE4))
|
||||
|
||||
(PUTPROPS \REPROBE MACRO ((BITS HA)
|
||||
(PUTPROPS \REPROBE MACRO ((BITS HA)
|
||||
(LOGOR [IREMAINDER (LOGXOR BITS (LRSH BITS 8))
|
||||
(IMIN 64 (ADD1 (fetch (HARRAYP LASTINDEX)
|
||||
of HA]
|
||||
(IMIN 64 (ADD1 (fetch (HARRAYP LASTINDEX) of HA]
|
||||
1)))
|
||||
)
|
||||
|
||||
@@ -1145,15 +1249,15 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992,
|
||||
(ADDTOVAR SYSTEMRECLST
|
||||
|
||||
(DATATYPE HARRAYP ((NULLSLOTS WORD)
|
||||
(LASTINDEX WORD)
|
||||
(HARRAYPBASE POINTER)
|
||||
(RECLAIMABLE FLAG)
|
||||
(OVERFLOWACTION POINTER)
|
||||
(NUMSLOTS WORD)
|
||||
(NUMKEYS WORD)
|
||||
(HASHBITSFN POINTER)
|
||||
(EQUIVFN POINTER)
|
||||
(HASHUSERDATA POINTER)))
|
||||
(LASTINDEX WORD)
|
||||
(HARRAYPBASE POINTER)
|
||||
(RECLAIMABLE FLAG)
|
||||
(OVERFLOWACTION POINTER)
|
||||
(NUMSLOTS WORD)
|
||||
(NUMKEYS WORD)
|
||||
(HASHBITSFN POINTER)
|
||||
(EQUIVFN POINTER)
|
||||
(HASHUSERDATA POINTER)))
|
||||
)
|
||||
|
||||
(RPAQQ \HASH.NULL.VALUE \Hash\Null\Value\)
|
||||
@@ -1277,14 +1381,14 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992,
|
||||
(DECLARE%: DONTCOPY
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(PUTPROPS EQPTR DMACRO (= . EQ))
|
||||
(PUTPROPS EQPTR DMACRO (= . EQ))
|
||||
|
||||
(PUTPROPS BUCKETINDEX MACRO ((N)
|
||||
(PUTPROPS BUCKETINDEX MACRO ((N)
|
||||
(IMIN (INTEGERLENGTH N)
|
||||
\MAXBUCKETINDEX)))
|
||||
|
||||
[PUTPROPS FREEBLOCKCHAIN.N MACRO ((N)
|
||||
(\ADDBASE2 \FREEBLOCKBUCKETS (BUCKETINDEX N]
|
||||
(PUTPROPS FREEBLOCKCHAIN.N MACRO ((N)
|
||||
(\ADDBASE2 \FREEBLOCKBUCKETS (BUCKETINDEX N))))
|
||||
)
|
||||
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
@@ -1297,43 +1401,43 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992,
|
||||
|
||||
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(PUTPROPS \ADDBASE2 MACRO (OPENLAMBDA (BASE N)
|
||||
(\ADDBASE (\ADDBASE BASE N)
|
||||
N)))
|
||||
(PUTPROPS \ADDBASE2 MACRO (OPENLAMBDA (BASE N)
|
||||
(\ADDBASE (\ADDBASE BASE N)
|
||||
N)))
|
||||
|
||||
(PUTPROPS \ADDBASE4 MACRO (OPENLAMBDA (BASE N)
|
||||
(\ADDBASE2 (\ADDBASE2 BASE N)
|
||||
N)))
|
||||
(PUTPROPS \ADDBASE4 MACRO (OPENLAMBDA (BASE N)
|
||||
(\ADDBASE2 (\ADDBASE2 BASE N)
|
||||
N)))
|
||||
|
||||
(PUTPROPS HUNKSIZEFROMNUMBER MACRO ((NTYPX)
|
||||
(PUTPROPS HUNKSIZEFROMNUMBER MACRO ((NTYPX)
|
||||
(FOLDLO (fetch DTDSIZE of (\GETDTD NTYPX))
|
||||
WORDSPERCELL)))
|
||||
|
||||
[PUTPROPS \BYTELT DMACRO (OPENLAMBDA (A J)
|
||||
(\GETBASEBYTE (fetch (ARRAYP BASE) of A)
|
||||
(IPLUS (fetch (ARRAYP OFFST) of A)
|
||||
J]
|
||||
(PUTPROPS \BYTELT DMACRO (OPENLAMBDA (A J)
|
||||
(\GETBASEBYTE (fetch (ARRAYP BASE) of A)
|
||||
(IPLUS (fetch (ARRAYP OFFST) of A)
|
||||
J))))
|
||||
|
||||
(PUTPROPS \BYTESETA DMACRO (OPENLAMBDA (A J V)
|
||||
(\PUTBASEBYTE (fetch (ARRAYP BASE) of A)
|
||||
(IPLUS (fetch (ARRAYP OFFST) of A)
|
||||
J)
|
||||
V)))
|
||||
(PUTPROPS \BYTESETA DMACRO (OPENLAMBDA (A J V)
|
||||
(\PUTBASEBYTE (fetch (ARRAYP BASE) of A)
|
||||
(IPLUS (fetch (ARRAYP OFFST) of A)
|
||||
J)
|
||||
V)))
|
||||
|
||||
[PUTPROPS \WORDELT DMACRO (OPENLAMBDA (A J)
|
||||
[CHECK (AND (ARRAYP A)
|
||||
(EQ 0 (fetch (ARRAYP ORIG) of A))
|
||||
(EQ \ST.POS16 (fetch (ARRAYP TYP) of A]
|
||||
(CHECK (IGREATERP (fetch (ARRAYP LENGTH) of A)
|
||||
J))
|
||||
(\GETBASE (fetch (ARRAYP BASE) of A)
|
||||
(IPLUS (fetch (ARRAYP OFFST) of A)
|
||||
J]
|
||||
(PUTPROPS \WORDELT DMACRO (OPENLAMBDA (A J)
|
||||
[CHECK (AND (ARRAYP A)
|
||||
(EQ 0 (fetch (ARRAYP ORIG) of A))
|
||||
(EQ \ST.POS16 (fetch (ARRAYP TYP) of A]
|
||||
(CHECK (IGREATERP (fetch (ARRAYP LENGTH) of A)
|
||||
J))
|
||||
(\GETBASE (fetch (ARRAYP BASE) of A)
|
||||
(IPLUS (fetch (ARRAYP OFFST) of A)
|
||||
J))))
|
||||
)
|
||||
|
||||
(RPAQQ BLOCKGCTYPECONSTANTS ((CODEBLOCK.GCT 2)
|
||||
(PTRBLOCK.GCT 1)
|
||||
(UNBOXEDBLOCK.GCT 0)))
|
||||
(PTRBLOCK.GCT 1)
|
||||
(UNBOXEDBLOCK.GCT 0)))
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(RPAQQ CODEBLOCK.GCT 2)
|
||||
@@ -1348,33 +1452,24 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992,
|
||||
(UNBOXEDBLOCK.GCT 0))
|
||||
)
|
||||
|
||||
(RPAQQ ARRAYCONSTANTS (\ArrayBlockHeaderCells \ArrayBlockHeaderWords \ArrayBlockTrailerCells
|
||||
\ArrayBlockTrailerWords (\ArrayBlockOverheadCells (IPLUS
|
||||
\ArrayBlockHeaderCells
|
||||
|
||||
\ArrayBlockTrailerCells
|
||||
))
|
||||
(\ArrayBlockOverheadWords (IPLUS \ArrayBlockHeaderWords
|
||||
\ArrayBlockTrailerWords))
|
||||
\ArrayBlockLinkingCells
|
||||
(\MinArrayBlockSize (IPLUS \ArrayBlockOverheadCells
|
||||
\ArrayBlockLinkingCells))
|
||||
(\MaxArrayBlockSize 65535)
|
||||
(\MaxArrayNCells (IDIFFERENCE \MaxArrayBlockSize
|
||||
\ArrayBlockOverheadCells))
|
||||
\MaxArrayLen
|
||||
(\ABPASSWORDSHIFT 3)
|
||||
(\ArrayBlockPassword (LRSH 43690 \ABPASSWORDSHIFT))
|
||||
(\FreeArrayFlagWord (LOGOR (LLSH \ArrayBlockPassword
|
||||
\ABPASSWORDSHIFT)
|
||||
(LLSH UNBOXEDBLOCK.GCT 1)))
|
||||
(\UsedArrayFlagWord (LOGOR (LLSH \ArrayBlockPassword
|
||||
\ABPASSWORDSHIFT)
|
||||
1))
|
||||
(\CodeArrayFlagWord (LOGOR (LLSH \ArrayBlockPassword
|
||||
\ABPASSWORDSHIFT)
|
||||
(LLSH CODEBLOCK.GCT 1)
|
||||
1))))
|
||||
(RPAQQ ARRAYCONSTANTS
|
||||
(\ArrayBlockHeaderCells \ArrayBlockHeaderWords \ArrayBlockTrailerCells \ArrayBlockTrailerWords
|
||||
(\ArrayBlockOverheadCells (IPLUS \ArrayBlockHeaderCells \ArrayBlockTrailerCells))
|
||||
(\ArrayBlockOverheadWords (IPLUS \ArrayBlockHeaderWords \ArrayBlockTrailerWords))
|
||||
\ArrayBlockLinkingCells
|
||||
(\MinArrayBlockSize (IPLUS \ArrayBlockOverheadCells \ArrayBlockLinkingCells))
|
||||
(\MaxArrayBlockSize 65535)
|
||||
(\MaxArrayNCells (IDIFFERENCE \MaxArrayBlockSize \ArrayBlockOverheadCells))
|
||||
\MaxArrayLen
|
||||
(\ABPASSWORDSHIFT 3)
|
||||
(\ArrayBlockPassword (LRSH 43690 \ABPASSWORDSHIFT))
|
||||
(\FreeArrayFlagWord (LOGOR (LLSH \ArrayBlockPassword \ABPASSWORDSHIFT)
|
||||
(LLSH UNBOXEDBLOCK.GCT 1)))
|
||||
(\UsedArrayFlagWord (LOGOR (LLSH \ArrayBlockPassword \ABPASSWORDSHIFT)
|
||||
1))
|
||||
(\CodeArrayFlagWord (LOGOR (LLSH \ArrayBlockPassword \ABPASSWORDSHIFT)
|
||||
(LLSH CODEBLOCK.GCT 1)
|
||||
1))))
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(RPAQQ \ArrayBlockHeaderCells 1)
|
||||
@@ -1404,14 +1499,14 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992,
|
||||
(RPAQ \ArrayBlockPassword (LRSH 43690 \ABPASSWORDSHIFT))
|
||||
|
||||
(RPAQ \FreeArrayFlagWord (LOGOR (LLSH \ArrayBlockPassword \ABPASSWORDSHIFT)
|
||||
(LLSH UNBOXEDBLOCK.GCT 1)))
|
||||
(LLSH UNBOXEDBLOCK.GCT 1)))
|
||||
|
||||
(RPAQ \UsedArrayFlagWord (LOGOR (LLSH \ArrayBlockPassword \ABPASSWORDSHIFT)
|
||||
1))
|
||||
1))
|
||||
|
||||
(RPAQ \CodeArrayFlagWord (LOGOR (LLSH \ArrayBlockPassword \ABPASSWORDSHIFT)
|
||||
(LLSH CODEBLOCK.GCT 1)
|
||||
1))
|
||||
(LLSH CODEBLOCK.GCT 1)
|
||||
1))
|
||||
|
||||
|
||||
(CONSTANTS \ArrayBlockHeaderCells \ArrayBlockHeaderWords \ArrayBlockTrailerCells
|
||||
@@ -1435,13 +1530,13 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992,
|
||||
)
|
||||
|
||||
(RPAQQ ARRAYTYPES ((\ST.BYTE 0)
|
||||
(\ST.POS16 1)
|
||||
(\ST.INT32 2)
|
||||
(\ST.CODE 4)
|
||||
(\ST.PTR 6)
|
||||
(\ST.FLOAT 7)
|
||||
(\ST.BIT 8)
|
||||
(\ST.PTR2 11)))
|
||||
(\ST.POS16 1)
|
||||
(\ST.INT32 2)
|
||||
(\ST.CODE 4)
|
||||
(\ST.PTR 6)
|
||||
(\ST.FLOAT 7)
|
||||
(\ST.BIT 8)
|
||||
(\ST.PTR2 11)))
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(RPAQQ \ST.BYTE 0)
|
||||
@@ -1487,52 +1582,51 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992,
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(BLOCKRECORD SEQUENCEDESCRIPTOR ((ORIG BITS 1)
|
||||
(NIL BITS 1)
|
||||
(READONLY FLAG)
|
||||
(NIL BITS 1)
|
||||
(BASE POINTER)
|
||||
(TYP BITS 4)
|
||||
(NIL BITS 4)
|
||||
(LENGTH BITS 24)
|
||||
(OFFST FIXP)))
|
||||
(NIL BITS 1)
|
||||
(READONLY FLAG)
|
||||
(NIL BITS 1)
|
||||
(BASE POINTER)
|
||||
(TYP BITS 4)
|
||||
(NIL BITS 4)
|
||||
(LENGTH BITS 24)
|
||||
(OFFST FIXP)))
|
||||
|
||||
(DATATYPE ARRAYP (
|
||||
(* ;; "Describes an INTERLISP ARRAYP, as opposed to a CL array.")
|
||||
(* ;; "Describes an INTERLISP ARRAYP, as opposed to a CL array.")
|
||||
|
||||
(ORIG BITS 1) (* ; "Origin, 0 or 1")
|
||||
(NIL BITS 1)
|
||||
(READONLY FLAG) (* ; "probably no READONLY arrays now")
|
||||
(NIL BITS 1)
|
||||
(BASE POINTER)
|
||||
(TYP BITS 4) (* ; "Type of the contents")
|
||||
(NIL BITS 4)
|
||||
(LENGTH BITS 24) (* ; "Array's length")
|
||||
(OFFST FIXP) (* ;
|
||||
"Offset from BASE where the data really starts.")
|
||||
)
|
||||
(ORIG BITS 1) (* ; "Origin, 0 or 1")
|
||||
(NIL BITS 1)
|
||||
(READONLY FLAG) (* ; "probably no READONLY arrays now")
|
||||
(NIL BITS 1)
|
||||
(BASE POINTER)
|
||||
(TYP BITS 4) (* ; "Type of the contents")
|
||||
(NIL BITS 4)
|
||||
(LENGTH BITS 24) (* ; "Array's length")
|
||||
(OFFST FIXP) (* ;
|
||||
"Offset from BASE where the data really starts.")
|
||||
)
|
||||
|
||||
(* ;; "note that while ARRAYP is a DATATYPE, the allocation of it actually happens at MAKEINIT time under INITDATATYPE{NAMES}")
|
||||
(* ;; "note that while ARRAYP is a DATATYPE, the allocation of it actually happens at MAKEINIT time under INITDATATYPE{NAMES}")
|
||||
|
||||
)
|
||||
)
|
||||
|
||||
(BLOCKRECORD ARRAYBLOCK ((PASSWORD BITS 13)
|
||||
(GCTYPE BITS 2) (* ; "Unboxed, Pointers, or Code")
|
||||
(INUSE FLAG)
|
||||
(ARLEN WORD)
|
||||
(FWD FULLXPOINTER) (* ; "Only when on free list")
|
||||
(BKWD FULLXPOINTER))
|
||||
(BLOCKRECORD ARRAYBLOCK ((ABFLAGS WORD)
|
||||
(GCTYPE BITS 2) (* ; "Unboxed, Pointers, or Code")
|
||||
(INUSE FLAG)
|
||||
(ARLEN WORD)
|
||||
(FWD FULLXPOINTER) (* ; "Only when on free list")
|
||||
(BKWD FULLXPOINTER))
|
||||
(BLOCKRECORD ARRAYBLOCK ((ABFLAGS WORD)
|
||||
(* ; "Used for header and trailer")
|
||||
))
|
||||
[ACCESSFNS ARRAYBLOCK ((DAT (\ADDBASE DATUM \ArrayBlockHeaderWords))
|
||||
(TRAILER (\ADDBASE2 DATUM
|
||||
(IDIFFERENCE (fetch
|
||||
(ARRAYBLOCK ARLEN)
|
||||
of DATUM)
|
||||
))
|
||||
[ACCESSFNS ARRAYBLOCK ((DAT (\ADDBASE DATUM \ArrayBlockHeaderWords))
|
||||
(TRAILER (\ADDBASE2 DATUM (IDIFFERENCE
|
||||
(fetch (ARRAYBLOCK ARLEN)
|
||||
of DATUM)
|
||||
\ArrayBlockTrailerCells]
|
||||
(TYPE? (AND (EQ 0 (NTYPX DATUM))
|
||||
(IGEQ (\HILOC DATUM)
|
||||
\FirstArraySegment))))
|
||||
(TYPE? (AND (EQ 0 (NTYPX DATUM))
|
||||
(IGEQ (\HILOC DATUM)
|
||||
\FirstArraySegment))))
|
||||
)
|
||||
|
||||
(/DECLAREDATATYPE 'ARRAYP '((BITS 1)
|
||||
@@ -2273,8 +2367,8 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992,
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(BLOCKRECORD SAFTABLE ((SAFITEMS WORD)
|
||||
(NIL WORD)
|
||||
(SAFCELLS FIXP)))
|
||||
(NIL WORD)
|
||||
(SAFCELLS FIXP)))
|
||||
)
|
||||
)
|
||||
|
||||
@@ -2484,7 +2578,7 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992,
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY
|
||||
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(PUTPROPS HUNKSIZEFROMNUMBER MACRO ((NTYPX)
|
||||
(PUTPROPS HUNKSIZEFROMNUMBER MACRO ((NTYPX)
|
||||
(FOLDLO (fetch DTDSIZE of (\GETDTD NTYPX))
|
||||
WORDSPERCELL)))
|
||||
)
|
||||
@@ -2494,8 +2588,7 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992,
|
||||
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(RPAQQ \HUNK.UNBOXEDSIZES
|
||||
(1 2 3 4 5 6 7 8 9 10 12 14 16 20 24 28 32 40 48 64))
|
||||
(RPAQQ \HUNK.UNBOXEDSIZES (1 2 3 4 5 6 7 8 9 10 12 14 16 20 24 28 32 40 48 64))
|
||||
|
||||
(RPAQQ \HUNK.CODESIZES (12 16 20 24 28 32 36 42 50 64))
|
||||
|
||||
@@ -2721,49 +2814,49 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992,
|
||||
(DECLARE%: DONTCOPY
|
||||
|
||||
(ADDTOVAR INITVALUES (\NxtArrayPage)
|
||||
(\HUNKING?))
|
||||
(\HUNKING?))
|
||||
|
||||
(ADDTOVAR INITPTRS (\FREEBLOCKBUCKETS)
|
||||
(\ArrayFrLst)
|
||||
(\ArrayFrLst2)
|
||||
(\UNBOXEDHUNK.TYPENUM.TABLE)
|
||||
(\CODEHUNK.TYPENUM.TABLE)
|
||||
(\PTRHUNK.TYPENUM.TABLE))
|
||||
(\ArrayFrLst)
|
||||
(\ArrayFrLst2)
|
||||
(\UNBOXEDHUNK.TYPENUM.TABLE)
|
||||
(\CODEHUNK.TYPENUM.TABLE)
|
||||
(\PTRHUNK.TYPENUM.TABLE))
|
||||
|
||||
(ADDTOVAR INEWCOMS (FNS \#BLOCKDATACELLS \PREFIXALIGNMENT? \ALLOCBLOCK \MAIKO.ALLOCBLOCK
|
||||
\ALLOCBLOCK.NEW \MAKEFREEARRAYBLOCK \MERGEBACKWARD \LINKBLOCK \ALLOCHUNK)
|
||||
(FNS PREINITARRAYS POSTINITARRAYS FILEARRAYBASE FILEBLOCKTRAILER FILECODEBLOCK
|
||||
FILEPATCHBLOCK)
|
||||
(FNS \SETUP.HUNK.TYPENUMBERS \COMPUTE.HUNK.TYPEDECLS \TURN.ON.HUNKING
|
||||
\SETUP.TYPENUM.TABLE))
|
||||
\ALLOCBLOCK.NEW \MAKEFREEARRAYBLOCK \MERGEBACKWARD \LINKBLOCK \ALLOCHUNK)
|
||||
(FNS PREINITARRAYS POSTINITARRAYS FILEARRAYBASE FILEBLOCKTRAILER FILECODEBLOCK
|
||||
FILEPATCHBLOCK)
|
||||
(FNS \SETUP.HUNK.TYPENUMBERS \COMPUTE.HUNK.TYPEDECLS \TURN.ON.HUNKING
|
||||
\SETUP.TYPENUM.TABLE))
|
||||
|
||||
(ADDTOVAR MKI.SUBFNS (\IN.MAKEINIT . T)
|
||||
(\ALLOCBLOCK.OLD . NILL)
|
||||
(\MERGEFORWARD . NILL)
|
||||
(\FIXCODENUM . I.FIXUPNUM)
|
||||
(\FIXCODESYM . I.FIXUPSYM)
|
||||
(\FIXCODEPTR . I.FIXUPPTR)
|
||||
(\CHECKARRAYBLOCK . NILL)
|
||||
(\ARRAYMERGING PROGN NIL))
|
||||
(\ALLOCBLOCK.OLD . NILL)
|
||||
(\MERGEFORWARD . NILL)
|
||||
(\FIXCODENUM . I.FIXUPNUM)
|
||||
(\FIXCODESYM . I.FIXUPSYM)
|
||||
(\FIXCODEPTR . I.FIXUPPTR)
|
||||
(\CHECKARRAYBLOCK . NILL)
|
||||
(\ARRAYMERGING PROGN NIL))
|
||||
|
||||
(ADDTOVAR EXPANDMACROFNS \ADDBASE2 \ADDBASE4 HUNKSIZEFROMNUMBER BUCKETINDEX FREEBLOCKCHAIN.N)
|
||||
|
||||
(ADDTOVAR RDCOMS (FNS \CHECKARRAYBLOCK \PARSEARRAYSPACE \PARSEARRAYSPACE1))
|
||||
|
||||
(ADDTOVAR RD.SUBFNS (EQPTR . EQUAL)
|
||||
(ARRAYBLOCKCHECKING . T))
|
||||
(ARRAYBLOCKCHECKING . T))
|
||||
|
||||
(ADDTOVAR RDPTRS (\FREEBLOCKBUCKETS))
|
||||
|
||||
(ADDTOVAR RDVALS (\ArrayFrLst)
|
||||
(\ArrayFrLst2))
|
||||
(\ArrayFrLst2))
|
||||
EVAL@COMPILE
|
||||
|
||||
(ADDTOVAR DONTCOMPILEFNS PREINITARRAYS POSTINITARRAYS FILEARRAYBASE FILEBLOCKTRAILER
|
||||
FILECODEBLOCK FILEPATCHBLOCK)
|
||||
(ADDTOVAR DONTCOMPILEFNS PREINITARRAYS POSTINITARRAYS FILEARRAYBASE FILEBLOCKTRAILER FILECODEBLOCK
|
||||
FILEPATCHBLOCK)
|
||||
|
||||
(ADDTOVAR DONTCOMPILEFNS \SETUP.HUNK.TYPENUMBERS \COMPUTE.HUNK.TYPEDECLS \TURN.ON.HUNKING
|
||||
\SETUP.TYPENUM.TABLE)
|
||||
\SETUP.TYPENUM.TABLE)
|
||||
)
|
||||
|
||||
|
||||
@@ -2937,32 +3030,174 @@ EVAL@COMPILE
|
||||
|
||||
(ADDTOVAR LAMA CL::PUTHASH HARRAYPROP)
|
||||
)
|
||||
(PUTPROPS LLARRAYELT COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1985 1986 1987 1988 1989
|
||||
1990 1991 1992 1993 1994))
|
||||
(PRETTYCOMPRINT LLARRAYELTCOMS)
|
||||
|
||||
(RPAQQ LLARRAYELTCOMS
|
||||
[(COMS (* ;
|
||||
"Because we use the UNLESSINEW macro in this file, we need it when compiling.")
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY (FILES (SOURCE)
|
||||
RENAMEMACROS)))
|
||||
(PROPS (LLARRAYELT FILETYPE))
|
||||
(COMS (* ; "ARRAY entries")
|
||||
(FNS AIN AOUT ARRAY ARRAYSIZE ARRAYTYP ARRAYORIG COPYARRAY)
|
||||
(DECLARE%: DONTCOPY (MACROS ARRAYSIZE))
|
||||
(FNS ELT ELTD SETA SETD SUBARRAY))
|
||||
[COMS (* ; "HASHARRAY entries")
|
||||
(FNS HARRAY HASHARRAY HARRAYP HARRAYPROP HARRAYSIZE CLRHASH MAPHASH GETHASH PUTHASH
|
||||
CL::PUTHASH REMHASH \HASHRECLAIM \HASHACCESS REHASH \COPYHARRAYP
|
||||
\HASHTABLE.DEFPRINT)
|
||||
(COMS (* ; "Originally on MACHINEINDEPENDENT")
|
||||
(FNS DMPHASH HASHOVERFLOW)
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY (MACROS HASHOVERFLOW.ARRAYTEST
|
||||
HASHOVERFLOW.UPDATEARRAY)))
|
||||
(FNS STRINGHASHBITS STRING-EQUAL-HASHBITS)
|
||||
(FNS \STRINGHASHBITS-UFN \STRING-EQUAL-HASHBITS-UFN)
|
||||
(DECLARE%: DONTCOPY (EXPORT (RECORDS HARRAYP)
|
||||
(MACROS \EQHASHINGBITS))
|
||||
(RECORDS HASHSLOT)
|
||||
(MACROS \FIRSTINDEX \HASHSLOT \REPROBE)
|
||||
(CONSTANTS (CELLSPERSLOT 2))
|
||||
(GLOBALVARS \HASH.NULL.VALUE SYSHASHARRAY))
|
||||
[DECLARE%: DONTEVAL@LOAD DOCOPY (P (DEFPRINT 'HARRAYP '\HASHTABLE.DEFPRINT]
|
||||
(INITRECORDS HARRAYP)
|
||||
(SYSRECORDS HARRAYP)
|
||||
(VARS (\HASH.NULL.VALUE '\Hash\Null\Value\]
|
||||
(COMS (* ; "System entries for CODE")
|
||||
(FNS \CODEARRAY \FIXCODENUM \FIXCODEPTR \FIXCODESYM))
|
||||
(COMS (* ; "Internal")
|
||||
(DECLARE%: DONTCOPY (MACROS EQPTR BUCKETINDEX FREEBLOCKCHAIN.N)
|
||||
(CONSTANTS \MAXBUCKETINDEX)
|
||||
(* ;
|
||||
"\ADDBASE2 and \ADDBASE4 do \ADDBASE of 2*N and 4*N without boxing")
|
||||
(EXPORT (MACROS \ADDBASE2 \ADDBASE4 HUNKSIZEFROMNUMBER \BYTELT \BYTESETA
|
||||
\WORDELT)
|
||||
(CONSTANTS * BLOCKGCTYPECONSTANTS)
|
||||
(CONSTANTS * ARRAYCONSTANTS)
|
||||
(CONSTANTS * ARRAYTYPES)
|
||||
(CONSTANTS \MAX.CELLSPERHUNK)
|
||||
(CONSTANTS (\IN.MAKEINIT))
|
||||
(RECORDS SEQUENCEDESCRIPTOR ARRAYP ARRAYBLOCK)
|
||||
(GLOBALVARS \NxtArrayPage \FREEBLOCKBUCKETS \HUNKING?))
|
||||
(GLOBALVARS \ArrayFrLst \ArrayFrLst2 \RECLAIM.COUNTDOWN))
|
||||
(FNS \ALLOCBLOCK \MAIKO.ALLOCBLOCK \ALLOCBLOCK.OLD \ALLOCBLOCK.NEW \PREFIXALIGNMENT?
|
||||
\MAKEFREEARRAYBLOCK \DELETEBLOCK? \LINKBLOCK \MERGEBACKWARD \MERGEFORWARD
|
||||
\ARRAYBLOCKMERGER \#BLOCKDATACELLS \COPYARRAYBLOCK \RECLAIMARRAYBLOCK
|
||||
\ADVANCE.ARRAY.SEGMENTS)
|
||||
(ADDVARS (\MAIKO.MOVDS (\MAIKO.ALLOCBLOCK \ALLOCBLOCK)))
|
||||
(FNS \BYTELT \BYTESETA \WORDELT)
|
||||
(FNS \ARRAYTYPENAME)
|
||||
(VARS (\ARRAYMERGING T))
|
||||
(GLOBALVARS \ARRAYMERGING)
|
||||
(COMS (* ; "for STORAGE")
|
||||
(FNS \SHOW.ARRAY.FREELISTS)
|
||||
(INITVARS (\ABSTORAGETABLE NIL))
|
||||
(GLOBALVARS \ABSTORAGETABLE)
|
||||
(DECLARE%: DONTCOPY (RECORDS SAFTABLE)))
|
||||
(COMS (* ; "Debugging and RDSYS")
|
||||
(FNS \CHECKARRAYBLOCK \PARSEARRAYSPACE \PARSEARRAYSPACE1)
|
||||
(INITVARS (ARRAYBLOCKCHECKING))
|
||||
(GLOBALVARS ARRAYBLOCKCHECKING)))
|
||||
(COMS (* ; "Basic hunking")
|
||||
(FNS \ALLOCHUNK)
|
||||
(VARS \HUNK.PTRSIZES)
|
||||
(* ;
|
||||
"Compiler needs \HUNK.PTRSIZES for creating closure environments")
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY (EXPORT (MACROS HUNKSIZEFROMNUMBER))
|
||||
(CONSTANTS \HUNK.UNBOXEDSIZES \HUNK.CODESIZES \HUNK.PTRSIZES)
|
||||
(GLOBALVARS \HUNKING? \UNBOXEDHUNK.TYPENUM.TABLE \CODEHUNK.TYPENUM.TABLE
|
||||
\PTRHUNK.TYPENUM.TABLE))
|
||||
(COMS
|
||||
(* ;; "Keep a list of all the hunks rejected due to poor page-straddling alignment, or to code falling off the end of a doublepage")
|
||||
|
||||
(VARS (\HUNKREJECTS))
|
||||
(GLOBALVARS \HUNKREJECTS)))
|
||||
[COMS (* ; "for MAKEINIT")
|
||||
(FNS PREINITARRAYS POSTINITARRAYS FILEARRAYBASE FILEBLOCKTRAILER FILECODEBLOCK
|
||||
FILEPATCHBLOCK)
|
||||
(COMS (* ; "Hunk Initialization")
|
||||
(FNS \SETUP.HUNK.TYPENUMBERS \COMPUTE.HUNK.TYPEDECLS \TURN.ON.HUNKING
|
||||
\SETUP.TYPENUM.TABLE))
|
||||
(DECLARE%: DONTCOPY (ADDVARS (INITVALUES (\NxtArrayPage)
|
||||
(\HUNKING?))
|
||||
(INITPTRS (\FREEBLOCKBUCKETS)
|
||||
(\ArrayFrLst)
|
||||
(\ArrayFrLst2)
|
||||
(\UNBOXEDHUNK.TYPENUM.TABLE)
|
||||
(\CODEHUNK.TYPENUM.TABLE)
|
||||
(\PTRHUNK.TYPENUM.TABLE))
|
||||
(INEWCOMS (FNS \#BLOCKDATACELLS \PREFIXALIGNMENT?
|
||||
\ALLOCBLOCK \MAIKO.ALLOCBLOCK \ALLOCBLOCK.NEW
|
||||
\MAKEFREEARRAYBLOCK \MERGEBACKWARD \LINKBLOCK
|
||||
\ALLOCHUNK)
|
||||
(FNS PREINITARRAYS POSTINITARRAYS FILEARRAYBASE
|
||||
FILEBLOCKTRAILER FILECODEBLOCK FILEPATCHBLOCK)
|
||||
(FNS \SETUP.HUNK.TYPENUMBERS \COMPUTE.HUNK.TYPEDECLS
|
||||
\TURN.ON.HUNKING \SETUP.TYPENUM.TABLE))
|
||||
(MKI.SUBFNS (\IN.MAKEINIT . T)
|
||||
(\ALLOCBLOCK.OLD . NILL)
|
||||
(\MERGEFORWARD . NILL)
|
||||
(\FIXCODENUM . I.FIXUPNUM)
|
||||
(\FIXCODESYM . I.FIXUPSYM)
|
||||
(\FIXCODEPTR . I.FIXUPPTR)
|
||||
(\CHECKARRAYBLOCK . NILL)
|
||||
(\ARRAYMERGING PROGN NIL))
|
||||
(EXPANDMACROFNS \ADDBASE2 \ADDBASE4 HUNKSIZEFROMNUMBER
|
||||
BUCKETINDEX FREEBLOCKCHAIN.N)
|
||||
(RDCOMS (FNS \CHECKARRAYBLOCK \PARSEARRAYSPACE
|
||||
\PARSEARRAYSPACE1))
|
||||
(RD.SUBFNS (EQPTR . EQUAL)
|
||||
(ARRAYBLOCKCHECKING . T))
|
||||
(RDPTRS (\FREEBLOCKBUCKETS))
|
||||
(RDVALS (\ArrayFrLst)
|
||||
(\ArrayFrLst2)))
|
||||
EVAL@COMPILE
|
||||
(ADDVARS (DONTCOMPILEFNS PREINITARRAYS POSTINITARRAYS FILEARRAYBASE
|
||||
FILEBLOCKTRAILER FILECODEBLOCK FILEPATCHBLOCK)
|
||||
(DONTCOMPILEFNS \SETUP.HUNK.TYPENUMBERS \COMPUTE.HUNK.TYPEDECLS
|
||||
\TURN.ON.HUNKING \SETUP.TYPENUM.TABLE]
|
||||
(COMS (* ; "Debugging aids")
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY (GLOBALVARS \ArrayFrLst)
|
||||
(CONSTANTS \ArrayBlockPassword)
|
||||
(ADDVARS (DONTCOMPILEFNS \HUNKFIT? \AB.NEXT \AB.BACK)))
|
||||
(FNS \HUNKFIT? \AB.NEXT \AB.BACK))
|
||||
(LOCALVARS . T)
|
||||
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA DMPHASH)
|
||||
(NLAML)
|
||||
(LAMA CL::PUTHASH
|
||||
HARRAYPROP])
|
||||
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
|
||||
|
||||
(ADDTOVAR NLAMA DMPHASH)
|
||||
|
||||
(ADDTOVAR NLAML )
|
||||
|
||||
(ADDTOVAR LAMA CL::PUTHASH HARRAYPROP)
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (9739 22117 (AIN 9749 . 12022) (AOUT 12024 . 14626) (ARRAY 14628 . 20213) (ARRAYSIZE
|
||||
20215 . 20355) (ARRAYTYP 20357 . 20953) (ARRAYORIG 20955 . 21122) (COPYARRAY 21124 . 22115)) (22283
|
||||
29928 (ELT 22293 . 23722) (ELTD 23724 . 24649) (SETA 24651 . 26908) (SETD 26910 . 27904) (SUBARRAY
|
||||
27906 . 29926)) (29963 55572 (HARRAY 29973 . 30193) (HASHARRAY 30195 . 34218) (HARRAYP 34220 . 34369)
|
||||
(HARRAYPROP 34371 . 38406) (HARRAYSIZE 38408 . 38573) (CLRHASH 38575 . 39947) (MAPHASH 39949 . 41078)
|
||||
(GETHASH 41080 . 44660) (PUTHASH 44662 . 44893) (CL::PUTHASH 44895 . 45607) (REMHASH 45609 . 45754) (
|
||||
\HASHRECLAIM 45756 . 47539) (\HASHACCESS 47541 . 53303) (REHASH 53305 . 54029) (\COPYHARRAYP 54031 .
|
||||
54761) (\HASHTABLE.DEFPRINT 54763 . 55570)) (55573 56129 (STRINGHASHBITS 55583 . 55740) (
|
||||
STRING-EQUAL-HASHBITS 55742 . 56127)) (56130 58192 (\STRINGHASHBITS-UFN 56140 . 57246) (
|
||||
\STRING-EQUAL-HASHBITS-UFN 57248 . 58190)) (62479 67574 (\CODEARRAY 62489 . 63319) (\FIXCODENUM 63321
|
||||
. 63986) (\FIXCODEPTR 63988 . 65048) (\FIXCODESYM 65050 . 67572)) (79255 114491 (\ALLOCBLOCK 79265 .
|
||||
83264) (\MAIKO.ALLOCBLOCK 83266 . 87458) (\ALLOCBLOCK.OLD 87460 . 92331) (\ALLOCBLOCK.NEW 92333 .
|
||||
95339) (\PREFIXALIGNMENT? 95341 . 98884) (\MAKEFREEARRAYBLOCK 98886 . 99481) (\DELETEBLOCK? 99483 .
|
||||
100588) (\LINKBLOCK 100590 . 102716) (\MERGEBACKWARD 102718 . 104079) (\MERGEFORWARD 104081 . 105178)
|
||||
(\ARRAYBLOCKMERGER 105180 . 107365) (\#BLOCKDATACELLS 107367 . 108603) (\COPYARRAYBLOCK 108605 .
|
||||
110173) (\RECLAIMARRAYBLOCK 110175 . 112304) (\ADVANCE.ARRAY.SEGMENTS 112306 . 114489)) (114553 116986
|
||||
(\BYTELT 114563 . 115362) (\BYTESETA 115364 . 116305) (\WORDELT 116307 . 116984)) (116987 117321 (
|
||||
\ARRAYTYPENAME 116997 . 117319)) (117444 121138 (\SHOW.ARRAY.FREELISTS 117454 . 121136)) (121451
|
||||
127201 (\CHECKARRAYBLOCK 121461 . 125836) (\PARSEARRAYSPACE 125838 . 126247) (\PARSEARRAYSPACE1 126249
|
||||
. 127199)) (127335 133601 (\ALLOCHUNK 127345 . 133599)) (134779 140675 (PREINITARRAYS 134789 . 135330
|
||||
) (POSTINITARRAYS 135332 . 138050) (FILEARRAYBASE 138052 . 138464) (FILEBLOCKTRAILER 138466 . 138761)
|
||||
(FILECODEBLOCK 138763 . 139779) (FILEPATCHBLOCK 139781 . 140673)) (140712 146136 (
|
||||
\SETUP.HUNK.TYPENUMBERS 140722 . 141758) (\COMPUTE.HUNK.TYPEDECLS 141760 . 143040) (\TURN.ON.HUNKING
|
||||
143042 . 143714) (\SETUP.TYPENUM.TABLE 143716 . 146134)) (148399 155000 (\HUNKFIT? 148409 . 149024) (
|
||||
\AB.NEXT 149026 . 152221) (\AB.BACK 152223 . 154998)))))
|
||||
(FILEMAP (NIL (9935 22313 (AIN 9945 . 12218) (AOUT 12220 . 14822) (ARRAY 14824 . 20409) (ARRAYSIZE
|
||||
20411 . 20551) (ARRAYTYP 20553 . 21149) (ARRAYORIG 21151 . 21318) (COPYARRAY 21320 . 22311)) (22488
|
||||
30133 (ELT 22498 . 23927) (ELTD 23929 . 24854) (SETA 24856 . 27113) (SETD 27115 . 28109) (SUBARRAY
|
||||
28111 . 30131)) (30168 55777 (HARRAY 30178 . 30398) (HASHARRAY 30400 . 34423) (HARRAYP 34425 . 34574)
|
||||
(HARRAYPROP 34576 . 38611) (HARRAYSIZE 38613 . 38778) (CLRHASH 38780 . 40152) (MAPHASH 40154 . 41283)
|
||||
(GETHASH 41285 . 44865) (PUTHASH 44867 . 45098) (CL::PUTHASH 45100 . 45812) (REMHASH 45814 . 45959) (
|
||||
\HASHRECLAIM 45961 . 47744) (\HASHACCESS 47746 . 53508) (REHASH 53510 . 54234) (\COPYHARRAYP 54236 .
|
||||
54966) (\HASHTABLE.DEFPRINT 54968 . 55775)) (55827 61097 (DMPHASH 55837 . 57451) (HASHOVERFLOW 57453
|
||||
. 61095)) (61873 62429 (STRINGHASHBITS 61883 . 62040) (STRING-EQUAL-HASHBITS 62042 . 62427)) (62430
|
||||
64492 (\STRINGHASHBITS-UFN 62440 . 63546) (\STRING-EQUAL-HASHBITS-UFN 63548 . 64490)) (68675 73770 (
|
||||
\CODEARRAY 68685 . 69515) (\FIXCODENUM 69517 . 70182) (\FIXCODEPTR 70184 . 71244) (\FIXCODESYM 71246
|
||||
. 73768)) (84170 119406 (\ALLOCBLOCK 84180 . 88179) (\MAIKO.ALLOCBLOCK 88181 . 92373) (
|
||||
\ALLOCBLOCK.OLD 92375 . 97246) (\ALLOCBLOCK.NEW 97248 . 100254) (\PREFIXALIGNMENT? 100256 . 103799) (
|
||||
\MAKEFREEARRAYBLOCK 103801 . 104396) (\DELETEBLOCK? 104398 . 105503) (\LINKBLOCK 105505 . 107631) (
|
||||
\MERGEBACKWARD 107633 . 108994) (\MERGEFORWARD 108996 . 110093) (\ARRAYBLOCKMERGER 110095 . 112280) (
|
||||
\#BLOCKDATACELLS 112282 . 113518) (\COPYARRAYBLOCK 113520 . 115088) (\RECLAIMARRAYBLOCK 115090 .
|
||||
117219) (\ADVANCE.ARRAY.SEGMENTS 117221 . 119404)) (119468 121901 (\BYTELT 119478 . 120277) (\BYTESETA
|
||||
120279 . 121220) (\WORDELT 121222 . 121899)) (121902 122236 (\ARRAYTYPENAME 121912 . 122234)) (122359
|
||||
126053 (\SHOW.ARRAY.FREELISTS 122369 . 126051)) (126358 132108 (\CHECKARRAYBLOCK 126368 . 130743) (
|
||||
\PARSEARRAYSPACE 130745 . 131154) (\PARSEARRAYSPACE1 131156 . 132106)) (132242 138508 (\ALLOCHUNK
|
||||
132252 . 138506)) (139686 145582 (PREINITARRAYS 139696 . 140237) (POSTINITARRAYS 140239 . 142957) (
|
||||
FILEARRAYBASE 142959 . 143371) (FILEBLOCKTRAILER 143373 . 143668) (FILECODEBLOCK 143670 . 144686) (
|
||||
FILEPATCHBLOCK 144688 . 145580)) (145619 151043 (\SETUP.HUNK.TYPENUMBERS 145629 . 146665) (
|
||||
\COMPUTE.HUNK.TYPEDECLS 146667 . 147947) (\TURN.ON.HUNKING 147949 . 148621) (\SETUP.TYPENUM.TABLE
|
||||
148623 . 151041)) (153219 159820 (\HUNKFIT? 153229 . 153844) (\AB.NEXT 153846 . 157041) (\AB.BACK
|
||||
157043 . 159818)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
385
sources/LOADFNS
385
sources/LOADFNS
@@ -1,20 +1,18 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED " 2-May-2022 11:38:55" {DSK}<home>larry>medley>sources>LOADFNS.;2 47218
|
||||
(FILECREATED "25-Feb-2026 01:03:38" {WMEDLEY}<sources>LOADFNS.;8 47522
|
||||
|
||||
:CHANGES-TO (FNS SCANFILEHELP)
|
||||
:EDIT-BY rmk
|
||||
|
||||
:PREVIOUS-DATE "16-Apr-2018 17:38:16" {DSK}<home>larry>medley>sources>LOADFNS.;1)
|
||||
:CHANGES-TO (VARS LOADFNSCOMS)
|
||||
|
||||
:PREVIOUS-DATE "23-Feb-2026 00:49:17" {WMEDLEY}<sources>LOADFNS.;7)
|
||||
|
||||
(* ; "
|
||||
Copyright (c) 1983-1984, 1986-1987, 1989-1990, 2018, 2022 by Venue & Xerox Corporation.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT LOADFNSCOMS)
|
||||
|
||||
(RPAQQ LOADFNSCOMS
|
||||
[(FNS LOADFROM LOADBLOCK GETBLOCKDEC LOADCOMP LOADCOMP? LOADVARS LOADEFS LOADFILEMAP LOADFNS
|
||||
[(FNS LOADFROM LOADBLOCK GETBLOCKDEC LOADCOMP LOADCOMP? LOADVARS LOADFILEMAP LOADFNS
|
||||
LOADFNS-FINDFILE LOADFNS-MAKELIST)
|
||||
(FNS LOADFNSCAN SCANFILE0 SCANCOMPILEDFN SCANDEFINEQ SCANEXP SCANDECLARECOLON SCANFILE1
|
||||
SCANFILE2 TMPSUBFN RETRYSCAN SCANFILEHELP)
|
||||
@@ -98,10 +96,6 @@ Copyright (c) 1983-1984, 1986-1987, 1989-1990, 2018, 2022 by Venue & Xerox Corpo
|
||||
[LAMBDA (VARS FILE LDFLG)
|
||||
(LOADFNS NIL FILE LDFLG VARS])
|
||||
|
||||
(LOADEFS
|
||||
[LAMBDA (FNS FILE) (* wt%: " 9-APR-80 20:27")
|
||||
(LOADFNS FNS FILE 'GETDEF])
|
||||
|
||||
(LOADFILEMAP
|
||||
[LAMBDA (FILE) (* wt%: "16-MAY-79 22:05")
|
||||
|
||||
@@ -110,107 +104,107 @@ Copyright (c) 1983-1984, 1986-1987, 1989-1990, 2018, 2022 by Venue & Xerox Corpo
|
||||
(LOADFNS NIL FILE NIL 'FILEMAP])
|
||||
|
||||
(LOADFNS
|
||||
[LAMBDA (FNS FILE LDFLG VARS) (* bvm%: "17-Nov-86 23:28")
|
||||
[LAMBDA (FNS FILE LDFLG VARS) (* ; "Edited 23-Feb-2026 00:49 by rmk")
|
||||
(* bvm%: "17-Nov-86 23:28")
|
||||
|
||||
(* ;;; "All of LOADVARS, LOADCOMP, LOADFILEMAP, LOADFROM come thru here.")
|
||||
(* ;;; "All of LOADVARS, LOADCOMP, LOADFILEMAP, LOADFROM come thru here.")
|
||||
|
||||
(DECLARE (SPECVARS FILE LDFLG VARS)) (* ; "Used free by RETRYSCAN")
|
||||
(DECLARE (SPECVARS FILE LDFLG VARS)) (* ; "Used free by RETRYSCAN")
|
||||
(RESETLST
|
||||
(PROG ((*PACKAGE* *INTERLISP-PACKAGE*)
|
||||
(DFNFLG DFNFLG)
|
||||
(BUILDMAPFLG BUILDMAPFLG)
|
||||
(FILEPKGFLG FILEPKGFLG)
|
||||
(ADDSPELLFLG ADDSPELLFLG)
|
||||
(LISPXHIST LISPXHIST)
|
||||
(FILECREATEDLST)
|
||||
(PRLST (AND FILEPKGFLG (FILEPKGCHANGES)))
|
||||
INSTREAM FNLST VARLST DONELST ROOTNAME FILEMAP TEM FILEMAPEND FILECREATEDLOC FILENV
|
||||
RESETSAVER MAPUPDATED)
|
||||
(DECLARE (SPECVARS *PACKAGE* DFNFLG BUILDMAPFLG FILEPKGFLG ADDSPELLFLG LISPXHIST FNLST
|
||||
VARLST DONELST FILECREATEDLST FILECREATEDLOC))
|
||||
(* ;
|
||||
"FILECREATEDLST is set by SCANEXP when it encounters a FILECREATED expression")
|
||||
TOP (COND
|
||||
((OR (EQ LDFLG 'EXPRESSIONS)
|
||||
(EQ LDFLG 'GETDEF)
|
||||
(MEMB LDFLG LOADOPTIONS))
|
||||
(SETQ DFNFLG LDFLG))
|
||||
((AND DWIMFLG (SETQ TEM (FIXSPELL LDFLG NIL LOADOPTIONS T)))
|
||||
(SETQ LDFLG TEM)
|
||||
(SETQ DFNFLG LDFLG))
|
||||
(T (SETQ LDFLG (ERROR "unrecognized load option" LDFLG))
|
||||
(GO TOP)))
|
||||
(COND
|
||||
((EQ LDFLG 'SYSLOAD)
|
||||
(SETQ DFNFLG T)
|
||||
(SETQ ADDSPELLFLG NIL)
|
||||
(SETQ BUILDMAPFLG NIL)
|
||||
(SETQ FILEPKGFLG NIL)
|
||||
(SETQ LISPXHIST NIL)))
|
||||
[AND LISPXHIST (COND
|
||||
((SETQ TEM (FMEMB 'SIDE LISPXHIST))
|
||||
(FRPLACA (CADR TEM)
|
||||
-1))
|
||||
(T (LISPXPUT 'SIDE (LIST -1)
|
||||
NIL LISPXHIST] (* ;
|
||||
"So that UNDOSAVE will keep saving regardless of how many undosaves are involved")
|
||||
(SETQ FNLST (LOADFNS-MAKELIST FNS T)) (* ; "Get list of functions")
|
||||
[COND
|
||||
((NULL FILE) (* ;
|
||||
"Infer what file caller meant (this is a feature!)")
|
||||
(SETQ FILE (LOADFNS-FINDFILE (CAR FNLST]
|
||||
RETRY
|
||||
[RESETSAVE NIL (SETQ RESETSAVER (LIST 'CLOSEF? (SETQ INSTREAM (OPENSTREAM FILE
|
||||
'INPUT]
|
||||
(* ;
|
||||
"CLOSEF? not CLOSEF because UPDATEFILEMAP might close file for us")
|
||||
(RESETSAVE (INPUT INSTREAM))
|
||||
(SETQ FILE (FULLNAME INSTREAM)) (* ;
|
||||
"Gets full file name. Also note that there may have been some error correction done in OPENSTREAM")
|
||||
(COND
|
||||
((NOT (RANDACCESSP INSTREAM))
|
||||
(SETQ FILE (ERROR FILE "not a random access file"))
|
||||
(GO RETRY)))
|
||||
(SETFILEPTR INSTREAM 0)
|
||||
(SETQ ROOTNAME (ROOTFILENAME FILE))
|
||||
(CL:MULTIPLE-VALUE-SETQ (FILENV FILEMAP FILECREATEDLOC FILECREATEDLST)
|
||||
(GET-ENVIRONMENT-AND-FILEMAP INSTREAM))
|
||||
(SETQ VARLST (SELECTQ VARS
|
||||
(NIL NIL)
|
||||
(VARS (* ;
|
||||
"Means load, i.e., evaluate, ALL rpaq/rpaqq")
|
||||
'VARS)
|
||||
(FNS/VARS (LIST (FILECOMS ROOTNAME 'COMS)
|
||||
(FILECOMS ROOTNAME 'BLOCKS)))
|
||||
(LOADCOMP (* ;
|
||||
"evaluate the EVAL@COMPILE expresions, notice the fns and vars.")
|
||||
(SETQ FNLST T)
|
||||
VARS)
|
||||
(FILEMAP (* ;
|
||||
"Return the filemap, or build one if not already available")
|
||||
(if (AND FILEMAP (NULL (CAR FILEMAP)))
|
||||
then (RETURN FILEMAP)
|
||||
elseif (NULL BUILDMAPFLG)
|
||||
then (RETURN NIL))
|
||||
'FILEMAP)
|
||||
(LOADFROM
|
||||
|
||||
(* ;; "evaluate all non-defineq expressions, but just return file name as value, i.e. dont bother adding to donelst")
|
||||
[PROG ((*PACKAGE* *INTERLISP-PACKAGE*)
|
||||
(DFNFLG DFNFLG)
|
||||
(BUILDMAPFLG BUILDMAPFLG)
|
||||
(FILEPKGFLG FILEPKGFLG)
|
||||
(ADDSPELLFLG ADDSPELLFLG)
|
||||
(LISPXHIST LISPXHIST)
|
||||
(FILECREATEDLST)
|
||||
(PRLST (AND FILEPKGFLG (FILEPKGCHANGES)))
|
||||
INSTREAM FNLST VARLST DONELST ROOTNAME FILEMAP TEM FILEMAPEND FILECREATEDLOC FILENV
|
||||
RESETSAVER MAPUPDATED)
|
||||
(DECLARE (SPECVARS *PACKAGE* DFNFLG BUILDMAPFLG FILEPKGFLG ADDSPELLFLG LISPXHIST FNLST
|
||||
VARLST DONELST FILECREATEDLST FILECREATEDLOC))
|
||||
(* ;
|
||||
"FILECREATEDLST is set by SCANEXP when it encounters a FILECREATED expression")
|
||||
TOP (COND
|
||||
((OR (EQ LDFLG 'EXPRESSIONS)
|
||||
(EQ LDFLG 'GETDEF)
|
||||
(MEMB LDFLG LOADOPTIONS))
|
||||
(SETQ DFNFLG LDFLG))
|
||||
((AND DWIMFLG (SETQ TEM (FIXSPELL LDFLG NIL LOADOPTIONS T)))
|
||||
(SETQ LDFLG TEM)
|
||||
(SETQ DFNFLG LDFLG))
|
||||
(T (SETQ LDFLG (ERROR "unrecognized load option" LDFLG))
|
||||
(GO TOP)))
|
||||
(COND
|
||||
((EQ LDFLG 'SYSLOAD)
|
||||
(SETQ DFNFLG T)
|
||||
(SETQ ADDSPELLFLG NIL)
|
||||
(SETQ BUILDMAPFLG NIL)
|
||||
(SETQ FILEPKGFLG NIL)
|
||||
(SETQ LISPXHIST NIL)))
|
||||
[AND LISPXHIST (COND
|
||||
((SETQ TEM (FMEMB 'SIDE LISPXHIST))
|
||||
(FRPLACA (CADR TEM)
|
||||
-1))
|
||||
(T (LISPXPUT 'SIDE (LIST -1)
|
||||
NIL LISPXHIST] (* ;
|
||||
"So that UNDOSAVE will keep saving regardless of how many undosaves are involved")
|
||||
(SETQ FNLST (LOADFNS-MAKELIST FNS T)) (* ; "Get list of functions")
|
||||
[COND
|
||||
((NULL FILE) (* ;
|
||||
"Infer what file caller meant (this is a feature!)")
|
||||
(SETQ FILE (LOADFNS-FINDFILE (CAR FNLST]
|
||||
RETRY
|
||||
[RESETSAVE NIL (SETQ RESETSAVER (LIST 'CLOSEF? (SETQ INSTREAM (OPENSTREAM FILE
|
||||
'INPUT]
|
||||
(* ;
|
||||
"CLOSEF? not CLOSEF because UPDATEFILEMAP might close file for us")
|
||||
(RESETSAVE (INPUT INSTREAM))
|
||||
(SETQ FILE (FULLNAME INSTREAM)) (* ;
|
||||
"Gets full file name. Also note that there may have been some error correction done in OPENSTREAM")
|
||||
(COND
|
||||
((NOT (RANDACCESSP INSTREAM))
|
||||
(SETQ FILE (ERROR FILE "not a random access file"))
|
||||
(GO RETRY)))
|
||||
(SETFILEPTR INSTREAM 0)
|
||||
(SETQ ROOTNAME (ROOTFILENAME FILE))
|
||||
(CL:MULTIPLE-VALUE-SETQ (FILENV FILEMAP FILECREATEDLOC FILECREATEDLST)
|
||||
(GET-ENVIRONMENT-AND-FILEMAP INSTREAM))
|
||||
(\EXTERNALFORMAT INSTREAM FILENV)
|
||||
(SETQ VARLST (SELECTQ VARS
|
||||
(NIL NIL)
|
||||
(VARS (* ;
|
||||
"Means load, i.e., evaluate, ALL rpaq/rpaqq")
|
||||
'VARS)
|
||||
(FNS/VARS (LIST (FILECOMS ROOTNAME 'COMS)
|
||||
(FILECOMS ROOTNAME 'BLOCKS)))
|
||||
(LOADCOMP (* ;
|
||||
"evaluate the EVAL@COMPILE expresions, notice the fns and vars.")
|
||||
(SETQ FNLST T)
|
||||
VARS)
|
||||
(FILEMAP (* ;
|
||||
"Return the filemap, or build one if not already available")
|
||||
(if (AND FILEMAP (NULL (CAR FILEMAP)))
|
||||
then (RETURN FILEMAP)
|
||||
elseif (NULL BUILDMAPFLG)
|
||||
then (RETURN NIL))
|
||||
'FILEMAP)
|
||||
(LOADFROM
|
||||
(* ;; "evaluate all non-defineq expressions, but just return file name as value, i.e. dont bother adding to donelst")
|
||||
|
||||
'LOADFROM)
|
||||
(DONTCOPY (* ;
|
||||
"means load all DECLARE: DONTCOPY expressions")
|
||||
VARS)
|
||||
(LOADFNS-MAKELIST VARS)))
|
||||
(SETQ FILEMAPEND (if FILEMAP
|
||||
then (CAR FILEMAP)
|
||||
else T)) (* ;
|
||||
"Remember how far the filemap scan got already")
|
||||
[WITH-READER-ENVIRONMENT
|
||||
FILENV
|
||||
(SETQ FILEMAP (LOADFNSCAN FILEMAP))
|
||||
'LOADFROM)
|
||||
(DONTCOPY (* ;
|
||||
"means load all DECLARE: DONTCOPY expressions")
|
||||
VARS)
|
||||
(LOADFNS-MAKELIST VARS)))
|
||||
(SETQ FILEMAPEND (if FILEMAP
|
||||
then (CAR FILEMAP)
|
||||
else T)) (* ;
|
||||
"Remember how far the filemap scan got already")
|
||||
(WITH-READER-ENVIRONMENT FILENV
|
||||
(SETQ FILEMAP (LOADFNSCAN FILEMAP))
|
||||
|
||||
(* ;;; "SCANFILE0 returns a 'map' for the file. The form of the map is (ADR ADRLST ADRLST ...) where ADR is last address scanned to in file, or NIL if entire file was scanned, or (ADR) where the scan stopped after a function in the middle of a DEFINEQ. Each ADRLST is either of the form (ADR1 ADR2 . FN) or (ADR1 ADR2 (FN ADRX . ADRY) (FN ADRX . ADRY) ...).
|
||||
(* ;;; "SCANFILE0 returns a 'map' for the file. The form of the map is (ADR ADRLST ADRLST ...) where ADR is last address scanned to in file, or NIL if entire file was scanned, or (ADR) where the scan stopped after a function in the middle of a DEFINEQ. Each ADRLST is either of the form (ADR1 ADR2 . FN) or (ADR1 ADR2 (FN ADRX . ADRY) (FN ADRX . ADRY) ...).
|
||||
|
||||
The first case corresponds to a compiled function, the second to a DEFINEQ. In the first case, ADR1 is the address of the first character AFTER the function name in the file (for use by LAPRD) and ADR2 the address of the first character after the de definition, i.e., after LAPRD or LCSKIP has finished.
|
||||
|
||||
@@ -218,89 +212,89 @@ In the second case, ADR1 is the address of the lef paren before the DEFINEQ, and
|
||||
|
||||
A map of non-functions is not kept because (a) it would not be of use to MAKEFILE since it always recomputes VARS, and (B) most requests for other than functions require scanning the entire file anyway, e.g. to find all RPAQQ's, and (C) the expressions are usually small compared to DEFINEQ's.")
|
||||
|
||||
[if FILEMAP
|
||||
then
|
||||
(if (NEQ FILEMAPEND (CAR FILEMAP))
|
||||
then (* ; "something was added")
|
||||
(PUTFILEMAP FILE FILEMAP FILECREATEDLST)
|
||||
(if (AND UPDATEMAPFLG (UPDATEFILEMAP INSTREAM FILEMAP))
|
||||
then (SETQ MAPUPDATED T)))
|
||||
(if (AND DWIMFLG (NOT NOSPELLFLG)
|
||||
(LISTP FNLST))
|
||||
then (* ;
|
||||
"There are still FNS left that we didn't find")
|
||||
(if (SETQ TEM
|
||||
(for X on FNLST
|
||||
bind [KNOWNFNS _ (for TRIPLE in (CDR FILEMAP)
|
||||
join (* ;
|
||||
"makes a list of functions found for use for spelling correction.")
|
||||
(if (LISTP (SETQ TEM (CDDR TRIPLE)))
|
||||
then
|
||||
(* ;
|
||||
"This is for normal source files, where TRIPLE = (start end . fnEntries)")
|
||||
(MAPCAR TEM (FUNCTION CAR))
|
||||
elseif TEM
|
||||
then
|
||||
(* ;
|
||||
"For compiled files, TRIPLE = (start end . fn)")
|
||||
(LIST TEM]
|
||||
when (AND (NOT (FMEMB (CAR X)
|
||||
KNOWNFNS))
|
||||
(FIXSPELL (CAR X)
|
||||
70 KNOWNFNS NIL X)) collect
|
||||
|
||||
(* ;; "The FMEMB check is necessary for when VARS=DEFS, as the reason that the function was not removed from FNLST may have been because this was a compiled file.")
|
||||
[if FILEMAP
|
||||
then
|
||||
(if (NEQ FILEMAPEND (CAR FILEMAP))
|
||||
then (* ; "something was added")
|
||||
(PUTFILEMAP FILE FILEMAP FILECREATEDLST)
|
||||
(if (AND UPDATEMAPFLG (UPDATEFILEMAP INSTREAM FILEMAP))
|
||||
then (SETQ MAPUPDATED T)))
|
||||
(if (AND DWIMFLG (NOT NOSPELLFLG)
|
||||
(LISTP FNLST))
|
||||
then (* ;
|
||||
"There are still FNS left that we didn't find")
|
||||
(if
|
||||
(SETQ TEM
|
||||
(for X on FNLST
|
||||
bind [KNOWNFNS _
|
||||
(for TRIPLE in (CDR FILEMAP)
|
||||
join (* ;
|
||||
"makes a list of functions found for use for spelling correction.")
|
||||
(if (LISTP (SETQ TEM (CDDR TRIPLE)))
|
||||
then (* ;
|
||||
"This is for normal source files, where TRIPLE = (start end . fnEntries)")
|
||||
(MAPCAR TEM (FUNCTION CAR))
|
||||
elseif TEM
|
||||
then (* ;
|
||||
"For compiled files, TRIPLE = (start end . fn)")
|
||||
(LIST TEM]
|
||||
when (AND (NOT (FMEMB (CAR X)
|
||||
KNOWNFNS))
|
||||
(FIXSPELL (CAR X)
|
||||
70 KNOWNFNS NIL X)) collect
|
||||
|
||||
(CAR X)))
|
||||
then (if MAPUPDATED
|
||||
then (* ; "UPDATEFILEMAP had closed the file")
|
||||
[RPLACA (CDR RESETSAVER)
|
||||
(SETQ INSTREAM (OPENSTREAM FILE 'INPUT]
|
||||
(INPUT INSTREAM))
|
||||
(SCANFILE1 FILEMAP TEM]
|
||||
(if (AND NOT-FOUNDTAG (LISTP FNLST))
|
||||
then (SETQ DONELST (CONS (CONS NOT-FOUNDTAG FNLST)
|
||||
DONELST)))
|
||||
(if
|
||||
[AND
|
||||
NOT-FOUNDTAG
|
||||
(LISTP VARLST)
|
||||
(SETQ TEM
|
||||
(if (FNTYP VARLST)
|
||||
then (AND (NULL DONELST)
|
||||
(LIST VARLST))
|
||||
else (for X in VARLST collect X
|
||||
unless (PROGN
|
||||
|
||||
(* ;; "Reason for this is if user says LOADVARS (DEFLIST file), then DEFLIST is not removed from VARLST, since you want all such instances.")
|
||||
(* ;; "The FMEMB check is necessary for when VARS=DEFS, as the reason that the function was not removed from FNLST may have been because this was a compiled file.")
|
||||
|
||||
(for Y in DONELST
|
||||
thereis (if (ATOM X)
|
||||
then (OR (EQ X (CAR Y))
|
||||
(EQ X (CADR Y)))
|
||||
else (EDIT4E X Y]
|
||||
then (SETQ DONELST (CONS (CONS NOT-FOUNDTAG TEM)
|
||||
DONELST)))
|
||||
(if (EQ LDFLG 'SYSLOAD)
|
||||
then (AND (NOT (MEMB (SETQ ROOTNAME (ROOTFILENAME FILE (CDR FILECREATEDLST)))
|
||||
SYSFILES))
|
||||
(SETQ SYSFILES (NCONC1 SYSFILES ROOTNAME)))
|
||||
(SMASHFILECOMS ROOTNAME)
|
||||
elseif FILEPKGFLG
|
||||
then (AND (NEQ VARS 'FILEMAP)
|
||||
(NEQ LDFLG 'EXPRESSIONS)
|
||||
(NEQ LDFLG 'GETDEF)
|
||||
(ADDFILE FILE (SELECTQ VARS
|
||||
((T LOADFROM)
|
||||
'LOADFNS)
|
||||
(LOADCOMP 'LOADCOMP)
|
||||
'loadfns)
|
||||
PRLST FILECREATEDLST]
|
||||
(RETURN (if (EQ VARS 'FILEMAP)
|
||||
then FILEMAP
|
||||
elseif (EQ VARS 'LOADFROM)
|
||||
then FILE
|
||||
else (DREVERSE DONELST])
|
||||
(CAR X)))
|
||||
then (if MAPUPDATED
|
||||
then (* ; "UPDATEFILEMAP had closed the file")
|
||||
[RPLACA (CDR RESETSAVER)
|
||||
(SETQ INSTREAM (OPENSTREAM FILE 'INPUT]
|
||||
(INPUT INSTREAM))
|
||||
(SCANFILE1 FILEMAP TEM]
|
||||
(if (AND NOT-FOUNDTAG (LISTP FNLST))
|
||||
then (SETQ DONELST (CONS (CONS NOT-FOUNDTAG FNLST)
|
||||
DONELST)))
|
||||
(if
|
||||
[AND
|
||||
NOT-FOUNDTAG
|
||||
(LISTP VARLST)
|
||||
(SETQ TEM
|
||||
(if (FNTYP VARLST)
|
||||
then (AND (NULL DONELST)
|
||||
(LIST VARLST))
|
||||
else (for X in VARLST collect X
|
||||
unless (PROGN
|
||||
|
||||
(* ;; "Reason for this is if user says LOADVARS (DEFLIST file), then DEFLIST is not removed from VARLST, since you want all such instances.")
|
||||
|
||||
(for Y in DONELST
|
||||
thereis (if (ATOM X)
|
||||
then (OR (EQ X (CAR Y))
|
||||
(EQ X (CADR Y)))
|
||||
else (EDIT4E X Y]
|
||||
then (SETQ DONELST (CONS (CONS NOT-FOUNDTAG TEM)
|
||||
DONELST)))
|
||||
(if (EQ LDFLG 'SYSLOAD)
|
||||
then (AND (NOT (MEMB (SETQ ROOTNAME (ROOTFILENAME FILE (CDR FILECREATEDLST)))
|
||||
SYSFILES))
|
||||
(SETQ SYSFILES (NCONC1 SYSFILES ROOTNAME)))
|
||||
(SMASHFILECOMS ROOTNAME)
|
||||
elseif FILEPKGFLG
|
||||
then (AND (NEQ VARS 'FILEMAP)
|
||||
(NEQ LDFLG 'EXPRESSIONS)
|
||||
(NEQ LDFLG 'GETDEF)
|
||||
(ADDFILE FILE (SELECTQ VARS
|
||||
((T LOADFROM)
|
||||
'LOADFNS)
|
||||
(LOADCOMP 'LOADCOMP)
|
||||
'loadfns)
|
||||
PRLST FILECREATEDLST))))
|
||||
(RETURN (if (EQ VARS 'FILEMAP)
|
||||
then FILEMAP
|
||||
elseif (EQ VARS 'LOADFROM)
|
||||
then FILE
|
||||
else (DREVERSE DONELST])])
|
||||
|
||||
(LOADFNS-FINDFILE
|
||||
[LAMBDA (FN) (* bvm%: "27-Sep-86 15:03")
|
||||
@@ -883,13 +877,12 @@ A map of non-functions is not kept because (a) it would not be of use to MAKEFIL
|
||||
(SPECVARS VARLST)
|
||||
(RETFNS SCANFILE0))
|
||||
)
|
||||
(PUTPROPS LOADFNS COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1986 1987 1989 1990 2018 2022))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (1224 19374 (LOADFROM 1234 . 1707) (LOADBLOCK 1709 . 2217) (GETBLOCKDEC 2219 . 3084) (
|
||||
LOADCOMP 3086 . 4249) (LOADCOMP? 4251 . 4951) (LOADVARS 4953 . 5033) (LOADEFS 5035 . 5179) (
|
||||
LOADFILEMAP 5181 . 5585) (LOADFNS 5587 . 17659) (LOADFNS-FINDFILE 17661 . 18177) (LOADFNS-MAKELIST
|
||||
18179 . 19372)) (19375 46586 (LOADFNSCAN 19385 . 19563) (SCANFILE0 19565 . 22972) (SCANCOMPILEDFN
|
||||
22974 . 25276) (SCANDEFINEQ 25278 . 30576) (SCANEXP 30578 . 35329) (SCANDECLARECOLON 35331 . 39535) (
|
||||
SCANFILE1 39537 . 43619) (SCANFILE2 43621 . 43907) (TMPSUBFN 43909 . 45073) (RETRYSCAN 45075 . 45472)
|
||||
(SCANFILEHELP 45474 . 46584)))))
|
||||
(FILEMAP (NIL (1109 19777 (LOADFROM 1119 . 1592) (LOADBLOCK 1594 . 2102) (GETBLOCKDEC 2104 . 2969) (
|
||||
LOADCOMP 2971 . 4134) (LOADCOMP? 4136 . 4836) (LOADVARS 4838 . 4918) (LOADFILEMAP 4920 . 5324) (
|
||||
LOADFNS 5326 . 18062) (LOADFNS-FINDFILE 18064 . 18580) (LOADFNS-MAKELIST 18582 . 19775)) (19778 46989
|
||||
(LOADFNSCAN 19788 . 19966) (SCANFILE0 19968 . 23375) (SCANCOMPILEDFN 23377 . 25679) (SCANDEFINEQ 25681
|
||||
. 30979) (SCANEXP 30981 . 35732) (SCANDECLARECOLON 35734 . 39938) (SCANFILE1 39940 . 44022) (
|
||||
SCANFILE2 44024 . 44310) (TMPSUBFN 44312 . 45476) (RETRYSCAN 45478 . 45875) (SCANFILEHELP 45877 .
|
||||
46987)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,14 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "29-Sep-2025 12:51:06"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>working-medley>sources>MACHINEINDEPENDENT.;39 119579
|
||||
(FILECREATED "22-Feb-2026 13:55:06" {WMEDLEY}<sources>MACHINEINDEPENDENT.;40 125302
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (VARS MACHINEINDEPENDENTCOMS)
|
||||
|
||||
:PREVIOUS-DATE "18-Jan-2024 10:40:56"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>working-medley>sources>MACHINEINDEPENDENT.;38)
|
||||
:PREVIOUS-DATE "29-Sep-2025 12:51:06" {WMEDLEY}<sources>MACHINEINDEPENDENT.;39)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT MACHINEINDEPENDENTCOMS)
|
||||
@@ -19,9 +17,6 @@
|
||||
(INITVARS (*COMPILED-EXTENSIONS* (LIST FASL.EXT COMPILE.EXT]
|
||||
(COMS (* ;
|
||||
"random machine-independent utilities")
|
||||
(FNS DMPHASH HASHOVERFLOW)
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY (MACROS HASHOVERFLOW.ARRAYTEST
|
||||
HASHOVERFLOW.UPDATEARRAY))
|
||||
(FNS BKBUFS CHANGENAME CHNGNM CLBUFS DEFINE FNS.PUTDEF EQMEMB EQUALN FNCHECK FNTYP1
|
||||
LCSKIP MAPRINT MKLIST NAMEFIELD NLIST PRINTBELLS PROMPTCHAR RAISEP READFILE
|
||||
READLINE REMPROPLIST RESETBUFS TAB UNSAVED1 WRITEFILE CLOSE-AND-MAYBE-DELETE
|
||||
@@ -485,104 +480,6 @@
|
||||
|
||||
(DEFINEQ
|
||||
|
||||
(DMPHASH
|
||||
[NLAMBDA L (* rmk%: " 6-Apr-84 14:30")
|
||||
(MAPC L (FUNCTION (LAMBDA (ARRAYNAME)
|
||||
(DECLARE (SPECVARS ARRAYNAME))
|
||||
(ERSETQ (PROG ((A (EVALV ARRAYNAME 'DMPHASH))
|
||||
AP)
|
||||
[PRINT (LIST 'RPAQ ARRAYNAME
|
||||
(COND
|
||||
[(LISTP A)
|
||||
(SETQ AP (CAR A))
|
||||
(LIST 'CONS [LIST 'HARRAY (HARRAYSIZE AP)
|
||||
(KWOTE (HARRAYPROP
|
||||
AP
|
||||
'OVERFLOW]
|
||||
(KWOTE (CDR A]
|
||||
(T (LIST 'HASHARRAY (HARRAYSIZE A)
|
||||
(KWOTE (HARRAYPROP AP 'OVERFLOW]
|
||||
(MAPHASH (OR AP A)
|
||||
(FUNCTION (LAMBDA (VAL ITEM)
|
||||
(PRINT (LIST 'PUTHASH (KWOTE ITEM)
|
||||
(KWOTE VAL)
|
||||
ARRAYNAME])
|
||||
|
||||
(HASHOVERFLOW
|
||||
[LAMBDA (HARRAY) (* ; "Edited 26-Feb-91 13:16 by jds")
|
||||
|
||||
(* ;; "Should be called from PUTHASH on hash overflow, but for implementations where PUTHASH calls ERRORX directly, may be called from ERRORX2 when the offender is a listp. HARRAY is guaranteed to be either HARRAYP or (LIST HARRAYP)")
|
||||
|
||||
(PROG ((OLDARRAY (HASHOVERFLOW.ARRAYTEST HARRAY))
|
||||
NEWARRAY NEWSIZE OLDNUMKEYS OVACTION NEWOVFLW)
|
||||
[COND
|
||||
((LISTP HARRAY)
|
||||
(SETQ OVACTION (CDR HARRAY))
|
||||
|
||||
(* ;; "Get OVERFLOW method from original HARRAY since it would erroneously be ERROR if we got the method from the coerced OLDARRAY")
|
||||
|
||||
(SETQ NEWOVFLW 'ERROR))
|
||||
(T (SETQ OVACTION (SETQ NEWOVFLW (HARRAYPROP OLDARRAY 'OVERFLOW]
|
||||
(SETQ OLDNUMKEYS (HARRAYPROP OLDARRAY 'NUMKEYS))
|
||||
|
||||
(* ;; "Compute the new array size:")
|
||||
|
||||
[SETQ NEWSIZE (SELECTQ OVACTION
|
||||
(NIL
|
||||
(* ;; "SIZE*1.5 --- favor to bbn, since pdp-11 doesnt have floatng point, and LRSH on other systems might be faster than IQUOTIENT")
|
||||
|
||||
(* ;;
|
||||
"[32749 IS THE BIGGEST PRIME < 32765, THE LIMIT ON ARRAY SIZES]")
|
||||
|
||||
[IMAX (+ OLDNUMKEYS 3)
|
||||
(IMIN 32749 (+ OLDNUMKEYS (LRSH (CL:1+ OLDNUMKEYS)
|
||||
1])
|
||||
(ERROR (do (ERRORX (LIST 26 HARRAY))))
|
||||
(if (FLOATP OVACTION)
|
||||
then [IMAX (+ OLDNUMKEYS 3)
|
||||
(IMIN 32760 (FIXR (FTIMES OLDNUMKEYS OVACTION]
|
||||
elseif (FIXP OVACTION)
|
||||
then (IMAX (+ OLDNUMKEYS 3)
|
||||
(IMIN 32749 (+ OLDNUMKEYS OVACTION)))
|
||||
elseif [AND (FNTYP OVACTION)
|
||||
(NUMBERP (SETQ OVACTION (APPLY* OVACTION HARRAY]
|
||||
then (if (FLOATP OVACTION)
|
||||
then (* ;
|
||||
"recompute NUMKEYS since OVACTION might have removed keys")
|
||||
[IMAX (+ (SETQ OLDNUMKEYS (HARRAYPROP OLDARRAY
|
||||
'NUMKEYS))
|
||||
3)
|
||||
(IMIN 32749 (FIXR (FTIMES OLDNUMKEYS
|
||||
OVACTION]
|
||||
else OVACTION)
|
||||
else (* ; "Default: multiply by 1.5")
|
||||
(SETQ OLDNUMKEYS (HARRAYPROP OLDARRAY 'NUMKEYS))
|
||||
(IMAX (+ OLDNUMKEYS 3)
|
||||
(IMIN 32749 (+ OLDNUMKEYS (LRSH (CL:1+ OLDNUMKEYS)
|
||||
1]
|
||||
[SETQ NEWARRAY (REHASH OLDARRAY (HASHARRAY NEWSIZE NEWOVFLW (HARRAYPROP OLDARRAY
|
||||
'HASHBITSFN)
|
||||
(HARRAYPROP OLDARRAY 'EQUIVFN]
|
||||
(HASHOVERFLOW.UPDATEARRAY HARRAY NEWARRAY OLDARRAY)
|
||||
(RETURN HARRAY])
|
||||
)
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
[PROGN (PUTPROPS HASHOVERFLOW.ARRAYTEST MACRO [(HARRAY)
|
||||
(CAR (OR (LISTP HARRAY)
|
||||
(ERRORX (LIST 27 HARRAY])
|
||||
(PUTPROPS HASHOVERFLOW.ARRAYTEST DMACRO ((HARRAY)
|
||||
(\DTEST HARRAY 'HARRAYP)))]
|
||||
|
||||
[PROGN (PUTPROPS HASHOVERFLOW.UPDATEARRAY MACRO ((HARRAY NEWARRAY OLDARRAY)
|
||||
(FRPLACA HARRAY NEWARRAY)))
|
||||
(PUTPROPS HASHOVERFLOW.UPDATEARRAY DMACRO ((HARRAY NEWARRAY OLDARRAY)
|
||||
(\COPYHARRAYP NEWARRAY OLDARRAY)))]
|
||||
)
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
(BKBUFS
|
||||
[LAMBDA (BUFS ID) (* DD%: " 6-Oct-81 15:34")
|
||||
(PROG (L S)
|
||||
@@ -2494,24 +2391,255 @@ This has little hope of working any more.")
|
||||
|
||||
(LOCALVARS . T)
|
||||
)
|
||||
(PRETTYCOMPRINT MACHINEINDEPENDENTCOMS)
|
||||
|
||||
(RPAQQ MACHINEINDEPENDENTCOMS
|
||||
([COMS (* ; " %"File loader%"")
|
||||
(FNS LOAD? FILESLOAD DOFILESLOAD FINDFILE-WITH-EXTENSIONS READ-FILECREATED)
|
||||
(INITVARS (*COMPILED-EXTENSIONS* (LIST FASL.EXT COMPILE.EXT]
|
||||
(COMS (* ;
|
||||
"random machine-independent utilities")
|
||||
(FNS BKBUFS CHANGENAME CHNGNM CLBUFS DEFINE FNS.PUTDEF EQMEMB EQUALN FNCHECK FNTYP1
|
||||
LCSKIP MAPRINT MKLIST NAMEFIELD NLIST PRINTBELLS PROMPTCHAR RAISEP READFILE
|
||||
READLINE REMPROPLIST RESETBUFS TAB UNSAVED1 WRITEFILE CLOSE-AND-MAYBE-DELETE
|
||||
UNSAFE.TO.MODIFY)
|
||||
(VARS UNSAFE.TO.MODIFY.FNS)
|
||||
(INITVARS (OK.TO.MODIFY.FNS))
|
||||
[COMS (* ;
|
||||
"FILEDATE, for finding out the creation date of source files, from the compiled files.")
|
||||
(FNS FILEDATE COMPILEFILETYPE)
|
||||
|
||||
(* ;; "FASL isn't loaded when MACHINEINDEPENDENT is, so we have to fake the FASL checker for now. It's defined in FASLOAD.")
|
||||
|
||||
(P (MOVD? 'NILL 'FASL-FILEDATE]
|
||||
(P (MOVD? 'CL:FMAKUNBOUND 'UNDOABLY-FMAKUNBOUND))
|
||||
(* ;
|
||||
"used in FNS.PUTDEF before CMLUNDO loaded")
|
||||
)
|
||||
(COMS (* ;
|
||||
"Functions for retrieving and remembering FILEMAPs and file reader environments")
|
||||
(FNS FILEMAP \PARSE-FILE-HEADER GET-ENVIRONMENT-AND-FILEMAP
|
||||
LOOKUP-ENVIRONMENT-AND-FILEMAP GET-FILEMAP-FROM-FILECREATED \FILEMAP-HASHOVERFLOW
|
||||
FLUSHFILEMAPS LISPSOURCEFILEP LISPFILETYPE GETFILEMAP PUTFILEMAP UPDATEFILEMAP)
|
||||
[INITVARS (*FILEMAP-LIMIT* 20)
|
||||
(*FILEMAP-VERSIONS* 2)
|
||||
(*FILEMAP-HASH* (HASHARRAY *FILEMAP-LIMIT* (FUNCTION \FILEMAP-HASHOVERFLOW)
|
||||
(FUNCTION STRING-EQUAL-HASHBITS)
|
||||
(FUNCTION STRING.EQUAL]
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS FILEMAPHASH)
|
||||
(GLOBALVARS *FILEMAP-LIMIT* *FILEMAP-VERSIONS* *FILEMAP-HASH*)))
|
||||
(COMS (* * LVLPRINT)
|
||||
(FNS LVLPRINT LVLPRIN1 LVLPRIN2 LVLPRIN LVLPRIN0))
|
||||
(COMS (* ; "used by PRINTOUT")
|
||||
(FNS FLUSHRIGHT PRINTPARA PRINTPARA1))
|
||||
(COMS (* ; "SUBLIS and friends")
|
||||
(FNS SUBLIS SUBPAIR DSUBLIS))
|
||||
[COMS (* * CONSTANTS)
|
||||
(FNS CONSTANTOK)
|
||||
(P (MOVD? 'EVQ 'CONSTANT)
|
||||
(MOVD? 'EVQ 'DEFERREDCONSTANT)
|
||||
(MOVD? 'EVQ 'LOADTIMECONSTANT]
|
||||
(COMS (* * SCRATCHLIST)
|
||||
(PROP MACRO SCRATCHLIST ADDTOSCRATCHLIST)
|
||||
(PROP INFO SCRATCHLIST))
|
||||
(GLOBALVARS SYSFILES LOADOPTIONS LISPXCOMS CLISPTRANFLG COMMENTFLG HISTSTR4 LISPXREADFN
|
||||
REREADFLG HISTSTR0 CTRLUFLG NOLINKMESS PROMPTCHARFORMS PROMPT#FLG FILERDTBL SPELLINGS2
|
||||
USERWORDS BELLS CLISPARRAY)
|
||||
(FNS NLAMBDA.ARGS)
|
||||
[DECLARE%:
|
||||
DONTEVAL@LOAD DOCOPY (* ;
|
||||
"initialization of variables used in many places")
|
||||
(ADDVARS (CLISPARRAY)
|
||||
(CLISPFLG)
|
||||
(CTRLUFLG)
|
||||
(EDITCALLS)
|
||||
(EDITHISTORY)
|
||||
(EDITUNDOSAVES)
|
||||
(EDITUNDOSTATS)
|
||||
(GLOBALVARS)
|
||||
(LCASEFLG)
|
||||
(LISPXBUFS)
|
||||
(LISPXCOMS)
|
||||
(LISPXFNS)
|
||||
(LISPXHIST)
|
||||
(LISPXHISTORY)
|
||||
(LISPXPRINTFLG)
|
||||
(NOCLEARSTKLST)
|
||||
(NOFIXFNSLST)
|
||||
(NOFIXVARSLST)
|
||||
(P.A.STATS)
|
||||
(PROMPTCHARFORMS)
|
||||
(READBUF)
|
||||
(READBUFSOURCE)
|
||||
(REREADFLG)
|
||||
(RESETSTATE)
|
||||
(SPELLSTATS1))
|
||||
(INITVARS (CHCONLST '(NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL
|
||||
NIL NIL NIL))
|
||||
(CHCONLST1 '(NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL
|
||||
NIL NIL))
|
||||
(CHCONLST2 '(NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL
|
||||
NIL NIL))
|
||||
(CLEARSTKLST T)
|
||||
(CLISPTRANFLG 'CLISP% )
|
||||
(HISTSTR0 "<c.r.>")
|
||||
(HISTSTR2 "repeat")
|
||||
(HISTSTR3 "from event:")
|
||||
(HISTSTR4 "ignore")
|
||||
(LISPXREADFN 'READ)
|
||||
(USEMAPFLG T))
|
||||
(P [MAPC '((APPLY BLKAPPLY)
|
||||
(SETTOPVAL SETATOMVAL)
|
||||
(GETTOPVAL GETATOMVAL)
|
||||
(APPLY* BLKAPPLY*)
|
||||
(RPLACA FRPLACA)
|
||||
(RPLACD FRPLACD)
|
||||
(STKNTH FSTKNTH)
|
||||
(STKNAME FSTKNAME)
|
||||
(CHARACTER FCHARACTER)
|
||||
(STKARG FSTKARG)
|
||||
(CHCON DCHCON)
|
||||
(UNPACK DUNPACK)
|
||||
(ADDPROP /ADDPROP)
|
||||
(ATTACH /ATTACH)
|
||||
(DREMOVE /DREMOVE)
|
||||
(DSUBST /DSUBST)
|
||||
(NCONC /NCONC)
|
||||
(NCONC1 /NCONC1)
|
||||
(PUT /PUT)
|
||||
(PUTPROP /PUTPROP)
|
||||
(PUTD /PUTD)
|
||||
(REMPROP /REMPROP)
|
||||
(RPLACA /RPLACA)
|
||||
(RPLACD /RPLACD)
|
||||
(SET /SET)
|
||||
(SETATOMVAL /SETATOMVAL)
|
||||
(SETTOPVAL /SETTOPVAL)
|
||||
(SETPROPLIST /SETPROPLIST)
|
||||
(SET SAVESET)
|
||||
(PRINT LISPXPRINT)
|
||||
(PRIN1 LISPXPRIN1)
|
||||
(PRIN2 LISPXPRIN2)
|
||||
(SPACES LISPXSPACES)
|
||||
(TAB LISPXTAB)
|
||||
(TERPRI LISPXTERPRI)
|
||||
(PRINT SHOWPRINT)
|
||||
(PRIN2 SHOWPRIN2)
|
||||
(PUTHASH /PUTHASH)
|
||||
'*
|
||||
(FNCLOSER /FNCLOSER)
|
||||
(FNCLOSERA /FNCLOSERA)
|
||||
(FNCLOSERD /FNCLOSERD)
|
||||
(EVQ DELFILE)
|
||||
(NILL SMASHFILECOMS)
|
||||
(PUTASSOC /PUTASSOC)
|
||||
(LISTPUT1 PUTL)
|
||||
(NILL I.S.OPR)
|
||||
(NILL RESETUNDO)
|
||||
(NILL LISPXWATCH)
|
||||
'ADDSTATS
|
||||
(NILL FREEVARS)
|
||||
'USEDFREE
|
||||
(COPYBYTES COPYCHARS))
|
||||
(FUNCTION (LAMBDA (X)
|
||||
(MOVD? (CAR X)
|
||||
(CADR X]
|
||||
[MAPC '((TIME PRIN1 LISPXPRIN1)
|
||||
(TIME SPACES LISPXSPACES)
|
||||
(TIME PRINT LISPXPRINT)
|
||||
(DEFC PRINT LISPXPRINT)
|
||||
(DEFC PUTD /PUTD)
|
||||
(DEFC PUTPROP /PUTPROP)
|
||||
(DOLINK FNCLOSERD /FNCLOSERD)
|
||||
(DOLINK FNCLOSERA /FNCLOSERA)
|
||||
(DEFLIST PUTPROP /PUTPROP)
|
||||
(SAVEDEF1 PUTPROP /PUTPROP)
|
||||
(MKSWAPBLOCK PUTD /PUTD))
|
||||
(FUNCTION (LAMBDA (X)
|
||||
(AND (CCODEP (CAR X))
|
||||
(APPLY 'CHANGENAME X]
|
||||
(MAPC '[[EVALQT (LAMBDA NIL (PROG (TEM)
|
||||
(RESETRESTORE NIL 'RESET)
|
||||
LP
|
||||
(PROMPTCHAR '_ T)
|
||||
(LISPX (LISPXREAD T T))
|
||||
(GO LP]
|
||||
[LISPX (LAMBDA (LISPXX)
|
||||
(PRINT [AND LISPXX (PROG (LISPXLINE LISPXHIST TEM)
|
||||
(RETURN (COND ((AND (NLISTP LISPXX)
|
||||
(SETQ LISPXLINE
|
||||
(READLINE T NIL
|
||||
T)))
|
||||
(APPLY LISPXX (CAR
|
||||
LISPXLINE
|
||||
)))
|
||||
(T (EVAL LISPXX]
|
||||
T T]
|
||||
[LISPXREAD (LAMBDA (FILE RDTBL)
|
||||
(COND [READBUF (PROG1 (CAR READBUF)
|
||||
(SETQ READBUF (CDR READBUF)))]
|
||||
(T (READ FILE RDTBL]
|
||||
[LISPXREADP (LAMBDA (FLG)
|
||||
(COND ((AND READBUF (SETQ READBUF (LISPXREADBUF READBUF)))
|
||||
T)
|
||||
(T (READP T FLG]
|
||||
[LISPXUNREAD (LAMBDA (LST)
|
||||
(SETQ READBUF (APPEND LST (CONS HISTSTR0 READBUF]
|
||||
[LISPXREADBUF (LAMBDA (RDBUF)
|
||||
(PROG NIL LP (COND ((NLISTP RDBUF)
|
||||
(RETURN NIL))
|
||||
((EQ (CAR RDBUF)
|
||||
HISTSTR0)
|
||||
(SETQ RDBUF (CDR RDBUF))
|
||||
(GO LP))
|
||||
(T (RETURN RDBUF]
|
||||
[LISPX/ (LAMBDA (X)
|
||||
X]
|
||||
[LOWERCASE (LAMBDA (FLG)
|
||||
(PROG1 LCASEFLG
|
||||
(RAISE (NULL FLG))
|
||||
(RPAQ LCASEFLG FLG))]
|
||||
[FILEPOS (LAMBDA (STR FILE)
|
||||
(PROG NIL LP (COND ((EQ (PEEKC FILE)
|
||||
(NTHCHAR STR 1))
|
||||
(RETURN T)))
|
||||
(READC FILE)
|
||||
(GO LP]
|
||||
(FILEPKGCOM (NLAMBDA NIL NIL]
|
||||
(FUNCTION (LAMBDA (L)
|
||||
(OR (GETD (CAR L))
|
||||
(PUTD (CAR L)
|
||||
(CADR L]
|
||||
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA RESETBUFS
|
||||
FILESLOAD)
|
||||
(NLAML FILEMAP)
|
||||
(LAMA READFILE NLIST)))
|
||||
(LOCALVARS . T)))
|
||||
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
|
||||
|
||||
(ADDTOVAR NLAMA RESETBUFS FILESLOAD)
|
||||
|
||||
(ADDTOVAR NLAML FILEMAP)
|
||||
|
||||
(ADDTOVAR LAMA READFILE NLIST)
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (12643 26068 (LOAD? 12653 . 14504) (FILESLOAD 14506 . 14795) (DOFILESLOAD 14797 . 22423)
|
||||
(FINDFILE-WITH-EXTENSIONS 22425 . 25624) (READ-FILECREATED 25626 . 26066)) (26185 31506 (DMPHASH
|
||||
26195 . 27789) (HASHOVERFLOW 27791 . 31504)) (32262 64370 (BKBUFS 32272 . 33391) (CHANGENAME 33393 .
|
||||
33654) (CHNGNM 33656 . 35504) (CLBUFS 35506 . 36779) (DEFINE 36781 . 37505) (FNS.PUTDEF 37507 . 40922)
|
||||
(EQMEMB 40924 . 41106) (EQUALN 41108 . 41937) (FNCHECK 41939 . 43946) (FNTYP1 43948 . 44045) (LCSKIP
|
||||
44047 . 44891) (MAPRINT 44893 . 45839) (MKLIST 45841 . 45991) (NAMEFIELD 45993 . 47518) (NLIST 47520
|
||||
. 47855) (PRINTBELLS 47857 . 47983) (PROMPTCHAR 47985 . 49875) (RAISEP 49877 . 50138) (READFILE 50140
|
||||
. 52484) (READLINE 52486 . 57926) (REMPROPLIST 57928 . 58816) (RESETBUFS 58818 . 59268) (TAB 59270 .
|
||||
59866) (UNSAVED1 59868 . 60973) (WRITEFILE 60975 . 62717) (CLOSE-AND-MAYBE-DELETE 62719 . 63063) (
|
||||
UNSAFE.TO.MODIFY 63065 . 64368)) (66589 71430 (FILEDATE 66599 . 69531) (COMPILEFILETYPE 69533 . 71428)
|
||||
) (71796 98999 (FILEMAP 71806 . 72276) (\PARSE-FILE-HEADER 72278 . 76093) (GET-ENVIRONMENT-AND-FILEMAP
|
||||
76095 . 78322) (LOOKUP-ENVIRONMENT-AND-FILEMAP 78324 . 80515) (GET-FILEMAP-FROM-FILECREATED 80517 .
|
||||
81341) (\FILEMAP-HASHOVERFLOW 81343 . 86007) (FLUSHFILEMAPS 86009 . 86632) (LISPSOURCEFILEP 86634 .
|
||||
88026) (LISPFILETYPE 88028 . 91277) (GETFILEMAP 91279 . 91698) (PUTFILEMAP 91700 . 93891) (
|
||||
UPDATEFILEMAP 93893 . 98997)) (99665 103251 (LVLPRINT 99675 . 99848) (LVLPRIN1 99850 . 100032) (
|
||||
LVLPRIN2 100034 . 100266) (LVLPRIN 100268 . 101282) (LVLPRIN0 101284 . 103249)) (103285 108202 (
|
||||
FLUSHRIGHT 103295 . 104110) (PRINTPARA 104112 . 105210) (PRINTPARA1 105212 . 108200)) (108238 110523 (
|
||||
SUBLIS 108248 . 108856) (SUBPAIR 108858 . 110086) (DSUBLIS 110088 . 110521)) (110546 111146 (
|
||||
CONSTANTOK 110556 . 111144)) (112899 113604 (NLAMBDA.ARGS 112909 . 113602)))))
|
||||
(FILEMAP (NIL (12360 25785 (LOAD? 12370 . 14221) (FILESLOAD 14223 . 14512) (DOFILESLOAD 14514 . 22140)
|
||||
(FINDFILE-WITH-EXTENSIONS 22142 . 25341) (READ-FILECREATED 25343 . 25783)) (25902 58010 (BKBUFS 25912
|
||||
. 27031) (CHANGENAME 27033 . 27294) (CHNGNM 27296 . 29144) (CLBUFS 29146 . 30419) (DEFINE 30421 .
|
||||
31145) (FNS.PUTDEF 31147 . 34562) (EQMEMB 34564 . 34746) (EQUALN 34748 . 35577) (FNCHECK 35579 . 37586
|
||||
) (FNTYP1 37588 . 37685) (LCSKIP 37687 . 38531) (MAPRINT 38533 . 39479) (MKLIST 39481 . 39631) (
|
||||
NAMEFIELD 39633 . 41158) (NLIST 41160 . 41495) (PRINTBELLS 41497 . 41623) (PROMPTCHAR 41625 . 43515) (
|
||||
RAISEP 43517 . 43778) (READFILE 43780 . 46124) (READLINE 46126 . 51566) (REMPROPLIST 51568 . 52456) (
|
||||
RESETBUFS 52458 . 52908) (TAB 52910 . 53506) (UNSAVED1 53508 . 54613) (WRITEFILE 54615 . 56357) (
|
||||
CLOSE-AND-MAYBE-DELETE 56359 . 56703) (UNSAFE.TO.MODIFY 56705 . 58008)) (60229 65070 (FILEDATE 60239
|
||||
. 63171) (COMPILEFILETYPE 63173 . 65068)) (65436 92639 (FILEMAP 65446 . 65916) (\PARSE-FILE-HEADER
|
||||
65918 . 69733) (GET-ENVIRONMENT-AND-FILEMAP 69735 . 71962) (LOOKUP-ENVIRONMENT-AND-FILEMAP 71964 .
|
||||
74155) (GET-FILEMAP-FROM-FILECREATED 74157 . 74981) (\FILEMAP-HASHOVERFLOW 74983 . 79647) (
|
||||
FLUSHFILEMAPS 79649 . 80272) (LISPSOURCEFILEP 80274 . 81666) (LISPFILETYPE 81668 . 84917) (GETFILEMAP
|
||||
84919 . 85338) (PUTFILEMAP 85340 . 87531) (UPDATEFILEMAP 87533 . 92637)) (93305 96891 (LVLPRINT 93315
|
||||
. 93488) (LVLPRIN1 93490 . 93672) (LVLPRIN2 93674 . 93906) (LVLPRIN 93908 . 94922) (LVLPRIN0 94924 .
|
||||
96889)) (96925 101842 (FLUSHRIGHT 96935 . 97750) (PRINTPARA 97752 . 98850) (PRINTPARA1 98852 . 101840)
|
||||
) (101878 104163 (SUBLIS 101888 . 102496) (SUBPAIR 102498 . 103726) (DSUBLIS 103728 . 104161)) (104186
|
||||
104786 (CONSTANTOK 104196 . 104784)) (106539 107244 (NLAMBDA.ARGS 106549 . 107242)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
296
sources/MCCS
296
sources/MCCS
@@ -1,12 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
(DEFINE-FILE-INFO :PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10 :FORMAT :UTF-8)
|
||||
|
||||
(FILECREATED " 5-Feb-2026 15:58:32" {WMEDLEY}<sources>MCCS.;163 65441
|
||||
(FILECREATED "26-Feb-2026 12:57:11" {WMEDLEY}<sources>MCCS.;168 61634
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (FNS \DUMMY-UTF8-FORMAT \CREATE.XCCS.EXTERNALFORMAT)
|
||||
:CHANGES-TO (FNS MCCSMAPPAIRS)
|
||||
|
||||
:PREVIOUS-DATE " 5-Feb-2026 12:26:39" {WMEDLEY}<sources>MCCS.;161)
|
||||
:PREVIOUS-DATE "20-Feb-2026 09:21:16" {WMEDLEY}<sources>MCCS.;167)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT MCCSCOMS)
|
||||
@@ -57,14 +57,10 @@
|
||||
"Mappings into MCCS: needed for hardcopy and Tedit coercion, e.g. \TEDIT.MCCS.TRANSLATE")
|
||||
|
||||
(FNS GACHATOMCODE SYMBOLTOMCODE SIGMATOMCODE ATOMCODE MATHTOMCODE HIPPOTOMCODE
|
||||
CYRILLICTOMCODE PALATINOTOMCODE)))
|
||||
(COMS (* ; "ISO8859/1")
|
||||
(FNS ISO1TOMCODE MTOISO1CODE \CREATE.ISO1.FORMAT \DUMMY-UTF8-FORMAT)
|
||||
(FNS ISO1TOMSTRING MTOISO1STRING)
|
||||
(VARS ISO1TOMCCS)
|
||||
(GLOBALVARS ISO1TOMCCS)
|
||||
(DECLARE%: DONTEVAL@LOAD DOCOPY (P (\CREATE.ISO1.FORMAT)
|
||||
(\DUMMY-UTF8-FORMAT])
|
||||
CYRILLICTOMCODE PALATINOTOMCODE))
|
||||
(COMS (FNS SYSTEM-EXTERNALFORMAT MTOSYSSTRING SYSTOMSTRING)
|
||||
(EXPORT (GLOBALVARS *SYSTEM-EXTERNALFORMAT*))
|
||||
(INITVARS (*SYSTEM-EXTERNALFORMAT* :UTF-8])
|
||||
|
||||
|
||||
|
||||
@@ -427,7 +423,7 @@
|
||||
|
||||
(* ;; "Converts Unicodes to MCCS codes in XSTRING.")
|
||||
|
||||
(for I XCODE (MSTRING _ (CL:IF DESTRUCTIVE
|
||||
(for I XCODE (MSTRING ← (CL:IF DESTRUCTIVE
|
||||
XSTRING
|
||||
(CONCAT XSTRING))) from 1 while (SETQ XCODE (NTHCHARCODE XSTRING I))
|
||||
do (RPLCHARCODE MSTRING I (XTOMCODE XCODE)) finally (RETURN MSTRING])
|
||||
@@ -438,7 +434,7 @@
|
||||
|
||||
(* ;; "Converts XCCS to MCCS codes in XSTRING.")
|
||||
|
||||
(for I MCODE (XSTRING _ (CL:IF DESTRUCTIVE
|
||||
(for I MCODE (XSTRING ← (CL:IF DESTRUCTIVE
|
||||
MSTRING
|
||||
(CONCAT MSTRING))) from 1 while (SETQ MCODE (NTHCHARCODE MSTRING I))
|
||||
do (RPLCHARCODE XSTRING I (MTOXCODE MCODE)) finally (RETURN XSTRING])
|
||||
@@ -500,12 +496,12 @@
|
||||
(
|
||||
(* ;; "From bravo doc")
|
||||
|
||||
(^N "356,055" MINUS)
|
||||
(^V "357,44" ENDASH)
|
||||
(^S EMDASH)
|
||||
(^O EMQUAD)
|
||||
(^X "356,055" MINUS)
|
||||
(^Y FIGURESPACE ENQUAD)
|
||||
(↑N "356,055" MINUS)
|
||||
(↑V "357,44" ENDASH)
|
||||
(↑S EMDASH)
|
||||
(↑O EMQUAD)
|
||||
(↑X "356,055" MINUS)
|
||||
(↑Y FIGURESPACE ENQUAD)
|
||||
|
||||
(* ;; "Fom current Helvetica/Timesroman fonts")
|
||||
|
||||
@@ -1372,7 +1368,8 @@
|
||||
NIL])
|
||||
|
||||
(MCCSMAPPAIRS
|
||||
[LAMBDA (FROMENCODING NONIDENTITY) (* ; "Edited 7-Oct-2025 14:47 by rmk")
|
||||
[LAMBDA (FROMENCODING NONIDENTITY) (* ; "Edited 26-Feb-2026 12:56 by rmk")
|
||||
(* ; "Edited 7-Oct-2025 14:47 by rmk")
|
||||
(* ; "Edited 6-Oct-2025 09:47 by rmk")
|
||||
(* ; "Edited 20-Sep-2025 09:45 by rmk")
|
||||
(* ; "Edited 6-Sep-2025 16:43 by rmk")
|
||||
@@ -1380,27 +1377,30 @@
|
||||
|
||||
(* ;; "Returns the pairs for MOVEFONTCHARS to use to move charset-0 glyphs into their MCCS positions. For example, the Leftarrow and Lowline glyphs switch positions in an XCCS$ font. Returns NIL (= nothing to do) if there is no function.")
|
||||
|
||||
(LET ((FN (MCCSMAPFN FROMENCODING))
|
||||
PAIRS KEEPCS0)
|
||||
(CL:WHEN FN
|
||||
[SETQ PAIRS (SELECTQ FROMENCODING
|
||||
(GACHA (* ; "ctrl and upper are slugged")
|
||||
[APPEND (XCCSUNDEFINEDPAIRS)
|
||||
'(((Uparrow TERMINAL)
|
||||
Circumflex)
|
||||
(^X Lowline])
|
||||
(ALTOTEXT (APPEND (XCCSUNDEFINEDPAIRS)
|
||||
ALTOTEXT2MCCS))
|
||||
(XCCS$ '((Uparrow Circumflex)
|
||||
(Leftarrow Lowline)
|
||||
(Lowline Leftarrow)
|
||||
(Circumflex Uparrow)))
|
||||
(PALATINO (APPEND (XCCS.CS0.UNDEFINED)
|
||||
PALATINOTOMCCS))
|
||||
(PROGN (SETQ KEEPCS0 T)
|
||||
(for C M from 0 to \MAXTHINCHAR
|
||||
when (SETQ M (APPLY* FN C NONIDENTITY))
|
||||
collect (LIST C M]
|
||||
(LET (PAIRS KEEPCS0)
|
||||
[SETQ PAIRS (SELECTQ FROMENCODING
|
||||
(GACHA (* ; "ctrl and upper are slugged")
|
||||
[APPEND (XCCSUNDEFINEDPAIRS)
|
||||
'(((Uparrow TERMINAL)
|
||||
Circumflex)
|
||||
(↑X Lowline])
|
||||
(ALTOTEXT (APPEND (XCCSUNDEFINEDPAIRS)
|
||||
ALTOTEXT2MCCS))
|
||||
(XCCS$ '((Uparrow Circumflex)
|
||||
(Leftarrow Lowline)
|
||||
(Lowline Leftarrow)
|
||||
(Circumflex Uparrow)))
|
||||
(UNICODE *UNICODETOMCCS*)
|
||||
(PALATINO (APPEND (XCCS.CS0.UNDEFINED)
|
||||
PALATINOTOMCCS))
|
||||
(PROGN (SETQ KEEPCS0 T)
|
||||
(for C M FN from 0 to \MAXTHINCHAR first (CL:UNLESS (SETQ FN
|
||||
(MCCSMAPFN
|
||||
FROMENCODING))
|
||||
(RETURN))
|
||||
when (SETQ M (APPLY* FN C NONIDENTITY))
|
||||
collect (LIST C M]
|
||||
(CL:WHEN (LISTP PAIRS)
|
||||
|
||||
(* ;; "Weed out interspersed comments, convert to charcodes")
|
||||
|
||||
@@ -1423,14 +1423,16 @@
|
||||
|
||||
(* ;; "Any character that is moved gets replaced by a slug. It may then be coerced from another font. But families like SYMBOL, HIPPO etc. want to preserve CS0 even if they copy their glyphs also to somewhere else.")
|
||||
|
||||
[APPEND PAIRS (for P in PAIRS when (CAR P)
|
||||
unless [OR (AND KEEPCS0 (ILEQ (CAR P)
|
||||
\MAXTHINCHAR))
|
||||
(AND (LISTP (CAR P))
|
||||
(LITATOM (CADAR P)))
|
||||
(thereis X in PAIRS suchthat (EQ (CADR X)
|
||||
(CAR P]
|
||||
collect (LIST NIL (CAR P])])
|
||||
[SETQ PAIRS (APPEND PAIRS (for P in PAIRS when (CAR P)
|
||||
unless [OR (AND KEEPCS0 (ILEQ (CAR P)
|
||||
\MAXTHINCHAR))
|
||||
(AND (LISTP (CAR P))
|
||||
(LITATOM (CADAR P)))
|
||||
(thereis X in PAIRS
|
||||
suchthat (EQ (CADR X)
|
||||
(CAR P]
|
||||
collect (LIST NIL (CAR P])
|
||||
PAIRS])
|
||||
|
||||
(XCCS.CS0.UNDEFINED
|
||||
[LAMBDA NIL (* ; "Edited 5-Oct-2025 22:44 by rmk")
|
||||
@@ -1463,7 +1465,7 @@
|
||||
|
||||
(* ;; "Gacha did not have a code for circumflex, so there is nothing to map")
|
||||
|
||||
(CL:IF (EQ GCODE (CHARCODE ^X))
|
||||
(CL:IF (EQ GCODE (CHARCODE ↑X))
|
||||
(CHARCODE Lowline)
|
||||
GCODE)])
|
||||
|
||||
@@ -1541,178 +1543,52 @@
|
||||
MCODE)))
|
||||
PCODE])
|
||||
)
|
||||
|
||||
|
||||
|
||||
(* ; "ISO8859/1")
|
||||
|
||||
(DEFINEQ
|
||||
|
||||
(ISO1TOMCODE
|
||||
[LAMBDA (ICODE) (* ; "Edited 5-Feb-2026 12:09 by rmk")
|
||||
(* ; "Edited 2-Feb-2026 23:14 by rmk")
|
||||
(* ; "Edited 7-Sep-2025 22:39 by rmk")
|
||||
(* ; "Edited 3-Sep-2025 10:21 by rmk")
|
||||
(* ; "Edited 7-Aug-2025 09:37 by rmk")
|
||||
(SYSTEM-EXTERNALFORMAT
|
||||
[LAMBDA NIL (* ; "Edited 6-Feb-2026 11:29 by rmk")
|
||||
(* ; "Edited 31-Jan-2026 18:51 by rmk")
|
||||
(* ; "Edited 10-Oct-2022 11:55 by lmm")
|
||||
(* ; "Edited 7-Jul-2022 10:41 by rmk")
|
||||
|
||||
(* ;; "ISO codes are 8bit, MCODES maybe not. Caller shouldn't pass a fat code.")
|
||||
(* ;; "Returns the name, sets the global. For now, UTF-8 or through, could be something else.")
|
||||
|
||||
(OR [CAR (find PAIR in ISO1TOMCCS suchthat (EQ ICODE (CADR PAIR]
|
||||
ICODE])
|
||||
(fetch (EXTERNALFORMAT NAME) of (SETQ *SYSTEM-EXTERNALFORMAT*
|
||||
(FIND-FORMAT (FOR X IN '("LC_CTYPE" "LC_ALL" "LANG")
|
||||
WHEN (STRPOS ".UTF-8" (UNIX-GETENV X))
|
||||
DO (RETURN :UTF-8) FINALLY (RETURN :THROUGH])
|
||||
|
||||
(MTOISO1CODE
|
||||
[LAMBDA (MCODE) (* ; "Edited 5-Feb-2026 12:26 by rmk")
|
||||
(* ; "Edited 2-Feb-2026 22:58 by rmk")
|
||||
(OR (CADR (ASSOC MCODE ISO1TOMCCS))
|
||||
MCODE])
|
||||
(MTOSYSSTRING
|
||||
[LAMBDA (MSTRING) (* ; "Edited 6-Feb-2026 00:20 by rmk")
|
||||
(MCCSTOFORMATBYTES *SYSTEM-EXTERNALFORMAT* (MKSTRING MSTRING])
|
||||
|
||||
(\CREATE.ISO1.FORMAT
|
||||
[LAMBDA NIL (* ; "Edited 5-Feb-2026 10:42 by rmk")
|
||||
(* ; "Edited 2-Feb-2026 23:37 by rmk")
|
||||
(* ; "Edited 1-Feb-2026 11:18 by rmk")
|
||||
(* ; "Edited 5-Aug-2021 22:15 by rmk:")
|
||||
(* ; "Edited 9-Mar-99 17:19 by rmk:")
|
||||
(* ; "Edited 7-Dec-95 16:24 by ")
|
||||
(* ; "Edited 7-Dec-95 16:20 by ")
|
||||
(MAKE-EXTERNALFORMAT :ISO8859/1 [FUNCTION (LAMBDA (STREAM COUNTP)
|
||||
(ISO1TOMCODE (\THROUGHIN STREAM COUNTP]
|
||||
[FUNCTION (LAMBDA (STREAM NOERRORFLG)
|
||||
(ISO1TOMCODE (\PEEKBIN STREAM NOERRORFLG]
|
||||
(FUNCTION \THROUGHBACKCCODE)
|
||||
(FUNCTION NILL)
|
||||
(FUNCTION NILL)
|
||||
NIL NIL (FUNCTION MTOISO1STRING)
|
||||
NIL
|
||||
(FUNCTION NILL)
|
||||
(FUNCTION ISO1TOMSTRING])
|
||||
(SYSTOMSTRING
|
||||
[LAMBDA (SYSTRING) (* ; "Edited 5-Feb-2026 23:36 by rmk")
|
||||
|
||||
(\DUMMY-UTF8-FORMAT
|
||||
[LAMBDA NIL (* ; "Edited 5-Feb-2026 15:58 by rmk")
|
||||
(* ; "Edited 1-Feb-2026 13:16 by rmk")
|
||||
(* ;; "SYSSTRING is presumably shared with Unix, guarantee a copy on the way out")
|
||||
|
||||
(* ;; "Works only for 7-bit codes, during the loadup")
|
||||
|
||||
(\INSTALL.EXTERNALFORMAT (create EXTERNALFORMAT using (FIND-FORMAT :ISO8859/1)
|
||||
NAME _ :UTF-8])
|
||||
(CONCAT (FORMATBYTESTOMCCS *SYSTEM-EXTERNALFORMAT* SYSTRING])
|
||||
)
|
||||
(DEFINEQ
|
||||
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: DOEVAL@COMPILE DONTCOPY
|
||||
|
||||
(ISO1TOMSTRING
|
||||
[LAMBDA (ISTRING DESTRUCTIVE) (* ; "Edited 5-Feb-2026 11:01 by rmk")
|
||||
(* ; "Edited 2-Feb-2026 23:46 by rmk")
|
||||
(* ; "Edited 2-Sep-2025 12:14 by rmk")
|
||||
(* ; "Edited 29-Apr-2025 13:08 by rmk")
|
||||
|
||||
(* ;; "Converts ISO8859/1 codes to MCCS codes in MSTRING.")
|
||||
|
||||
(for I ICODE (MSTRING _ (CL:IF DESTRUCTIVE
|
||||
ISTRING
|
||||
(CONCAT ISTRING))) from 1 while (SETQ ICODE (NTHCHARCODE ISTRING I))
|
||||
do (RPLCHARCODE MSTRING I (ISO1TOMCODE ICODE)) finally (RETURN MSTRING])
|
||||
|
||||
(MTOISO1STRING
|
||||
[LAMBDA (MSTRING DESTRUCTIVE) (* ; "Edited 2-Feb-2026 23:47 by rmk")
|
||||
(* ; "Edited 2-Sep-2025 12:22 by rmk")
|
||||
(* ; "Edited 29-Apr-2025 13:08 by rmk")
|
||||
|
||||
(* ;; "Converts MCCS to ISO8859/1 codes in MSTRING.")
|
||||
|
||||
(for I MCODE (ISTRING _ (CL:IF DESTRUCTIVE
|
||||
MSTRING
|
||||
(CONCAT MSTRING))) from 1 while (SETQ MCODE (NTHCHARCODE MSTRING I))
|
||||
do (RPLCHARCODE ISTRING I (MTOISO1CODE MCODE)) finally (RETURN ISTRING])
|
||||
(GLOBALVARS *SYSTEM-EXTERNALFORMAT*)
|
||||
)
|
||||
|
||||
(RPAQQ ISO1TOMCCS
|
||||
((94 8593)
|
||||
(95 8592)
|
||||
(169 8216)
|
||||
(170 8220)
|
||||
(172 95)
|
||||
(173 94)
|
||||
(174 8594)
|
||||
(175 8595)
|
||||
(180 215)
|
||||
(184 247)
|
||||
(185 8217)
|
||||
(186 8221)
|
||||
(193 768)
|
||||
(194 769)
|
||||
(195 770)
|
||||
(196 771)
|
||||
(197 772)
|
||||
(198 774)
|
||||
(199 775)
|
||||
(200 776)
|
||||
(202 778)
|
||||
(203 807)
|
||||
(204 818)
|
||||
(205 779)
|
||||
(206 808)
|
||||
(207 780)
|
||||
(208 8213)
|
||||
(209 185)
|
||||
(210 174)
|
||||
(211 169)
|
||||
(212 8482)
|
||||
(213 9834)
|
||||
(220 8539)
|
||||
(221 8540)
|
||||
(222 8541)
|
||||
(223 8542)
|
||||
(224 8486)
|
||||
(225 198)
|
||||
(226 208)
|
||||
(227 170)
|
||||
(228 294)
|
||||
(229 567)
|
||||
(230 306)
|
||||
(231 319)
|
||||
(232 321)
|
||||
(233 216)
|
||||
(234 338)
|
||||
(235 186)
|
||||
(236 222)
|
||||
(237 358)
|
||||
(238 330)
|
||||
(239 329)
|
||||
(240 312)
|
||||
(241 230)
|
||||
(242 273)
|
||||
(243 240)
|
||||
(244 295)
|
||||
(245 305)
|
||||
(246 307)
|
||||
(247 320)
|
||||
(248 322)
|
||||
(249 248)
|
||||
(250 339)
|
||||
(251 223)
|
||||
(252 254)
|
||||
(253 359)
|
||||
(254 331)))
|
||||
(DECLARE%: DOEVAL@COMPILE DONTCOPY
|
||||
(* "END EXPORTED DEFINITIONS")
|
||||
|
||||
(GLOBALVARS ISO1TOMCCS)
|
||||
)
|
||||
(DECLARE%: DONTEVAL@LOAD DOCOPY
|
||||
|
||||
(\CREATE.ISO1.FORMAT)
|
||||
|
||||
(\DUMMY-UTF8-FORMAT)
|
||||
)
|
||||
(RPAQ? *SYSTEM-EXTERNALFORMAT* :UTF-8)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (3345 14916 (\MCCSINCCODE 3355 . 6443) (\MCCSPEEKCCODE 6445 . 9332) (\MCCSOUTCHAR 9334
|
||||
. 11433) (\MCCSBACKCCODE 11435 . 12979) (\MCCSFORMATBYTESTREAM 12981 . 13711) (\MCCSCHARSETFN 13713
|
||||
. 14914)) (14917 17368 (\CREATE.MCCS.EXTERNALFORMAT 14927 . 15797) (\CREATE.XCCS.EXTERNALFORMAT 15799
|
||||
. 17366)) (17369 18346 (\MCCS.24BITENCODING.ERROR 17379 . 18344)) (19722 22360 (MTOXCODE 19732 .
|
||||
20529) (XTOMCODE 20531 . 21188) (XTOMSTRING 21190 . 21775) (MTOXSTRING 21777 . 22358)) (22361 24021 (
|
||||
MTOX$CODE 22371 . 23103) (X$TOMCODE 23105 . 24019)) (24022 24662 (KANJICHARSETP 24032 . 24288) (
|
||||
CHINESECHARSETP 24290 . 24660)) (45230 47719 (MCCSCODEMAPARRAY 45240 . 47717)) (48335 54816 (MCCSMAPFN
|
||||
48345 . 49712) (MCCSMAPPAIRS 49714 . 53822) (XCCS.CS0.UNDEFINED 53824 . 54453) (XCCSUNDEFINEDPAIRS
|
||||
54455 . 54814)) (54921 59673 (GACHATOMCODE 54931 . 55443) (SYMBOLTOMCODE 55445 . 56093) (SIGMATOMCODE
|
||||
56095 . 56741) (ATOMCODE 56743 . 57275) (MATHTOMCODE 57277 . 57933) (HIPPOTOMCODE 57935 . 58472) (
|
||||
CYRILLICTOMCODE 58474 . 58908) (PALATINOTOMCODE 58910 . 59671)) (59700 62493 (ISO1TOMCODE 59710 .
|
||||
60459) (MTOISO1CODE 60461 . 60751) (\CREATE.ISO1.FORMAT 60753 . 62018) (\DUMMY-UTF8-FORMAT 62020 .
|
||||
62491)) (62494 64025 (ISO1TOMSTRING 62504 . 63320) (MTOISO1STRING 63322 . 64023)))))
|
||||
(FILEMAP (NIL (3103 14674 (\MCCSINCCODE 3113 . 6201) (\MCCSPEEKCCODE 6203 . 9090) (\MCCSOUTCHAR 9092
|
||||
. 11191) (\MCCSBACKCCODE 11193 . 12737) (\MCCSFORMATBYTESTREAM 12739 . 13469) (\MCCSCHARSETFN 13471
|
||||
. 14672)) (14675 17126 (\CREATE.MCCS.EXTERNALFORMAT 14685 . 15555) (\CREATE.XCCS.EXTERNALFORMAT 15557
|
||||
. 17124)) (17127 18104 (\MCCS.24BITENCODING.ERROR 17137 . 18102)) (19480 22122 (MTOXCODE 19490 .
|
||||
20287) (XTOMCODE 20289 . 20946) (XTOMSTRING 20948 . 21535) (MTOXSTRING 21537 . 22120)) (22123 23783 (
|
||||
MTOX$CODE 22133 . 22865) (X$TOMCODE 22867 . 23781)) (23784 24424 (KANJICHARSETP 23794 . 24050) (
|
||||
CHINESECHARSETP 24052 . 24422)) (45004 47493 (MCCSCODEMAPARRAY 45014 . 47491)) (48109 55125 (MCCSMAPFN
|
||||
48119 . 49486) (MCCSMAPPAIRS 49488 . 54131) (XCCS.CS0.UNDEFINED 54133 . 54762) (XCCSUNDEFINEDPAIRS
|
||||
54764 . 55123)) (55230 59984 (GACHATOMCODE 55240 . 55754) (SYMBOLTOMCODE 55756 . 56404) (SIGMATOMCODE
|
||||
56406 . 57052) (ATOMCODE 57054 . 57586) (MATHTOMCODE 57588 . 58244) (HIPPOTOMCODE 58246 . 58783) (
|
||||
CYRILLICTOMCODE 58785 . 59219) (PALATINOTOMCODE 59221 . 59982)) (59985 61423 (SYSTEM-EXTERNALFORMAT
|
||||
59995 . 60939) (MTOSYSSTRING 60941 . 61134) (SYSTOMSTRING 61136 . 61421)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
2739
sources/UNICODE-FORMATS
Normal file
2739
sources/UNICODE-FORMATS
Normal file
File diff suppressed because it is too large
Load Diff
BIN
sources/UNICODE-FORMATS.LCOM
Normal file
BIN
sources/UNICODE-FORMATS.LCOM
Normal file
Binary file not shown.
@@ -1,20 +1,19 @@
|
||||
(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE "COMPILER" ( USE "LISP" "XCL")))
|
||||
(IL:FILECREATED "19-Sep-2020 22:02:59"
|
||||
IL:|{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>XCLC-TOP-LEVEL.;10| 78326
|
||||
(DEFINE-FILE-INFO :PACKAGE (DEFPACKAGE "COMPILER" (:USE "LISP" "XCL")) :READTABLE "XCL" :BASE 10)
|
||||
|
||||
IL:|changes| IL:|to:| (IL:FUNCTIONS START-COMPILATION)
|
||||
(IL:FILECREATED "25-Feb-2026 23:03:55" IL:|{WMEDLEY}<sources>XCLC-TOP-LEVEL.;2| 78162
|
||||
|
||||
IL:|previous| IL:|date:| "19-Sep-2020 21:33:34"
|
||||
IL:|{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>XCLC-TOP-LEVEL.;9|)
|
||||
:EDIT-BY IL:|rmk|
|
||||
|
||||
:CHANGES-TO (IL:FUNCTIONS COMPILE-FILE)
|
||||
|
||||
:PREVIOUS-DATE "19-Sep-2020 22:02:59" IL:|{WMEDLEY}<sources>XCLC-TOP-LEVEL.;1|)
|
||||
|
||||
; Copyright (c) 1986, 1987, 1988, 1989, 1990, 1991, 1994, 2020 by Venue & Xerox Corporation. All rights reserved.
|
||||
|
||||
(IL:PRETTYCOMPRINT IL:XCLC-TOP-LEVELCOMS)
|
||||
|
||||
(IL:RPAQQ IL:XCLC-TOP-LEVELCOMS
|
||||
(
|
||||
(IL:* IL:|;;| "Top-level entry points ")
|
||||
(IL:* IL:|;;| "Top-level entry points ")
|
||||
|
||||
(IL:STRUCTURES COMPILER-CONTEXT)
|
||||
(IL:VARIABLES *COMPILE-FILE-CONTEXT* *COMPILE-SCAN-CONTEXT* *COMPILE-DEFINER-CONTEXT*)
|
||||
@@ -33,18 +32,18 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>XCLC-TOP-LEVEL.;9|)
|
||||
(IL:COMS (IL:STRUCTURES ASSEMBLER-ERROR)
|
||||
(IL:FUNCTIONS ASSEMBLER-ERROR))
|
||||
|
||||
(IL:* IL:|;;| "Reading the #, macro")
|
||||
(IL:* IL:|;;| "Reading the #, macro")
|
||||
|
||||
(IL:VARIABLES *COMPILER-IS-READING*)
|
||||
(IL:STRUCTURES EVAL-WHEN-LOAD)
|
||||
|
||||
(IL:* IL:|;;| "Support for Block Compilation")
|
||||
(IL:* IL:|;;| "Support for Block Compilation")
|
||||
|
||||
(IL:VARIABLES *BLOCK-HASH-TABLE* *BLOCKS* *CURRENT-BLOCK*)
|
||||
(IL:STRUCTURES BLOCK-DECL)
|
||||
(IL:FUNCTIONS SET-UP-BLOCK-DECLS)
|
||||
|
||||
(IL:* IL:|;;| "Processing of top-level forms in a file")
|
||||
(IL:* IL:|;;| "Processing of top-level forms in a file")
|
||||
|
||||
(IL:VARIABLES PASS)
|
||||
(IL:FUNCTIONS CONSTANT-EXPRESSION-P)
|
||||
@@ -60,14 +59,14 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>XCLC-TOP-LEVEL.;9|)
|
||||
COMPILE-FILE-PROCESS-FUNCTION)
|
||||
(IL:FUNCTIONS CRACK-DEFMACRO ESTABLISH-MACRO-IN-COMPILER)
|
||||
|
||||
(IL:* IL:|;;| "Support for :Process-Entire-File")
|
||||
(IL:* IL:|;;| "Support for :Process-Entire-File")
|
||||
|
||||
(IL:VARIABLES *DEFERRED-FORMS* *MAKING-SECOND-PASS* *PREPROCESSING-PHASE*)
|
||||
(IL:FUNCTIONS COMPILE-SCAN-DECLARE\: COMPILE-SCAN-DEFINE-FILE-INFO COMPILE-SCAN-MACROLET
|
||||
COMPILE-SCAN-DEFINER COMPILE-SCAN-LOOSE-FORM COMPILE-SCAN-OUTSTANDING-LOOSE-FORMS)
|
||||
(IL:FUNCTIONS MERGE-FIRST-FORMS)
|
||||
|
||||
(IL:* IL:|;;| "for compiling definers")
|
||||
(IL:* IL:|;;| "for compiling definers")
|
||||
|
||||
(IL:VARIABLES *LAP-FLG* *AUTOMATIC-SPECIAL-DECLARATIONS*)
|
||||
(IL:FUNCTIONS COMPILE COMPILE-DEFINER)
|
||||
@@ -75,11 +74,11 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>XCLC-TOP-LEVEL.;9|)
|
||||
(IL:FUNCTIONS COMPILE-DEFINER-DEFINER COMPILE-DEFINER-NAMED-PROGN
|
||||
COMPILE-DEFINER-PROCESS-FUNCTION COMPILE-DEFINER-OUTSTANDING-LOOSE-FORMS)
|
||||
|
||||
(IL:* IL:|;;| "Arrange for correct compiler to be used.")
|
||||
(IL:* IL:|;;| "Arrange for correct compiler to be used.")
|
||||
|
||||
(IL:PROP IL:FILETYPE IL:XCLC-TOP-LEVEL)
|
||||
|
||||
(IL:* IL:|;;| "Arrange for the correct makefile environment")
|
||||
(IL:* IL:|;;| "Arrange for the correct makefile environment")
|
||||
|
||||
(IL:PROP IL:MAKEFILE-ENVIRONMENT IL:XCLC-TOP-LEVEL)))
|
||||
|
||||
@@ -89,9 +88,9 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>XCLC-TOP-LEVEL.;9|)
|
||||
|
||||
|
||||
(DEFSTRUCT (COMPILER-CONTEXT (:FAST-ACCESSORS T)
|
||||
(:CONC-NAME NIL)
|
||||
(:COPIER NIL)
|
||||
(:PREDICATE NIL))
|
||||
(:CONC-NAME NIL)
|
||||
(:COPIER NIL)
|
||||
(:PREDICATE NIL))
|
||||
SETF-SYMBOL-FUNCTION-FN
|
||||
DEFINEQ-FN
|
||||
DEFCONSTANT-FN
|
||||
@@ -185,51 +184,50 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>XCLC-TOP-LEVEL.;9|)
|
||||
(DEFVAR *LOOSE-NAME* NIL)
|
||||
|
||||
(DEFUN COMPILE-FILE (INPUT-FILE &KEY (OUTPUT-FILE NIL)
|
||||
(LAP-FILE NIL)
|
||||
(ERROR-FILE NIL)
|
||||
(ERRORS-TO-TERMINAL T)
|
||||
(FILE-MANAGER-FORMAT NIL F-M-F-GIVEN)
|
||||
(PROCESS-ENTIRE-FILE NIL P-E-F-GIVEN)
|
||||
(LOAD NIL))
|
||||
(LAP-FILE NIL)
|
||||
(ERROR-FILE NIL)
|
||||
(ERRORS-TO-TERMINAL T)
|
||||
(FILE-MANAGER-FORMAT NIL F-M-F-GIVEN)
|
||||
(PROCESS-ENTIRE-FILE NIL P-E-F-GIVEN)
|
||||
(LOAD NIL)) (IL:* IL:\; "Edited 25-Feb-2026 21:33 by rmk")
|
||||
|
||||
(IL:* IL:|;;;| "Compiles the forms on Input-File, producing a FASL file.")
|
||||
(IL:* IL:|;;;| "Compiles the forms on Input-File, producing a FASL file.")
|
||||
|
||||
(IL:* IL:|;;;| " :Output-File")
|
||||
(IL:* IL:|;;;| " :Output-File")
|
||||
|
||||
(IL:* IL:|;;| "The name of a file to which binary code should be written.")
|
||||
(IL:* IL:|;;| "The name of a file to which binary code should be written.")
|
||||
|
||||
(IL:* IL:|;;| " Defaults to Input-File with the extension '.dfasl'")
|
||||
(IL:* IL:|;;| " Defaults to Input-File with the extension '.dfasl'")
|
||||
|
||||
(IL:* IL:|;;;| ":Lap-File")
|
||||
(IL:* IL:|;;;| ":Lap-File")
|
||||
|
||||
(IL:* IL:|;;| "The name of a file to which LAP assemble code should be written.")
|
||||
(IL:* IL:|;;| "The name of a file to which LAP assemble code should be written.")
|
||||
|
||||
(IL:* IL:|;;|
|
||||
" If T, defulats to Input-File with the extension '.dlap', if NIL, no LAP file is produced.")
|
||||
(IL:* IL:|;;|
|
||||
" If T, defulats to Input-File with the extension '.dlap', if NIL, no LAP file is produced.")
|
||||
|
||||
(IL:* IL:|;;;| ":Error-FIle")
|
||||
(IL:* IL:|;;;| ":Error-FIle")
|
||||
|
||||
(IL:* IL:|;;| "The name of a file to which compiler error messages should be written. Defaults like :Lap-File, but with the extension '.log'")
|
||||
(IL:* IL:|;;| "The name of a file to which compiler error messages should be written. Defaults like :Lap-File, but with the extension '.log'")
|
||||
|
||||
(IL:* IL:|;;;| ":Errors-To-Terminal")
|
||||
(IL:* IL:|;;;| ":Errors-To-Terminal")
|
||||
|
||||
(IL:* IL:|;;|
|
||||
"True if error messages should be sent to *ERROR-OUTPUT* as well as any :Error-File.")
|
||||
(IL:* IL:|;;|
|
||||
"True if error messages should be sent to *ERROR-OUTPUT* as well as any :Error-File.")
|
||||
|
||||
(IL:* IL:|;;;| ":File-Manager-Format")
|
||||
(IL:* IL:|;;;| ":File-Manager-Format")
|
||||
|
||||
(IL:* IL:|;;|
|
||||
"True if the file should be assumed to have been produced by the MAKEFILE function.")
|
||||
(IL:* IL:|;;| "True if the file should be assumed to have been produced by the MAKEFILE function.")
|
||||
|
||||
(IL:* IL:|;;| "If not specified, we check the first non-blank character in the file. If that character is a left-paren, we assume that MAKEFILE made the file.")
|
||||
(IL:* IL:|;;| "If not specified, we check the first non-blank character in the file. If that character is a left-paren, we assume that MAKEFILE made the file.")
|
||||
|
||||
(IL:* IL:|;;;| ":Process-Entire-File")
|
||||
(IL:* IL:|;;;| ":Process-Entire-File")
|
||||
|
||||
(IL:* IL:|;;| "If true, the whole file is read in, evaluating those forms which are explicitly or implicitly EVAL-WHEN (OMPILE), before any code is generated. This allows macros to be defined after use, for example. This defaults to T if the file is declared or discovered to be in Interlisp format.")
|
||||
(IL:* IL:|;;| "If true, the whole file is read in, evaluating those forms which are explicitly or implicitly EVAL-WHEN (OMPILE), before any code is generated. This allows macros to be defined after use, for example. This defaults to T if the file is declared or discovered to be in Interlisp format.")
|
||||
|
||||
(IL:* IL:|;;;| ":Load")
|
||||
(IL:* IL:|;;;| ":Load")
|
||||
|
||||
(IL:* IL:|;;| "If true, definitions will be installed in the environment after they are compiled. If this is :SAVE, the any previous definitions are saved on the property list before the new ones are installed.")
|
||||
(IL:* IL:|;;| "If true, definitions will be installed in the environment after they are compiled. If this is :SAVE, the any previous definitions are saved on the property list before the new ones are installed.")
|
||||
|
||||
(LET ((*ERROR-OUTPUT* *ERROR-OUTPUT*)
|
||||
(*INPUT-STREAM* NIL)
|
||||
@@ -246,10 +244,10 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>XCLC-TOP-LEVEL.;9|)
|
||||
(*OUTSTANDING-LOOSE-FORMS* NIL)
|
||||
(*PROCESSED-FUNCTIONS* NIL)
|
||||
(*UNKNOWN-FUNCTIONS* NIL)
|
||||
(*INPUT-FILECOMS-VARIABLE* NIL) (IL:* IL:\;
|
||||
"Bound for the convenience of the optimizers on RPAQQ and PRETTYCOMPRINT.")
|
||||
(*INPUT-FILECOMS-VARIABLE* NIL) (IL:* IL:\;
|
||||
"Bound for the convenience of the optimizers on RPAQQ and PRETTYCOMPRINT.")
|
||||
|
||||
(IL:* IL:|;;| "Rebind all of these both to set up a canonical environment inside the compiler and to protect the outside environment from anything that might happen during this file.")
|
||||
(IL:* IL:|;;| "Rebind all of these both to set up a canonical environment inside the compiler and to protect the outside environment from anything that might happen during this file.")
|
||||
|
||||
(IL:SPECVARS T)
|
||||
(IL:LOCALVARS IL:SYSLOCALVARS)
|
||||
@@ -259,11 +257,11 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>XCLC-TOP-LEVEL.;9|)
|
||||
(IL:NLAML IL:NLAML)
|
||||
(IL:LAMA IL:LAMA)
|
||||
(IL:DONTCOMPILEFNS IL:DONTCOMPILEFNS))
|
||||
(DECLARE (SPECIAL IL:SPECVARS IL:LOCALVARS IL:LOCALFREEVARS IL:GLOBALVARS IL:NLAMA
|
||||
IL:NLAML IL:LAMA IL:DONTCOMPILEFNS))
|
||||
(DECLARE (SPECIAL IL:SPECVARS IL:LOCALVARS IL:LOCALFREEVARS IL:GLOBALVARS IL:NLAMA IL:NLAML
|
||||
IL:LAMA IL:DONTCOMPILEFNS))
|
||||
(UNWIND-PROTECT
|
||||
(PROGN
|
||||
(IL:* IL:|;;| "Set up the input stream.")
|
||||
(IL:* IL:|;;| "Set up the input stream.")
|
||||
|
||||
(LET ((PATH (OR (PROBE-FILE INPUT-FILE)
|
||||
(PROBE-FILE (MERGE-PATHNAMES INPUT-FILE ".lisp")))))
|
||||
@@ -281,19 +279,17 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>XCLC-TOP-LEVEL.;9|)
|
||||
(T (ERROR "The file \"~A\" is nonexistent or cannot be read.~%" INPUT-FILE
|
||||
))))
|
||||
|
||||
(IL:* IL:|;;| "Set up the FASL output stream.")
|
||||
(IL:* IL:|;;| "Set up the FASL output stream.")
|
||||
|
||||
(SETQ FASL-PATHNAME (COND
|
||||
(OUTPUT-FILE (PATHNAME OUTPUT-FILE))
|
||||
(T (MAKE-PATHNAME :TYPE
|
||||
(STRING (LOCALLY (DECLARE (SPECIAL
|
||||
IL:FASL.EXT)
|
||||
)
|
||||
(STRING (LOCALLY (DECLARE (SPECIAL IL:FASL.EXT))
|
||||
IL:FASL.EXT))
|
||||
:VERSION :NEWEST :DEFAULTS *INPUT-FILENAME*))))
|
||||
(SETQ *FASL-HANDLE* (FASL:OPEN-FASL-HANDLE FASL-PATHNAME))
|
||||
|
||||
(IL:* IL:|;;| "Set up the LAP stream.")
|
||||
(IL:* IL:|;;| "Set up the LAP stream.")
|
||||
|
||||
(WHEN LAP-FILE
|
||||
(SETQ *LAP-STREAM* (OPEN (IF (EQ LAP-FILE T)
|
||||
@@ -302,7 +298,7 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>XCLC-TOP-LEVEL.;9|)
|
||||
LAP-FILE)
|
||||
:DIRECTION :OUTPUT)))
|
||||
|
||||
(IL:* IL:|;;| "Set up the error output stream.")
|
||||
(IL:* IL:|;;| "Set up the error output stream.")
|
||||
|
||||
(WHEN ERROR-FILE
|
||||
(SETQ ERROR-FILE-STREAM (OPEN (IF (EQ ERROR-FILE T)
|
||||
@@ -317,8 +313,8 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>XCLC-TOP-LEVEL.;9|)
|
||||
*ERROR-OUTPUT*)
|
||||
ERROR-FILE-STREAM))
|
||||
|
||||
(IL:* IL:|;;|
|
||||
"Fix up the default values of FILE-MANAGER-FORMAT and PROCESS-ENTIRE-FILE.")
|
||||
(IL:* IL:|;;|
|
||||
"Fix up the default values of FILE-MANAGER-FORMAT and PROCESS-ENTIRE-FILE.")
|
||||
|
||||
(IF (NOT F-M-F-GIVEN)
|
||||
(SETQ FILE-MANAGER-FORMAT (EQ (IL:SKIPSEPRCODES *INPUT-STREAM* IL:FILERDTBL)
|
||||
@@ -326,22 +322,22 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>XCLC-TOP-LEVEL.;9|)
|
||||
(IF (NOT P-E-F-GIVEN)
|
||||
(SETQ PROCESS-ENTIRE-FILE FILE-MANAGER-FORMAT))
|
||||
|
||||
(IL:* IL:|;;| "Pick the right readtable and do the compilation.")
|
||||
(IL:* IL:|;;| "Pick the right readtable and do the compilation.")
|
||||
|
||||
(IL:WITH-READER-ENVIRONMENT (IF FILE-MANAGER-FORMAT
|
||||
IL:*OLD-INTERLISP-READ-ENVIRONMENT*
|
||||
IL:*DEFINE-FILE-INFO-ENV*
|
||||
IL:*COMMON-LISP-READ-ENVIRONMENT*)
|
||||
(START-COMPILATION)
|
||||
(PROCESS-FORMS PROCESS-ENTIRE-FILE)
|
||||
(FINISH-COMPILATION)
|
||||
(SETQ COMPILATION-SUCCEEDED T)
|
||||
|
||||
(IL:* IL:|;;|
|
||||
"Return the DFASL pathname so that people can say, for example, (LOAD (COMPILE-FILE ...))")
|
||||
(IL:* IL:|;;|
|
||||
"Return the DFASL pathname so that people can say, for example, (LOAD (COMPILE-FILE ...))")
|
||||
|
||||
FASL-PATHNAME))
|
||||
|
||||
(IL:* IL:|;;| "The compilation is over. Close all of the streams. If the compilations did not succeed (that is, we have aborted it), then delete the FASL file as well rather than leave garbage around.")
|
||||
(IL:* IL:|;;| "The compilation is over. Close all of the streams. If the compilations did not succeed (that is, we have aborted it), then delete the FASL file as well rather than leave garbage around.")
|
||||
|
||||
(IF (STREAMP *INPUT-STREAM*)
|
||||
(CLOSE *INPUT-STREAM*))
|
||||
@@ -352,9 +348,9 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>XCLC-TOP-LEVEL.;9|)
|
||||
(IF (STREAMP *LAP-STREAM*)
|
||||
(CLOSE *LAP-STREAM*)))))
|
||||
|
||||
(DEFUN START-COMPILATION () (IL:* IL:\; "Edited 19-Sep-2020 22:02 by rmk:")
|
||||
(DEFUN START-COMPILATION () (IL:* IL:\; "Edited 19-Sep-2020 22:02 by rmk:")
|
||||
|
||||
(IL:* IL:|;;;| "Write out banners on the various output files.")
|
||||
(IL:* IL:|;;;| "Write out banners on the various output files.")
|
||||
|
||||
(FLET ((DATE-STRING (UNIV-TIME)
|
||||
(MULTIPLE-VALUE-BIND (SECONDS MINUTES HOUR DATE MONTH YEAR DAY-OF-WEEK)
|
||||
@@ -370,7 +366,7 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>XCLC-TOP-LEVEL.;9|)
|
||||
(LET ((FASL-STREAM (FASL:BEGIN-TEXT *FASL-HANDLE*))
|
||||
(FILECREATED (IL:READ-FILECREATED *INPUT-STREAM*)))
|
||||
|
||||
(IL:* IL:|;;| "RMK: This had a complicated format, didn't work, so I reverted to printout. PRIN3 to stop wrap around")
|
||||
(IL:* IL:|;;| "RMK: This had a complicated format, didn't work, so I reverted to printout. PRIN3 to stop wrap around")
|
||||
|
||||
(IL:PRINTOUT FASL-STREAM "XCL Compiler output for source file " IL:\#
|
||||
(IL:PRIN3 (OR (CADDR FILECREATED)
|
||||
@@ -395,9 +391,9 @@ LAP file created ~A.~%~%"
|
||||
|
||||
(DEFUN FINISH-COMPILATION ()
|
||||
|
||||
(IL:* IL:|;;;| "Clean up after the compilation.")
|
||||
(IL:* IL:|;;;| "Clean up after the compilation.")
|
||||
|
||||
(IL:* IL:|;;| "Remove this file from IL:NOTCOMPILEDFILES for CLEANUP.")
|
||||
(IL:* IL:|;;| "Remove this file from IL:NOTCOMPILEDFILES for CLEANUP.")
|
||||
|
||||
(LOCALLY (DECLARE (IL:GLOBALVARS IL:NOTCOMPILEDFILES))
|
||||
(SETQ IL:NOTCOMPILEDFILES (REMOVE (INTERN (LET ((TYPE (PATHNAME-TYPE *INPUT-FILENAME*)))
|
||||
@@ -411,13 +407,13 @@ LAP file created ~A.~%~%"
|
||||
"INTERLISP")
|
||||
IL:NOTCOMPILEDFILES)))
|
||||
|
||||
(IL:* IL:|;;| "Possibly warn about unknown functions encountered during compilation.")
|
||||
(IL:* IL:|;;| "Possibly warn about unknown functions encountered during compilation.")
|
||||
|
||||
(WARN-ABOUT-UNKNOWN-FUNCTIONS))
|
||||
|
||||
(DEFUN SCAN-ONE-FORM (FORM COMPILER-CONTEXT)
|
||||
|
||||
(IL:* IL:|;;| "Assumes sedit like comments have already been stripped ")
|
||||
(IL:* IL:|;;| "Assumes sedit like comments have already been stripped ")
|
||||
|
||||
(IF (ATOM FORM)
|
||||
FORM
|
||||
@@ -433,8 +429,7 @@ LAP file created ~A.~%~%"
|
||||
(CERROR "Ignore this DEFMACRO." "~S is not a legal macro name." NAME)
|
||||
)
|
||||
(T (UNLESS *MAKING-SECOND-PASS*
|
||||
(ESTABLISH-MACRO-IN-COMPILER NAME (CRACK-DEFMACRO
|
||||
FORM)))
|
||||
(ESTABLISH-MACRO-IN-COMPILER NAME (CRACK-DEFMACRO FORM)))
|
||||
(SCAN-ONE-FORM (OPTIMIZE-AND-MACROEXPAND-1 FORM)
|
||||
COMPILER-CONTEXT)))))
|
||||
((EVAL-WHEN) (IF (NOT (AND (LISTP (SECOND FORM))
|
||||
@@ -476,12 +471,11 @@ LAP file created ~A.~%~%"
|
||||
VALUE)))))))
|
||||
((DEFCONSTANT) (COMPILER-APPLY DEFCONSTANT COMPILER-CONTEXT FORM))
|
||||
((IL:DECLARE\:) (COMPILER-APPLY IL:DECLARE\: COMPILER-CONTEXT FORM))
|
||||
((IL:SETF-SYMBOL-FUNCTION) (COMPILER-APPLY IL:SETF-SYMBOL-FUNCTION COMPILER-CONTEXT
|
||||
FORM))
|
||||
((IL:SETF-SYMBOL-FUNCTION) (COMPILER-APPLY IL:SETF-SYMBOL-FUNCTION COMPILER-CONTEXT FORM))
|
||||
((IL:DEFINEQ) (COMPILER-APPLY IL:DEFINEQ COMPILER-CONTEXT FORM))
|
||||
((IL:DEFINE-FILE-INFO) (COMPILER-APPLY IL:DEFINE-FILE-INFO COMPILER-CONTEXT FORM))
|
||||
((MAKE-PACKAGE IN-PACKAGE SHADOW SHADOWING-IMPORT EXPORT UNEXPORT USE-PACKAGE
|
||||
UNUSE-PACKAGE IMPORT DEFPACKAGE) (COMPILER-APPLY PACKAGE-FORM COMPILER-CONTEXT
|
||||
UNUSE-PACKAGE IMPORT DEFPACKAGE) (COMPILER-APPLY PACKAGE-FORM COMPILER-CONTEXT
|
||||
FORM))
|
||||
((PROCLAIM) (COMPILER-APPLY PROCLAIM COMPILER-CONTEXT FORM))
|
||||
((COMPILER-LET) (COMPILER-APPLY COMPILER-LET COMPILER-CONTEXT FORM))
|
||||
@@ -522,11 +516,11 @@ LAP file created ~A.~%~%"
|
||||
(DOLIST (PAIR (UNKNOWN-FUNCTION-WARNING-CALL-LIST CONDITION))
|
||||
(FORMAT T " ~S -- called from " (CAR PAIR))
|
||||
|
||||
(IL:* IL:|;;|
|
||||
"I almost used this hairy thing, but FORMAT is too slow... Aren't you glad?")
|
||||
(IL:* IL:|;;|
|
||||
"I almost used this hairy thing, but FORMAT is too slow... Aren't you glad?")
|
||||
|
||||
(IL:* IL:|;;|
|
||||
"\"~:[nowhere?!~;~:*~{~#[~;~S~;~S and ~S~:;~@{~#[~;and ~]~S~^, ~}~]~}.~]~%\"")
|
||||
(IL:* IL:|;;|
|
||||
"\"~:[nowhere?!~;~:*~{~#[~;~S~;~S and ~S~:;~@{~#[~;and ~]~S~^, ~}~]~}.~]~%\"")
|
||||
|
||||
(COND
|
||||
((NULL (CDR PAIR))
|
||||
@@ -563,32 +557,32 @@ LAP file created ~A.~%~%"
|
||||
|
||||
(DEFUN WARN-ABOUT-UNKNOWN-FUNCTIONS ()
|
||||
|
||||
(IL:* IL:|;;;| "If there's anything on *UNKNOWN-FUNCTIONS*, issue a summary and warning.")
|
||||
(IL:* IL:|;;;| "If there's anything on *UNKNOWN-FUNCTIONS*, issue a summary and warning.")
|
||||
|
||||
(WHEN (NOT (NULL *UNKNOWN-FUNCTIONS*))
|
||||
(WARN 'UNKNOWN-FUNCTION-WARNING :CALL-LIST *UNKNOWN-FUNCTIONS*)))
|
||||
|
||||
(DEFVAR *PROCESSED-FUNCTIONS*
|
||||
|
||||
(IL:* IL:|;;;| "A list of the names of the global functions processed during this compilation. Used in conjunction with *UNKNOWN-FUNCTIONS* to produce a warning at the end of compilation if there are any functions called but not defined.")
|
||||
(IL:* IL:|;;;| "A list of the names of the global functions processed during this compilation. Used in conjunction with *UNKNOWN-FUNCTIONS* to produce a warning at the end of compilation if there are any functions called but not defined.")
|
||||
|
||||
)
|
||||
|
||||
(DEFVAR *UNKNOWN-FUNCTIONS*
|
||||
|
||||
(IL:* IL:|;;;| "A list containing the names of undefined global functions called from code in the current compilation. Actually, it's an AList mapping the unknown function to the list of functions in which it is called. Used in conjunction with *PROCESSED-FUNCTIONS* to produce a warning at the end of compilation if there are any functions called but not defined.")
|
||||
(IL:* IL:|;;;| "A list containing the names of undefined global functions called from code in the current compilation. Actually, it's an AList mapping the unknown function to the list of functions in which it is called. Used in conjunction with *PROCESSED-FUNCTIONS* to produce a warning at the end of compilation if there are any functions called but not defined.")
|
||||
|
||||
)
|
||||
|
||||
(DEFVAR *CURRENT-FUNCTION*
|
||||
|
||||
(IL:* IL:|;;;| "The name of the unit currently being compiled.")
|
||||
(IL:* IL:|;;;| "The name of the unit currently being compiled.")
|
||||
|
||||
)
|
||||
|
||||
(DEFINE-CONDITION ASSEMBLER-ERROR
|
||||
|
||||
(IL:* IL:|;;;| "Signalled by an assembler when it encounters an unrecoverable error. The compiler catches such, prints an error message, and continues with the next form on the file.")
|
||||
(IL:* IL:|;;;| "Signalled by an assembler when it encounters an unrecoverable error. The compiler catches such, prints an error message, and continues with the next form on the file.")
|
||||
|
||||
(ERROR)
|
||||
(FORMAT-STRING FORMAT-ARGUMENTS)
|
||||
@@ -620,33 +614,33 @@ LAP file created ~A.~%~%"
|
||||
|
||||
(DEFVAR *BLOCK-HASH-TABLE* NIL
|
||||
|
||||
(IL:* IL:|;;;| "A mapping from function names to lists of BLOCK-DECL structures describing blocks that include that function. Initialized from the list of BLOCK: declarations gathered into *BLOCKS* (q.v.) during the preprocessing scan.")
|
||||
(IL:* IL:|;;;| "A mapping from function names to lists of BLOCK-DECL structures describing blocks that include that function. Initialized from the list of BLOCK: declarations gathered into *BLOCKS* (q.v.) during the preprocessing scan.")
|
||||
|
||||
)
|
||||
|
||||
(DEFVAR *BLOCKS* NIL
|
||||
|
||||
(IL:* IL:|;;;| "A list of the Interlisp block descriptions found on the file. This list is added to during the preprocessing scan of the file and then used for initialising *BLOCK-HASH-TABLE* (q.v.)")
|
||||
(IL:* IL:|;;;| "A list of the Interlisp block descriptions found on the file. This list is added to during the preprocessing scan of the file and then used for initialising *BLOCK-HASH-TABLE* (q.v.)")
|
||||
|
||||
)
|
||||
|
||||
(DEFVAR *CURRENT-BLOCK* NIL
|
||||
|
||||
(IL:* IL:|;;;| "Bound during compilation of a LAMBDA to the BLOCK-DECL structure describing the block containing the current function. This is NIL if the function is not a part of any block.")
|
||||
(IL:* IL:|;;;| "Bound during compilation of a LAMBDA to the BLOCK-DECL structure describing the block containing the current function. This is NIL if the function is not a part of any block.")
|
||||
|
||||
)
|
||||
|
||||
(DEFSTRUCT (BLOCK-DECL (:INLINE NIL))
|
||||
|
||||
(IL:* IL:|;;;|
|
||||
"A BLOCK-DECL holds the information describing a particular Interlisp BLOCK: declaration.")
|
||||
(IL:* IL:|;;;|
|
||||
"A BLOCK-DECL holds the information describing a particular Interlisp BLOCK: declaration.")
|
||||
|
||||
(IL:* IL:|;;;| "NAME is the symbol naming the block or NIL if this is only a pseudo-block.")
|
||||
(IL:* IL:|;;;| "NAME is the symbol naming the block or NIL if this is only a pseudo-block.")
|
||||
|
||||
(IL:* IL:|;;;|
|
||||
"FN-NAME-MAP is an AList mapping internal function names to their new \\BLOCK/FN style name.")
|
||||
(IL:* IL:|;;;|
|
||||
"FN-NAME-MAP is an AList mapping internal function names to their new \\BLOCK/FN style name.")
|
||||
|
||||
(IL:* IL:|;;;| "SPECVARS, LOCALVARS, LOCALFREEVARS and GLOBALVARS contain the values those variables should have during the compilation of functions in this block.")
|
||||
(IL:* IL:|;;;| "SPECVARS, LOCALVARS, LOCALFREEVARS and GLOBALVARS contain the values those variables should have during the compilation of functions in this block.")
|
||||
|
||||
NAME
|
||||
FN-NAME-MAP
|
||||
@@ -657,7 +651,7 @@ LAP file created ~A.~%~%"
|
||||
|
||||
(DEFUN SET-UP-BLOCK-DECLS (DECLS)
|
||||
|
||||
(IL:* IL:|;;;| "Parse the given list of Interlisp BLOCK: declarations and return a hash-table mapping functions named therein to a list of the BLOCK-DECLs representing decls mentioning that function.")
|
||||
(IL:* IL:|;;;| "Parse the given list of Interlisp BLOCK: declarations and return a hash-table mapping functions named therein to a list of the BLOCK-DECLs representing decls mentioning that function.")
|
||||
|
||||
(LET ((HASH-TABLE (MAKE-HASH-TABLE)))
|
||||
(DOLIST (DECL DECLS)
|
||||
@@ -670,9 +664,9 @@ LAP file created ~A.~%~%"
|
||||
(NOT-RENAMED-FNS (CONS BLOCK-NAME (UNION IL:RETFNS IL:NOLINKFNS)))
|
||||
(FNS NIL))
|
||||
(DECLARE (SPECIAL IL:SPECVARS IL:LOCALVARS IL:LOCALFREEVARS IL:GLOBALVARS
|
||||
IL:NOLINKFNS))
|
||||
IL:NOLINKFNS))
|
||||
|
||||
(IL:* IL:|;;| "We do this next bit because BCOMPL2 does it.")
|
||||
(IL:* IL:|;;| "We do this next bit because BCOMPL2 does it.")
|
||||
|
||||
(COND
|
||||
((NULL BLOCK-NAME)
|
||||
@@ -681,7 +675,7 @@ LAP file created ~A.~%~%"
|
||||
(T (SETQ IL:LOCALVARS T)
|
||||
(SETQ IL:SPECVARS IL:SYSSPECVARS)))
|
||||
|
||||
(IL:* IL:|;;| "For each item in the declaration, either add it to the list of functions or make the appropriate modifications to the named variable.")
|
||||
(IL:* IL:|;;| "For each item in the declaration, either add it to the list of functions or make the appropriate modifications to the named variable.")
|
||||
|
||||
(DOLIST (ITEM (CDR DECL))
|
||||
(COND
|
||||
@@ -709,8 +703,8 @@ LAP file created ~A.~%~%"
|
||||
"DONTCOMPILEFNS is not supported in BLOCK: declarations."
|
||||
))
|
||||
((IL:BLKAPPLYFNS IL:NOLINKFNS IL:RETFNS IL:ENTRIES)
|
||||
(IL:* IL:\;
|
||||
"These functions should not be renamed, according to BYTEBLOCKCOMPILE2.")
|
||||
(IL:* IL:\;
|
||||
"These functions should not be renamed, according to BYTEBLOCKCOMPILE2.")
|
||||
(WHEN (CONSP (CDR ITEM))
|
||||
(SETQ NOT-RENAMED-FNS (APPEND (CDR ITEM)
|
||||
NOT-RENAMED-FNS))))
|
||||
@@ -729,14 +723,14 @@ LAP file created ~A.~%~%"
|
||||
IL:GLOBALVARS)
|
||||
(LET* ((BLOCK-NAME-STRING (STRING BLOCK-NAME))
|
||||
(BLOCK-PACKAGE (SYMBOL-PACKAGE BLOCK-NAME)))
|
||||
(UNLESS (NULL BLOCK-NAME) (IL:* IL:\;
|
||||
"NIL blocks don't do renaming.")
|
||||
(UNLESS (NULL BLOCK-NAME) (IL:* IL:\;
|
||||
"NIL blocks don't do renaming.")
|
||||
(SETF (BLOCK-DECL-FN-NAME-MAP BD)
|
||||
(IL:|for| FN IL:|in| (NSET-DIFFERENCE FNS NOT-RENAMED-FNS)
|
||||
IL:|collect| (CONS FN (INTERN (CONCATENATE 'STRING "\\"
|
||||
BLOCK-NAME-STRING "/"
|
||||
(STRING FN))
|
||||
BLOCK-PACKAGE))))))))
|
||||
BLOCK-NAME-STRING "/"
|
||||
(STRING FN))
|
||||
BLOCK-PACKAGE))))))))
|
||||
HASH-TABLE))
|
||||
|
||||
|
||||
@@ -761,8 +755,8 @@ LAP file created ~A.~%~%"
|
||||
(RETURN NIL))))))))
|
||||
|
||||
(DEFUN COMPILE-AND-DUMP (NAME DEFN KIND)
|
||||
(LET ((*CURRENT-BLOCK* NIL) (IL:* IL:\;
|
||||
"So that we aren't dependent upon the top-level binding.")
|
||||
(LET ((*CURRENT-BLOCK* NIL) (IL:* IL:\;
|
||||
"So that we aren't dependent upon the top-level binding.")
|
||||
)
|
||||
(COND
|
||||
((AND (SYMBOLP NAME)
|
||||
@@ -783,7 +777,7 @@ LAP file created ~A.~%~%"
|
||||
(IL:LOCALFREEVARS (BLOCK-DECL-LOCALFREEVARS *CURRENT-BLOCK*))
|
||||
(IL:GLOBALVARS (BLOCK-DECL-GLOBALVARS *CURRENT-BLOCK*)))
|
||||
(DECLARE (SPECIAL IL:SPECVARS IL:LOCALVARS IL:LOCALFREEVARS
|
||||
IL:GLOBALVARS))
|
||||
IL:GLOBALVARS))
|
||||
(COMPILE-AND-DUMP-1 NEW-NAME DEFN KIND)))))))
|
||||
(T (COMPILE-AND-DUMP-1 NAME DEFN KIND)))))
|
||||
|
||||
@@ -824,14 +818,14 @@ LAP file created ~A.~%~%"
|
||||
(SYMBOL-FUNCTION NAME)))
|
||||
(SETF (SYMBOL-FUNCTION NAME)
|
||||
(D-ASSEM:INTERN-DCODE DCODE)))
|
||||
(:ONE-SHOT (LET ((IL:FILEPKGFLG NIL)) (IL:* IL:\;
|
||||
"so that things don't get marked as changed when you execute the one-shot.")
|
||||
(:ONE-SHOT (LET ((IL:FILEPKGFLG NIL)) (IL:* IL:\;
|
||||
"so that things don't get marked as changed when you execute the one-shot.")
|
||||
(DECLARE (SPECIAL IL:FILEPKGFLG))
|
||||
(FUNCALL (D-ASSEM:INTERN-DCODE DCODE))))))))
|
||||
|
||||
(DEFUN COMPILE-ONE-LAMBDA (NAME DEFN)
|
||||
|
||||
(IL:* IL:|;;;| "Return a LAP function for the given function definition. NAME is the symbol with which the definition will be associated at load time and DEFN is the LAMBDA-expression to be compiled.")
|
||||
(IL:* IL:|;;;| "Return a LAP function for the given function definition. NAME is the symbol with which the definition will be associated at load time and DEFN is the LAMBDA-expression to be compiled.")
|
||||
|
||||
(LET ((*CONTEXT* *NULL-CONTEXT*)
|
||||
(*AUTOMATIC-SPECIAL-DECLARATIONS* NIL))
|
||||
@@ -844,9 +838,9 @@ LAP file created ~A.~%~%"
|
||||
LAP-CODE)))
|
||||
|
||||
(DEFUN OPTIMIZE-AND-MACROEXPAND (FORM &OPTIONAL (ENVIRONMENT *ENVIRONMENT*)
|
||||
(CONTEXT *CONTEXT*))
|
||||
(CONTEXT *CONTEXT*))
|
||||
|
||||
(IL:* IL:|;;;| "Analagous to MACROEXPAND: keep trying OPTIMIZE-AND-MACROEXPAND-1 until it fails to change the form.")
|
||||
(IL:* IL:|;;;| "Analagous to MACROEXPAND: keep trying OPTIMIZE-AND-MACROEXPAND-1 until it fails to change the form.")
|
||||
|
||||
(PROG (NEW-FORM CHANGED-P)
|
||||
(MULTIPLE-VALUE-SETQ (NEW-FORM CHANGED-P)
|
||||
@@ -861,9 +855,9 @@ LAP file created ~A.~%~%"
|
||||
(RETURN (VALUES NEW-FORM T)))))
|
||||
|
||||
(DEFUN OPTIMIZE-AND-MACROEXPAND-1 (FORM &OPTIONAL (ENVIRONMENT *ENVIRONMENT*)
|
||||
(CONTEXT *CONTEXT*))
|
||||
(CONTEXT *CONTEXT*))
|
||||
|
||||
(IL:* IL:|;;;| "If the given form is a list, then look for macros and optimizers defined for its CAR. Return two values like MACROEXPAND-1.")
|
||||
(IL:* IL:|;;;| "If the given form is a list, then look for macros and optimizers defined for its CAR. Return two values like MACROEXPAND-1.")
|
||||
|
||||
(LET ((*NEW-COMPILER-IS-EXPANDING* T))
|
||||
(COND
|
||||
@@ -871,23 +865,23 @@ LAP file created ~A.~%~%"
|
||||
(NOT (SYMBOLP (CAR FORM))))
|
||||
(VALUES FORM NIL))
|
||||
(T
|
||||
(IL:* IL:|;;| "Check for compiler optimizers.")
|
||||
(IL:* IL:|;;| "Check for compiler optimizers.")
|
||||
|
||||
(LET ((OPTIMIZERS (OPTIMIZER-LIST (CAR FORM))))
|
||||
(WHEN (AND (NOT (NULL OPTIMIZERS))
|
||||
(NOT (ENV-FBOUNDP ENVIRONMENT (CAR FORM)
|
||||
:LEXICAL-ONLY T))
|
||||
(NOT (ENV-INLINE-DISALLOWED ENVIRONMENT (CAR FORM))))
|
||||
(IL:* IL:\;
|
||||
"Optimizers cannot apply to lexical functions or macros or to functions declared NOTINLINE.")
|
||||
(IL:* IL:\;
|
||||
"Optimizers cannot apply to lexical functions or macros or to functions declared NOTINLINE.")
|
||||
(DOLIST (OPT-FN OPTIMIZERS)
|
||||
(LET ((RESULT (FUNCALL OPT-FN FORM ENVIRONMENT CONTEXT)))
|
||||
(UNLESS (OR (EQ RESULT 'PASS)
|
||||
(EQ RESULT 'IL:IGNOREMACRO)
|
||||
(EQ RESULT FORM))(IL:* IL:\; "This optimizer fired.")
|
||||
(EQ RESULT FORM))(IL:* IL:\; "This optimizer fired.")
|
||||
(RETURN-FROM OPTIMIZE-AND-MACROEXPAND-1 (VALUES RESULT T)))))))
|
||||
|
||||
(IL:* IL:|;;| "Check for a macro expansion function.")
|
||||
(IL:* IL:|;;| "Check for a macro expansion function.")
|
||||
|
||||
(MACROEXPAND-1 FORM ENVIRONMENT)))))
|
||||
|
||||
@@ -919,47 +913,45 @@ LAP file created ~A.~%~%"
|
||||
(IL:RPAQQ (IF (EQ (SECOND FORM)
|
||||
*INPUT-FILECOMS-VARIABLE*)
|
||||
|
||||
(IL:* IL:|;;|
|
||||
"Don't remove comments from file coms")
|
||||
(IL:* IL:|;;| "Don't remove comments from file coms")
|
||||
|
||||
FORM
|
||||
(REMOVE-COMMENTS FORM)))
|
||||
(IL:DEFCLASS
|
||||
|
||||
(IL:* IL:|;;|
|
||||
"Don't remove comments from LOOPS DEFCLASS forms")
|
||||
(IL:* IL:|;;| "Don't remove comments from LOOPS DEFCLASS forms")
|
||||
|
||||
FORM)
|
||||
(IL:DATATYPE
|
||||
|
||||
(IL:* IL:|;;| "Don't remove comments from record declarations")
|
||||
(IL:* IL:|;;| "Don't remove comments from record declarations")
|
||||
|
||||
FORM)
|
||||
(IL:RECORD
|
||||
|
||||
(IL:* IL:|;;| "Don't remove comments from record declarations")
|
||||
(IL:* IL:|;;| "Don't remove comments from record declarations")
|
||||
|
||||
FORM)
|
||||
(IL:BLOCKRECORD
|
||||
|
||||
(IL:* IL:|;;| "Don't remove comments from record declarations")
|
||||
(IL:* IL:|;;| "Don't remove comments from record declarations")
|
||||
|
||||
FORM)
|
||||
(IL:DECLARE\:
|
||||
|
||||
(IL:* IL:|;;|
|
||||
"Process each form inside this as though it were at top-level")
|
||||
(IL:* IL:|;;|
|
||||
"Process each form inside this as though it were at top-level")
|
||||
|
||||
(IL:FOR X IL:IN FORM
|
||||
IL:COLLECT (COND
|
||||
((NOT (CONSP X))
|
||||
X)
|
||||
(T (CASE (CAR X)
|
||||
(IL:DEFCLASS X)
|
||||
(IL:DATATYPE X)
|
||||
(IL:RECORD X)
|
||||
(IL:BLOCKRECORD X)
|
||||
(OTHERWISE (REMOVE-COMMENTS X)))))))
|
||||
((NOT (CONSP X))
|
||||
X)
|
||||
(T (CASE (CAR X)
|
||||
(IL:DEFCLASS X)
|
||||
(IL:DATATYPE X)
|
||||
(IL:RECORD X)
|
||||
(IL:BLOCKRECORD X)
|
||||
(OTHERWISE (REMOVE-COMMENTS X)))))))
|
||||
(OTHERWISE (REMOVE-COMMENTS FORM)))))
|
||||
(SCAN-ONE-FORM NEW-FORM *COMPILE-SCAN-CONTEXT*))
|
||||
(SCAN-ONE-FORM FORM *COMPILE-FILE-CONTEXT*)))
|
||||
@@ -988,9 +980,10 @@ LAP file created ~A.~%~%"
|
||||
(WHEN *EVAL-WHEN-COMPILE* (EVAL FORM))
|
||||
(LET ((NAME (SECOND NAME-FORM))
|
||||
(DEFINITION (SECOND FUNCTION-FORM)))
|
||||
(COMPILER-APPLY PROCESS-FUNCTION COMPILER-CONTEXT (FORMAT NIL "~s ~a"
|
||||
(CAR DEFINITION)
|
||||
NAME)
|
||||
(COMPILER-APPLY PROCESS-FUNCTION COMPILER-CONTEXT (FORMAT NIL "~s ~a" (CAR
|
||||
DEFINITION
|
||||
)
|
||||
NAME)
|
||||
NAME DEFINITION)))
|
||||
(T (COMPILER-APPLY PROCESS-LOOSE-FORM COMPILER-CONTEXT FORM)))))
|
||||
|
||||
@@ -1002,8 +995,8 @@ LAP file created ~A.~%~%"
|
||||
(SECOND DEFN)
|
||||
(CONS 'IL:LAMBDA (CDR DEFN)))))
|
||||
(COMPILER-APPLY PROCESS-FUNCTION COMPILER-CONTEXT (FORMAT NIL "~s ~s"
|
||||
(CAR REAL-DEFN)
|
||||
(CAR DEFN))
|
||||
(CAR REAL-DEFN)
|
||||
(CAR DEFN))
|
||||
(CAR DEFN)
|
||||
REAL-DEFN)))
|
||||
(CDR FORM)))
|
||||
@@ -1019,10 +1012,10 @@ LAP file created ~A.~%~%"
|
||||
VALUE)
|
||||
(ENV-DECLARE-A-GLOBAL (FIND-TOP-ENVIRONMENT *ENVIRONMENT*)
|
||||
SYMBOL)))
|
||||
(SCAN-ONE-FORM `(NAMED-PROGN DEFCONSTANT ,SYMBOL
|
||||
(LOCALLY (DECLARE (GLOBAL ,SYMBOL))
|
||||
,(EXPAND-DEFINER 'DEFCONSTANT (REMOVE-COMMENTS FORM)
|
||||
*ENVIRONMENT*)))
|
||||
(SCAN-ONE-FORM `(NAMED-PROGN DEFCONSTANT ,SYMBOL (LOCALLY (DECLARE (GLOBAL ,SYMBOL))
|
||||
,(EXPAND-DEFINER 'DEFCONSTANT
|
||||
(REMOVE-COMMENTS FORM)
|
||||
*ENVIRONMENT*)))
|
||||
COMPILER-CONTEXT)))
|
||||
|
||||
(DEFUN COMPILE-FILE-DECLARE\: (COMPILER-CONTEXT FORM &OPTIONAL (DOCOPY T))
|
||||
@@ -1044,9 +1037,8 @@ LAP file created ~A.~%~%"
|
||||
((IL:COPYWHEN) (SETQ DOCOPY (IL:EVAL (CAR (SETQ TAIL (CDR TAIL))))))
|
||||
((IL:FIRST) )
|
||||
((IL:NOTFIRST IL:COMPILERVARS) )
|
||||
(OTHERWISE (COMPILER-MESSAGE
|
||||
"Warning: Ignoring unrecognized DECLARE: tag: ~S~%" (CAR TAIL))))
|
||||
)
|
||||
(OTHERWISE (COMPILER-MESSAGE "Warning: Ignoring unrecognized DECLARE: tag: ~S~%"
|
||||
(CAR TAIL)))))
|
||||
((EQ 'IL:DECLARE\: (CAR (CAR TAIL)))
|
||||
(COMPILER-APPLY IL:DECLARE\: COMPILER-CONTEXT (CAR TAIL)
|
||||
DOCOPY))
|
||||
@@ -1068,11 +1060,13 @@ LAP file created ~A.~%~%"
|
||||
IL:FILECREATEDLOC)
|
||||
(DECLARE (SPECIAL *STANDARD-INPUT* IL:FILECREATEDLOC))
|
||||
(EVAL FORM))
|
||||
(COMPILER-APPLY PROCESS-LOOSE-FORM COMPILER-CONTEXT
|
||||
`(LET ((*STANDARD-INPUT* (OPEN "{Null}" :DIRECTION :OUTPUT))
|
||||
IL:FILECREATEDLOC)
|
||||
(DECLARE (SPECIAL *STANDARD-INPUT* IL:FILECREATEDLOC))
|
||||
,FORM))
|
||||
(COMPILER-APPLY PROCESS-LOOSE-FORM COMPILER-CONTEXT `(LET ((*STANDARD-INPUT* (OPEN "{Null}"
|
||||
:DIRECTION
|
||||
:OUTPUT))
|
||||
IL:FILECREATEDLOC)
|
||||
(DECLARE (SPECIAL *STANDARD-INPUT*
|
||||
IL:FILECREATEDLOC))
|
||||
,FORM))
|
||||
(COMPILER-APPLY PROCESS-OUTSTANDING-LOOSE-FORMS COMPILER-CONTEXT))
|
||||
|
||||
(DEFUN COMPILE-FILE-PACKAGE-FORM (COMPILER-CONTEXT FORM)
|
||||
@@ -1229,7 +1223,7 @@ LAP file created ~A.~%~%"
|
||||
|
||||
(DEFUN CRACK-DEFMACRO (FORM)
|
||||
|
||||
(IL:* IL:|;;;| "FORM is a call to DEFMACRO. Return two values: the LAMBDA-expression representing the expansion function for the macro and the documentation string, if present.")
|
||||
(IL:* IL:|;;;| "FORM is a call to DEFMACRO. Return two values: the LAMBDA-expression representing the expansion function for the macro and the documentation string, if present.")
|
||||
|
||||
(LET ((NAME (SECOND FORM))
|
||||
(ARG-LIST (THIRD FORM))
|
||||
@@ -1245,7 +1239,7 @@ LAP file created ~A.~%~%"
|
||||
|
||||
(DEFUN ESTABLISH-MACRO-IN-COMPILER (NAME EXPN-FN)
|
||||
|
||||
(IL:* IL:|;;;| "Arrange for the symbol NAME to refer to a macro with the given expansion-function EXPN-FN within this compilation.")
|
||||
(IL:* IL:|;;;| "Arrange for the symbol NAME to refer to a macro with the given expansion-function EXPN-FN within this compilation.")
|
||||
|
||||
(ENV-BIND-FUNCTION (FIND-TOP-ENVIRONMENT *ENVIRONMENT*)
|
||||
NAME :MACRO EXPN-FN))
|
||||
@@ -1261,18 +1255,18 @@ LAP file created ~A.~%~%"
|
||||
|
||||
(DEFVAR *MAKING-SECOND-PASS* NIL
|
||||
|
||||
(IL:* IL:|;;;| "Bound to T during second pass over saved forms; used for :Process-Entire-File option to compile-file.")
|
||||
(IL:* IL:|;;;| "Bound to T during second pass over saved forms; used for :Process-Entire-File option to compile-file.")
|
||||
|
||||
)
|
||||
|
||||
(DEFVAR *PREPROCESSING-PHASE* NIL
|
||||
|
||||
(IL:* IL:|;;;| "Bound to T during the preprocessing phase so that inferiors can tell.")
|
||||
(IL:* IL:|;;;| "Bound to T during the preprocessing phase so that inferiors can tell.")
|
||||
|
||||
)
|
||||
|
||||
(DEFUN COMPILE-SCAN-DECLARE\: (COMPILER-CONTEXT FORM &OPTIONAL (DOCOPY T)
|
||||
(DOFIRST NIL))
|
||||
(DOFIRST NIL))
|
||||
(LET ((FIRST-FORMS NIL)
|
||||
(IL:DFNFLG IL:DFNFLG)
|
||||
(*EVAL-WHEN-COMPILE* *EVAL-WHEN-COMPILE*))
|
||||
@@ -1295,9 +1289,8 @@ LAP file created ~A.~%~%"
|
||||
((IL:FIRST) (SETQ DOFIRST T))
|
||||
((IL:NOTFIRST) (SETQ DOFIRST NIL))
|
||||
((IL:COMPILERVARS) (SETQ IL:DFNFLG T))
|
||||
(OTHERWISE (COMPILER-MESSAGE
|
||||
"Warning: Ignoring unrecognized DECLARE: tag: ~S~%" (CAR TAIL))))
|
||||
)
|
||||
(OTHERWISE (COMPILER-MESSAGE "Warning: Ignoring unrecognized DECLARE: tag: ~S~%"
|
||||
(CAR TAIL)))))
|
||||
((EQ 'IL:DECLARE\: (CAR (CAR TAIL)))
|
||||
(COMPILER-APPLY IL:DECLARE\: COMPILER-CONTEXT (CAR TAIL)
|
||||
DOCOPY DOFIRST))
|
||||
@@ -1416,7 +1409,7 @@ LAP file created ~A.~%~%"
|
||||
(*UNKNOWN-FUNCTIONS* NIL)
|
||||
(*CURRENT-FUNCTION* NAME)
|
||||
(*INPUT-STREAM* NIL)
|
||||
(*LAP-FLG* LAP) (IL:* IL:\; "FXAR-111")
|
||||
(*LAP-FLG* LAP) (IL:* IL:\; "FXAR-111")
|
||||
(COMPILED-DEFN (RAW-COMPILE NAME DEFN)))
|
||||
(DECLARE (SPECIAL IL:SPECVARS IL:LOCALVARS IL:LOCALFREEVARS IL:GLOBALVARS))
|
||||
(WARN-ABOUT-UNKNOWN-FUNCTIONS)
|
||||
@@ -1516,7 +1509,7 @@ LAP file created ~A.~%~%"
|
||||
(LET ((*ENVIRONMENT* (COPY-ENV *ENVIRONMENT*))
|
||||
COMPILED-DEFN)
|
||||
|
||||
(IL:* IL:|;;| "The resulting function is defined locally, so we have to compile for the host architecture rather than the target architecture:")
|
||||
(IL:* IL:|;;| "The resulting function is defined locally, so we have to compile for the host architecture rather than the target architecture:")
|
||||
|
||||
(SETF (ENV-TARGET-ARCHITECTURE *ENVIRONMENT*)
|
||||
*HOST-ARCHITECTURE*)
|
||||
@@ -1531,20 +1524,20 @@ LAP file created ~A.~%~%"
|
||||
|
||||
(DEFUN COMPILE-DEFINER-OUTSTANDING-LOOSE-FORMS (COMPILER-CONTEXT)
|
||||
|
||||
(IL:* IL:|;;|
|
||||
"Compile any outstanding loose forms in the context of a structure definition being compiled")
|
||||
(IL:* IL:|;;|
|
||||
"Compile any outstanding loose forms in the context of a structure definition being compiled")
|
||||
|
||||
(WHEN (NOT (NULL *OUTSTANDING-LOOSE-FORMS*))
|
||||
(LET* ((*ENVIRONMENT* (COPY-ENV *ENVIRONMENT*))
|
||||
COMPILED-DEFN)
|
||||
|
||||
(IL:* IL:|;;| "The resulting function is executed locally, so have to compile for the host architecture rather than the target architecture:")
|
||||
(IL:* IL:|;;| "The resulting function is executed locally, so have to compile for the host architecture rather than the target architecture:")
|
||||
|
||||
(SETF (ENV-TARGET-ARCHITECTURE *ENVIRONMENT*)
|
||||
*HOST-ARCHITECTURE*)
|
||||
(SETQ COMPILED-DEFN (RAW-COMPILE *LOOSE-NAME* `(LAMBDA NIL ,@(REVERSE
|
||||
*OUTSTANDING-LOOSE-FORMS*
|
||||
))))
|
||||
))))
|
||||
(SETQ *OUTSTANDING-LOOSE-FORMS* NIL)
|
||||
(FUNCALL COMPILED-DEFN))))
|
||||
|
||||
@@ -1561,36 +1554,37 @@ LAP file created ~A.~%~%"
|
||||
|
||||
|
||||
(IL:PUTPROPS IL:XCLC-TOP-LEVEL IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE
|
||||
(DEFPACKAGE "COMPILER"
|
||||
(:USE "LISP" "XCL"))))
|
||||
(IL:PUTPROPS IL:XCLC-TOP-LEVEL IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1989 1990 1991
|
||||
1994 2020))
|
||||
(DEFPACKAGE "COMPILER" (:USE "LISP"
|
||||
"XCL"))))
|
||||
(IL:DECLARE\: IL:DONTCOPY
|
||||
(IL:FILEMAP (NIL (7050 7194 (COMPILER-ERROR 7050 . 7194)) (8749 17618 (COMPILE-FILE 8749 . 17618)) (
|
||||
17620 20017 (START-COMPILATION 17620 . 20017)) (20019 21292 (FINISH-COMPILATION 20019 . 21292)) (21294
|
||||
26872 (SCAN-ONE-FORM 21294 . 26872)) (26874 27071 (FUNCTION-P 26874 . 27071)) (28998 29614 (
|
||||
CHECK-FOR-UNKNOWN-FUNCTION 28998 . 29614)) (29616 29870 (WARN-ABOUT-UNKNOWN-FUNCTIONS 29616 . 29870))
|
||||
(31345 31475 (ASSEMBLER-ERROR 31345 . 31475)) (33238 38333 (SET-UP-BLOCK-DECLS 33238 . 38333)) (38481
|
||||
39021 (CONSTANT-EXPRESSION-P 38481 . 39021)) (39023 40665 (COMPILE-AND-DUMP 39023 . 40665)) (40667
|
||||
42619 (COMPILE-AND-DUMP-1 40667 . 42619)) (42621 43312 (COMPILE-ONE-LAMBDA 42621 . 43312)) (43314
|
||||
44035 (OPTIMIZE-AND-MACROEXPAND 43314 . 44035)) (44037 45685 (OPTIMIZE-AND-MACROEXPAND-1 44037 . 45685
|
||||
)) (45893 49547 (PROCESS-FORMS 45893 . 49547)) (49549 49684 (MAYBE-REMOVE-COMMENTS 49549 . 49684)) (
|
||||
49686 50599 (COMPILE-FILE-SETF-SYMBOL-FUNCTION 49686 . 50599)) (50601 51400 (COMPILE-FILE-DEFINEQ
|
||||
50601 . 51400)) (51402 52329 (COMPILE-FILE-DEFCONSTANT 51402 . 52329)) (52331 54264 (
|
||||
COMPILE-FILE-DECLARE\: 52331 . 54264)) (54266 54828 (COMPILE-FILE-DEFINE-FILE-INFO 54266 . 54828)) (
|
||||
54830 55074 (COMPILE-FILE-PACKAGE-FORM 54830 . 55074)) (55076 57795 (COMPILE-FILE-PROCLAMATION 55076
|
||||
. 57795)) (57797 59208 (COMPILE-FILE-COMPILER-LET 57797 . 59208)) (59210 59890 (COMPILE-FILE-MACROLET
|
||||
59210 . 59890)) (59892 60882 (COMPILE-FILE-DEFINER 59892 . 60882)) (60884 61812 (
|
||||
COMPILE-FILE-NAMED-PROGN 60884 . 61812)) (61814 62464 (COMPILE-FILE-OUTSTANDING-LOOSE-FORMS 61814 .
|
||||
62464)) (62466 62608 (COMPILE-FILE-LOOSE-FORM 62466 . 62608)) (62610 62929 (
|
||||
COMPILE-FILE-PROCESS-FUNCTION 62610 . 62929)) (62931 63608 (CRACK-DEFMACRO 62931 . 63608)) (63610
|
||||
63893 (ESTABLISH-MACRO-IN-COMPILER 63610 . 63893)) (64587 66834 (COMPILE-SCAN-DECLARE\: 64587 . 66834)
|
||||
) (66836 67198 (COMPILE-SCAN-DEFINE-FILE-INFO 66836 . 67198)) (67200 68114 (COMPILE-SCAN-MACROLET
|
||||
67200 . 68114)) (68116 68751 (COMPILE-SCAN-DEFINER 68116 . 68751)) (68753 68886 (
|
||||
COMPILE-SCAN-LOOSE-FORM 68753 . 68886)) (68888 68962 (COMPILE-SCAN-OUTSTANDING-LOOSE-FORMS 68888 .
|
||||
68962)) (68964 69412 (MERGE-FIRST-FORMS 68964 . 69412)) (69537 71788 (COMPILE 69537 . 71788)) (71790
|
||||
72043 (COMPILE-DEFINER 71790 . 72043)) (72045 73084 (COMPILE-FORM 72045 . 73084)) (73086 73958 (
|
||||
RAW-COMPILE 73086 . 73958)) (73960 75059 (COMPILE-DEFINER-DEFINER 73960 . 75059)) (75061 75899 (
|
||||
COMPILE-DEFINER-NAMED-PROGN 75061 . 75899)) (75901 76736 (COMPILE-DEFINER-PROCESS-FUNCTION 75901 .
|
||||
76736)) (76738 77694 (COMPILE-DEFINER-OUTSTANDING-LOOSE-FORMS 76738 . 77694)))))
|
||||
(IL:FILEMAP (NIL (6860 7004 (COMPILER-ERROR 6860 . 7004)) (7006 7507 (COMPILER-APPLY 7006 . 7507)) (
|
||||
8559 17297 (COMPILE-FILE 8559 . 17297)) (17299 19704 (START-COMPILATION 17299 . 19704)) (19706 20979 (
|
||||
FINISH-COMPILATION 19706 . 20979)) (20981 26437 (SCAN-ONE-FORM 20981 . 26437)) (26439 26636 (
|
||||
FUNCTION-P 26439 . 26636)) (26638 26760 (COMPILER-MESSAGE 26638 . 26760)) (26762 26850 (
|
||||
COMPILING-MESSAGE 26762 . 26850)) (26852 26919 (DONE-MESSAGE 26852 . 26919)) (28567 29183 (
|
||||
CHECK-FOR-UNKNOWN-FUNCTION 28567 . 29183)) (29185 29439 (WARN-ABOUT-UNKNOWN-FUNCTIONS 29185 . 29439))
|
||||
(30914 31044 (ASSEMBLER-ERROR 30914 . 31044)) (32807 37890 (SET-UP-BLOCK-DECLS 32807 . 37890)) (38038
|
||||
38578 (CONSTANT-EXPRESSION-P 38038 . 38578)) (38580 40220 (COMPILE-AND-DUMP 38580 . 40220)) (40222
|
||||
42176 (COMPILE-AND-DUMP-1 40222 . 42176)) (42178 42869 (COMPILE-ONE-LAMBDA 42178 . 42869)) (42871
|
||||
43588 (OPTIMIZE-AND-MACROEXPAND 42871 . 43588)) (43590 45236 (OPTIMIZE-AND-MACROEXPAND-1 43590 . 45236
|
||||
)) (45238 45442 (EXPAND-DEFINER 45238 . 45442)) (45444 48977 (PROCESS-FORMS 45444 . 48977)) (48979
|
||||
49114 (MAYBE-REMOVE-COMMENTS 48979 . 49114)) (49116 50132 (COMPILE-FILE-SETF-SYMBOL-FUNCTION 49116 .
|
||||
50132)) (50134 50925 (COMPILE-FILE-DEFINEQ 50134 . 50925)) (50927 51935 (COMPILE-FILE-DEFCONSTANT
|
||||
50927 . 51935)) (51937 53854 (COMPILE-FILE-DECLARE\: 51937 . 53854)) (53856 54795 (
|
||||
COMPILE-FILE-DEFINE-FILE-INFO 53856 . 54795)) (54797 55041 (COMPILE-FILE-PACKAGE-FORM 54797 . 55041))
|
||||
(55043 57762 (COMPILE-FILE-PROCLAMATION 55043 . 57762)) (57764 59175 (COMPILE-FILE-COMPILER-LET 57764
|
||||
. 59175)) (59177 59857 (COMPILE-FILE-MACROLET 59177 . 59857)) (59859 60849 (COMPILE-FILE-DEFINER
|
||||
59859 . 60849)) (60851 61779 (COMPILE-FILE-NAMED-PROGN 60851 . 61779)) (61781 62431 (
|
||||
COMPILE-FILE-OUTSTANDING-LOOSE-FORMS 61781 . 62431)) (62433 62575 (COMPILE-FILE-LOOSE-FORM 62433 .
|
||||
62575)) (62577 62896 (COMPILE-FILE-PROCESS-FUNCTION 62577 . 62896)) (62898 63575 (CRACK-DEFMACRO 62898
|
||||
. 63575)) (63577 63860 (ESTABLISH-MACRO-IN-COMPILER 63577 . 63860)) (64554 66781 (
|
||||
COMPILE-SCAN-DECLARE\: 64554 . 66781)) (66783 67145 (COMPILE-SCAN-DEFINE-FILE-INFO 66783 . 67145)) (
|
||||
67147 68061 (COMPILE-SCAN-MACROLET 67147 . 68061)) (68063 68698 (COMPILE-SCAN-DEFINER 68063 . 68698))
|
||||
(68700 68833 (COMPILE-SCAN-LOOSE-FORM 68700 . 68833)) (68835 68909 (
|
||||
COMPILE-SCAN-OUTSTANDING-LOOSE-FORMS 68835 . 68909)) (68911 69359 (MERGE-FIRST-FORMS 68911 . 69359)) (
|
||||
69484 71735 (COMPILE 69484 . 71735)) (71737 71990 (COMPILE-DEFINER 71737 . 71990)) (71992 73031 (
|
||||
COMPILE-FORM 71992 . 73031)) (73033 73905 (RAW-COMPILE 73033 . 73905)) (73907 75006 (
|
||||
COMPILE-DEFINER-DEFINER 73907 . 75006)) (75008 75846 (COMPILE-DEFINER-NAMED-PROGN 75008 . 75846)) (
|
||||
75848 76683 (COMPILE-DEFINER-PROCESS-FUNCTION 75848 . 76683)) (76685 77639 (
|
||||
COMPILE-DEFINER-OUTSTANDING-LOOSE-FORMS 76685 . 77639)))))
|
||||
IL:STOP
|
||||
|
||||
Binary file not shown.
Reference in New Issue
Block a user