Compare commits
7 Commits
medley-251
...
fgh_wget
| Author | SHA1 | Date | |
|---|---|---|---|
|
4ae7a5d9af | ||
|
aae53a700f | ||
|
|
54f8b889b9 | ||
|
|
8d0011ce2c | ||
|
|
87b3ee3134 | ||
|
|
1ff49b58fe | ||
|
|
ac570f4b06 |
@@ -1,12 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
|
||||
|
||||
(FILECREATED "18-Aug-2025 12:09:49" |{WMEDLEY}<internal>loadups>LOADUP-LISP.;21| 6713
|
||||
(FILECREATED "16-Oct-2025 16:55:27" |{WMEDLEY}<internal>loadups>LOADUP-LISP.;22| 7104
|
||||
|
||||
:EDIT-BY |rmk|
|
||||
|
||||
:CHANGES-TO (FNS LOADUP-LISP)
|
||||
|
||||
:PREVIOUS-DATE "15-Jun-2025 14:39:57" |{WMEDLEY}<internal>loadups>LOADUP-LISP.;20|)
|
||||
:PREVIOUS-DATE "18-Aug-2025 12:09:49" |{WMEDLEY}<internal>loadups>LOADUP-LISP.;21|)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT LOADUP-LISPCOMS)
|
||||
@@ -19,7 +19,8 @@
|
||||
(DEFINEQ
|
||||
|
||||
(LOADUP-LISP
|
||||
(LAMBDA (DRIBBLEFILE) (* \; "Edited 18-Aug-2025 12:08 by rmk")
|
||||
(LAMBDA (DRIBBLEFILE) (* \; "Edited 16-Oct-2025 16:55 by rmk")
|
||||
(* \; "Edited 18-Aug-2025 12:08 by rmk")
|
||||
(* \; "Edited 15-Jun-2025 14:39 by rmk")
|
||||
(* \; "Edited 24-May-2025 10:20 by rmk")
|
||||
(* \; "Edited 21-May-2025 09:25 by rmk")
|
||||
@@ -89,9 +90,11 @@
|
||||
|
||||
(* |;;| "Before the MEDLEYFONT implementation, FONTPROFILE came after NEWPRINTDEF above, but the loadup failed for undiagnosed reasons. After moving it around, it appears that it must come before MENU, because it creates thw WINDOWTITLEFONT, but after HLDISPLAY. Not yet known what the HLDISPLAY dependency is. ")
|
||||
|
||||
(LOADUP '(UNICODE CMLPATHNAME HPRINT AARITH ADISPLAY HLDISPLAY FONTPROFILE MENU WINDOWOBJ
|
||||
WINDOWSCROLL WINDOW WINDOWICON PAINTW ATTACHEDWINDOW XXGEOM XXFILL DEXEC INSPECT
|
||||
DESCRIBE CMLARRAYINSPECTOR EDITINTERFACE TTYIN))
|
||||
(* |;;| "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 '(BREAK-AND-TRACE))
|
||||
(LOADUP '(FASDUMP XCL-COMPILER ADVISE))
|
||||
|
||||
@@ -141,5 +144,5 @@
|
||||
(GLOBALVARS MAKESYSFILENAME MEDLEY-INIT-VARS MEDLEYDIR SYSTEMINITVARS USERRECLST)
|
||||
)
|
||||
(DECLARE\: DONTCOPY
|
||||
(FILEMAP (NIL (640 6507 (LOADUP-LISP 650 . 6505)))))
|
||||
(FILEMAP (NIL (640 6898 (LOADUP-LISP 650 . 6896)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
700
library/UNICODE
700
library/UNICODE
@@ -1,20 +1,23 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "11-Oct-2025 13:01:09" {WMEDLEY}<library>UNICODE.;179 113928
|
||||
(FILECREATED "23-Oct-2025 08:31:21" {WMEDLEY}<library>UNICODE.;211 82245
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (VARS UNICODECOMS)
|
||||
(FNS XCCSTOMCCS-MAPPING READ-UNICODE-MAPPING MAKE-UNICODE-TRANSLATION-TABLES
|
||||
MERGE-UNICODE-TRANSLATION-TABLES UNICODE-EXTEND-TRANSLATION?)
|
||||
:CHANGES-TO (FNS UTOMCODE UTF8.INCCODEFN UTOMCODE? UTF8.PEEKCCODEFN)
|
||||
(VARS UNICODECOMS)
|
||||
(MACROS UNICODE.SMALLP)
|
||||
|
||||
:PREVIOUS-DATE " 5-Oct-2025 17:44:17" {WMEDLEY}<library>UNICODE.;174)
|
||||
:PREVIOUS-DATE "22-Oct-2025 23:28:51" {WMEDLEY}<library>UNICODE.;210)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT UNICODECOMS)
|
||||
|
||||
(RPAQQ UNICODECOMS
|
||||
((COMS (* ; "External formats")
|
||||
(
|
||||
(* ;; "Unicode external formats and MCCS-to-Unicode mapping functions. Must be loaded after UNICODE-TABLES.")
|
||||
|
||||
(COMS (* ; "External formats")
|
||||
(FNS UTF8.OUTCHARFN UTF8.SLUG.OUTCHARFN UTF8.INCCODEFN UTF8.PEEKCCODEFN
|
||||
\UTF8.BACKCCODEFN)
|
||||
(FNS UTF16BE.OUTCHARFN UTF16BE.INCCODEFN UTF16BE.PEEKCCODEFN \UTF16BE.BACKCCODEFN)
|
||||
@@ -26,38 +29,16 @@
|
||||
(ADDVARS (*DEFAULT-EXTERNALFORMATS* (UNIX :UTF-8)))
|
||||
(FNS UTF8.BINCODE \UTF8.FETCHCODE)
|
||||
(FNS UTF8.VALIDATE NUTF8-BYTE1-BYTES NUTF8-CODE-BYTES NUTF8-STRING-BYTES N-MCHARS)
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY (MACROS UNICODE.TRANSLATE \UTF8.GETBASEBYTE))
|
||||
(FNS MTOUCODE UTOMCODE MTOUCODE? UTOMCODE? MTOUSTRING UTOMSTRING MTOUTF8STRING
|
||||
UTF8TOMSTRING)
|
||||
(FNS XTOUCODE UTOXCODE XTOUCODE? UTOXCODE? XTOUSTRING UTOXSTRING XTOUTF8STRING))
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY (MACROS UNICODE.TRANSLATE \UTF8.GETBASEBYTE
|
||||
UNICODE.SMALLP)))
|
||||
|
||||
(* ;; "")
|
||||
|
||||
(COMS (* ; "Read Unicode mapping files")
|
||||
(INITVARS (UNICODEDIRECTORIES NIL))
|
||||
(VARS XCCS-CHARSETS)
|
||||
(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 ALL-UNICODE-MAPPINGS XCCSJAPANESECHARSETS)
|
||||
(INITVARS (*MCCSTOUNICODE*)
|
||||
(*UNICODETOMCCS*)
|
||||
(*MCCS-LOADED-CHARSETS*)
|
||||
(*UNICODE-LOADED-CHARSETS*))
|
||||
(GLOBALVARS *MCCSTOUNICODE* *UNICODETOMCCS* *NEXT-PRIVATE-UNICODE*
|
||||
*NEXT-PRIVATE-MCCSCODE* *MCCS-LOADED-CHARSETS* *UNICODE-LOADED-CHARSETS*)
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY
|
||||
|
||||
(* ;; "These come after the translation tables have been loaded, since the Unix file names needed to read the mapping files depend on the UTF8 string coercions. Those functions are defined as EVQ in UFS, cannot be used until the tables exist. This assumes that previous files have only 7-bit MCCS characters in their names.")
|
||||
|
||||
(* ;; "There are 6400 private Unicodes in 25 256-code charsets. For XCCS we map to a contiguous region of unused/reserved--private isn't big enough.")
|
||||
|
||||
(CONSTANTS (FIRST-PRIVATE-UNICODE (HEXNUM? "E000"))
|
||||
(LAST-PRIVATE-UNICODE (HEXNUM? "F8FF"))
|
||||
(FIRST-PRIVATE-MCCSCODE (CHARCODE "200,0"))
|
||||
(LAST-PRIVATE-MCCSCODE (CHARCODE "230,377")))
|
||||
(MACROS TRUECODEP))
|
||||
(DECLARE%: DONTEVAL@LOAD DOCOPY (P (MAKE-UNICODE-TRANSLATION-TABLES 'ALL]
|
||||
(FNS MTOUCODE UTOMCODE MTOUCODE? UTOMCODE? MTOUSTRING UTOMSTRING MTOUTF8STRING UTF8TOMSTRING)
|
||||
(FNS XTOUCODE UTOXCODE XTOUCODE? UTOXCODE? XTOUSTRING UTOXSTRING XTOUTF8STRING)
|
||||
|
||||
(* ;; "")
|
||||
|
||||
@@ -77,13 +58,20 @@
|
||||
(COMS (* ; "debugging")
|
||||
(FNS SHOWCHARS)
|
||||
(DECLARE%: DOEVAL@LOAD DONTCOPY (MACROS HEXCHAR OCTALCHAR)))
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY (FILES (FROM LOADUPS)
|
||||
EXPORTS.ALL))
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP)
|
||||
UNICODE-EXPORTS))
|
||||
(PROP (FILETYPE)
|
||||
UNICODE)))
|
||||
|
||||
|
||||
|
||||
(* ;;
|
||||
"Unicode external formats and MCCS-to-Unicode mapping functions. Must be loaded after UNICODE-TABLES."
|
||||
)
|
||||
|
||||
|
||||
|
||||
|
||||
(* ; "External formats")
|
||||
|
||||
(DEFINEQ
|
||||
@@ -150,7 +138,8 @@
|
||||
T])
|
||||
|
||||
(UTF8.INCCODEFN
|
||||
[LAMBDA (STREAM COUNTP RAW) (* ; "Edited 24-Apr-2025 15:44 by rmk")
|
||||
[LAMBDA (STREAM COUNTP RAW) (* ; "Edited 23-Oct-2025 08:31 by rmk")
|
||||
(* ; "Edited 24-Apr-2025 15:44 by rmk")
|
||||
(* ; "Edited 2-Feb-2024 11:44 by rmk")
|
||||
(* ; "Edited 30-Jan-2024 22:56 by rmk")
|
||||
(* ; "Edited 6-Aug-2021 16:02 by rmk:")
|
||||
@@ -235,13 +224,15 @@
|
||||
(LLSH (LOADBYTE BYTE3 0 6)
|
||||
6)
|
||||
(LOADBYTE BYTE4 0 6])
|
||||
(CL:UNLESS (OR RAW (NOT (SMALLP CODE)))
|
||||
(SETQ CODE (UNICODE.TRANSLATE CODE *UNICODETOMCCS*)))
|
||||
(CL:UNLESS RAW
|
||||
(SETQ CODE (UNICODE.TRANSLATE (UNICODE.SMALLP CODE)
|
||||
*UNICODETOMCCS*)))
|
||||
(CL:WHEN COUNTP (SETQ *BYTECOUNTER* COUNT))
|
||||
CODE])
|
||||
|
||||
(UTF8.PEEKCCODEFN
|
||||
[LAMBDA (STREAM NOERROR RAW) (* ; "Edited 24-Apr-2025 15:44 by rmk")
|
||||
[LAMBDA (STREAM NOERROR RAW) (* ; "Edited 23-Oct-2025 08:26 by rmk")
|
||||
(* ; "Edited 24-Apr-2025 15:44 by rmk")
|
||||
(* ; "Edited 2-Feb-2024 11:48 by rmk")
|
||||
(* ; "Edited 14-Jun-2021 22:53 by rmk:")
|
||||
|
||||
@@ -324,7 +315,8 @@
|
||||
elseif NOERROR
|
||||
else (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3 BYTE4]
|
||||
(CL:WHEN (AND CODE (NOT RAW))
|
||||
(SETQ CODE (UNICODE.TRANSLATE CODE *UNICODETOMCCS*)))
|
||||
(SETQ CODE (UNICODE.TRANSLATE (UNICODE.SMALLP CODE)
|
||||
*UNICODETOMCCS*)))
|
||||
(RETURN CODE])
|
||||
|
||||
(\UTF8.BACKCCODEFN
|
||||
@@ -854,7 +846,7 @@
|
||||
(* ;; "If RETURNALL and there are alternatives in the RANG, the list is returned. Othewise just the first one if the fake flag allows ")
|
||||
|
||||
(LET [(RANGE (OR (GETHASH CODE TRANSLATION-TABLE)
|
||||
(UNICODE.UNMAPPED CODE TRANSLATION-TABLE
|
||||
(UNICODE.UNMAPPED CODE TRANSLATION-TABLE
|
||||
DONTFAKE]
|
||||
(CL:WHEN RANGE
|
||||
(if (AND RETURNALL (CDR RANGE))
|
||||
@@ -872,8 +864,26 @@
|
||||
(ERROR "INVALID UTF8 BYTE" BYTE))
|
||||
BYTE)
|
||||
ELSE (\GETBASEBYTE BASE OFFSET))))
|
||||
|
||||
(PUTPROPS UNICODE.SMALLP MACRO [OPENLAMBDA (UNICODE) (* ;
|
||||
"Cananonicalizes a large UNICODE for EQ hash-testing")
|
||||
(OR (SMALLP UNICODE)
|
||||
(CAR (OR (MEMBER UNICODE *LARGEUNICODES*)
|
||||
(PUSH *LARGEUNICODES* UNICODE])
|
||||
)
|
||||
)
|
||||
|
||||
|
||||
|
||||
(* ;; "")
|
||||
|
||||
|
||||
|
||||
|
||||
(* ;;
|
||||
"These come after the translation tables have been loaded, since the Unix file names needed to read the mapping files depend on the UTF8 string coercions. Those functions are defined as EVQ in UFS, cannot be used until the tables exist. This assumes that previous files have only 7-bit MCCS characters in their names."
|
||||
)
|
||||
|
||||
(DEFINEQ
|
||||
|
||||
(MTOUCODE
|
||||
@@ -883,10 +893,12 @@
|
||||
(UNICODE.TRANSLATE MCODE *MCCSTOUNICODE*])
|
||||
|
||||
(UTOMCODE
|
||||
[LAMBDA (UNNICODE) (* ; "Edited 24-Apr-2025 10:17 by rmk")
|
||||
[LAMBDA (UNICODE) (* ; "Edited 23-Oct-2025 08:23 by rmk")
|
||||
(* ; "Edited 24-Apr-2025 10:17 by rmk")
|
||||
(* ; "Edited 16-Jan-2025 23:46 by rmk")
|
||||
(* ; "Edited 9-Aug-2020 09:04 by rmk:")
|
||||
(UNICODE.TRANSLATE UNNICODE *UNICODETOMCCS*])
|
||||
(UNICODE.TRANSLATE (UNICODE.SMALLP UNICODE)
|
||||
*UNICODETOMCCS*])
|
||||
|
||||
(MTOUCODE?
|
||||
[LAMBDA (MCODE) (* ; "Edited 4-Sep-2025 15:09 by rmk")
|
||||
@@ -902,7 +914,8 @@
|
||||
(UNICODE.TRANSLATE MCODE *MCCSTOUNICODE* T T])
|
||||
|
||||
(UTOMCODE?
|
||||
[LAMBDA (UNICODE) (* ; "Edited 24-Apr-2025 10:18 by rmk")
|
||||
[LAMBDA (UNICODE) (* ; "Edited 23-Oct-2025 08:24 by rmk")
|
||||
(* ; "Edited 24-Apr-2025 10:18 by rmk")
|
||||
(* ; "Edited 19-Jan-2025 21:14 by rmk")
|
||||
(* ; "Edited 18-Jan-2025 11:46 by rmk")
|
||||
(* ; "Edited 15-Jan-2025 19:51 by rmk")
|
||||
@@ -914,7 +927,10 @@
|
||||
(* ;;
|
||||
" NOTE: Alternative codes are returned in a list, the code itself is returned for a singleton.")
|
||||
|
||||
(UNICODE.TRANSLATE UNICODE *UNICODETOMCCS* T T])
|
||||
(* ;; "Canonicalize unicodes outside of the 16-bit plane")
|
||||
|
||||
(UNICODE.TRANSLATE (UNICODE.SMALLP UNICODE)
|
||||
*UNICODETOMCCS* T T])
|
||||
|
||||
(MTOUSTRING
|
||||
[LAMBDA (MSTRING DESTRUCTIVE) (* ; "Edited 2-Sep-2025 12:19 by rmk")
|
||||
@@ -1002,7 +1018,9 @@
|
||||
else MSTRING])
|
||||
|
||||
(UTF8TOMSTRING
|
||||
[LAMBDA (UTF8STRING) (* ; "Edited 9-Sep-2025 08:59 by rmk")
|
||||
[LAMBDA (UTF8STRING) (* ; "Edited 22-Oct-2025 22:00 by rmk")
|
||||
(* ; "Edited 16-Oct-2025 14:39 by rmk")
|
||||
(* ; "Edited 9-Sep-2025 08:59 by rmk")
|
||||
(CL:UNLESS (OR (STRINGP UTF8STRING)
|
||||
(LITATOM UTF8STRING))
|
||||
(SETQ UTF8STRING (MKSTRING UTF8STRING)))
|
||||
@@ -1112,552 +1130,6 @@
|
||||
|
||||
|
||||
|
||||
(* ; "Read Unicode mapping files")
|
||||
|
||||
|
||||
(RPAQ? UNICODEDIRECTORIES NIL)
|
||||
|
||||
(RPAQQ XCCS-CHARSETS
|
||||
((LATIN "0")
|
||||
(JAPANESE-SYMBOLS1 "41")
|
||||
(JAPANESE-SYMBOLS2 "42")
|
||||
(EXTENDED-LATIN "43")
|
||||
(HIRAGANA "44")
|
||||
(KATAKANA "45")
|
||||
(GREEK "46")
|
||||
(CYRILLIC "47")
|
||||
(FORMS "50")
|
||||
(RUNIC-GOTHIC "51")
|
||||
(MORE-CYRILLIC "52")
|
||||
(UNKNOWN1 "56")
|
||||
(UNKNOWN2 "57")
|
||||
(JIS "60-166")
|
||||
(ARABIC "340")
|
||||
(HEBREW "341")
|
||||
(IPA "342")
|
||||
(HANGUL "343")
|
||||
(GEORGIAN-ARMENIAN "344")
|
||||
(DEVANAGRI "345")
|
||||
(BENGALI "346")
|
||||
(GURMUKHI "347")
|
||||
(THAI-LAO "350")
|
||||
(SYMBOLS3 "353")
|
||||
(EXTENDED-ITC-DINGBATS "354")
|
||||
(ITC-DINGBATS1 "355")
|
||||
(SYMBOLS2 "356")
|
||||
(SYMBOLS1 "357")
|
||||
(LIGATURES "360")
|
||||
(ACCENTED-LATIN1 "361")
|
||||
(ACCENTED-LATIN2 "362")
|
||||
(ACCENTED-GREEK1 "363")
|
||||
(ACCENTED-GREEK2 "364")
|
||||
(MORE-ARABIC "365")
|
||||
(GRAPHIC-VARIANTS "375")
|
||||
(DEFAULT LATIN ACCENTED-LATIN1 EXTENDED-LATIN SYMBOLS1 SYMBOLS2 FORMS JAPANESE-SYMBOLS1
|
||||
JAPANESE-SYMBOLS2)
|
||||
(JAPANESE HIRAGANA KATAKANA JIS)))
|
||||
(DEFINEQ
|
||||
|
||||
(READ-UNICODE-MAPPING-FILENAMES
|
||||
[LAMBDA (FILESPEC) (* ; "Edited 4-Sep-2025 00:11 by rmk")
|
||||
(* ; "Edited 27-Jan-2025 16:46 by rmk")
|
||||
(* ; "Edited 21-Jan-2025 22:51 by rmk")
|
||||
(* ; "Edited 19-Jan-2025 12:21 by rmk")
|
||||
(* ; "Edited 3-Feb-2024 11:00 by rmk")
|
||||
(* ; "Edited 30-Jan-2024 08:45 by rmk")
|
||||
(* ; "Edited 26-Jan-2024 14:02 by mth")
|
||||
(* ; "Edited 5-Aug-2020 15:59 by kaplan")
|
||||
(* ; "Edited 4-Aug-2020 17:31 by rmk:")
|
||||
|
||||
(* ;; "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
|
||||
[if (EQ FILESPEC 'ALL)
|
||||
then
|
||||
(* ;;
|
||||
"Perhaps should figure out which files in the directories and subdirectories are relevant?")
|
||||
|
||||
(READ-UNICODE-MAPPING-FILENAMES (for N in XCCS-CHARSETS collect (CAR N)))
|
||||
else (FOR F X CSI INSIDE 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) (* ;
|
||||
"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])
|
||||
|
||||
(READ-UNICODE-MAPPING
|
||||
[LAMBDA (FILESPEC PRINT NOERROR) (* ; "Edited 11-Oct-2025 12:08 by rmk")
|
||||
(* ; "Edited 4-Sep-2025 00:17 by rmk")
|
||||
(* ; "Edited 24-Apr-2025 15:32 by rmk")
|
||||
(* ; "Edited 31-Jan-2025 17:43 by rmk")
|
||||
(* ; "Edited 17-Jan-2025 16:41 by rmk")
|
||||
(* ; "Edited 3-Feb-2024 00:21 by rmk")
|
||||
(* ; "Edited 5-Jan-2024 12:26 by rmk")
|
||||
(* ; "Edited 3-Jul-2021 13:37 by rmk:")
|
||||
|
||||
(* ;; "Combines the char-mapping tables from FILES coded in the Uncode-CDROM format. Comments prefixed by # and")
|
||||
|
||||
(* ;; " Column 1: XCCS input hex code in the format 0xXXXX")
|
||||
|
||||
(* ;; " Column 2: Corresponding Unicode code-sequence in the format")
|
||||
|
||||
(* ;; " 0xXXXX ... 0xYYYY")
|
||||
|
||||
(* ;; " Column 3: (after #) Character name in some mapping files, utf-8 character")
|
||||
|
||||
(* ;; " for XCCS mapping files")
|
||||
|
||||
(* ;; "")
|
||||
|
||||
(* ;; "Result is a list of (fromcode tocode1 ... tocoden) integer lists (almost always with only a single tocode, where fromcode is an XCCS code and the tocodes are corresponding Unicodes.")
|
||||
|
||||
(for FILE [SEPBITTABLE _ (MAKEBITTABLE (CHARCODE (TAB SPACE] in (READ-UNICODE-MAPPING-FILENAMES
|
||||
FILESPEC)
|
||||
join
|
||||
(* ;; "External format :THROUGH means read as bytes, so the Unicode UTF-8 comments cannot cause reading problems.")
|
||||
|
||||
(CL:WITH-OPEN-FILE (STREAM FILE :DIRECTION :INPUT :EXTERNAL-FORMAT `(:THROUGH LF))
|
||||
(bind LINE NAME CHARSET START MAP
|
||||
first (CL:UNLESS (FILEPOS "Name:" STREAM NIL NIL NIL T)
|
||||
(ERROR "NOT A UNICODE MAPPING FILE" (FULLNAME STREAM)))
|
||||
(SETQ NAME (CL:STRING-TRIM " " (CL:READ-LINE STREAM NIL NIL)))
|
||||
(SETQ CHARSET (CL:IF (FILEPOS "XCCS charset:" STREAM NIL NIL NIL T)
|
||||
(CL:STRING-TRIM " " (CL:READ-LINE STREAM NIL NIL))
|
||||
""))
|
||||
(CL:WHEN PRINT (* ; "Strip off XCCS in front of name")
|
||||
(PRINTOUT T T CHARSET " " [SUBSTRING NAME (CONSTANT
|
||||
(ADD1 (NCHARS "XCCS"]
|
||||
T)) while (SETQ LINE (CL:READ-LINE STREAM NIL NIL))
|
||||
when (SETQ START (STRPOSL SEPBITTABLE LINE 1 T))
|
||||
unless (EQ (CHARCODE %#)
|
||||
(NTHCHARCODE LINE START))
|
||||
collect [SETQ MAP (bind END CODES while [SETQ END (OR (STRPOSL SEPBITTABLE LINE
|
||||
START)
|
||||
(ADD1 (NCHARS LINE]
|
||||
collect [CHARCODE.DECODE (SUBSTRING LINE START
|
||||
(SUB1 END)
|
||||
(CONSTANT (CONCAT]
|
||||
repeatwhile (AND (SETQ START (STRPOSL SEPBITTABLE LINE END
|
||||
T))
|
||||
(NEQ (CHARCODE %#)
|
||||
(NTHCHARCODE LINE START)))
|
||||
finally (CL:WHEN (CDDR $$VAL)
|
||||
(* ; "Combiners go into a CADR list")
|
||||
(RPLACD $$VAL (CONS (CDR $$VAL))))]
|
||||
MAP])
|
||||
)
|
||||
|
||||
|
||||
|
||||
(* ; "Make translation tables for UTF external formats")
|
||||
|
||||
(DEFINEQ
|
||||
|
||||
(MAKE-UNICODE-TRANSLATION-TABLES
|
||||
[LAMBDA (MAPPING REINSTALL) (* ; "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")
|
||||
(* ; "Edited 26-Jan-2025 19:36 by rmk")
|
||||
(* ; "Edited 22-Jan-2025 14:22 by rmk")
|
||||
(* ; "Edited 19-Jan-2025 15:08 by rmk")
|
||||
(* ; "Edited 18-Jan-2025 11:52 by rmk")
|
||||
(* ; "Edited 3-Feb-2024 00:24 by rmk")
|
||||
(* ; "Edited 30-Jan-2024 09:54 by rmk")
|
||||
(* ; "Edited 21-Aug-2021 13:12 by rmk:")
|
||||
|
||||
(* ;; "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).")
|
||||
|
||||
(* ;; "")
|
||||
|
||||
(* ;; "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
|
||||
then (SETQ *MCCS-LOADED-CHARSETS* (SETQ *UNICODE-LOADED-CHARSETS* NIL))
|
||||
(SETQ *NEXT-PRIVATE-MCCSCODE* FIRST-PRIVATE-MCCSCODE)
|
||||
(SETQ *NEXT-PRIVATE-UNICODE* FIRST-PRIVATE-UNICODE)
|
||||
(LET [(TABLE (HASHARRAY (LENGTH MAPPING)))
|
||||
(INVERSETABLE (HASHARRAY (LENGTH MAPPING]
|
||||
(MERGE-UNICODE-TRANSLATION-TABLES NIL MAPPING TABLE INVERSETABLE)
|
||||
(SETQ *MCCSTOUNICODE* TABLE)
|
||||
(SETQ *UNICODETOMCCS* INVERSETABLE)
|
||||
(LIST *MCCSTOUNICODE* *UNICODETOMCCS*))
|
||||
else (CL:UNLESS (BOUNDP '*NEXT-PRIVATE-MCCSCODE*)
|
||||
(SETQ *NEXT-PRIVATE-MCCSCODE* FIRST-PRIVATE-MCCSCODE)
|
||||
(SETQ *NEXT-PRIVATE-UNICODE* FIRST-PRIVATE-UNICODE))
|
||||
(MERGE-UNICODE-TRANSLATION-TABLES NIL MAPPING])
|
||||
|
||||
(XCCSTOMCCS-MAPPING
|
||||
[LAMBDA (XTOUMAPPING) (* ; "Edited 11-Oct-2025 12:57 by rmk")
|
||||
|
||||
(* ;;
|
||||
"This translates the pairs that map XCCS to Unicode into pairs that translate MCCS to Unicode.")
|
||||
|
||||
(* ;;
|
||||
"We grab the affected pairs before we make any changes so that we don't get into ordering issues.")
|
||||
|
||||
(LET* ([XTOMCODES (CHARCODE ((Currency Dollar)
|
||||
(Dollar Currency)
|
||||
(Uparrow Circumflex)
|
||||
(Circumflex Uparrow)
|
||||
(Leftarrow Lowline)
|
||||
(Lowline Leftarrow]
|
||||
(AFFECTED (for MP in XTOUMAPPING when (thereis XP in XTOMCODES
|
||||
suchthat (EQ (CAR MP)
|
||||
(CAR XP))) collect MP)))
|
||||
(for AP in AFFECTED do (RPLACA AP (CADR (ASSOC (CAR AP)
|
||||
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")
|
||||
(* ; "Edited 31-Jan-2025 17:46 by rmk")
|
||||
(* ; "Edited 26-Jan-2025 13:40 by rmk")
|
||||
(* ; "Edited 22-Jan-2025 14:07 by rmk")
|
||||
(* ; "Edited 19-Jan-2025 12:20 by rmk")
|
||||
(* ; "Edited 17-Jan-2025 22:32 by rmk")
|
||||
(* ; "Edited 15-Jan-2025 09:49 by rmk")
|
||||
(* ; "Edited 27-Mar-2024 14:48 by rmk")
|
||||
(* ; "Edited 5-Feb-2024 13:14 by rmk")
|
||||
(* ; "Edited 3-Feb-2024 09:16 by rmk")
|
||||
|
||||
(* ;; "Reads all the XCCS-to-UNICODE mapping files that we know about, and produces a 2-level index that maps between MCCS codes and UNICODE codes, depending on INVERTED.")
|
||||
|
||||
(* ;; "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")
|
||||
|
||||
(* ;; " (CADR (ASSOC MCCSCODE (\CHARSET MCCSCODE) INDEX)))).")
|
||||
|
||||
(* ;; "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))
|
||||
|
||||
(* ;;
|
||||
"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 ...). (CADR is the first (and almost always) the only one.")
|
||||
|
||||
(pushnew [CDR (OR (ASSOC DOMAIN (CDR CHARSET))
|
||||
(CAR (push (CDR CHARSET)
|
||||
(CONS DOMAIN]
|
||||
RANGE))
|
||||
|
||||
(* ;; "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
|
||||
(* ;;
|
||||
"Sort the range alternatives, if any")
|
||||
|
||||
(change (CDR M)
|
||||
(SORT DATUM)))
|
||||
|
||||
(* ;; "Sort by domain codes and push down a level")
|
||||
|
||||
(change (CDR CS)
|
||||
(CONS (SORT DATUM T]
|
||||
(SETQ INDEX (SORT INDEX T)) (* ; "Sort character sets")
|
||||
(if FILE
|
||||
then (SETQ FILE (PACKFILENAME 'BODY (if (NEQ FILE T)
|
||||
then FILE
|
||||
elseif INVERTED
|
||||
then 'UNICODE-TO-MCCS-MAPPINGS
|
||||
else 'MCCS-TO-UNICODE-MAPPINGS)
|
||||
'DIRECTORY
|
||||
(CAR (MKLIST UNICODEDIRECTORIES))
|
||||
'EXTENSION
|
||||
'TXT))
|
||||
(CL:WITH-OPEN-FILE (STREAM FILE :DIRECTION :OUTPUT :IF-EXISTS :NEW-VERSION)
|
||||
|
||||
(* ;;
|
||||
"We can FILEPOS for %"[nnn %" then READ for each segment. Or just READFILE to get them all.")
|
||||
|
||||
(for I in INDEX do (PRINTOUT STREAM "[" (CAR I)
|
||||
" "
|
||||
(CADR I)
|
||||
"]" T T))
|
||||
(PRINTOUT STREAM "STOP" T)
|
||||
(FULLNAME STREAM))
|
||||
else INDEX])
|
||||
|
||||
(XCCSJAPANESECHARSETS
|
||||
[LAMBDA (OCTAL FILE) (* ; "Edited 11-Jun-2025 23:00 by rmk")
|
||||
|
||||
(* ;; "Returns the list of numbers for the Japanese character sets.")
|
||||
|
||||
(for F POS CS in (READ-UNICODE-MAPPING-FILENAMES "JIS")
|
||||
when (SETQ POS (STRPOS "XCCS-" F 1 NIL NIL T))
|
||||
collect [SETQ CS (SUBSTRING F POS (SUB1 (STRPOS '=JIS F POS]
|
||||
(CL:IF OCTAL
|
||||
CS
|
||||
(MKATOM (CONCAT CS "Q")))
|
||||
finally (SORT $$VAL)
|
||||
(CL:WHEN FILE
|
||||
(RETURN (CL:WITH-OPEN-FILE (STREAM (PACKFILENAME 'BODY (CL:IF (EQ FILE T)
|
||||
"JAPANESECHARSETS"
|
||||
FILE)
|
||||
'DIRECTORY
|
||||
(CAR (MKLIST UNICODEDIRECTORIES))
|
||||
'EXTENSION
|
||||
'TXT)
|
||||
:DIRECTION :OUTPUT :IF-EXISTS :NEW-VERSION)
|
||||
(PRINT $$VAL STREAM)
|
||||
(FULLNAME STREAM))))])
|
||||
)
|
||||
|
||||
(RPAQ? *MCCSTOUNICODE* )
|
||||
|
||||
(RPAQ? *UNICODETOMCCS* )
|
||||
|
||||
(RPAQ? *MCCS-LOADED-CHARSETS* )
|
||||
|
||||
(RPAQ? *UNICODE-LOADED-CHARSETS* )
|
||||
(DECLARE%: DOEVAL@COMPILE DONTCOPY
|
||||
|
||||
(GLOBALVARS *MCCSTOUNICODE* *UNICODETOMCCS* *NEXT-PRIVATE-UNICODE* *NEXT-PRIVATE-MCCSCODE*
|
||||
*MCCS-LOADED-CHARSETS* *UNICODE-LOADED-CHARSETS*)
|
||||
)
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(RPAQ FIRST-PRIVATE-UNICODE (HEXNUM? "E000"))
|
||||
|
||||
(RPAQ LAST-PRIVATE-UNICODE (HEXNUM? "F8FF"))
|
||||
|
||||
(RPAQ FIRST-PRIVATE-MCCSCODE (CHARCODE "200,0"))
|
||||
|
||||
(RPAQ LAST-PRIVATE-MCCSCODE (CHARCODE "230,377"))
|
||||
|
||||
|
||||
(CONSTANTS (FIRST-PRIVATE-UNICODE (HEXNUM? "E000"))
|
||||
(LAST-PRIVATE-UNICODE (HEXNUM? "F8FF"))
|
||||
(FIRST-PRIVATE-MCCSCODE (CHARCODE "200,0"))
|
||||
(LAST-PRIVATE-MCCSCODE (CHARCODE "230,377")))
|
||||
)
|
||||
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(PUTPROPS TRUECODEP MACRO (OPENLAMBDA (RANGE TABLE)
|
||||
|
||||
(* ;; "Return NIL if RANGE is a fake range in TABLE, otherwise RANGE.")
|
||||
|
||||
(CL:UNLESS (CL:IF (EQ TABLE *MCCSTOUNICODE*)
|
||||
(AND (IGEQ RANGE FIRST-PRIVATE-UNICODE)
|
||||
(ILEQ RANGE LAST-PRIVATE-UNICODE))
|
||||
(AND (IGEQ RANGE FIRST-PRIVATE-MCCSCODE)
|
||||
(ILEQ RANGE LAST-PRIVATE-MCCSCODE)))
|
||||
RANGE)))
|
||||
)
|
||||
)
|
||||
(DECLARE%: DONTEVAL@LOAD DOCOPY
|
||||
|
||||
(MAKE-UNICODE-TRANSLATION-TABLES 'ALL)
|
||||
)
|
||||
|
||||
|
||||
|
||||
(* ;; "")
|
||||
|
||||
|
||||
|
||||
|
||||
(* ; "Write Unicode mapping files")
|
||||
|
||||
(DEFINEQ
|
||||
@@ -2005,31 +1477,27 @@
|
||||
)
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY
|
||||
|
||||
(FILESLOAD (FROM LOADUPS)
|
||||
EXPORTS.ALL)
|
||||
(FILESLOAD (LOADCOMP)
|
||||
UNICODE-EXPORTS)
|
||||
)
|
||||
|
||||
(PUTPROPS UNICODE FILETYPE :TCOMPL)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (4573 19821 (UTF8.OUTCHARFN 4583 . 7599) (UTF8.SLUG.OUTCHARFN 7601 . 8265) (
|
||||
UTF8.INCCODEFN 8267 . 13988) (UTF8.PEEKCCODEFN 13990 . 18839) (\UTF8.BACKCCODEFN 18841 . 19819)) (
|
||||
19822 24512 (UTF16BE.OUTCHARFN 19832 . 20851) (UTF16BE.INCCODEFN 20853 . 21978) (UTF16BE.PEEKCCODEFN
|
||||
21980 . 23320) (\UTF16BE.BACKCCODEFN 23322 . 24510)) (24513 29236 (UTF16LE.OUTCHARFN 24523 . 25639) (
|
||||
UTF16LE.INCCODEFN 25641 . 26766) (UTF16LE.PEEKCCODEFN 26768 . 28044) (\UTF16LE.BACKCCODEFN 28046 .
|
||||
29234)) (29237 32284 (READBOM 29247 . 31316) (WRITEBOM 31318 . 32282)) (32314 35879 (
|
||||
MAKE-UNICODE-FORMATS 32324 . 35877)) (35976 40470 (UTF8.BINCODE 35986 . 38674) (\UTF8.FETCHCODE 38676
|
||||
. 40468)) (40471 46098 (UTF8.VALIDATE 40481 . 43078) (NUTF8-BYTE1-BYTES 43080 . 43817) (
|
||||
NUTF8-CODE-BYTES 43819 . 44876) (NUTF8-STRING-BYTES 44878 . 45774) (N-MCHARS 45776 . 46096)) (47826
|
||||
56695 (MTOUCODE 47836 . 48223) (UTOMCODE 48225 . 48615) (MTOUCODE? 48617 . 49650) (UTOMCODE? 49652 .
|
||||
50616) (MTOUSTRING 50618 . 51203) (UTOMSTRING 51205 . 51790) (MTOUTF8STRING 51792 . 55798) (
|
||||
UTF8TOMSTRING 55800 . 56693)) (56696 62398 (XTOUCODE 56706 . 57224) (UTOXCODE 57226 . 57734) (
|
||||
XTOUCODE? 57736 . 58797) (UTOXCODE? 58799 . 59882) (XTOUSTRING 59884 . 60577) (UTOXSTRING 60579 .
|
||||
61320) (XTOUTF8STRING 61322 . 62396)) (63635 71937 (READ-UNICODE-MAPPING-FILENAMES 63645 . 67442) (
|
||||
READ-UNICODE-MAPPING 67444 . 71935)) (72004 86230 (MAKE-UNICODE-TRANSLATION-TABLES 72014 . 75770) (
|
||||
XCCSTOMCCS-MAPPING 75772 . 76989) (MERGE-UNICODE-TRANSLATION-TABLES 76991 . 79644) (UNICODE.UNMAPPED
|
||||
79646 . 82970) (UNICODE-EXTEND-TRANSLATION? 82972 . 86228)) (86231 93067 (ALL-UNICODE-MAPPINGS 86241
|
||||
. 91730) (XCCSJAPANESECHARSETS 91732 . 93065)) (94658 105926 (WRITE-UNICODE-MAPPING 94668 . 98418) (
|
||||
WRITE-UNICODE-INCLUDED 98420 . 103142) (WRITE-UNICODE-MAPPING-HEADER 103144 . 104392) (
|
||||
WRITE-UNICODE-MAPPING-FILENAME 104394 . 105924)) (105927 106603 (XCCS-UTF8-AFTER-OPEN 105937 . 106601)
|
||||
) (109128 111345 (UTF8HEXSTRING 109138 . 111343)) (111372 113414 (SHOWCHARS 111382 . 113412)))))
|
||||
(FILEMAP (NIL (3488 19026 (UTF8.OUTCHARFN 3498 . 6514) (UTF8.SLUG.OUTCHARFN 6516 . 7180) (
|
||||
UTF8.INCCODEFN 7182 . 13035) (UTF8.PEEKCCODEFN 13037 . 18044) (\UTF8.BACKCCODEFN 18046 . 19024)) (
|
||||
19027 23717 (UTF16BE.OUTCHARFN 19037 . 20056) (UTF16BE.INCCODEFN 20058 . 21183) (UTF16BE.PEEKCCODEFN
|
||||
21185 . 22525) (\UTF16BE.BACKCCODEFN 22527 . 23715)) (23718 28441 (UTF16LE.OUTCHARFN 23728 . 24844) (
|
||||
UTF16LE.INCCODEFN 24846 . 25971) (UTF16LE.PEEKCCODEFN 25973 . 27249) (\UTF16LE.BACKCCODEFN 27251 .
|
||||
28439)) (28442 31489 (READBOM 28452 . 30521) (WRITEBOM 30523 . 31487)) (31519 35084 (
|
||||
MAKE-UNICODE-FORMATS 31529 . 35082)) (35181 39675 (UTF8.BINCODE 35191 . 37879) (\UTF8.FETCHCODE 37881
|
||||
. 39673)) (39676 45303 (UTF8.VALIDATE 39686 . 42283) (NUTF8-BYTE1-BYTES 42285 . 43022) (
|
||||
NUTF8-CODE-BYTES 43024 . 44081) (NUTF8-STRING-BYTES 44083 . 44979) (N-MCHARS 44981 . 45301)) (47785
|
||||
57213 (MTOUCODE 47795 . 48182) (UTOMCODE 48184 . 48710) (MTOUCODE? 48712 . 49745) (UTOMCODE? 49747 .
|
||||
50916) (MTOUSTRING 50918 . 51503) (UTOMSTRING 51505 . 52090) (MTOUTF8STRING 52092 . 56098) (
|
||||
UTF8TOMSTRING 56100 . 57211)) (57214 62916 (XTOUCODE 57224 . 57742) (UTOXCODE 57744 . 58252) (
|
||||
XTOUCODE? 58254 . 59315) (UTOXCODE? 59317 . 60400) (XTOUSTRING 60402 . 61095) (UTOXSTRING 61097 .
|
||||
61838) (XTOUTF8STRING 61840 . 62914)) (62979 74247 (WRITE-UNICODE-MAPPING 62989 . 66739) (
|
||||
WRITE-UNICODE-INCLUDED 66741 . 71463) (WRITE-UNICODE-MAPPING-HEADER 71465 . 72713) (
|
||||
WRITE-UNICODE-MAPPING-FILENAME 72715 . 74245)) (74248 74924 (XCCS-UTF8-AFTER-OPEN 74258 . 74922)) (
|
||||
77449 79666 (UTF8HEXSTRING 77459 . 79664)) (79693 81735 (SHOWCHARS 79703 . 81733)))))
|
||||
STOP
|
||||
|
||||
79
library/UNICODE-EXPORTS
Normal file
79
library/UNICODE-EXPORTS
Normal file
@@ -0,0 +1,79 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "22-Oct-2025 23:27:50" {WMEDLEY}<library>UNICODE-EXPORTS.;1 2673
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (VARS UNICODE-EXPORTSCOMS))
|
||||
|
||||
|
||||
(PRETTYCOMPRINT UNICODE-EXPORTSCOMS)
|
||||
|
||||
(RPAQQ UNICODE-EXPORTSCOMS
|
||||
(
|
||||
(* ;; "Compile-time declarations shared by UNICODE-TABLES and UNICODE")
|
||||
|
||||
(GLOBALVARS *MCCSTOUNICODE* *UNICODETOMCCS* *NEXT-PRIVATE-UNICODE* *NEXT-PRIVATE-MCCSCODE*
|
||||
*MCCS-LOADED-CHARSETS* *UNICODE-LOADED-CHARSETS* *LARGEUNICODES*)
|
||||
|
||||
(* ;; "There are 6400 private Unicodes in 25 256-code charsets. For MCCS we map to a contiguous region of unused/reserved--private isn't big enough.")
|
||||
|
||||
(CONSTANTS (FIRST-PRIVATE-UNICODE (HEXNUM? "E000"))
|
||||
(LAST-PRIVATE-UNICODE (HEXNUM? "F8FF"))
|
||||
(FIRST-PRIVATE-MCCSCODE (CHARCODE "200,0"))
|
||||
(LAST-PRIVATE-MCCSCODE (CHARCODE "230,377")))
|
||||
(MACROS TRUECODEP)
|
||||
(FILES (FROM LOADUPS)
|
||||
EXPORTS.ALL)))
|
||||
|
||||
|
||||
|
||||
(* ;; "Compile-time declarations shared by UNICODE-TABLES and UNICODE")
|
||||
|
||||
(DECLARE%: DOEVAL@COMPILE DONTCOPY
|
||||
|
||||
(GLOBALVARS *MCCSTOUNICODE* *UNICODETOMCCS* *NEXT-PRIVATE-UNICODE* *NEXT-PRIVATE-MCCSCODE*
|
||||
*MCCS-LOADED-CHARSETS* *UNICODE-LOADED-CHARSETS* *LARGEUNICODES*)
|
||||
)
|
||||
|
||||
|
||||
|
||||
(* ;;
|
||||
"There are 6400 private Unicodes in 25 256-code charsets. For MCCS we map to a contiguous region of unused/reserved--private isn't big enough."
|
||||
)
|
||||
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(RPAQ FIRST-PRIVATE-UNICODE (HEXNUM? "E000"))
|
||||
|
||||
(RPAQ LAST-PRIVATE-UNICODE (HEXNUM? "F8FF"))
|
||||
|
||||
(RPAQ FIRST-PRIVATE-MCCSCODE (CHARCODE "200,0"))
|
||||
|
||||
(RPAQ LAST-PRIVATE-MCCSCODE (CHARCODE "230,377"))
|
||||
|
||||
|
||||
(CONSTANTS (FIRST-PRIVATE-UNICODE (HEXNUM? "E000"))
|
||||
(LAST-PRIVATE-UNICODE (HEXNUM? "F8FF"))
|
||||
(FIRST-PRIVATE-MCCSCODE (CHARCODE "200,0"))
|
||||
(LAST-PRIVATE-MCCSCODE (CHARCODE "230,377")))
|
||||
)
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(PUTPROPS TRUECODEP MACRO (OPENLAMBDA (RANGE TABLE)
|
||||
|
||||
(* ;; "Return NIL if RANGE is a fake range in TABLE, otherwise RANGE.")
|
||||
|
||||
(CL:UNLESS (CL:IF (EQ TABLE *MCCSTOUNICODE*)
|
||||
(AND (IGEQ RANGE FIRST-PRIVATE-UNICODE)
|
||||
(ILEQ RANGE LAST-PRIVATE-UNICODE))
|
||||
(AND (IGEQ RANGE FIRST-PRIVATE-MCCSCODE)
|
||||
(ILEQ RANGE LAST-PRIVATE-MCCSCODE)))
|
||||
RANGE)))
|
||||
)
|
||||
|
||||
(FILESLOAD (FROM LOADUPS)
|
||||
EXPORTS.ALL)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL)))
|
||||
STOP
|
||||
571
library/UNICODE-TABLES
Normal file
571
library/UNICODE-TABLES
Normal file
@@ -0,0 +1,571 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "22-Oct-2025 23:28:42" {WMEDLEY}<library>UNICODE-TABLES.;4 34028
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (VARS UNICODE-TABLESCOMS)
|
||||
|
||||
:PREVIOUS-DATE "16-Oct-2025 16:47:54" {WMEDLEY}<library>UNICODE-TABLES.;3)
|
||||
|
||||
|
||||
(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.")
|
||||
|
||||
(COMS (* ; "Read Unicode mapping files")
|
||||
(INITVARS (UNICODEDIRECTORIES NIL))
|
||||
(GLOBALVARS UNICODEDIRECTORIES)
|
||||
(VARS XCCS-CHARSETS)
|
||||
(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 ALL-UNICODE-MAPPINGS XCCSJAPANESECHARSETS)
|
||||
(INITVARS (*MCCSTOUNICODE*)
|
||||
(*UNICODETOMCCS*)
|
||||
(*MCCS-LOADED-CHARSETS*)
|
||||
(*UNICODE-LOADED-CHARSETS*)
|
||||
(*LARGEUNICODES*))
|
||||
[DECLARE%: DONTEVAL@LOAD DOCOPY (P (MAKE-UNICODE-TRANSLATION-TABLES 'ALL]
|
||||
(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."
|
||||
)
|
||||
|
||||
|
||||
|
||||
|
||||
(* ; "Read Unicode mapping files")
|
||||
|
||||
|
||||
(RPAQ? UNICODEDIRECTORIES NIL)
|
||||
(DECLARE%: DOEVAL@COMPILE DONTCOPY
|
||||
|
||||
(GLOBALVARS UNICODEDIRECTORIES)
|
||||
)
|
||||
|
||||
(RPAQQ XCCS-CHARSETS
|
||||
((LATIN "0")
|
||||
(JAPANESE-SYMBOLS1 "41")
|
||||
(JAPANESE-SYMBOLS2 "42")
|
||||
(EXTENDED-LATIN "43")
|
||||
(HIRAGANA "44")
|
||||
(KATAKANA "45")
|
||||
(GREEK "46")
|
||||
(CYRILLIC "47")
|
||||
(FORMS "50")
|
||||
(RUNIC-GOTHIC "51")
|
||||
(MORE-CYRILLIC "52")
|
||||
(UNKNOWN1 "56")
|
||||
(UNKNOWN2 "57")
|
||||
(JIS "60-166")
|
||||
(ARABIC "340")
|
||||
(HEBREW "341")
|
||||
(IPA "342")
|
||||
(HANGUL "343")
|
||||
(GEORGIAN-ARMENIAN "344")
|
||||
(DEVANAGRI "345")
|
||||
(BENGALI "346")
|
||||
(GURMUKHI "347")
|
||||
(THAI-LAO "350")
|
||||
(SYMBOLS3 "353")
|
||||
(EXTENDED-ITC-DINGBATS "354")
|
||||
(ITC-DINGBATS1 "355")
|
||||
(SYMBOLS2 "356")
|
||||
(SYMBOLS1 "357")
|
||||
(LIGATURES "360")
|
||||
(ACCENTED-LATIN1 "361")
|
||||
(ACCENTED-LATIN2 "362")
|
||||
(ACCENTED-GREEK1 "363")
|
||||
(ACCENTED-GREEK2 "364")
|
||||
(MORE-ARABIC "365")
|
||||
(GRAPHIC-VARIANTS "375")
|
||||
(DEFAULT LATIN ACCENTED-LATIN1 EXTENDED-LATIN SYMBOLS1 SYMBOLS2 FORMS JAPANESE-SYMBOLS1
|
||||
JAPANESE-SYMBOLS2)
|
||||
(JAPANESE HIRAGANA KATAKANA JIS)))
|
||||
(DEFINEQ
|
||||
|
||||
(READ-UNICODE-MAPPING-FILENAMES
|
||||
[LAMBDA (FILESPEC) (* ; "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")
|
||||
(* ; "Edited 19-Jan-2025 12:21 by rmk")
|
||||
(* ; "Edited 3-Feb-2024 11:00 by rmk")
|
||||
(* ; "Edited 30-Jan-2024 08:45 by rmk")
|
||||
(* ; "Edited 26-Jan-2024 14:02 by mth")
|
||||
(* ; "Edited 5-Aug-2020 15:59 by kaplan")
|
||||
(* ; "Edited 4-Aug-2020 17:31 by rmk:")
|
||||
|
||||
(* ;; "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
|
||||
(* ;;
|
||||
"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)")
|
||||
|
||||
(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])
|
||||
|
||||
(READ-UNICODE-MAPPING
|
||||
[LAMBDA (FILESPEC PRINT NOERROR) (* ; "Edited 16-Oct-2025 11:25 by rmk")
|
||||
(* ; "Edited 11-Oct-2025 12:08 by rmk")
|
||||
(* ; "Edited 4-Sep-2025 00:17 by rmk")
|
||||
(* ; "Edited 24-Apr-2025 15:32 by rmk")
|
||||
(* ; "Edited 31-Jan-2025 17:43 by rmk")
|
||||
(* ; "Edited 17-Jan-2025 16:41 by rmk")
|
||||
(* ; "Edited 3-Feb-2024 00:21 by rmk")
|
||||
(* ; "Edited 5-Jan-2024 12:26 by rmk")
|
||||
(* ; "Edited 3-Jul-2021 13:37 by rmk:")
|
||||
|
||||
(* ;; "Combines the char-mapping tables from FILES coded in the Uncode-CDROM format. Comments prefixed by # and")
|
||||
|
||||
(* ;; " Column 1: XCCS input hex code in the format 0xXXXX")
|
||||
|
||||
(* ;; " Column 2: Corresponding Unicode code-sequence in the format")
|
||||
|
||||
(* ;; " 0xXXXX ... 0xYYYY")
|
||||
|
||||
(* ;; " Column 3: (after #) Character name in some mapping files, utf-8 character")
|
||||
|
||||
(* ;; " for XCCS mapping files")
|
||||
|
||||
(* ;; "")
|
||||
|
||||
(RESETLST
|
||||
(for FILE STREAM [SEPBITTABLE _ (MAKEBITTABLE (CHARCODE (TAB SPACE] in (
|
||||
READ-UNICODE-MAPPING-FILENAMES
|
||||
FILESPEC)
|
||||
join
|
||||
(* ;; "External format :THROUGH means read as bytes, so the Unicode UTF-8 comments cannot cause reading problems.")
|
||||
|
||||
[RESETSAVE [SETQ STREAM (OPENSTREAM FILE 'INPUT NIL '((FORMAT :THROUGH)
|
||||
(EOLCONVENTION LF]
|
||||
'(PROGN (CLOSEF? OLDVALUE]
|
||||
(bind LINE NAME CHARSET START
|
||||
first (CL:UNLESS (FILEPOS "Name:" STREAM NIL NIL NIL T)
|
||||
(ERROR "NOT A UNICODE MAPPING FILE" (FULLNAME STREAM)))
|
||||
(SETQ NAME (CL:STRING-TRIM " " (CL:READ-LINE STREAM NIL NIL)))
|
||||
(SETQ CHARSET (CL:IF (FILEPOS "XCCS charset:" STREAM NIL NIL NIL T)
|
||||
(CL:STRING-TRIM " " (CL:READ-LINE STREAM NIL NIL))
|
||||
""))
|
||||
(CL:WHEN PRINT (* ; "Strip off XCCS in front of name")
|
||||
(PRINTOUT T T CHARSET " " [SUBSTRING NAME (CONSTANT (ADD1 (NCHARS "XCCS"
|
||||
]
|
||||
T)) while (SETQ LINE (CL:READ-LINE STREAM NIL NIL))
|
||||
when (SETQ START (STRPOSL SEPBITTABLE LINE 1 T))
|
||||
unless (EQ (CHARCODE %#)
|
||||
(NTHCHARCODE LINE START))
|
||||
collect [bind END CODES while [SETQ END (OR (STRPOSL SEPBITTABLE LINE START)
|
||||
(ADD1 (NCHARS LINE]
|
||||
collect [CHARCODE.DECODE (SUBSTRING LINE START (SUB1 END)
|
||||
(CONSTANT (CONCAT]
|
||||
repeatwhile (AND (SETQ START (STRPOSL SEPBITTABLE LINE END T))
|
||||
(NEQ (CHARCODE %#)
|
||||
(NTHCHARCODE LINE START)))
|
||||
finally (CL:WHEN (CDDR $$VAL) (* ; "Combiners go into a CADR list")
|
||||
(RPLACD $$VAL (CONS (CDR $$VAL))))]
|
||||
finally (CLOSEF? STREAM))))])
|
||||
)
|
||||
|
||||
|
||||
|
||||
(* ; "Make translation tables for UTF external formats")
|
||||
|
||||
(DEFINEQ
|
||||
|
||||
(MAKE-UNICODE-TRANSLATION-TABLES
|
||||
[LAMBDA (MAPPING REINSTALL) (* ; "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")
|
||||
(* ; "Edited 26-Jan-2025 19:36 by rmk")
|
||||
(* ; "Edited 22-Jan-2025 14:22 by rmk")
|
||||
(* ; "Edited 19-Jan-2025 15:08 by rmk")
|
||||
(* ; "Edited 18-Jan-2025 11:52 by rmk")
|
||||
(* ; "Edited 3-Feb-2024 00:24 by rmk")
|
||||
(* ; "Edited 30-Jan-2024 09:54 by rmk")
|
||||
(* ; "Edited 21-Aug-2021 13:12 by rmk:")
|
||||
|
||||
(* ;; "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).")
|
||||
|
||||
(* ;; "")
|
||||
|
||||
(* ;; "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
|
||||
then (SETQ *MCCS-LOADED-CHARSETS* (SETQ *UNICODE-LOADED-CHARSETS* NIL))
|
||||
(SETQ *NEXT-PRIVATE-MCCSCODE* FIRST-PRIVATE-MCCSCODE)
|
||||
(SETQ *NEXT-PRIVATE-UNICODE* FIRST-PRIVATE-UNICODE)
|
||||
(LET [(TABLE (HASHARRAY (LENGTH MAPPING)))
|
||||
(INVERSETABLE (HASHARRAY (LENGTH MAPPING]
|
||||
(MERGE-UNICODE-TRANSLATION-TABLES NIL MAPPING TABLE INVERSETABLE)
|
||||
(SETQ *MCCSTOUNICODE* TABLE)
|
||||
(SETQ *UNICODETOMCCS* INVERSETABLE)
|
||||
(LIST *MCCSTOUNICODE* *UNICODETOMCCS*))
|
||||
else (CL:UNLESS (BOUNDP '*NEXT-PRIVATE-MCCSCODE*)
|
||||
(SETQ *NEXT-PRIVATE-MCCSCODE* FIRST-PRIVATE-MCCSCODE)
|
||||
(SETQ *NEXT-PRIVATE-UNICODE* FIRST-PRIVATE-UNICODE))
|
||||
(MERGE-UNICODE-TRANSLATION-TABLES NIL MAPPING])
|
||||
|
||||
(XCCSTOMCCS-MAPPING
|
||||
[LAMBDA (XTOUMAPPING) (* ; "Edited 11-Oct-2025 12:57 by rmk")
|
||||
|
||||
(* ;;
|
||||
"This translates the pairs that map XCCS to Unicode into pairs that translate MCCS to Unicode.")
|
||||
|
||||
(* ;;
|
||||
"We grab the affected pairs before we make any changes so that we don't get into ordering issues.")
|
||||
|
||||
(LET* ([XTOMCODES (CHARCODE ((Currency Dollar)
|
||||
(Dollar Currency)
|
||||
(Uparrow Circumflex)
|
||||
(Circumflex Uparrow)
|
||||
(Leftarrow Lowline)
|
||||
(Lowline Leftarrow]
|
||||
(AFFECTED (for MP in XTOUMAPPING when (thereis XP in XTOMCODES
|
||||
suchthat (EQ (CAR MP)
|
||||
(CAR XP))) collect MP)))
|
||||
(for AP in AFFECTED do (RPLACA AP (CADR (ASSOC (CAR AP)
|
||||
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")
|
||||
(* ; "Edited 31-Jan-2025 17:46 by rmk")
|
||||
(* ; "Edited 26-Jan-2025 13:40 by rmk")
|
||||
(* ; "Edited 22-Jan-2025 14:07 by rmk")
|
||||
(* ; "Edited 19-Jan-2025 12:20 by rmk")
|
||||
(* ; "Edited 17-Jan-2025 22:32 by rmk")
|
||||
(* ; "Edited 15-Jan-2025 09:49 by rmk")
|
||||
(* ; "Edited 27-Mar-2024 14:48 by rmk")
|
||||
(* ; "Edited 5-Feb-2024 13:14 by rmk")
|
||||
(* ; "Edited 3-Feb-2024 09:16 by rmk")
|
||||
|
||||
(* ;; "Reads all the XCCS-to-UNICODE mapping files that we know about, and produces a 2-level index that maps between MCCS codes and UNICODE codes, depending on INVERTED.")
|
||||
|
||||
(* ;; "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")
|
||||
|
||||
(* ;; " (CADR (ASSOC MCCSCODE (\CHARSET MCCSCODE) INDEX)))).")
|
||||
|
||||
(* ;; "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))
|
||||
|
||||
(* ;;
|
||||
"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 ...). (CADR is the first (and almost always) the only one.")
|
||||
|
||||
(pushnew [CDR (OR (ASSOC DOMAIN (CDR CHARSET))
|
||||
(CAR (push (CDR CHARSET)
|
||||
(CONS DOMAIN]
|
||||
RANGE))
|
||||
|
||||
(* ;; "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
|
||||
(* ;;
|
||||
"Sort the range alternatives, if any")
|
||||
|
||||
(change (CDR M)
|
||||
(SORT DATUM)))
|
||||
|
||||
(* ;; "Sort by domain codes and push down a level")
|
||||
|
||||
(change (CDR CS)
|
||||
(CONS (SORT DATUM T]
|
||||
(SETQ INDEX (SORT INDEX T)) (* ; "Sort character sets")
|
||||
(if FILE
|
||||
then (SETQ FILE (PACKFILENAME 'BODY (if (NEQ FILE T)
|
||||
then FILE
|
||||
elseif INVERTED
|
||||
then 'UNICODE-TO-MCCS-MAPPINGS
|
||||
else 'MCCS-TO-UNICODE-MAPPINGS)
|
||||
'DIRECTORY
|
||||
(CAR (MKLIST UNICODEDIRECTORIES))
|
||||
'EXTENSION
|
||||
'TXT))
|
||||
(CL:WITH-OPEN-FILE (STREAM FILE :DIRECTION :OUTPUT :IF-EXISTS :NEW-VERSION)
|
||||
|
||||
(* ;;
|
||||
"We can FILEPOS for %"[nnn %" then READ for each segment. Or just READFILE to get them all.")
|
||||
|
||||
(for I in INDEX do (PRINTOUT STREAM "[" (CAR I)
|
||||
" "
|
||||
(CADR I)
|
||||
"]" T T))
|
||||
(PRINTOUT STREAM "STOP" T)
|
||||
(FULLNAME STREAM))
|
||||
else INDEX])
|
||||
|
||||
(XCCSJAPANESECHARSETS
|
||||
[LAMBDA (OCTAL FILE) (* ; "Edited 11-Jun-2025 23:00 by rmk")
|
||||
|
||||
(* ;; "Returns the list of numbers for the Japanese character sets.")
|
||||
|
||||
(for F POS CS in (READ-UNICODE-MAPPING-FILENAMES "JIS")
|
||||
when (SETQ POS (STRPOS "XCCS-" F 1 NIL NIL T))
|
||||
collect [SETQ CS (SUBSTRING F POS (SUB1 (STRPOS '=JIS F POS]
|
||||
(CL:IF OCTAL
|
||||
CS
|
||||
(MKATOM (CONCAT CS "Q")))
|
||||
finally (SORT $$VAL)
|
||||
(CL:WHEN FILE
|
||||
(RETURN (CL:WITH-OPEN-FILE (STREAM (PACKFILENAME 'BODY (CL:IF (EQ FILE T)
|
||||
"JAPANESECHARSETS"
|
||||
FILE)
|
||||
'DIRECTORY
|
||||
(CAR (MKLIST UNICODEDIRECTORIES))
|
||||
'EXTENSION
|
||||
'TXT)
|
||||
:DIRECTION :OUTPUT :IF-EXISTS :NEW-VERSION)
|
||||
(PRINT $$VAL STREAM)
|
||||
(FULLNAME STREAM))))])
|
||||
)
|
||||
|
||||
(RPAQ? *MCCSTOUNICODE* )
|
||||
|
||||
(RPAQ? *UNICODETOMCCS* )
|
||||
|
||||
(RPAQ? *MCCS-LOADED-CHARSETS* )
|
||||
|
||||
(RPAQ? *UNICODE-LOADED-CHARSETS* )
|
||||
|
||||
(RPAQ? *LARGEUNICODES* )
|
||||
(DECLARE%: DONTEVAL@LOAD DOCOPY
|
||||
|
||||
(MAKE-UNICODE-TRANSLATION-TABLES 'ALL)
|
||||
)
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY
|
||||
|
||||
(FILESLOAD (LOADCOMP)
|
||||
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)))))
|
||||
STOP
|
||||
BIN
library/UNICODE-TABLES.LCOM
Normal file
BIN
library/UNICODE-TABLES.LCOM
Normal file
Binary file not shown.
Binary file not shown.
@@ -1,11 +1,13 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "13-Nov-2023 12:57:10" {DSK}<home>frank>il>medley>gmedley>library>UNIXUTILS.;26 16663
|
||||
(FILECREATED " 2-Nov-2025 12:18:12" {DSK}<home>frank>il>medley>library>UNIXUTILS.;2 18685
|
||||
|
||||
:CHANGES-TO (FNS ShellBrowser)
|
||||
:EDIT-BY "FGH"
|
||||
|
||||
:PREVIOUS-DATE "11-Nov-2023 09:06:39" {DSK}<home>frank>il>medley>gmedley>library>UNIXUTILS.;25
|
||||
)
|
||||
:CHANGES-TO (VARS UNIXUTILSCOMS)
|
||||
(FUNCTIONS ShellWget)
|
||||
|
||||
:PREVIOUS-DATE "22-Oct-2025 13:05:51" {DSK}<home>frank>il>medley>library>UNIXUTILS.;1)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT UNIXUTILSCOMS)
|
||||
@@ -17,7 +19,7 @@
|
||||
(GLOBALVARS ShellBrowser ShellOpener)
|
||||
(INITVARS (ShellBrowser)
|
||||
(ShellOpener))
|
||||
(FUNCTIONS ShellCommand ShellWhich)
|
||||
(FUNCTIONS ShellCommand ShellWget ShellWhich)
|
||||
(ADDVARS (MEDLEY-INIT-VARS (ShellBrowser)
|
||||
(ShellOpener)))
|
||||
(FNS ShellBrowser ShellBrowse ShellOpener ShellOpen PROCESS-COMMAND SLASHIT UNIX-FILE-NAME)
|
||||
@@ -45,6 +47,20 @@
|
||||
OUT))
|
||||
NIL)
|
||||
|
||||
(CL:DEFUN ShellWget (URL OUTFILENAME) (* ; "Edited 1-Nov-2025 23:42 by FGH")
|
||||
(LET* ((WGET (ShellWhich "wget"))
|
||||
(OUTNAME (OUTFILEP OUTFILENAME))
|
||||
(UNIXNAME (LET [(UN (UNIX-FILE-NAME OUTNAME 'OUTPUT]
|
||||
(if (STREQUAL (SUBSTRING UN (NCHARS UN))
|
||||
".")
|
||||
then (SUBSTRING UN 1 -2)
|
||||
else UN)))
|
||||
(CMD (CONCAT WGET " " URL " -O " UNIXNAME)))
|
||||
(if (NULL WGET)
|
||||
then (ERROR "ShellWget - wget not available"))
|
||||
(ShellCommand CMD)
|
||||
OUTNAME))
|
||||
|
||||
(CL:DEFUN ShellWhich (Cmd) (* ; "Edited 18-Jan-2023 13:19 by FGH")
|
||||
[CL:WITH-OPEN-STREAM (S (OPENSTREAM '{NODIRCORE} 'BOTH))
|
||||
(ShellCommand (CONCAT "command -v " Cmd)
|
||||
@@ -146,7 +162,8 @@
|
||||
"true"])
|
||||
|
||||
(ShellOpen
|
||||
[LAMBDA (FilenameOrURL)
|
||||
[LAMBDA (FilenameOrURL) (* ; "Edited 10-Sep-2025 15:29 by rmk")
|
||||
(* ; "Edited 4-May-2025 11:14 by rmk")
|
||||
|
||||
(* ;; "Open the file or URL using the generic %"opener%" for this machine via a shell call.")
|
||||
|
||||
@@ -176,62 +193,56 @@
|
||||
" >>/tmp/ShellBrowser-warnings-$$.txt"))
|
||||
T)
|
||||
else (CONCAT "Unable to find a browser to open: " FilenameOrURL)))
|
||||
else
|
||||
(LET*
|
||||
((OPENER (ShellOpener))
|
||||
(FULLNAME (FULLNAME FilenameOrURL)))
|
||||
(if (NOT FULLNAME)
|
||||
then (CONCAT "File not found: " FilenameOrURL)
|
||||
elseif (STREQUAL OPENER "true")
|
||||
then (CONCAT "Unable to find a file opener to open: " FilenameOrURL)
|
||||
else (LET* ((VERSION.SPECIFIED (FILENAMEFIELD FilenameOrURL 'VERSION))
|
||||
(UNPACKED (UNPACKFILENAME.STRING FULLNAME))
|
||||
(NEWNAME (CONCAT (LISTGET UNPACKED 'NAME)
|
||||
"~"
|
||||
(LISTGET UNPACKED 'VERSION)
|
||||
"~"))
|
||||
(EXTENSION (LISTGET UNPACKED 'EXTENSION))
|
||||
[UNVERSIONED (LET (FN (UNPACKED (COPY UNPACKED)))
|
||||
(LISTPUT UNPACKED 'VERSION NIL)
|
||||
(LISTPUT UNPACKED 'HOST NIL)
|
||||
(SETQ FN (PACKFILENAME.STRING UNPACKED))
|
||||
(if (STREQUAL (SUBSTRING FN -1)
|
||||
".")
|
||||
then (SETQ FN (SUBSTRING UNIXFILE 1 -2)))
|
||||
(SETQ FN (SLASHIT FN]
|
||||
(UNVERSIONED.EXISTS (INFILEP (CONCAT "{UNIX}" UNVERSIONED)))
|
||||
(TMPDIR (CONCAT "/tmp/" (RAND 1000 9999)))
|
||||
(TARGETFILE.LISP (PACKFILENAME.STRING 'HOST "{UNIX}" 'DIRECTORY TMPDIR
|
||||
'NAME NEWNAME 'EXTENSION EXTENSION))
|
||||
(TARGETFILE.UNIX (SLASHIT (PACKFILENAME.STRING 'HOST NIL 'DIRECTORY TMPDIR
|
||||
'NAME NEWNAME 'EXTENSION EXTENSION)))
|
||||
(UNIXFILE NIL))
|
||||
(DECLARE (SPECVARS UNIXFILE))
|
||||
(if (OR VERSION.SPECIFIED (NOT UNVERSIONED.EXISTS))
|
||||
then (COPYFILE FULLNAME TARGETFILE.LISP)
|
||||
(SETQ UNIXFILE TARGETFILE.UNIX)
|
||||
else (SETQ UNIXFILE UNVERSIONED))
|
||||
(CL:WITH-OPEN-STREAM
|
||||
(SHELLSTREAM (OPENSTREAM (CONCAT "{CORE}SHELLOUT" (RAND 1000 9999))
|
||||
'BOTH))
|
||||
(ShellCommand (CONCAT OPENER " '" UNIXFILE "'"
|
||||
" >>/tmp/ShellOpener-warnings-$$.txt")
|
||||
SHELLSTREAM)
|
||||
(if (EQ (GETFILEPTR SHELLSTREAM)
|
||||
0)
|
||||
then T
|
||||
else (LET* ((OUTSTRING (ALLOCSTRING (GETFILEPTR SHELLSTREAM)
|
||||
" ")))
|
||||
(CL:WITH-OPEN-STREAM (STRINGSTREAM (OPENSTRINGSTREAM OUTSTRING
|
||||
'OUTPUT))
|
||||
(SETFILEPTR SHELLSTREAM 0)
|
||||
(CL:TAGBODY [SETFILEINFO SHELLSTREAM 'ENDOFSTREAMOP
|
||||
#'(CL:LAMBDA (s)
|
||||
(GO OUT]
|
||||
(CL:LOOP (PRINTCCODE (READCCODE SHELLSTREAM)
|
||||
STRINGSTREAM))
|
||||
OUT))
|
||||
OUTSTRING])
|
||||
else (LET* ((OPENER (ShellOpener))
|
||||
(FULLNAME (FULLNAME FilenameOrURL)))
|
||||
(if (NOT FULLNAME)
|
||||
then (CONCAT "File not found: " FilenameOrURL)
|
||||
elseif (STREQUAL OPENER "true")
|
||||
then (CONCAT "Unable to find a file opener to open: " FilenameOrURL)
|
||||
else (LET* ((VERSION.SPECIFIED (FILENAMEFIELD FilenameOrURL 'VERSION))
|
||||
(UNPACKED (UNPACKFILENAME.STRING FULLNAME))
|
||||
(NEWNAME (CONCAT (LISTGET UNPACKED 'NAME)
|
||||
"~"
|
||||
(LISTGET UNPACKED 'VERSION)
|
||||
"~"))
|
||||
(EXTENSION (LISTGET UNPACKED 'EXTENSION))
|
||||
[UNVERSIONED (LET (FN (UNPACKED (COPY UNPACKED)))
|
||||
(LISTPUT UNPACKED 'VERSION NIL)
|
||||
(LISTPUT UNPACKED 'HOST NIL)
|
||||
(SETQ FN (PACKFILENAME.STRING UNPACKED))
|
||||
(if (STREQUAL (SUBSTRING FN -1)
|
||||
".")
|
||||
then (SETQ FN (SUBSTRING UNIXFILE 1 -2)))
|
||||
(SETQ FN (SLASHIT FN]
|
||||
(UNVERSIONED.EXISTS (INFILEP (CONCAT "{UNIX}" UNVERSIONED)))
|
||||
(TMPDIR (CONCAT "/tmp/" (RAND 1000 9999)))
|
||||
(TARGETFILE.LISP (PACKFILENAME.STRING 'HOST "{UNIX}" 'DIRECTORY TMPDIR
|
||||
'NAME NEWNAME 'EXTENSION EXTENSION))
|
||||
(TARGETFILE.UNIX (SLASHIT (PACKFILENAME.STRING 'HOST NIL 'DIRECTORY
|
||||
TMPDIR 'NAME NEWNAME 'EXTENSION
|
||||
EXTENSION)))
|
||||
(UNIXFILE NIL))
|
||||
(DECLARE (SPECVARS UNIXFILE))
|
||||
(if (OR VERSION.SPECIFIED (NOT UNVERSIONED.EXISTS))
|
||||
then (COPYFILE FULLNAME TARGETFILE.LISP)
|
||||
(SETQ UNIXFILE TARGETFILE.UNIX)
|
||||
else (SETQ UNIXFILE UNVERSIONED))
|
||||
(CL:WITH-OPEN-STREAM
|
||||
(SHELLSTREAM (OPENSTREAM (CONCAT "{CORE}SHELLOUT" (RAND 1000 9999))
|
||||
'BOTH))
|
||||
(ShellCommand (CONCAT OPENER " '" UNIXFILE "'"
|
||||
" >>/tmp/ShellOpener-warnings-$$.txt")
|
||||
SHELLSTREAM)
|
||||
(if (EQ (GETFILEPTR SHELLSTREAM)
|
||||
0)
|
||||
then T
|
||||
else (LET ((OUTSTRING (ALLOCSTRING (GETFILEPTR SHELLSTREAM)
|
||||
" ")))
|
||||
(CL:WITH-OPEN-STREAM (STRINGSTREAM (OPENSTRINGSTREAM
|
||||
OUTSTRING
|
||||
'OUTPUT))
|
||||
(COPYCHARS SHELLSTREAM STRINGSTREAM 0 -1))
|
||||
OUTSTRING])
|
||||
|
||||
(PROCESS-COMMAND
|
||||
[LAMBDA (CMD) (* ; "Edited 17-Jul-2022 08:17 by rmk")
|
||||
@@ -244,7 +255,9 @@
|
||||
0))) DO (BLOCK) FINALLY (RETURN CODE])
|
||||
|
||||
(SLASHIT
|
||||
[LAMBDA (X LCASEDIRS NOHOST) (* ; "Edited 23-Sep-2023 15:27 by rmk")
|
||||
[LAMBDA (X LCASEDIRS NOHOST) (* ; "Edited 22-Oct-2025 13:05 by rmk")
|
||||
(* ; "Edited 25-Sep-2025 09:57 by rmk")
|
||||
(* ; "Edited 23-Sep-2023 15:27 by rmk")
|
||||
|
||||
(* ;; "It would also be nice to use the generic unpackfilename/packfilename tools. But packfilename sticks in brackets again, and sticks a dot on when removing the version.")
|
||||
|
||||
@@ -255,13 +268,14 @@
|
||||
(LET [LASTDIRPOS SLASHED (DIRPOS (ADD1 (OR (STRPOS "}" X)
|
||||
0]
|
||||
[SETQ SLASHED (CONCATCODES (for I C from DIRPOS while (SETQ C (NTHCHARCODE X I))
|
||||
collect (SELCHARQ C
|
||||
((< >)
|
||||
(SETQ LASTDIRPOS I)
|
||||
(CHARCODE /))
|
||||
(/ (SETQ LASTDIRPOS I)
|
||||
C)
|
||||
C]
|
||||
join (SELCHARQ C
|
||||
((< >)
|
||||
(SETQ LASTDIRPOS I)
|
||||
(CONS (CHARCODE /)))
|
||||
(/ (SETQ LASTDIRPOS I)
|
||||
(CONS C))
|
||||
(SPACE (CHARCODE (\ SPACE)))
|
||||
(CONS C]
|
||||
(CL:WHEN (AND LCASEDIRS LASTDIRPOS)
|
||||
(SETQ LASTDIRPOS (ADD1 (IDIFFERENCE LASTDIRPOS DIRPOS)))
|
||||
(SETQ SLASHED (CONCAT (L-CASE (SUBSTRING SLASHED 1 LASTDIRPOS))
|
||||
@@ -274,13 +288,15 @@
|
||||
SLASHED))])
|
||||
|
||||
(UNIX-FILE-NAME
|
||||
[LAMBDA (FILE ACCESS COPY) (* ; "Edited 1-Oct-2023 20:52 by rmk")
|
||||
[LAMBDA (FILE ACCESS COPY) (* ; "Edited 27-Sep-2025 16:24 by rmk")
|
||||
(* ; "Edited 19-Sep-2025 07:29 by rmk")
|
||||
(* ; "Edited 13-Sep-2025 18:37 by rmk")
|
||||
(* ; "Edited 1-Oct-2023 20:52 by rmk")
|
||||
|
||||
(* ;; "Forces an extension %"ufn%" if there isn't one already, to avoid the dot/no-dot question")
|
||||
|
||||
(* ;; "Tries to return the string that would reference FILE in a Unix shell, for the use of PROCESS-COMMAND and ShellCommand. If VERSION is 1, it assumes that the Unix file is doesn't have the Medley version convention. If FILE does not have a corresponding Unix name, COPY is non-NIL, and ACCESS is INPUT, FILE will be copied to a unix tmp file (with COPY in its name) and that name will be returned.")
|
||||
|
||||
(CL:WHEN (\GETSTREAM FILE ACCESS T)
|
||||
(SETQ FILE (OR (FULLNAME FILE)
|
||||
FILE))) (* ; "Might catch NODIRCORE")
|
||||
(* ; "Might catch NODIRCORE")
|
||||
(CL:WHEN FILE
|
||||
(SETQ FILE (TRUEFILENAME FILE))
|
||||
(CL:UNLESS (STREAMP FILE)
|
||||
@@ -290,35 +306,43 @@
|
||||
(NIL (SETQ ACCESS 'INPUT)
|
||||
'OLD)
|
||||
(\ILLEGAL.ARG ACCESS])
|
||||
[SELECTQ (FILENAMEFIELD FILE 'HOST)
|
||||
(UNIX [SUBSTRING FILE (ADD1 (CONSTANT (NCHARS "{UNIX}"])
|
||||
(DSK (LET [(VERSION (FILENAMEFIELD FILE 'VERSION]
|
||||
(SETQ FILE (SLASHIT (PACKFILENAME 'HOST NIL 'VERSION NIL 'BODY FILE)))
|
||||
(CL:IF (AND VERSION (IGREATERP VERSION 1))
|
||||
(CONCAT FILE (CL:IF (FILENAMEFIELD FILE 'EXTENSION)
|
||||
"."
|
||||
"")
|
||||
"~" VERSION "~")
|
||||
FILE)))
|
||||
(CL:WHEN (AND COPY (EQ ACCESS 'INPUT)
|
||||
FILE)
|
||||
(RESETLST
|
||||
(CL:WHEN (\GETSTREAM FILE 'INPUT T) (* ; "Hope is randaccess")
|
||||
[RESETSAVE (GETFILEPTR FILE)
|
||||
`(PROGN (SETFILEPTR ,FILE OLDVALUE])
|
||||
(COPYFILE FILE (CONCAT "{UNIX}/tmp/medley-" (L-CASE COPY)
|
||||
"-"
|
||||
(IDATE)
|
||||
"-"
|
||||
(RAND)
|
||||
(CL:IF (FILENAMEFIELD FILE 'EXTENSION)
|
||||
(CONCAT "." (FILENAMEFIELD FILE 'EXTENSION))
|
||||
"")))))])])
|
||||
(LET (UNAME VERSION)
|
||||
[SELECTQ (FILENAMEFIELD FILE 'HOST)
|
||||
((UNIX DSK)
|
||||
(SETQ UNAME FILE))
|
||||
(PROGN
|
||||
(* ;; "Catch the streams as well as other devices (CORE, servers)")
|
||||
|
||||
[SETQ UNAME (OUTFILEP (CONCAT "{DSK}/tmp/medley-" (CL:IF COPY
|
||||
(CONCAT (L-CASE COPY)
|
||||
"-")
|
||||
"")
|
||||
(IDATE]
|
||||
(CL:WHEN (AND COPY FILE)
|
||||
(RESETLST
|
||||
(CL:WHEN (\GETSTREAM FILE 'INPUT T)
|
||||
(* ; "Hope it's randaccess")
|
||||
[RESETSAVE (GETFILEPTR FILE)
|
||||
`(PROGN (SETFILEPTR ,FILE OLDVALUE])
|
||||
|
||||
(* ;; "Let DSK pick a new version number, rather than RAND")
|
||||
|
||||
(COPYFILE FILE UNAME)))]
|
||||
(SETQ VERSION (FILENAMEFIELD UNAME 'VERSION)) (* ; "Convert to Unix version. ")
|
||||
(SETQ UNAME (PACKFILENAME 'VERSION NIL 'BODY UNAME))
|
||||
(CL:WHEN (AND VERSION (IGREATERP VERSION 1))
|
||||
(SETQ UNAME (CONCAT UNAME ".~" VERSION "~")))
|
||||
(SETQ UNAME (SLASHIT UNAME NIL T))
|
||||
(CL:IF (EQ (CHARCODE %.)
|
||||
(NTHCHARCODE UNAME -1))
|
||||
(SUBSTRING UNAME 1 -2)
|
||||
UNAME)))])
|
||||
)
|
||||
|
||||
(PUTPROPS UNIXUTILS FILETYPE CL:COMPILE-FILE)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (1146 1519 (ShellCommand 1146 . 1519)) (1521 1918 (ShellWhich 1521 . 1918)) (2008 16585
|
||||
(ShellBrowser 2018 . 3790) (ShellBrowse 3792 . 4477) (ShellOpener 4479 . 6167) (ShellOpen 6169 . 11324
|
||||
) (PROCESS-COMMAND 11326 . 11939) (SLASHIT 11941 . 13983) (UNIX-FILE-NAME 13985 . 16583)))))
|
||||
(FILEMAP (NIL (1201 1574 (ShellCommand 1201 . 1574)) (1576 2249 (ShellWget 1576 . 2249)) (2251 2648 (
|
||||
ShellWhich 2251 . 2648)) (2738 18607 (ShellBrowser 2748 . 4520) (ShellBrowse 4522 . 5207) (ShellOpener
|
||||
5209 . 6897) (ShellOpen 6899 . 12378) (PROCESS-COMMAND 12380 . 12993) (SLASHIT 12995 . 15332) (
|
||||
UNIX-FILE-NAME 15334 . 18605)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,12 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "30-Apr-2025 14:09:18" {WMEDLEY}<library>tedit>TEDIT-BUTTONS.;228 125393
|
||||
(FILECREATED "19-Oct-2025 10:44:18" {WMEDLEY}<library>TEDIT>TEDIT-BUTTONS.;229 125526
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (FNS MB.NWAY.ADDITEM MB.NWAY.CREATE MB.NWAY.SETSTATEFN MB.NWAY.SELECT)
|
||||
:CHANGES-TO (FNS MB.ADD)
|
||||
|
||||
:PREVIOUS-DATE "14-Apr-2025 23:50:23" {WMEDLEY}<library>tedit>TEDIT-BUTTONS.;226)
|
||||
:PREVIOUS-DATE "30-Apr-2025 14:09:18" {WMEDLEY}<library>TEDIT>TEDIT-BUTTONS.;228)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT TEDIT-BUTTONSCOMS)
|
||||
@@ -67,14 +67,16 @@
|
||||
(DEFINEQ
|
||||
|
||||
(MB.ADD
|
||||
[LAMBDA (MENUDESC MENUTSTREAM WHERE INCREMENTALUPDATES) (* ; "Edited 6-Apr-2025 14:35 by rmk")
|
||||
[LAMBDA (MENUDESC MENUTSTREAM WHERE INCREMENTALUPDATES MAINTSTREAM)
|
||||
(* ; "Edited 19-Oct-2025 10:22 by rmk")
|
||||
(* ; "Edited 6-Apr-2025 14:35 by rmk")
|
||||
(* ; "Edited 5-Jan-2025 11:36 by rmk")
|
||||
(* ; "Edited 22-Oct-2024 09:16 by rmk")
|
||||
(* ; "Edited 21-Oct-2024 00:26 by rmk")
|
||||
(* ; "Edited 18-Oct-2024 13:49 by rmk")
|
||||
(* ; "Edited 6-Oct-2024 15:25 by rmk")
|
||||
(* ; "Edited 24-Aug-2024 21:08 by rmk")
|
||||
(DECLARE (SPECVARS MENUTSTREAM))
|
||||
(DECLARE (SPECVARS MENUTSTREAM MAINTSTREAM))
|
||||
(SETQ MENUTSTREAM (TEXTSTREAM MENUTSTREAM)) (* ; "Edited 22-Aug-2024 11:10 by rmk")
|
||||
|
||||
(* ;; "MENUDESC is a Tedit menu specification, a list of items describing one or more elements to be inserted in TSTREAM after WHERE. ")
|
||||
@@ -1969,25 +1971,25 @@
|
||||
(MB.FIELD.INIT)
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (3279 19224 (MB.ADD 3289 . 9810) (MB.DELETE 9812 . 10186) (MB.GET 10188 . 16958) (
|
||||
MB.GET.MBARG 16960 . 18629) (TEDIT.BACKTOMAIN 18631 . 19222)) (19268 39204 (MB.BUTTONEVENTINFN 19278
|
||||
. 20846) (MB.DISPLAYFN 20848 . 22907) (MB.SETIMAGE 22909 . 24077) (MB.SIZEFN 24079 . 25627) (
|
||||
MB.WHENOPERATEDONFN 25629 . 27578) (MB.COPYFN 27580 . 28038) (MB.GETFN 28040 . 29001) (MB.PUTFN 29003
|
||||
. 30103) (MB.SHOWSELFN 30105 . 31614) (MB.CREATE 31616 . 35639) (MB.CHANGENAME 35641 . 36123) (
|
||||
MB.INIT 36125 . 37586) (MB.TRACK.UNTIL 37588 . 38283) (MB.DON'T 38285 . 38581) (MB.SPEC.REMAINDER
|
||||
38583 . 39202)) (39366 49371 (MB.3STATE.CREATE 39376 . 40240) (MB.3STATE.DISPLAYFN 40242 . 41228) (
|
||||
MB.3STATE.SHOWSELFN 41230 . 43541) (MB.3STATE.INIT 43543 . 44954) (MB.3STATE.SETSTATEFN 44956 . 45614)
|
||||
(MB.3STATE.BUTTONEVENTINFN 45616 . 49369)) (49526 80622 (MB.NWAY.CREATE 49536 . 55719) (
|
||||
MB.NWAY.DISPLAYFN 55721 . 56584) (MB.NWAY.WHENOPERATEDONFN 56586 . 58776) (MB.NWAY.SIZEFN 58778 .
|
||||
62714) (MB.NWAY.SELECT 62716 . 66286) (MB.NWAY.BUTTONEVENTINFN 66288 . 69500) (MB.NWAY.NEWMENUBUTTON
|
||||
69502 . 70214) (MB.NWAY.COPYFN 70216 . 71183) (MB.NWAY.INIT 71185 . 72676) (MB.NWAY.ARRANGEBUTTONS
|
||||
72678 . 74649) (MB.NWAY.ADDITEM 74651 . 78800) (MB.NWAY.FINDSUBOBJ 78802 . 79316) (MB.NWAY.SETSTATEFN
|
||||
79318 . 80620)) (80701 92700 (MB.TOGGLE.CREATE 80711 . 81706) (MB.TOGGLE.DISPLAYFN 81708 . 83191) (
|
||||
MB.TOGGLE.INIT 83193 . 84992) (MB.SET.TOGGLE 84994 . 86195) (MB.TOGGLE.SETSTATEFN 86197 . 87037) (
|
||||
MB.TOGGLE.BUTTONEVENTINFN 87039 . 91355) (MB.TOGGLE.WHENOPERATEDONFN 91357 . 92698)) (92781 125314 (
|
||||
MB.FIELD.CREATE 92791 . 98242) (MB.FIELD.DISPLAYFN 98244 . 99035) (MB.FIELD.IMAGEBOXFN 99037 . 100519)
|
||||
(MB.FIELD.PREFIXCREATE 100521 . 104457) (MB.FIELD.SUFFIXCREATE 104459 . 106119) (MB.FIELD.INIT 106121
|
||||
. 107888) (MB.FIELD.WHENOPERATEDONFN 107890 . 109161) (MB.FIELD.GETSTATEFN 109163 . 113097) (
|
||||
MB.FIELD.SETSTATEFN 113099 . 117903) (MB.FIELD.BUTTONEVENTINFN 117905 . 120210) (MB.FIELD.SIZEFN
|
||||
120212 . 120452) (MB.FIELD.INSURETYPE 120454 . 125312)))))
|
||||
(FILEMAP (NIL (3221 19357 (MB.ADD 3231 . 9943) (MB.DELETE 9945 . 10319) (MB.GET 10321 . 17091) (
|
||||
MB.GET.MBARG 17093 . 18762) (TEDIT.BACKTOMAIN 18764 . 19355)) (19401 39337 (MB.BUTTONEVENTINFN 19411
|
||||
. 20979) (MB.DISPLAYFN 20981 . 23040) (MB.SETIMAGE 23042 . 24210) (MB.SIZEFN 24212 . 25760) (
|
||||
MB.WHENOPERATEDONFN 25762 . 27711) (MB.COPYFN 27713 . 28171) (MB.GETFN 28173 . 29134) (MB.PUTFN 29136
|
||||
. 30236) (MB.SHOWSELFN 30238 . 31747) (MB.CREATE 31749 . 35772) (MB.CHANGENAME 35774 . 36256) (
|
||||
MB.INIT 36258 . 37719) (MB.TRACK.UNTIL 37721 . 38416) (MB.DON'T 38418 . 38714) (MB.SPEC.REMAINDER
|
||||
38716 . 39335)) (39499 49504 (MB.3STATE.CREATE 39509 . 40373) (MB.3STATE.DISPLAYFN 40375 . 41361) (
|
||||
MB.3STATE.SHOWSELFN 41363 . 43674) (MB.3STATE.INIT 43676 . 45087) (MB.3STATE.SETSTATEFN 45089 . 45747)
|
||||
(MB.3STATE.BUTTONEVENTINFN 45749 . 49502)) (49659 80755 (MB.NWAY.CREATE 49669 . 55852) (
|
||||
MB.NWAY.DISPLAYFN 55854 . 56717) (MB.NWAY.WHENOPERATEDONFN 56719 . 58909) (MB.NWAY.SIZEFN 58911 .
|
||||
62847) (MB.NWAY.SELECT 62849 . 66419) (MB.NWAY.BUTTONEVENTINFN 66421 . 69633) (MB.NWAY.NEWMENUBUTTON
|
||||
69635 . 70347) (MB.NWAY.COPYFN 70349 . 71316) (MB.NWAY.INIT 71318 . 72809) (MB.NWAY.ARRANGEBUTTONS
|
||||
72811 . 74782) (MB.NWAY.ADDITEM 74784 . 78933) (MB.NWAY.FINDSUBOBJ 78935 . 79449) (MB.NWAY.SETSTATEFN
|
||||
79451 . 80753)) (80834 92833 (MB.TOGGLE.CREATE 80844 . 81839) (MB.TOGGLE.DISPLAYFN 81841 . 83324) (
|
||||
MB.TOGGLE.INIT 83326 . 85125) (MB.SET.TOGGLE 85127 . 86328) (MB.TOGGLE.SETSTATEFN 86330 . 87170) (
|
||||
MB.TOGGLE.BUTTONEVENTINFN 87172 . 91488) (MB.TOGGLE.WHENOPERATEDONFN 91490 . 92831)) (92914 125447 (
|
||||
MB.FIELD.CREATE 92924 . 98375) (MB.FIELD.DISPLAYFN 98377 . 99168) (MB.FIELD.IMAGEBOXFN 99170 . 100652)
|
||||
(MB.FIELD.PREFIXCREATE 100654 . 104590) (MB.FIELD.SUFFIXCREATE 104592 . 106252) (MB.FIELD.INIT 106254
|
||||
. 108021) (MB.FIELD.WHENOPERATEDONFN 108023 . 109294) (MB.FIELD.GETSTATEFN 109296 . 113230) (
|
||||
MB.FIELD.SETSTATEFN 113232 . 118036) (MB.FIELD.BUTTONEVENTINFN 118038 . 120343) (MB.FIELD.SIZEFN
|
||||
120345 . 120585) (MB.FIELD.INSURETYPE 120587 . 125445)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,14 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "25-Sep-2025 21:32:46"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>working-medley>library>tedit>TEDIT-FILE.;655 173148
|
||||
(FILECREATED "23-Oct-2025 08:49:06" {WMEDLEY}<library>tedit>TEDIT-FILE.;656 173140
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (FNS \TEDIT.GET.FORMATTED.FILE \TEDIT.PUT.SINGLE.CHARLOOKS
|
||||
\TEDIT.GET.SINGLE.CHARLOOKS)
|
||||
:CHANGES-TO (FNS \TEDIT.GET.UNFORMATTED.FILE.UTF8)
|
||||
|
||||
:PREVIOUS-DATE " 9-Sep-2025 21:49:43" {WMEDLEY}<library>tedit>TEDIT-FILE.;653)
|
||||
:PREVIOUS-DATE "25-Sep-2025 21:32:46" {WMEDLEY}<library>tedit>TEDIT-FILE.;655)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT TEDIT-FILECOMS)
|
||||
@@ -1388,7 +1386,8 @@
|
||||
(DEFINEQ
|
||||
|
||||
(\TEDIT.GET.UNFORMATTED.FILE.UTF8
|
||||
[LAMBDA (STRM START END DEFAULTCHARLOOKS DEFAULTPARALOOKS) (* ; "Edited 28-Jul-2025 23:45 by rmk")
|
||||
[LAMBDA (STRM START END DEFAULTCHARLOOKS DEFAULTPARALOOKS) (* ; "Edited 23-Oct-2025 08:48 by rmk")
|
||||
(* ; "Edited 28-Jul-2025 23:45 by rmk")
|
||||
(* ; "Edited 11-Mar-2024 23:55 by rmk")
|
||||
(* ; "Edited 4-Feb-2024 10:12 by rmk")
|
||||
(* ; "Edited 2-Feb-2024 11:24 by rmk")
|
||||
@@ -1428,7 +1427,7 @@
|
||||
(SETQ CHAR (\PEEKBIN STRM)) (* ;
|
||||
"Keep CHAR for CR/LF checking, error if EOF")
|
||||
(* ; "Error if invalid header")
|
||||
(SETQ NEXTCODESIZE (UTF8-SIZE-FROM-BYTE1 CHAR))
|
||||
(SETQ NEXTCODESIZE (NUTF8-BYTE1-BYTES CHAR))
|
||||
(CL:UNLESS (EQ CODESIZE NEXTCODESIZE) (* ; "Header byte hasn't been read")
|
||||
|
||||
(* ;; "Don't want LF processing if we split because of size change. If next is a CR/LF still in size 1, we pick it up below")
|
||||
@@ -2694,28 +2693,28 @@
|
||||
|
||||
(RPAQ? *TEDIT-FILE-READTABLE* (COPYREADTABLE \ORIGREADTABLE))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (5431 35690 (TEDIT.GET 5441 . 11851) (TEDIT.FORMATTEDFILEP 11853 . 13169) (
|
||||
TEDIT.FILEDATE 13171 . 14480) (TEDIT.INCLUDE 14482 . 22511) (TEDIT.RAW.INCLUDE 22513 . 23321) (
|
||||
TEDIT.PUT 23323 . 31679) (TEDIT.PUT.STREAM 31681 . 35688)) (35691 56965 (\TEDIT.GET.FOREIGN.FILE 35701
|
||||
. 39126) (\TEDIT.GET.UNFORMATTED.FILE 39128 . 43434) (\TEDIT.GET.FORMATTED.FILE 43436 . 47079) (
|
||||
\TEDIT.FORMATTEDSTREAMP 47081 . 50212) (\ARBIN 50214 . 50934) (\ATMIN 50936 . 51473) (\DWIN 51475 .
|
||||
51854) (\STRINGIN 51856 . 52564) (\TEDIT.GET.TRAILER 52566 . 55434) (\TEDIT.CACHEFILE 55436 . 56963))
|
||||
(57131 73169 (\TEDIT.GET.PIECES3 57141 . 68104) (\TEDIT.GET.PROPS3 68106 . 71328) (
|
||||
\TEDIT.MAKE.STRINGPIECE 71330 . 73167)) (73170 86596 (\TEDIT.GET.UNFORMATTED.FILE.MCCS 73180 . 79413)
|
||||
(\TEDIT.INTERPRET.MCCS.SHIFTS 79415 . 85660) (\TEDIT.CONVERT.XCCSTOMCCS 85662 . 86594)) (86618 92757 (
|
||||
\TEDIT.GET.UNFORMATTED.FILE.UTF8 86628 . 92755)) (92780 104122 (\TEDIT.GET.CHARLOOKS.LIST 92790 .
|
||||
93521) (\TEDIT.GET.SINGLE.CHARLOOKS 93523 . 100595) (\TEDIT.GET.CHARLOOKS 100597 . 102153) (
|
||||
\TEDIT.GET.PARALOOKS.INDEX 102155 . 102699) (\TEDIT.GET.CHARLOOKS.INDEX 102701 . 104120)) (104123
|
||||
111780 (\TEDIT.GET.PARALOOKS.LIST 104133 . 104755) (\TEDIT.GET.SINGLE.PARALOOKS 104757 . 111778)) (
|
||||
111781 115614 (\TEDIT.GET.OBJECT 111791 . 115612)) (115679 148942 (\TEDIT.PUT.PCTB 115689 . 125596) (
|
||||
\TEDIT.PUT.PCTB.PIECEDATA 125598 . 128796) (\TEDIT.PUT.TRAILER 128798 . 130126) (
|
||||
\TEDIT.PUT.PCTB.MERGEABLE 130128 . 133901) (\TEDIT.PUT.UTF8.SPLITPIECES 133903 . 138605) (
|
||||
\TEDIT.PUT.PCTB.NEXTNEW 138607 . 143103) (\TEDIT.INSERT.NEWPIECES 143105 . 146540) (\TEDIT.PUTRESET
|
||||
146542 . 146784) (\ARBOUT 146786 . 147510) (\ATMOUT 147512 . 148117) (\DWOUT 148119 . 148398) (
|
||||
\STRINGOUT 148400 . 148940)) (148943 161677 (\TEDIT.PUT.CHARLOOKS.LIST 148953 . 150625) (
|
||||
\TEDIT.PUT.SINGLE.CHARLOOKS 150627 . 156907) (\TEDIT.PUT.CHARLOOKS 156909 . 158248) (
|
||||
\TEDIT.PUT.CHARLOOKS1 158250 . 159301) (\TEDIT.PUT.OBJECT 159303 . 161675)) (161678 169317 (
|
||||
\TEDIT.PUT.PARALOOKS.LIST 161688 . 162590) (\TEDIT.PUT.SINGLE.PARALOOKS 162592 . 168176) (
|
||||
\TEDIT.PUT.PARALOOKS 168178 . 169315)) (169412 172841 (TEDITFROMLISPSOURCE 169422 . 172090) (
|
||||
SHELLSCRIPTP 172092 . 172321) (TEDITFROMSHELLSCRIPT 172323 . 172839)))))
|
||||
(FILEMAP (NIL (5317 35576 (TEDIT.GET 5327 . 11737) (TEDIT.FORMATTEDFILEP 11739 . 13055) (
|
||||
TEDIT.FILEDATE 13057 . 14366) (TEDIT.INCLUDE 14368 . 22397) (TEDIT.RAW.INCLUDE 22399 . 23207) (
|
||||
TEDIT.PUT 23209 . 31565) (TEDIT.PUT.STREAM 31567 . 35574)) (35577 56851 (\TEDIT.GET.FOREIGN.FILE 35587
|
||||
. 39012) (\TEDIT.GET.UNFORMATTED.FILE 39014 . 43320) (\TEDIT.GET.FORMATTED.FILE 43322 . 46965) (
|
||||
\TEDIT.FORMATTEDSTREAMP 46967 . 50098) (\ARBIN 50100 . 50820) (\ATMIN 50822 . 51359) (\DWIN 51361 .
|
||||
51740) (\STRINGIN 51742 . 52450) (\TEDIT.GET.TRAILER 52452 . 55320) (\TEDIT.CACHEFILE 55322 . 56849))
|
||||
(57017 73055 (\TEDIT.GET.PIECES3 57027 . 67990) (\TEDIT.GET.PROPS3 67992 . 71214) (
|
||||
\TEDIT.MAKE.STRINGPIECE 71216 . 73053)) (73056 86482 (\TEDIT.GET.UNFORMATTED.FILE.MCCS 73066 . 79299)
|
||||
(\TEDIT.INTERPRET.MCCS.SHIFTS 79301 . 85546) (\TEDIT.CONVERT.XCCSTOMCCS 85548 . 86480)) (86504 92749 (
|
||||
\TEDIT.GET.UNFORMATTED.FILE.UTF8 86514 . 92747)) (92772 104114 (\TEDIT.GET.CHARLOOKS.LIST 92782 .
|
||||
93513) (\TEDIT.GET.SINGLE.CHARLOOKS 93515 . 100587) (\TEDIT.GET.CHARLOOKS 100589 . 102145) (
|
||||
\TEDIT.GET.PARALOOKS.INDEX 102147 . 102691) (\TEDIT.GET.CHARLOOKS.INDEX 102693 . 104112)) (104115
|
||||
111772 (\TEDIT.GET.PARALOOKS.LIST 104125 . 104747) (\TEDIT.GET.SINGLE.PARALOOKS 104749 . 111770)) (
|
||||
111773 115606 (\TEDIT.GET.OBJECT 111783 . 115604)) (115671 148934 (\TEDIT.PUT.PCTB 115681 . 125588) (
|
||||
\TEDIT.PUT.PCTB.PIECEDATA 125590 . 128788) (\TEDIT.PUT.TRAILER 128790 . 130118) (
|
||||
\TEDIT.PUT.PCTB.MERGEABLE 130120 . 133893) (\TEDIT.PUT.UTF8.SPLITPIECES 133895 . 138597) (
|
||||
\TEDIT.PUT.PCTB.NEXTNEW 138599 . 143095) (\TEDIT.INSERT.NEWPIECES 143097 . 146532) (\TEDIT.PUTRESET
|
||||
146534 . 146776) (\ARBOUT 146778 . 147502) (\ATMOUT 147504 . 148109) (\DWOUT 148111 . 148390) (
|
||||
\STRINGOUT 148392 . 148932)) (148935 161669 (\TEDIT.PUT.CHARLOOKS.LIST 148945 . 150617) (
|
||||
\TEDIT.PUT.SINGLE.CHARLOOKS 150619 . 156899) (\TEDIT.PUT.CHARLOOKS 156901 . 158240) (
|
||||
\TEDIT.PUT.CHARLOOKS1 158242 . 159293) (\TEDIT.PUT.OBJECT 159295 . 161667)) (161670 169309 (
|
||||
\TEDIT.PUT.PARALOOKS.LIST 161680 . 162582) (\TEDIT.PUT.SINGLE.PARALOOKS 162584 . 168168) (
|
||||
\TEDIT.PUT.PARALOOKS 168170 . 169307)) (169404 172833 (TEDITFROMLISPSOURCE 169414 . 172082) (
|
||||
SHELLSCRIPTP 172084 . 172313) (TEDITFROMSHELLSCRIPT 172315 . 172831)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,12 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "10-Sep-2025 17:08:43" {WMEDLEY}<library>TEDIT>TEDIT-MENU.;492 178438
|
||||
(FILECREATED "22-Oct-2025 12:55:36" {WMEDLEY}<library>TEDIT>TEDIT-MENU.;498 183397
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (VARS TEDIT-MENUCOMS)
|
||||
:CHANGES-TO (FNS MARGINBAR.NEUTRALIZE \TEDIT.PARALOOKS.TO.MARBAR)
|
||||
|
||||
:PREVIOUS-DATE "28-Jul-2025 23:26:01" {WMEDLEY}<library>TEDIT>TEDIT-MENU.;491)
|
||||
:PREVIOUS-DATE "19-Oct-2025 15:14:00" {WMEDLEY}<library>TEDIT>TEDIT-MENU.;496)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT TEDIT-MENUCOMS)
|
||||
@@ -59,7 +59,7 @@
|
||||
|
||||
(* ; "PARAMENU")
|
||||
(FNS \TEDIT.PARAMENU.CREATE \TEDIT.PARAMENU.START \TEDIT.APPLY.PARALOOKS
|
||||
\TEDIT.SHOW.PARALOOKS \TEDIT.PARAMENU.FILLIN)
|
||||
\TEDIT.SHOW.PARALOOKS \TEDIT.PARAMENU.FILLIN \TEDIT.PARAMENU.RESHAPEFN)
|
||||
|
||||
(* ;; "")
|
||||
|
||||
@@ -95,7 +95,7 @@
|
||||
(DECLARE%: DOEVAL@COMPILE DONTCOPY
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(RECORD MARGINBAR (MARL1 MARLN MARR MARTABS MARUNIT MARTABTYPE)
|
||||
(RECORD MARGINBAR (MARL1 MARLN MARR MARTABS MARUNIT MARTABTYPE MARBARWIDTH)
|
||||
[TYPE? (AND (IMAGEOBJP DATUM)
|
||||
(EQ (IMAGEOBJPROP DATUM 'DISPLAYFN)
|
||||
'MB.MARGINBAR.DISPLAYFN])
|
||||
@@ -511,7 +511,9 @@
|
||||
(MB.MARGINBAR.SHOWTAB W TAB UNIT 'PAINT])
|
||||
|
||||
(MARGINBAR.CREATE
|
||||
[LAMBDA (MARL1 MARLN MARR MARTABS MARUNIT MARTABTYPE) (* ; "Edited 29-Sep-2024 12:53 by rmk")
|
||||
[LAMBDA (MARL1 MARLN MARR MARTABS MARUNIT MARTABTYPE MAINTSTREAM/WIDTH)
|
||||
(* ; "Edited 19-Oct-2025 15:13 by rmk")
|
||||
(* ; "Edited 29-Sep-2024 12:53 by rmk")
|
||||
(* ; "Edited 4-Aug-2024 22:36 by rmk")
|
||||
(* ; "Edited 29-Jul-2024 10:13 by rmk")
|
||||
(* ; "Edited 28-Jul-2024 09:18 by rmk")
|
||||
@@ -519,10 +521,16 @@
|
||||
(* ; "Edited 22-Jul-2024 11:54 by rmk")
|
||||
(* ; "Edited 12-Jun-90 18:59 by mitani")
|
||||
|
||||
(* ;; "Create an instance of the margin-setting ruler for TEdit's use.")
|
||||
(* ;; "Create an instance of the margin-setting ruler for TEdit's use. ")
|
||||
|
||||
(PROG ((BOX (create IMAGEBOX
|
||||
XSIZE _ 1008
|
||||
XSIZE _ (IDIFFERENCE (OR (FIXP MAINTSTREAM/WIDTH)
|
||||
(AND MAINTSTREAM/WIDTH (\TEDIT.PRIMARYPANE
|
||||
MAINTSTREAM/WIDTH)
|
||||
(PANEWIDTH (\TEDIT.PRIMARYPANE MAINTSTREAM/WIDTH
|
||||
)))
|
||||
SCREENWIDTH)
|
||||
18)
|
||||
YSIZE _ 62
|
||||
YDESC _ 0
|
||||
XKERN _ 4))
|
||||
@@ -535,7 +543,8 @@
|
||||
MARR _ MARR
|
||||
MARTABS _ MARTABS
|
||||
MARUNIT _ MARUNIT
|
||||
MARTABTYPE _ MARTABTYPE))
|
||||
MARTABTYPE _ MARTABTYPE
|
||||
MARBARWIDTH _ (fetch (IMAGEBOX XSIZE) of BOX)))
|
||||
MARGINBARIMAGEFNS)) (* ;
|
||||
"Create an IMAGEOBJ, containing an instance of the record to hold margin and tab info")
|
||||
(SETQ BITMAP (BITMAPCREATE (fetch XSIZE of BOX)
|
||||
@@ -850,13 +859,15 @@
|
||||
PC])
|
||||
|
||||
(MARGINBAR.NEUTRALIZE
|
||||
[LAMBDA (OBJ) (* ; "Edited 29-Jul-2024 12:14 by rmk")
|
||||
[LAMBDA (OBJ) (* ; "Edited 22-Oct-2025 12:55 by rmk")
|
||||
(* ; "Edited 29-Jul-2024 12:14 by rmk")
|
||||
|
||||
(* ;; "Neutralizes the settings of the marginbar")
|
||||
|
||||
(create MARGINBAR smashing (IMAGEOBJPROP OBJ 'OBJECTDATUM)
|
||||
MARL1 _ -0.5 MARLN _ -0.5 MARR _ -39.5 MARTABS _ 'NEUTRAL MARUNIT _ 12
|
||||
MARTABTYPE _ NIL])
|
||||
MARTABTYPE _ NIL MARBARWIDTH _ (fetch (MARGINBAR MARBARWIDTH)
|
||||
of (IMAGEOBJPROP OBJ 'OBJECTDATUM])
|
||||
|
||||
(MARGINBAR.LOOKS
|
||||
[LAMBDA (OBJ DOTTEDLEADER) (* ; "Edited 20-Oct-2024 15:27 by rmk")
|
||||
@@ -913,13 +924,14 @@
|
||||
LOOKS])
|
||||
|
||||
(MB.MARGINBAR.SIZEFN
|
||||
[LAMBDA (OBJ) (* ; "Edited 3-Dec-2024 20:03 by rmk")
|
||||
[LAMBDA (OBJ) (* ; "Edited 19-Oct-2025 09:47 by rmk")
|
||||
(* ; "Edited 3-Dec-2024 20:03 by rmk")
|
||||
(* jds " 5-Sep-84 14:10")
|
||||
|
||||
(* ;; "YDESC is 2 so that selecting the bar and highlighting doesn't wipe out the bottom line. Although you shouldn't be able to select it")
|
||||
|
||||
(LET ((BOX (create IMAGEBOX
|
||||
XSIZE _ 1008
|
||||
XSIZE _ (fetch (MARGINBAR MARBARWIDTH) of (IMAGEOBJPROP OBJ 'OBJECTDATUM))
|
||||
YSIZE _ 62
|
||||
YDESC _ 2
|
||||
XKERN _ 4)))
|
||||
@@ -1070,7 +1082,8 @@
|
||||
'MarginRuler])
|
||||
|
||||
(\TEDIT.PARALOOKS.TO.MARBAR
|
||||
[LAMBDA (PARALOOKS UNIT) (* ; "Edited 19-Feb-2025 13:25 by rmk")
|
||||
[LAMBDA (PARALOOKS UNIT) (* ; "Edited 22-Oct-2025 12:29 by rmk")
|
||||
(* ; "Edited 19-Feb-2025 13:25 by rmk")
|
||||
(* ; "Edited 8-Feb-2025 21:08 by rmk")
|
||||
(* ; "Edited 4-Aug-2024 22:50 by rmk")
|
||||
|
||||
@@ -1088,7 +1101,8 @@
|
||||
MARUNIT _ UNIT
|
||||
MARTABS _ (for TAB in (FGETPLOOKS PARALOOKS FMTTABS)
|
||||
collect (create TAB using TAB TABX _ (QUOTIENT (fetch (TAB TABX) of TAB)
|
||||
UNIT])
|
||||
UNIT)))
|
||||
MARBARWIDTH _ (FGETPLOOKS PARALOOKS RIGHTMAR])
|
||||
)
|
||||
|
||||
(RPAQQ \TEDIT.LEFTTAB #*(10 8)B@@@B@@@G@@@JH@@B@@@B@@@CN@@@@@@)
|
||||
@@ -1247,7 +1261,8 @@
|
||||
(DEFINEQ
|
||||
|
||||
(\TEDIT.MENU.CREATE
|
||||
[LAMBDA (MENUDESC MENUPROPS) (* ; "Edited 17-Dec-2024 08:53 by rmk")
|
||||
[LAMBDA (MENUDESC MENUPROPS MAINTSTREAM) (* ; "Edited 19-Oct-2025 10:36 by rmk")
|
||||
(* ; "Edited 17-Dec-2024 08:53 by rmk")
|
||||
(* ; "Edited 22-Aug-2024 11:09 by rmk")
|
||||
(* ; "Edited 21-Aug-2024 09:54 by rmk")
|
||||
(* ; "Edited 14-Aug-2024 09:40 by rmk")
|
||||
@@ -1263,7 +1278,7 @@
|
||||
(* ;; "Create the TEXTSTREAM for a menu, given a menu description. That stream is marked as a menu and passed to \TEDIT.MENU.START to get the menu up on screen")
|
||||
|
||||
(LET [(MENUTSTREAM (OPENTEXTSTREAM NIL NIL NIL NIL (OR MENUPROPS '(FONT (MODERN 10]
|
||||
(MB.ADD MENUDESC MENUTSTREAM)
|
||||
(MB.ADD MENUDESC MENUTSTREAM NIL NIL MAINTSTREAM)
|
||||
(SETSEL (TEXTSEL (GETTSTR MENUTSTREAM TEXTOBJ))
|
||||
SET NIL)
|
||||
(SETTOBJ (GETTSTR MENUTSTREAM TEXTOBJ)
|
||||
@@ -1663,7 +1678,8 @@
|
||||
(DEFINEQ
|
||||
|
||||
(\TEDIT.PARAMENU.CREATE
|
||||
[LAMBDA NIL (* ; "Edited 13-Jul-2025 22:35 by rmk")
|
||||
[LAMBDA (MAINTSTREAM) (* ; "Edited 19-Oct-2025 15:12 by rmk")
|
||||
(* ; "Edited 13-Jul-2025 22:35 by rmk")
|
||||
(* ; "Edited 7-Jan-2025 15:48 by rmk")
|
||||
(* ; "Edited 8-Nov-2024 08:35 by rmk")
|
||||
(* ; "Edited 20-Oct-2024 23:46 by rmk")
|
||||
@@ -1680,7 +1696,7 @@
|
||||
(* ; "Edited 27-Jul-2024 10:18 by rmk")
|
||||
(* jds " 2-Aug-84 15:32")
|
||||
|
||||
(* ;; "Creates the TEdit Expanded Paragraph Menu. (PROGN to suppress %"value of comment used? compile-time messages.)")
|
||||
(* ;; "Creates the TEdit Expanded Paragraph Menu for MAINTSTREAM. (PROGN to suppress %"value of comment used? compile-time messages.)")
|
||||
|
||||
(PROGN
|
||||
(* ;; "Hack so Masterscope knows that these otherwise quoted functions are here.")
|
||||
@@ -1689,88 +1705,97 @@
|
||||
(FUNCTION \TEDIT.SHOW.PARALOOKS)
|
||||
(FUNCTION \TEDIT.MENU.NEUTRALIZE)
|
||||
(FUNCTION \TEDIT.TABTYPE.SET)
|
||||
(FUNCTION PRINTERTYPE))
|
||||
(\TEDIT.MENU.CREATE `((ACTION (LABEL APPLY)
|
||||
(IGNORE T)
|
||||
(SELECTFN \TEDIT.APPLY.PARALOOKS))
|
||||
3
|
||||
(ACTION (LABEL SHOW)
|
||||
(IGNORE T)
|
||||
(SELECTFN \TEDIT.SHOW.PARALOOKS))
|
||||
3
|
||||
(ACTION (LABEL NEUTRAL)
|
||||
(IGNORE T)
|
||||
(SELECTFN \TEDIT.MENU.NEUTRALIZE))
|
||||
EOL
|
||||
(NWAY (IDENTIFIER QUAD)
|
||||
(BUTTONS (Left Right Centered Justified))
|
||||
(INITSTATE OFF))
|
||||
TAB
|
||||
(3STATE (IDENTIFIER TYPE)
|
||||
(LABEL "Page Heading"))
|
||||
2
|
||||
(FIELD (IDENTIFIER SUBTYPE)
|
||||
(PRELABEL "type")
|
||||
(FIELDTYPE SYMBOL))
|
||||
EOL
|
||||
(FIELD (IDENTIFIER LINELEADING)
|
||||
(PRELABEL "Line leading")
|
||||
(POSTLABEL "pts")
|
||||
(FIELDTYPE NUMBER)
|
||||
(LABELFONT (HELVETICA 8)))
|
||||
(FIELD (PRELABEL " Para leading")
|
||||
(POSTLABEL "pts")
|
||||
(IDENTIFIER PARALEADING)
|
||||
(FIELDTYPE NUMBER)
|
||||
(LABELFONT (HELVETICA 8)))
|
||||
(FIELD (IDENTIFIER SPECIALX)
|
||||
(PRELABEL " Special Locn: X")
|
||||
(POSTLABEL "picas")
|
||||
(FIELDTYPE PICAS)
|
||||
(LABELFONT (HELVETICA 8)))
|
||||
(FIELD (IDENTIFIER SPECIALY)
|
||||
(PRELABEL " Y")
|
||||
(POSTLABEL "picas")
|
||||
(FIELDTYPE PICAS)
|
||||
(LABELFONT (HELVETICA 8)))
|
||||
EOL
|
||||
(TEXT (STRING "New Page: ")
|
||||
(FONT (HELVETICA 8)))
|
||||
(3STATE (IDENTIFIER NEWPAGEBEFORE)
|
||||
(LABEL "Before"))
|
||||
2
|
||||
(3STATE (IDENTIFIER NEWPAGEAFTER)
|
||||
(LABEL "After"))
|
||||
4
|
||||
(3STATE (IDENTIFIER HEADINGKEEP)
|
||||
(LABEL "Keep heading"))
|
||||
(TEXT (STRING " Display mode: ")
|
||||
(FONT (HELVETICA 8)))
|
||||
(3STATE (LABEL "Hardcopy")) (* (FIELD (IDENTIFIER PRINTFILETYPE)
|
||||
(FUNCTION PRINTERTYPE)
|
||||
(FUNCTION \TEDIT.PARAMENU.RESHAPEFN))
|
||||
(LET (MENUTSTREAM)
|
||||
(SETQ MENUTSTREAM (\TEDIT.MENU.CREATE `((ACTION (LABEL APPLY)
|
||||
(IGNORE T)
|
||||
(SELECTFN \TEDIT.APPLY.PARALOOKS))
|
||||
3
|
||||
(ACTION (LABEL SHOW)
|
||||
(IGNORE T)
|
||||
(SELECTFN \TEDIT.SHOW.PARALOOKS))
|
||||
3
|
||||
(ACTION (LABEL NEUTRAL)
|
||||
(IGNORE T)
|
||||
(SELECTFN \TEDIT.MENU.NEUTRALIZE))
|
||||
EOL
|
||||
(NWAY (IDENTIFIER QUAD)
|
||||
(BUTTONS (Left Right Centered Justified))
|
||||
(INITSTATE OFF))
|
||||
TAB
|
||||
(3STATE (IDENTIFIER TYPE)
|
||||
(LABEL "Page Heading"))
|
||||
2
|
||||
(FIELD (IDENTIFIER SUBTYPE)
|
||||
(PRELABEL "type")
|
||||
(FIELDTYPE SYMBOL))
|
||||
EOL
|
||||
(FIELD (IDENTIFIER LINELEADING)
|
||||
(PRELABEL "Line leading")
|
||||
(POSTLABEL "pts")
|
||||
(FIELDTYPE NUMBER)
|
||||
(LABELFONT (HELVETICA 8)))
|
||||
(FIELD (PRELABEL " Para leading")
|
||||
(POSTLABEL "pts")
|
||||
(IDENTIFIER PARALEADING)
|
||||
(FIELDTYPE NUMBER)
|
||||
(LABELFONT (HELVETICA 8)))
|
||||
(FIELD (IDENTIFIER SPECIALX)
|
||||
(PRELABEL " Special Locn: X")
|
||||
(POSTLABEL "picas")
|
||||
(FIELDTYPE PICAS)
|
||||
(LABELFONT (HELVETICA 8)))
|
||||
(FIELD (IDENTIFIER SPECIALY)
|
||||
(PRELABEL " Y")
|
||||
(POSTLABEL "picas")
|
||||
(FIELDTYPE PICAS)
|
||||
(LABELFONT (HELVETICA 8)))
|
||||
EOL
|
||||
(TEXT (STRING "New Page: ")
|
||||
(FONT (HELVETICA 8)))
|
||||
(3STATE (IDENTIFIER NEWPAGEBEFORE)
|
||||
(LABEL "Before"))
|
||||
2
|
||||
(3STATE (IDENTIFIER NEWPAGEAFTER)
|
||||
(LABEL "After"))
|
||||
4
|
||||
(3STATE (IDENTIFIER HEADINGKEEP)
|
||||
(LABEL "Keep heading"))
|
||||
(TEXT (STRING " Display mode: ")
|
||||
(FONT (HELVETICA 8)))
|
||||
(3STATE (LABEL "Hardcopy"))
|
||||
(* (FIELD (IDENTIFIER PRINTFILETYPE)
|
||||
(FIELDTYPE SYMBOL) (INITSTATE
|
||||
(\, (PRINTERTYPE)))))
|
||||
4 EOL (TEXT (STRING "Tab Type: ")
|
||||
(FONT (HELVETICA 8)))
|
||||
(NWAY (IDENTIFIER TABTYPE)
|
||||
(BUTTONS (Left Right Centered Decimal))
|
||||
(IGNORE T))
|
||||
3
|
||||
(TOGGLE (IDENTIFIER DOTTEDLEADER)
|
||||
(LABEL "Dotted Leader")
|
||||
(IGNORE T))
|
||||
(FIELD (IDENTIFIER DEFAULTTAB)
|
||||
(PRELABEL " Default Tab:")
|
||||
(POSTLABEL "pts")
|
||||
(FIELDTYPE NUMBER)
|
||||
(LABELFONT (HELVETICA 8)))
|
||||
EOL
|
||||
((PROGN (TEDIT.INSERT.OBJECT (MARGINBAR.CREATE -0.5 -0.5 -39.5 NIL 12)
|
||||
MENUTSTREAM CH# '(PROTECTED OFF))
|
||||
1))
|
||||
EOL])
|
||||
4 EOL (TEXT (STRING "Tab Type: ")
|
||||
(FONT (HELVETICA 8)))
|
||||
(NWAY (IDENTIFIER TABTYPE)
|
||||
(BUTTONS (Left Right Centered Decimal))
|
||||
(IGNORE T))
|
||||
3
|
||||
(TOGGLE (IDENTIFIER DOTTEDLEADER)
|
||||
(LABEL "Dotted Leader")
|
||||
(IGNORE T))
|
||||
(FIELD (IDENTIFIER DEFAULTTAB)
|
||||
(PRELABEL " Default Tab:")
|
||||
(POSTLABEL "pts")
|
||||
(FIELDTYPE NUMBER)
|
||||
(LABELFONT (HELVETICA 8)))
|
||||
EOL
|
||||
((PROGN (TEDIT.INSERT.OBJECT (MARGINBAR.CREATE
|
||||
-0.5 -0.5 -39.5 NIL 12
|
||||
NIL MAINTSTREAM)
|
||||
MENUTSTREAM CH# '(PROTECTED OFF))
|
||||
1))
|
||||
EOL)
|
||||
NIL MAINTSTREAM))
|
||||
[PUTTEXTPROP MENUTSTREAM 'WINDOWPROPS `(RESHAPEFN (\TEDIT.PARAMENU.RESHAPEFN]
|
||||
MENUTSTREAM])
|
||||
|
||||
(\TEDIT.PARAMENU.START
|
||||
[LAMBDA (TSTREAM) (* ; "Edited 28-May-2025 23:45 by rmk")
|
||||
[LAMBDA (MAINTSTREAM) (* ; "Edited 19-Oct-2025 10:29 by rmk")
|
||||
(* ; "Edited 28-May-2025 23:45 by rmk")
|
||||
(* ; "Edited 14-Mar-2025 15:42 by rmk")
|
||||
(* ; "Edited 7-Jan-2025 15:36 by rmk")
|
||||
(* ; "Edited 27-Jul-2024 00:06 by rmk")
|
||||
@@ -1778,9 +1803,9 @@
|
||||
(* ; "Edited 27-Feb-2024 07:53 by rmk")
|
||||
(* ; "Edited 19-Sep-2023 08:51 by rmk")
|
||||
(* ; "Edited 20-Aug-87 16:51 by jds")
|
||||
(CL:UNLESS (\TEDIT.MENU.OPEN? "Paragraph-Looks Menu" TSTREAM)
|
||||
(\TEDIT.MENU.START (\TEDIT.PARAMENU.CREATE)
|
||||
TSTREAM "Paragraph-Looks Menu" (HEIGHTIFWINDOW 141 T)
|
||||
(CL:UNLESS (\TEDIT.MENU.OPEN? "Paragraph-Looks Menu" MAINTSTREAM)
|
||||
(\TEDIT.MENU.START (\TEDIT.PARAMENU.CREATE MAINTSTREAM)
|
||||
MAINTSTREAM "Paragraph-Looks Menu" (HEIGHTIFWINDOW 141 T)
|
||||
'PARALOOKS))])
|
||||
|
||||
(\TEDIT.APPLY.PARALOOKS
|
||||
@@ -1895,6 +1920,21 @@
|
||||
(CL:WHEN SETSTATEFN
|
||||
(SETQ PC (APPLY* SETSTATEFN PC VAL MENUSTREAM))
|
||||
(TEDIT.OBJECT.CHANGED MENUSTREAM OBJ))])
|
||||
|
||||
(\TEDIT.PARAMENU.RESHAPEFN
|
||||
[LAMBDA (PANE BITS OLDREGION) (* ; "Edited 19-Oct-2025 14:18 by rmk")
|
||||
|
||||
(* ;; "The marginbar's width may change when the parawindow is reshaped. If PANE is wider than the previous width, extend the margin bar.")
|
||||
|
||||
(LET [(PC (MB.GET 'MARGINBAR PANE 'STARTPC]
|
||||
(CL:WHEN [AND PC (IGREATERP (PANEWIDTH PANE)
|
||||
(fetch (MARGINBAR MARBARWIDTH) of (IMAGEOBJPROP (POBJ PC)
|
||||
'OBJECTDATUM]
|
||||
[WITH MARGINBAR (IMAGEOBJPROP (POBJ PC)
|
||||
'OBJECTDATUM)
|
||||
(FSETPC PC POBJ (MARGINBAR.CREATE MARL1 MARLN MARR MARTABS MARUNIT MARTABTYPE
|
||||
(PANEWIDTH PANE])
|
||||
(\TEDIT.RESHAPEFN PANE BITS OLDREGION])
|
||||
)
|
||||
|
||||
|
||||
@@ -2867,32 +2907,32 @@
|
||||
(ADDTOVAR LAMA )
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (4902 16540 (TEDIT.ADD.MENUITEM 4912 . 7029) (TEDIT.DEFAULT.MENUFN 7031 . 13752) (
|
||||
TEDIT.REMOVE.MENUITEM 13754 . 14751) (\TEDIT.CREATEMENU 14753 . 15318) (\TEDIT.MENU.WHENHELDFN 15320
|
||||
. 16225) (\TEDIT.MENU.WHENSELECTEDFN 16227 . 16538)) (17354 63997 (DRAWMARGINSCALE 17364 . 20823) (
|
||||
MARGINBAR 20825 . 27950) (MARGINBAR.CREATE 27952 . 31371) (MB.MARGINBAR.BUTTONEVENTINFN 31373 . 39175)
|
||||
(MB.MARGINBAR.SELFN.TABS 39177 . 44417) (MB.MARGINBAR.SELFN.TABS.KIND 44419 . 45354) (
|
||||
MARGINBAR.GETSTATEFN 45356 . 49343) (MARGINBAR.SETSTATEFN 49345 . 49555) (MARGINBAR.NEUTRALIZE 49557
|
||||
. 49970) (MARGINBAR.LOOKS 49972 . 53078) (MB.MARGINBAR.SIZEFN 53080 . 53683) (MB.MARGINBAR.DISPLAYFN
|
||||
53685 . 56746) (MDESCALE 56748 . 57288) (MSCALE 57290 . 57620) (MB.MARGINBAR.SHOWTAB 57622 . 59945) (
|
||||
MB.MARGINBAR.TABTRACK 59947 . 61332) (MARGINBAR.INIT 61334 . 62727) (\TEDIT.PARALOOKS.TO.MARBAR 62729
|
||||
. 63995)) (64822 72104 (TEDIT.MENUSTREAM 64832 . 65832) (TEDITMENUP 65834 . 66803) (\TEDIT.MENU.START
|
||||
66805 . 71152) (\TEDIT.MENU.OPEN? 71154 . 71528) (\TEDIT.MENU.BUTTONEVENTFN 71530 . 72102)) (72423
|
||||
80345 (\TEDIT.MENU.CREATE 72433 . 74244) (\TEDIT.MENU.PARSE 74246 . 77935) (\TEDIT.MENU.NEUTRALIZE
|
||||
77937 . 80008) (\TEDITMENU.RECORD.UNFORMATTED 80010 . 80343)) (80411 100192 (
|
||||
\TEDIT.EXPANDEDMENU.CREATE 80421 . 85888) (\TEDIT.EXPANDEDMENU.START 85890 . 87514) (
|
||||
\TEDIT.EXPANDEDMENU.FN 87516 . 90771) (\TEDIT.EXPANDEDMENU.ACTIONFN 90773 . 100190)) (100254 116311 (
|
||||
\TEDIT.PARAMENU.CREATE 100264 . 106658) (\TEDIT.PARAMENU.START 106660 . 107785) (
|
||||
\TEDIT.APPLY.PARALOOKS 107787 . 108839) (\TEDIT.SHOW.PARALOOKS 108841 . 111558) (
|
||||
\TEDIT.PARAMENU.FILLIN 111560 . 116309)) (116516 143358 (\TEDIT.CHARMENU.CREATE 116526 . 119130) (
|
||||
\TEDIT.CHARMENU.START 119132 . 120422) (\TEDIT.CHARMENU.SPEC 120424 . 125107) (\TEDIT.CHARMENU.PARSE
|
||||
125109 . 128277) (\TEDIT.CHARMENU.FILLIN 128279 . 132909) (\TEDIT.SHOW.CHARLOOKS 132911 . 136456) (
|
||||
\TEDIT.APPLY.CHARLOOKS 136458 . 137619) (\TEDIT.OFFSETTYPE.STATEFN 137621 . 139584) (
|
||||
\TEDIT.OTHER.STATECHANGEFN 139586 . 141231) (\TEDIT.OTHER.SELECTFN 141233 . 143356)) (143420 172478 (
|
||||
\TEDIT.PAGEMENU.CREATE 143430 . 151942) (\TEDIT.PAGEMENU.START 151944 . 152295) (\TEDIT.SHOW.PAGELOOKS
|
||||
152297 . 154183) (\TEDIT.PAGEMENU.FILLIN 154185 . 155735) (\TEDIT.PAGEREGION.UNPARSE 155737 . 165136)
|
||||
(\TEDIT.APPLY.PAGELOOKS 165138 . 167065) (\TEDIT.CHANGE.PAGELOOKS 167067 . 171634) (
|
||||
\TEDIT.PAGEMENU.CHARLOOKS.STATEFN 171636 . 172476)) (172479 178282 (\TEDIT.PAGEMENU.CREATE.HEADINGS
|
||||
172489 . 175301) (\TEDIT.PAGEMENU.HEADINGS.SETSTATEFN 175303 . 176728) (
|
||||
\TEDIT.PAGEMENU.HEADINGS.STATEFN 176730 . 178280)))))
|
||||
(FILEMAP (NIL (4972 16610 (TEDIT.ADD.MENUITEM 4982 . 7099) (TEDIT.DEFAULT.MENUFN 7101 . 13822) (
|
||||
TEDIT.REMOVE.MENUITEM 13824 . 14821) (\TEDIT.CREATEMENU 14823 . 15388) (\TEDIT.MENU.WHENHELDFN 15390
|
||||
. 16295) (\TEDIT.MENU.WHENSELECTEDFN 16297 . 16608)) (17424 65459 (DRAWMARGINSCALE 17434 . 20893) (
|
||||
MARGINBAR 20895 . 28020) (MARGINBAR.CREATE 28022 . 32220) (MB.MARGINBAR.BUTTONEVENTINFN 32222 . 40024)
|
||||
(MB.MARGINBAR.SELFN.TABS 40026 . 45266) (MB.MARGINBAR.SELFN.TABS.KIND 45268 . 46203) (
|
||||
MARGINBAR.GETSTATEFN 46205 . 50192) (MARGINBAR.SETSTATEFN 50194 . 50404) (MARGINBAR.NEUTRALIZE 50406
|
||||
. 51081) (MARGINBAR.LOOKS 51083 . 54189) (MB.MARGINBAR.SIZEFN 54191 . 54977) (MB.MARGINBAR.DISPLAYFN
|
||||
54979 . 58040) (MDESCALE 58042 . 58582) (MSCALE 58584 . 58914) (MB.MARGINBAR.SHOWTAB 58916 . 61239) (
|
||||
MB.MARGINBAR.TABTRACK 61241 . 62626) (MARGINBAR.INIT 62628 . 64021) (\TEDIT.PARALOOKS.TO.MARBAR 64023
|
||||
. 65457)) (66284 73566 (TEDIT.MENUSTREAM 66294 . 67294) (TEDITMENUP 67296 . 68265) (\TEDIT.MENU.START
|
||||
68267 . 72614) (\TEDIT.MENU.OPEN? 72616 . 72990) (\TEDIT.MENU.BUTTONEVENTFN 72992 . 73564)) (73885
|
||||
81936 (\TEDIT.MENU.CREATE 73895 . 75835) (\TEDIT.MENU.PARSE 75837 . 79526) (\TEDIT.MENU.NEUTRALIZE
|
||||
79528 . 81599) (\TEDITMENU.RECORD.UNFORMATTED 81601 . 81934)) (82002 101783 (
|
||||
\TEDIT.EXPANDEDMENU.CREATE 82012 . 87479) (\TEDIT.EXPANDEDMENU.START 87481 . 89105) (
|
||||
\TEDIT.EXPANDEDMENU.FN 89107 . 92362) (\TEDIT.EXPANDEDMENU.ACTIONFN 92364 . 101781)) (101845 121270 (
|
||||
\TEDIT.PARAMENU.CREATE 101855 . 110586) (\TEDIT.PARAMENU.START 110588 . 111842) (
|
||||
\TEDIT.APPLY.PARALOOKS 111844 . 112896) (\TEDIT.SHOW.PARALOOKS 112898 . 115615) (
|
||||
\TEDIT.PARAMENU.FILLIN 115617 . 120366) (\TEDIT.PARAMENU.RESHAPEFN 120368 . 121268)) (121475 148317 (
|
||||
\TEDIT.CHARMENU.CREATE 121485 . 124089) (\TEDIT.CHARMENU.START 124091 . 125381) (\TEDIT.CHARMENU.SPEC
|
||||
125383 . 130066) (\TEDIT.CHARMENU.PARSE 130068 . 133236) (\TEDIT.CHARMENU.FILLIN 133238 . 137868) (
|
||||
\TEDIT.SHOW.CHARLOOKS 137870 . 141415) (\TEDIT.APPLY.CHARLOOKS 141417 . 142578) (
|
||||
\TEDIT.OFFSETTYPE.STATEFN 142580 . 144543) (\TEDIT.OTHER.STATECHANGEFN 144545 . 146190) (
|
||||
\TEDIT.OTHER.SELECTFN 146192 . 148315)) (148379 177437 (\TEDIT.PAGEMENU.CREATE 148389 . 156901) (
|
||||
\TEDIT.PAGEMENU.START 156903 . 157254) (\TEDIT.SHOW.PAGELOOKS 157256 . 159142) (\TEDIT.PAGEMENU.FILLIN
|
||||
159144 . 160694) (\TEDIT.PAGEREGION.UNPARSE 160696 . 170095) (\TEDIT.APPLY.PAGELOOKS 170097 . 172024)
|
||||
(\TEDIT.CHANGE.PAGELOOKS 172026 . 176593) (\TEDIT.PAGEMENU.CHARLOOKS.STATEFN 176595 . 177435)) (
|
||||
177438 183241 (\TEDIT.PAGEMENU.CREATE.HEADINGS 177448 . 180260) (\TEDIT.PAGEMENU.HEADINGS.SETSTATEFN
|
||||
180262 . 181687) (\TEDIT.PAGEMENU.HEADINGS.STATEFN 181689 . 183239)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,13 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED " 7-Aug-2025 12:51:00" {WMEDLEY}<library>tedit>TEDIT-SCREEN.;909 186327
|
||||
(FILECREATED "19-Oct-2025 00:07:29" {WMEDLEY}<library>TEDIT>TEDIT-SCREEN.;910 186445
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (VARS TEDIT-SCREENCOMS)
|
||||
(FNS \TEDIT.FORMATLINE)
|
||||
:CHANGES-TO (FNS \TEDIT.FORMATLINE.HORIZONTAL)
|
||||
|
||||
:PREVIOUS-DATE "28-Jul-2025 23:23:33" {WMEDLEY}<library>tedit>TEDIT-SCREEN.;908)
|
||||
:PREVIOUS-DATE " 7-Aug-2025 12:51:00" {WMEDLEY}<library>TEDIT>TEDIT-SCREEN.;909)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT TEDIT-SCREENCOMS)
|
||||
@@ -1294,7 +1293,8 @@
|
||||
IMAGESTREAM])
|
||||
|
||||
(\TEDIT.FORMATLINE.HORIZONTAL
|
||||
[LAMBDA (LINE THISLINE PREVSP SPACELEFT OVERHANG LINETYPE) (* ; "Edited 29-May-2025 15:15 by rmk")
|
||||
[LAMBDA (LINE THISLINE PREVSP SPACELEFT OVERHANG LINETYPE) (* ; "Edited 18-Oct-2025 20:05 by rmk")
|
||||
(* ; "Edited 29-May-2025 15:15 by rmk")
|
||||
(* ; "Edited 19-Feb-2025 13:35 by rmk")
|
||||
(* ; "Edited 8-Feb-2025 23:37 by rmk")
|
||||
(* ; "Edited 15-Mar-2024 19:35 by rmk")
|
||||
@@ -1318,6 +1318,8 @@
|
||||
|
||||
(* ;; "")
|
||||
|
||||
(SETQ SPACELEFT (MAX SPACELEFT 0))
|
||||
|
||||
(* ;; "Also for HARDCOPYDISPLAY the horizontal positions (margins and character widths) are in hardcopy units. At the end we scale them back to screen points. ")
|
||||
|
||||
(LET* ((PARALOOKS (FGETLD LINE LPARALOOKS))
|
||||
@@ -2861,21 +2863,21 @@
|
||||
(\TEDIT.LINE.TALLP LINE PHEIGHT))))])
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (26256 28472 (\TEDIT.LINEDESCRIPTOR.DEFPRINT 26266 . 28470)) (35926 119762 (
|
||||
\TEDIT.FORMATLINE 35936 . 71423) (\TEDIT.FORMATLINE.SETUP.PARA 71425 . 76591) (
|
||||
\TEDIT.FORMATLINE.HORIZONTAL 76593 . 81261) (\TEDIT.FORMATLINE.VERTICAL 81263 . 83714) (
|
||||
\TEDIT.FORMATLINE.JUSTIFY 83716 . 89737) (\TEDIT.FORMATLINE.TABS 89739 . 97767) (\TEDIT.SCALE.TABS
|
||||
97769 . 98560) (\TEDIT.FORMATLINE.PURGE.SPACES 98562 . 99989) (\TEDIT.FORMATLINE.FLUSH.SOFTHYPHEN
|
||||
99991 . 101068) (\TEDIT.FORMATLINE.EMPTY 101070 . 105890) (\TEDIT.FORMATLINE.UPDATELOOKS 105892 .
|
||||
112073) (\TEDIT.FORMATLINE.LASTLEGAL 112075 . 115525) (\TEDIT.LINES.ABOVE 115527 . 119138) (
|
||||
\TEDIT.CHNO.TO.YTOP 119140 . 119760)) (120039 140619 (\TEDIT.DISPLAYLINE 120049 . 132559) (
|
||||
\TEDIT.DISPLAYLINE.TABS 132561 . 135365) (\TEDIT.LINECACHE 135367 . 136095) (\TEDIT.CREATE.LINECACHE
|
||||
136097 . 136933) (\TEDIT.BLTCHAR 136935 . 139562) (\TEDIT.DIACRITIC.SHIFT 139564 . 140617)) (141234
|
||||
186304 (\TEDIT.BACKFORMAT 141244 . 143798) (\TEDIT.PREVIOUS.LINEBREAK 143800 . 146603) (
|
||||
\TEDIT.UPDATE.LINES 146605 . 152320) (\TEDIT.PANE.CREATELINES 152322 . 154612) (
|
||||
\TEDIT.SUFFIXLINE.CREATE 154614 . 156229) (\TEDIT.LINES.BELOW 156231 . 160841) (\TEDIT.MEASURED.LINES
|
||||
160843 . 162852) (\TEDIT.VALID.LASTCHNOS 162854 . 166630) (\TEDIT.VALID.NEXTCHNOS 166632 . 170106) (
|
||||
\TEDIT.LASTVALIDLINE 170108 . 174779) (\TEDIT.NEXTVALIDLINE 174781 . 177751) (
|
||||
\TEDIT.CLEARPANE.BELOW.LINE 177753 . 179859) (\TEDIT.INSERTLINE 179861 . 181247) (\TEDIT.LINE.BOTTOM
|
||||
181249 . 184479) (\TEDIT.SHOW.AT.BOTTOMP 184481 . 185591) (\TEDIT.SHOW.AT.TOPP 185593 . 186302)))))
|
||||
(FILEMAP (NIL (26225 28441 (\TEDIT.LINEDESCRIPTOR.DEFPRINT 26235 . 28439)) (35895 119880 (
|
||||
\TEDIT.FORMATLINE 35905 . 71392) (\TEDIT.FORMATLINE.SETUP.PARA 71394 . 76560) (
|
||||
\TEDIT.FORMATLINE.HORIZONTAL 76562 . 81379) (\TEDIT.FORMATLINE.VERTICAL 81381 . 83832) (
|
||||
\TEDIT.FORMATLINE.JUSTIFY 83834 . 89855) (\TEDIT.FORMATLINE.TABS 89857 . 97885) (\TEDIT.SCALE.TABS
|
||||
97887 . 98678) (\TEDIT.FORMATLINE.PURGE.SPACES 98680 . 100107) (\TEDIT.FORMATLINE.FLUSH.SOFTHYPHEN
|
||||
100109 . 101186) (\TEDIT.FORMATLINE.EMPTY 101188 . 106008) (\TEDIT.FORMATLINE.UPDATELOOKS 106010 .
|
||||
112191) (\TEDIT.FORMATLINE.LASTLEGAL 112193 . 115643) (\TEDIT.LINES.ABOVE 115645 . 119256) (
|
||||
\TEDIT.CHNO.TO.YTOP 119258 . 119878)) (120157 140737 (\TEDIT.DISPLAYLINE 120167 . 132677) (
|
||||
\TEDIT.DISPLAYLINE.TABS 132679 . 135483) (\TEDIT.LINECACHE 135485 . 136213) (\TEDIT.CREATE.LINECACHE
|
||||
136215 . 137051) (\TEDIT.BLTCHAR 137053 . 139680) (\TEDIT.DIACRITIC.SHIFT 139682 . 140735)) (141352
|
||||
186422 (\TEDIT.BACKFORMAT 141362 . 143916) (\TEDIT.PREVIOUS.LINEBREAK 143918 . 146721) (
|
||||
\TEDIT.UPDATE.LINES 146723 . 152438) (\TEDIT.PANE.CREATELINES 152440 . 154730) (
|
||||
\TEDIT.SUFFIXLINE.CREATE 154732 . 156347) (\TEDIT.LINES.BELOW 156349 . 160959) (\TEDIT.MEASURED.LINES
|
||||
160961 . 162970) (\TEDIT.VALID.LASTCHNOS 162972 . 166748) (\TEDIT.VALID.NEXTCHNOS 166750 . 170224) (
|
||||
\TEDIT.LASTVALIDLINE 170226 . 174897) (\TEDIT.NEXTVALIDLINE 174899 . 177869) (
|
||||
\TEDIT.CLEARPANE.BELOW.LINE 177871 . 179977) (\TEDIT.INSERTLINE 179979 . 181365) (\TEDIT.LINE.BOTTOM
|
||||
181367 . 184597) (\TEDIT.SHOW.AT.BOTTOMP 184599 . 185709) (\TEDIT.SHOW.AT.TOPP 185711 . 186420)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,12 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED " 5-Oct-2025 10:56:19" {WMEDLEY}<library>TEDIT>TEDIT-WINDOW.;867 229880
|
||||
(FILECREATED "25-Oct-2025 10:33:08" {WMEDLEY}<library>TEDIT>TEDIT-WINDOW.;878 230780
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (FNS \TEDIT.SPLITW)
|
||||
:CHANGES-TO (FNS \TEDIT.WINDOW.GETREGION)
|
||||
|
||||
:PREVIOUS-DATE "18-Sep-2025 23:09:24" {WMEDLEY}<library>TEDIT>TEDIT-WINDOW.;864)
|
||||
:PREVIOUS-DATE "24-Oct-2025 09:11:52" {WMEDLEY}<library>tedit>TEDIT-WINDOW.;874)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT TEDIT-WINDOWCOMS)
|
||||
@@ -354,25 +354,19 @@
|
||||
(DEFINEQ
|
||||
|
||||
(\TEDIT.WINDOW.CREATE
|
||||
[LAMBDA (WINDOW TSTREAM PROPS) (* ; "Edited 21-Jul-2025 11:55 by rmk")
|
||||
[LAMBDA (WINDOW TSTREAM PROPS) (* ; "Edited 23-Oct-2025 18:22 by rmk")
|
||||
(* ; "Edited 21-Jul-2025 11:55 by rmk")
|
||||
(* ; "Edited 9-May-2025 12:11 by rmk")
|
||||
(* ; "Edited 25-Apr-2025 21:24 by rmk")
|
||||
(* ; "Edited 20-Apr-2025 15:21 by rmk")
|
||||
(* ; "Edited 18-Feb-2025 09:49 by rmk")
|
||||
(* ; "Edited 1-Jul-2024 22:55 by rmk")
|
||||
(* ; "Edited 29-Jun-2024 23:16 by rmk")
|
||||
(* ; "Edited 5-May-2024 21:54 by rmk")
|
||||
(* ; "Edited 20-Mar-2024 09:57 by rmk")
|
||||
(* ; "Edited 14-Jan-2024 22:13 by rmk")
|
||||
(* ; "Edited 18-Dec-2023 23:01 by rmk")
|
||||
(* ; "Edited 25-Nov-2023 10:37 by rmk")
|
||||
(* ; "Edited 23-Oct-2023 22:11 by rmk")
|
||||
(* ; "Edited 21-Oct-2023 12:20 by rmk")
|
||||
(* ; "Edited 18-Oct-2023 09:56 by rmk")
|
||||
(* ; "Edited 1-Jan-2022 23:54 by rmk")
|
||||
(* ; "Edited 30-Dec-2021 23:00 by rmk")
|
||||
(* ; "Edited 29-Dec-2021 16:35 by rmk")
|
||||
(* ; "Edited 24-Dec-2021 19:21 by rmk")
|
||||
(* ; "Edited 1-Jan-2022 23:54 by rmk")
|
||||
(* jds "23-May-85 15:19")
|
||||
(* ; "Edited 27-Oct-2021 12:25 by rmk:")
|
||||
|
||||
@@ -420,7 +414,6 @@
|
||||
(SETQ REGION (if (REGIONP WINDOW)
|
||||
then (PROG1 (COPY WINDOW)
|
||||
(SETQ WINDOW NIL))
|
||||
elseif (GRAB-TYPED-REGION REGIONTYPE)
|
||||
else (SETQ REGION (\TEDIT.WINDOW.GETREGION TSTREAM REGIONTYPE PHEIGHT))
|
||||
(* ;
|
||||
"We don't want the default to keep shrinking")
|
||||
@@ -462,56 +455,92 @@
|
||||
WINDOW])
|
||||
|
||||
(\TEDIT.WINDOW.GETREGION
|
||||
[LAMBDA (TSTREAM REGIONTYPE PHEIGHT) (* ; "Edited 14-Apr-2025 00:05 by rmk")
|
||||
[LAMBDA (TSTREAM REGIONTYPE PHEIGHT) (* ; "Edited 25-Oct-2025 10:27 by rmk")
|
||||
(* ; "Edited 19-Oct-2025 01:05 by rmk")
|
||||
(* ; "Edited 14-Apr-2025 00:05 by rmk")
|
||||
(* ; "Edited 31-Mar-2025 22:43 by rmk")
|
||||
(* ; "Edited 24-Mar-2025 11:29 by rmk")
|
||||
(* ; "Edited 18-Mar-2025 21:52 by rmk")
|
||||
(* ; "Edited 19-Feb-2025 16:48 by rmk")
|
||||
(* ; "Edited 18-Feb-2025 10:09 by rmk")
|
||||
(LET ((TEXTOBJ (GETTSTR TSTREAM TEXTOBJ))
|
||||
[WIDTHOVERHEAD (IPLUS \TEDIT.LINEREGION.WIDTH (TIMES 2 WBorder)
|
||||
(if (FGETTOBJ TEXTOBJ TXTNOTSPLITTABLE)
|
||||
then 0
|
||||
elseif (ILEQ \TEDIT.OP.WIDTH 0)
|
||||
then
|
||||
(* ;; "On both sides, for symmetry")
|
||||
|
||||
\TEDIT.LINEREGION.WIDTH
|
||||
else
|
||||
(* ;;
|
||||
"36 to allow for some spacing between the text and the OPS area on the right.")
|
||||
|
||||
(IPLUS \TEDIT.OP.WIDTH 36]
|
||||
[HEIGHTOVERHEAD (IPLUS PHEIGHT (ADD1 (TIMES 2 WBorder))
|
||||
(FONTPROP WindowTitleDisplayStream 'HEIGHT]
|
||||
WIDTH HEIGHT)
|
||||
(CLRPROMPT) (* ; "System promptwindow")
|
||||
(printout PROMPTWINDOW "Please specify a " (OR REGIONTYPE "Tedit")
|
||||
" window region")
|
||||
(CL:WHEN (TXTFILE TSTREAM)
|
||||
(printout PROMPTWINDOW " for " 2 (GETTEXTPROP TSTREAM 'FILENAME)))
|
||||
(TERPRI PROMPTWINDOW)
|
||||
(if (IGREATERP (TEXTLEN TEXTOBJ)
|
||||
0)
|
||||
then
|
||||
(* ;; "Explict user properties covers content")
|
||||
|
||||
[SETQ WIDTH (OR (GETTEXTPROP TEXTOBJ 'OPENWIDTH)
|
||||
(for PARALOOKS in (FGETTOBJ TEXTOBJ TXTPARALOOKSLIST)
|
||||
largest (GETPLOOKS PARALOOKS RIGHTMAR)
|
||||
finally (CL:UNLESS (AND $$EXTREME (IGREATERP $$EXTREME 0))
|
||||
(SETQ $$EXTREME (TIMES 6 PTSPERINCH)))
|
||||
(RETURN $$EXTREME]
|
||||
(* ;; "Explict properties cover content")
|
||||
|
||||
(* ;; "Allow for extra stuff. 36 to allow for some spacing.")
|
||||
[SETQ WIDTH (OR (GETTEXTPROP TEXTOBJ 'OPENWIDTH)
|
||||
(for PARALOOKS in (FGETTOBJ TEXTOBJ TXTPARALOOKSLIST)
|
||||
when (IGREATERP (GETPLOOKS PARALOOKS RIGHTMAR)
|
||||
0) largest (GETPLOOKS PARALOOKS RIGHTMAR)
|
||||
finally (RETURN $$EXTREME]
|
||||
(SETQ HEIGHT (GETTEXTPROP TEXTOBJ 'OPENHEIGHT))
|
||||
|
||||
[add WIDTH (IPLUS \TEDIT.LINEREGION.WIDTH (ADD1 (TIMES 2 WBorder)
|
||||
1)
|
||||
(CL:IF (FGETTOBJ TEXTOBJ TXTNOTSPLITTABLE)
|
||||
0
|
||||
(CL:IF (EQ 0 \TEDIT.OP.WIDTH)
|
||||
\TEDIT.LINEREGION.WIDTH
|
||||
(IPLUS \TEDIT.OP.WIDTH 36)))]
|
||||
[SETQ HEIGHT (if (GETTEXTPROP TEXTOBJ 'OPENHEIGHT)
|
||||
elseif (ZEROP (TEXTLEN TEXTOBJ))
|
||||
then 50
|
||||
else (for I L (TEXTLEN _ (TEXTLEN TEXTOBJ))
|
||||
(CHNO _ 1) from 1 to 20 while (ILEQ CHNO TEXTLEN)
|
||||
sum (SETQ L (\TEDIT.FORMATLINE TSTREAM CHNO))
|
||||
(SETQ CHNO (FGETLD L LCHARLIM))
|
||||
(FGETLD L LHEIGHT)
|
||||
finally (RETURN (IPLUS $$VAL PHEIGHT (ADD1 (TIMES 2 WBorder)
|
||||
)
|
||||
(FONTPROP WindowTitleDisplayStream
|
||||
'HEIGHT]
|
||||
(GETBOXREGION WIDTH HEIGHT)
|
||||
else (GETREGION (IMAX 200 (ADD1 (TIMES 2 WBorder)))
|
||||
(IMAX 100 (ADD1 (TIMES 2 WBorder])
|
||||
(* ;; "If still no WIDTH or HEIGHT, look at the first 20 lines")
|
||||
|
||||
(CL:UNLESS (AND HEIGHT WIDTH)
|
||||
(for I L (TEXTLEN _ (TEXTLEN TEXTOBJ))
|
||||
(REG _ (CREATEREGION 0 0 (IDIFFERENCE SCREENWIDTH WIDTHOVERHEAD)
|
||||
(IDIFFERENCE SCREENHEIGHT HEIGHTOVERHEAD)))
|
||||
(W _ 0)
|
||||
(H _ 0)
|
||||
(CHNO _ 1) from 1 to 20 while (ILEQ CHNO TEXTLEN)
|
||||
do
|
||||
(* ;;
|
||||
"But we start by saying that the right margin is infinite, so we can find the true width")
|
||||
|
||||
(SETQ L (\TEDIT.FORMATLINE TSTREAM CHNO NIL REG))
|
||||
(SETQ CHNO (FGETLD L LCHARLIM))
|
||||
(add H (FGETLD L LHEIGHT))
|
||||
(CL:UNLESS WIDTH
|
||||
(CL:WHEN (EQ 'LEFT (FGETPLOOKS (FGETLD L LPARALOOKS)
|
||||
QUAD))
|
||||
|
||||
(* ;;
|
||||
"JUSTIFIED, RIGHT and CENTERED involve right margin, which we don't know")
|
||||
|
||||
(SETQ W (IMAX W (FGETLD L LXLIM)))))
|
||||
finally (CL:UNLESS (OR WIDTH (EQ W 0)) (* ; "Maybe no lefts?")
|
||||
(SETQ WIDTH W))
|
||||
(CL:UNLESS (OR HEIGHT (EQ H 0))
|
||||
(SETQ HEIGHT H))))
|
||||
|
||||
(* ;; "Minimum sizes")
|
||||
|
||||
(SETQ WIDTH (IMAX 200 (OR WIDTH 0)))
|
||||
(SETQ HEIGHT (IMAX 100 (OR HEIGHT 0)))
|
||||
|
||||
(* ;; "Allow for the extra stuff")
|
||||
|
||||
(add WIDTH WIDTHOVERHEAD)
|
||||
(add HEIGHT HEIGHTOVERHEAD)
|
||||
(if (GRAB-TYPED-REGION REGIONTYPE WIDTH HEIGHT 1.1)
|
||||
else
|
||||
(* ;; "Maximum new sizes")
|
||||
|
||||
[SETQ WIDTH (IMIN WIDTH (FIXR (FTIMES SCREENWIDTH 0.9]
|
||||
[SETQ HEIGHT (IMIN HEIGHT (FIXR (FTIMES SCREENHEIGHT 0.9]
|
||||
(CLRPROMPT) (* ; "System promptwindow")
|
||||
(printout PROMPTWINDOW "Please specify a " (OR REGIONTYPE "Tedit")
|
||||
" region")
|
||||
(CL:WHEN (TXTFILE TSTREAM)
|
||||
(printout PROMPTWINDOW " for " 2 (GETTEXTPROP TSTREAM 'FILENAME)))
|
||||
(TERPRI PROMPTWINDOW)
|
||||
(GETBOXREGION WIDTH HEIGHT])
|
||||
|
||||
(\TEDIT.WINDOW.SETUP
|
||||
[LAMBDA (PANE TSTREAM PROPS AFTERPANE LCHAR1) (* ; "Edited 6-May-2025 11:44 by rmk")
|
||||
@@ -576,7 +605,8 @@
|
||||
(\TEDIT.SET.WINDOW.EXTENT TEXTOBJ PANE])
|
||||
|
||||
(\TEDIT.MINIMAL.WINDOW.SETUP
|
||||
[LAMBDA (PANEWINDOW TSTREAM PROPS) (* ; "Edited 20-Apr-2025 15:19 by rmk")
|
||||
[LAMBDA (PANEWINDOW TSTREAM PROPS) (* ; "Edited 19-Oct-2025 14:55 by rmk")
|
||||
(* ; "Edited 20-Apr-2025 15:19 by rmk")
|
||||
(* ; "Edited 30-Nov-2024 13:32 by rmk")
|
||||
(* ; "Edited 4-Nov-2024 19:46 by rmk")
|
||||
(* ; "Edited 26-Oct-2024 11:10 by rmk")
|
||||
@@ -677,6 +707,11 @@
|
||||
|
||||
(WINDOWADDPROP PANEWINDOW 'CLOSEFN (FUNCTION TEDIT.DEACTIVATE.WINDOW)
|
||||
T)
|
||||
|
||||
(* ;; "Possible the only WINDOWPROPS client is the MARGINBAR in the paragraph menu")
|
||||
|
||||
(for PTAIL on (GETTEXTPROP TSTREAM 'WINDOWPROPS) do (WINDOWPROP PANEWINDOW (CAR PTAIL)
|
||||
(CADR PTAIL)))
|
||||
PANEWINDOW])
|
||||
|
||||
(\TEDIT.CLEARPANE
|
||||
@@ -3624,36 +3659,36 @@
|
||||
(RPAQ? TEDIT.TITLED.ICON.TEMPLATE (create TITLEDICON ICON _ TEDITICON MASK _ TEDITMASK TITLEREG _
|
||||
TEDIT.ICON.TITLE.REGION))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (17093 17989 (TEDIT.DEFER.UPDATES 17103 . 17987)) (17990 43935 (\TEDIT.WINDOW.CREATE
|
||||
18000 . 25330) (\TEDIT.WINDOW.GETREGION 25332 . 28822) (\TEDIT.WINDOW.SETUP 28824 . 33154) (
|
||||
\TEDIT.MINIMAL.WINDOW.SETUP 33156 . 40567) (\TEDIT.CLEARPANE 40569 . 41286) (\TEDIT.FILL.PANES 41288
|
||||
. 43933)) (43936 67637 (\TEDIT.CURSORMOVEDFN 43946 . 49556) (\TEDIT.CURSOROUTFN 49558 . 50246) (
|
||||
\TEDIT.ACTIVE.WINDOWP 50248 . 51318) (\TEDIT.EXPANDFN 51320 . 51883) (\TEDIT.MAINW 51885 . 53165) (
|
||||
\TEDIT.MAINSTREAM 53167 . 53501) (\TEDIT.PRIMARYPANE 53503 . 54273) (\TEDIT.PANELIST 54275 . 54771) (
|
||||
\TEDIT.NEWREGIONFN 54773 . 57289) (\TEDIT.SET.WINDOW.EXTENT 57291 . 62273) (\TEDIT.SHRINK.ICONCREATE
|
||||
62275 . 65008) (\TEDIT.SHRINKFN 65010 . 65419) (\TEDIT.PANEREGION 65421 . 67635)) (67669 100715 (
|
||||
\TEDIT.BUTTONEVENTFN 67679 . 80652) (\TEDIT.BUTTONEVENTFN.DOOPERATION 80654 . 87917) (
|
||||
\TEDIT.BUTTONEVENTFN.GETOPERATION 87919 . 89761) (\TEDIT.BUTTONEVENTFN.CURSEL.INIT 89763 . 93433) (
|
||||
\TEDIT.BUTTONEVENTFN.INACTIVE 93435 . 95865) (\TEDIT.BUTTONEVENTFN.INTITLE 95867 . 97702) (
|
||||
\TEDIT.COPYINSERTFN 97704 . 98836) (\TEDIT.FOREIGN.COPY 98838 . 100713)) (100716 118279 (
|
||||
\TEDIT.PANE.SPLIT 100726 . 104674) (\TEDIT.SPLITW 104676 . 112735) (\TEDIT.UNSPLITW 112737 . 116936) (
|
||||
\TEDIT.LINKPANES 116938 . 117701) (\TEDIT.UNLINKPANE 117703 . 118277)) (119713 120604 (TEDITWINDOWP
|
||||
119723 . 120602)) (120641 123744 (TEDIT.GETINPUT 120651 . 123094) (\TEDIT.MAKEFILENAME 123096 . 123742
|
||||
)) (123793 131443 (TEDIT.PROMPTWINDOW 123803 . 124117) (TEDIT.PROMPTPRINT 124119 . 126746) (
|
||||
TEDIT.PROMPTCLEAR 126748 . 128490) (TEDIT.PROMPTFLASH 128492 . 129750) (\TEDIT.PROMPT.PAGEFULLFN
|
||||
129752 . 131441)) (131681 142259 (\TEDIT.FILENAME 131691 . 132463) (\TEDIT.DEFAULT.TITLE 132465 .
|
||||
134844) (\TEDIT.WINDOW.TITLE 134846 . 137015) (\TEDIT.LIKELY.FILENAME 137017 . 139741) (
|
||||
\TEDIT.UPDATE.TITLE 139743 . 142257)) (142302 154786 (TEDIT.DEACTIVATE.WINDOW 142312 . 147885) (
|
||||
\TEDIT.RESHAPEFN 147887 . 149972) (\TEDIT.REPAINTFN 149974 . 150198) (\TEDIT.CLOSESPLITS 150200 .
|
||||
152645) (\TEDIT.CLOSEPANE 152647 . 154784)) (154787 197586 (\TEDIT.SCROLLFN 154797 . 157028) (
|
||||
\TEDIT.SCROLLCH.TOP 157030 . 159141) (\TEDIT.SCROLLCH.BOTTOM 159143 . 163473) (\TEDIT.SCROLLUP 163475
|
||||
. 169201) (\TEDIT.TOPLINE.YTOP 169203 . 170872) (\TEDIT.SCROLLDOWN 170874 . 177913) (
|
||||
\TEDIT.SCROLL.CARET 177915 . 180753) (\TEDIT.VISIBLECARETP 180755 . 183049) (\TEDIT.VISIBLECHARP
|
||||
183051 . 184142) (\TEDIT.BITMAPLINES 184144 . 188064) (\TEDIT.SETPANE.TOPLINE 188066 . 188678) (
|
||||
\TEDIT.SHIFTLINES 188680 . 197584)) (197587 208456 (\TEDIT.ONSCREEN? 197597 . 202148) (
|
||||
\TEDIT.ONSCREEN.REGION 202150 . 205801) (\TEDIT.AFTERMOVEFN 205803 . 206700) (OFFSCREENP 206702 .
|
||||
208454)) (208498 211312 (\TEDIT.PROCIDLEFN 208508 . 210168) (\TEDIT.PROCENTRYFN 210170 . 210615) (
|
||||
\TEDIT.PROCEXITFN 210617 . 211310)) (211391 224616 (\TEDIT.DOWNCARET 211401 . 212194) (
|
||||
\TEDIT.FLASHCARET 212196 . 214307) (\TEDIT.UPCARET 214309 . 215413) (TEDIT.NORMALIZECARET 215415 .
|
||||
218633) (\TEDIT.SETCARET 218635 . 223986) (\TEDIT.CARET 223988 . 224614)))))
|
||||
(FILEMAP (NIL (17103 17999 (TEDIT.DEFER.UPDATES 17113 . 17997)) (18000 44835 (\TEDIT.WINDOW.CREATE
|
||||
18010 . 24616) (\TEDIT.WINDOW.GETREGION 24618 . 29322) (\TEDIT.WINDOW.SETUP 29324 . 33654) (
|
||||
\TEDIT.MINIMAL.WINDOW.SETUP 33656 . 41467) (\TEDIT.CLEARPANE 41469 . 42186) (\TEDIT.FILL.PANES 42188
|
||||
. 44833)) (44836 68537 (\TEDIT.CURSORMOVEDFN 44846 . 50456) (\TEDIT.CURSOROUTFN 50458 . 51146) (
|
||||
\TEDIT.ACTIVE.WINDOWP 51148 . 52218) (\TEDIT.EXPANDFN 52220 . 52783) (\TEDIT.MAINW 52785 . 54065) (
|
||||
\TEDIT.MAINSTREAM 54067 . 54401) (\TEDIT.PRIMARYPANE 54403 . 55173) (\TEDIT.PANELIST 55175 . 55671) (
|
||||
\TEDIT.NEWREGIONFN 55673 . 58189) (\TEDIT.SET.WINDOW.EXTENT 58191 . 63173) (\TEDIT.SHRINK.ICONCREATE
|
||||
63175 . 65908) (\TEDIT.SHRINKFN 65910 . 66319) (\TEDIT.PANEREGION 66321 . 68535)) (68569 101615 (
|
||||
\TEDIT.BUTTONEVENTFN 68579 . 81552) (\TEDIT.BUTTONEVENTFN.DOOPERATION 81554 . 88817) (
|
||||
\TEDIT.BUTTONEVENTFN.GETOPERATION 88819 . 90661) (\TEDIT.BUTTONEVENTFN.CURSEL.INIT 90663 . 94333) (
|
||||
\TEDIT.BUTTONEVENTFN.INACTIVE 94335 . 96765) (\TEDIT.BUTTONEVENTFN.INTITLE 96767 . 98602) (
|
||||
\TEDIT.COPYINSERTFN 98604 . 99736) (\TEDIT.FOREIGN.COPY 99738 . 101613)) (101616 119179 (
|
||||
\TEDIT.PANE.SPLIT 101626 . 105574) (\TEDIT.SPLITW 105576 . 113635) (\TEDIT.UNSPLITW 113637 . 117836) (
|
||||
\TEDIT.LINKPANES 117838 . 118601) (\TEDIT.UNLINKPANE 118603 . 119177)) (120613 121504 (TEDITWINDOWP
|
||||
120623 . 121502)) (121541 124644 (TEDIT.GETINPUT 121551 . 123994) (\TEDIT.MAKEFILENAME 123996 . 124642
|
||||
)) (124693 132343 (TEDIT.PROMPTWINDOW 124703 . 125017) (TEDIT.PROMPTPRINT 125019 . 127646) (
|
||||
TEDIT.PROMPTCLEAR 127648 . 129390) (TEDIT.PROMPTFLASH 129392 . 130650) (\TEDIT.PROMPT.PAGEFULLFN
|
||||
130652 . 132341)) (132581 143159 (\TEDIT.FILENAME 132591 . 133363) (\TEDIT.DEFAULT.TITLE 133365 .
|
||||
135744) (\TEDIT.WINDOW.TITLE 135746 . 137915) (\TEDIT.LIKELY.FILENAME 137917 . 140641) (
|
||||
\TEDIT.UPDATE.TITLE 140643 . 143157)) (143202 155686 (TEDIT.DEACTIVATE.WINDOW 143212 . 148785) (
|
||||
\TEDIT.RESHAPEFN 148787 . 150872) (\TEDIT.REPAINTFN 150874 . 151098) (\TEDIT.CLOSESPLITS 151100 .
|
||||
153545) (\TEDIT.CLOSEPANE 153547 . 155684)) (155687 198486 (\TEDIT.SCROLLFN 155697 . 157928) (
|
||||
\TEDIT.SCROLLCH.TOP 157930 . 160041) (\TEDIT.SCROLLCH.BOTTOM 160043 . 164373) (\TEDIT.SCROLLUP 164375
|
||||
. 170101) (\TEDIT.TOPLINE.YTOP 170103 . 171772) (\TEDIT.SCROLLDOWN 171774 . 178813) (
|
||||
\TEDIT.SCROLL.CARET 178815 . 181653) (\TEDIT.VISIBLECARETP 181655 . 183949) (\TEDIT.VISIBLECHARP
|
||||
183951 . 185042) (\TEDIT.BITMAPLINES 185044 . 188964) (\TEDIT.SETPANE.TOPLINE 188966 . 189578) (
|
||||
\TEDIT.SHIFTLINES 189580 . 198484)) (198487 209356 (\TEDIT.ONSCREEN? 198497 . 203048) (
|
||||
\TEDIT.ONSCREEN.REGION 203050 . 206701) (\TEDIT.AFTERMOVEFN 206703 . 207600) (OFFSCREENP 207602 .
|
||||
209354)) (209398 212212 (\TEDIT.PROCIDLEFN 209408 . 211068) (\TEDIT.PROCENTRYFN 211070 . 211515) (
|
||||
\TEDIT.PROCEXITFN 211517 . 212210)) (212291 225516 (\TEDIT.DOWNCARET 212301 . 213094) (
|
||||
\TEDIT.FLASHCARET 213096 . 215207) (\TEDIT.UPCARET 215209 . 216313) (TEDIT.NORMALIZECARET 216315 .
|
||||
219533) (\TEDIT.SETCARET 219535 . 224886) (\TEDIT.CARET 224888 . 225514)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,12 +1,10 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED " 6-Jul-2023 08:52:09" {WMEDLEY}<library>virtualkeyboards>DANDELIONKEYBOARDS.;3 33795
|
||||
(FILECREATED "15-Oct-2025 16:50:39" {WMEDLEY}<library>virtualkeyboards>DANDELIONKEYBOARDS.;4 33748
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (VARS DANDELIONKEYBOARDSCOMS)
|
||||
|
||||
:PREVIOUS-DATE " 4-Jul-2023 23:18:05" {WMEDLEY}<library>virtualkeyboards>DANDELIONKEYBOARDS.;2
|
||||
:PREVIOUS-DATE " 6-Jul-2023 08:52:09" {WMEDLEY}<library>virtualkeyboards>DANDELIONKEYBOARDS.;3
|
||||
)
|
||||
|
||||
|
||||
@@ -324,7 +322,7 @@
|
||||
(135 (9850 9818 LOCKSHIFT))
|
||||
(137 (9841 9809 LOCKSHIFT))
|
||||
(138 (106 74 LOCKSHIFT))
|
||||
(139 (9826 66 LOCKSHIFT))
|
||||
(139 (9826 9794 LOCKSHIFT))
|
||||
(140 (9833 9801 LOCKSHIFT))
|
||||
(141 1SHIFTDOWN . 1SHIFTUP)
|
||||
(142 (46 62 NOLOCKSHIFT))
|
||||
|
||||
Binary file not shown.
@@ -1,12 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "24-Aug-2025 13:38:35" {WMEDLEY}<lispusers>COMPAREDIRECTORIES.;268 133743
|
||||
(FILECREATED "25-Oct-2025 23:59:24" {MEDLEY}<lispusers>COMPAREDIRECTORIES.;2 135376
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (FNS CDENTRIES.SELECT CDPRINT.LINE)
|
||||
:CHANGES-TO (FNS CDBROWSER-COPY)
|
||||
|
||||
:PREVIOUS-DATE "26-Mar-2025 09:41:31" {WMEDLEY}<lispusers>COMPAREDIRECTORIES.;267)
|
||||
:PREVIOUS-DATE "22-Oct-2025 08:32:01" {WMEDLEY}<lispusers>COMPAREDIRECTORIES.;272)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT COMPAREDIRECTORIESCOMS)
|
||||
@@ -160,6 +160,8 @@
|
||||
(COMPAREDIRECTORIES.INFOS
|
||||
[LAMBDA (DIR INCLUDEDFILES EXCLUDEDFILES ALLVERSIONS DEPTH USEDIRECTORYDATE INCLUDEAUTHOR)
|
||||
|
||||
(* ;; "Edited 21-Oct-2025 14:26 by rmk")
|
||||
|
||||
(* ;; "Edited 29-Sep-2023 17:25 by rmk")
|
||||
|
||||
(* ;; "Edited 22-May-2022 14:17 by rmk")
|
||||
@@ -168,43 +170,45 @@
|
||||
|
||||
(* ;; "Each entry is a list of the form (matchname . CDINFOS). CDINFOS is guaranteed to be a singleton, unless ALLVERSIONS. ")
|
||||
|
||||
(FOR FULLNAME TYPE LDATE STREAM (STARTPOS _ (ADD1 (NCHARS DIR)))
|
||||
IN (CDFILES DIR INCLUDEDFILES EXCLUDEDFILES ALLVERSIONS DEPTH)
|
||||
COLLECT
|
||||
(CL:WHEN (DIRECTORYNAMEP DIR)
|
||||
[FOR FULLNAME TYPE LDATE STREAM (STARTPOS _ (ADD1 (NCHARS DIR)))
|
||||
IN (CDFILES DIR INCLUDEDFILES EXCLUDEDFILES ALLVERSIONS DEPTH)
|
||||
COLLECT
|
||||
|
||||
(* ;; "GDATE/IDATE in case Y2K")
|
||||
(* ;; "GDATE/IDATE in case Y2K")
|
||||
|
||||
(SETQ STREAM (OPENSTREAM FULLNAME 'INPUT)) (* ;
|
||||
(SETQ STREAM (OPENSTREAM FULLNAME 'INPUT)) (* ;
|
||||
"So all the GETFILEINFO's, FILEDATES, etc. don't have to do the directory searching.")
|
||||
(* ;
|
||||
"Is it a Lisp file? Get it's internal filecreated date. ")
|
||||
(CL:MULTIPLE-VALUE-SETQ (TYPE LDATE)
|
||||
(COMPAREDIRECTORIES.INFOS.TYPE STREAM))
|
||||
(PROG1 (LIST (MATCHNAME FULLNAME STARTPOS)
|
||||
(CREATE CDINFO
|
||||
FULLNAME _ (FULLNAME STREAM)
|
||||
DATE _ (GDATE (IDATE (IF (OR USEDIRECTORYDATE (NULL LDATE))
|
||||
THEN (GETFILEINFO STREAM 'CREATIONDATE)
|
||||
ELSE (SETFILEINFO STREAM 'CREATIONDATE LDATE)
|
||||
LDATE)))
|
||||
LENGTH _ (GETFILEINFO STREAM 'LENGTH)
|
||||
AUTHOR _ (AND INCLUDEAUTHOR (GETFILEINFO STREAM 'AUTHOR))
|
||||
TYPE _ TYPE
|
||||
EOL _ (EOLTYPE STREAM)))
|
||||
(CLOSEF? STREAM))
|
||||
FINALLY
|
||||
(CL:MULTIPLE-VALUE-SETQ (TYPE LDATE)
|
||||
(COMPAREDIRECTORIES.INFOS.TYPE STREAM))
|
||||
(PROG1 (LIST (MATCHNAME FULLNAME STARTPOS)
|
||||
(CREATE CDINFO
|
||||
FULLNAME _ (FULLNAME STREAM)
|
||||
DATE _ (GDATE (IDATE (IF (OR USEDIRECTORYDATE (NULL LDATE))
|
||||
THEN (GETFILEINFO STREAM 'CREATIONDATE)
|
||||
ELSE (SETFILEINFO STREAM 'CREATIONDATE
|
||||
LDATE)
|
||||
LDATE)))
|
||||
LENGTH _ (GETFILEINFO STREAM 'LENGTH)
|
||||
AUTHOR _ (AND INCLUDEAUTHOR (GETFILEINFO STREAM 'AUTHOR))
|
||||
TYPE _ TYPE
|
||||
EOL _ (EOLTYPE STREAM)))
|
||||
(CLOSEF? STREAM))
|
||||
FINALLY
|
||||
|
||||
(* ;; "Sort to get all entries with the same matchname adjacent. Presumably we would only need to collect multiples if ALLVERSIONS, but in a case-sensitive file system we might see files with names that differ in case. We have deliberately given them a case-insensitive matchname, so we can expose this issue in the display.")
|
||||
(* ;; "Sort to get all entries with the same matchname adjacent. Presumably we would only need to collect multiples if ALLVERSIONS, but in a case-sensitive file system we might see files with names that differ in case. We have deliberately given them a case-insensitive matchname, so we can expose this issue in the display.")
|
||||
|
||||
(* ;; "If we see (MN X)(MN Y), smash the Y in after the X")
|
||||
(* ;; "If we see (MN X)(MN Y), smash the Y in after the X")
|
||||
|
||||
(RETURN (FOR ITAIL I VAL MN ON (SORT $$VAL T)
|
||||
DO (SETQ I (CAR ITAIL))
|
||||
(SETQ MN (CAR I))
|
||||
[WHILE (EQ MN (CAADR ITAIL)) DO (POP ITAIL)
|
||||
(PUSH (CDR I)
|
||||
(CADR (CAR ITAIL]
|
||||
(PUSH VAL I) FINALLY (RETURN (DREVERSE VAL])
|
||||
(RETURN (FOR ITAIL I VAL MN ON (SORT $$VAL T)
|
||||
DO (SETQ I (CAR ITAIL))
|
||||
(SETQ MN (CAR I))
|
||||
[WHILE (EQ MN (CAADR ITAIL)) DO (POP ITAIL)
|
||||
(PUSH (CDR I)
|
||||
(CADR (CAR ITAIL]
|
||||
(PUSH VAL I) FINALLY (RETURN (DREVERSE VAL])])
|
||||
|
||||
(COMPAREDIRECTORIES.CANDIDATES
|
||||
[LAMBDA (INFOS1 INFOS2)
|
||||
@@ -335,7 +339,9 @@
|
||||
CDE])
|
||||
|
||||
(COMPAREDIRECTORIES.INFOS.TYPE
|
||||
[LAMBDA (FILE) (* ; "Edited 28-Sep-2023 23:09 by rmk")
|
||||
[LAMBDA (FILE) (* ; "Edited 22-Oct-2025 08:29 by rmk")
|
||||
(* ; "Edited 20-Sep-2025 12:59 by rmk")
|
||||
(* ; "Edited 28-Sep-2023 23:09 by rmk")
|
||||
(* ; "Edited 22-May-2022 14:27 by rmk")
|
||||
(* ; "Edited 25-Apr-2022 09:02 by rmk")
|
||||
(* ; "Edited 4-Jan-2022 13:10 by rmk")
|
||||
@@ -404,7 +410,8 @@
|
||||
(DEFINEQ
|
||||
|
||||
(CDFILES
|
||||
[LAMBDA (DIR INCLUDEDFILES EXCLUDEDFILES ALLVERSIONS DEPTH)(* ; "Edited 17-Jun-2023 23:04 by rmk")
|
||||
[LAMBDA (DIR INCLUDEDFILES EXCLUDEDFILES ALLVERSIONS DEPTH)(* ; "Edited 20-Oct-2025 23:25 by rmk")
|
||||
(* ; "Edited 17-Jun-2023 23:04 by rmk")
|
||||
(* ; "Edited 3-Oct-2022 12:03 by rmk")
|
||||
(* ; "Edited 25-Apr-2022 08:42 by rmk")
|
||||
(* ; "Edited 5-Mar-2022 15:05 by rmk")
|
||||
@@ -426,8 +433,7 @@
|
||||
|
||||
(* ;; "EXCLUDEDFILES is a filepattern with * meaning everything, COM means *.LCOM and *.DFASL")
|
||||
|
||||
[SETQ EXCLUDEDFILES `(*>.DS_Store
|
||||
,@(MKLIST EXCLUDEDFILES]
|
||||
[SETQ EXCLUDEDFILES `(*>.DS¬Store ,@(MKLIST EXCLUDEDFILES]
|
||||
(CL:UNLESS (EQMEMB '.* INCLUDEDFILES) (* ;
|
||||
"Excluded dot files unless specifically asked for")
|
||||
[SETQ EXCLUDEDFILES `(.* ,@(MKLIST EXCLUDEDFILES])
|
||||
@@ -2117,13 +2123,17 @@
|
||||
NIL])
|
||||
|
||||
(CDBROWSER-COPY
|
||||
[LAMBDA (CDBROWSER TBITEM SOURCE) (* ; "Edited 24-May-2022 15:49 by rmk")
|
||||
[LAMBDA (CDBROWSER TBITEM SOURCE UNIXDEST) (* ; "Edited 25-Oct-2025 23:58 by rmk")
|
||||
(* ; "Edited 24-May-2022 15:49 by rmk")
|
||||
(* ; "Edited 25-Apr-2022 09:24 by rmk")
|
||||
(* ; "Edited 5-Feb-2022 17:27 by rmk")
|
||||
(* ; "Edited 2-Feb-2022 22:18 by rmk")
|
||||
|
||||
(* ;; "Copies the file identified as SOURCE (LEFT or RIGHT) in CDENTRY to the other file of the end. If the destination file is missing, it is assumed to be a new/unversioned file of the same name as the source but with the directory prefix switched. CDVALUE needed to know what directory prefixes are involved.")
|
||||
|
||||
(* ;;
|
||||
"if UNIXDEST, coerces the true destination file to host UNIX--suppresses Medley version numbers")
|
||||
|
||||
(* ;; "Returns NIL if the copy fails.")
|
||||
|
||||
(CL:UNLESS (TB.ITEM.DELETED? CDBROWSER TBITEM)
|
||||
@@ -2167,7 +2177,17 @@
|
||||
(CLEARW T)
|
||||
(CL:UNLESS DESTFILE
|
||||
(SETQ DESTFILE (CD-SWAPDIRS SOURCEFILE SOURCEDIR DESTDIR)))
|
||||
(SETQ RESULT (COPYFILE SOURCEFILE (PACKFILENAME.STRING 'VERSION NIL 'BODY DESTFILE)))
|
||||
[SETQ RESULT (if UNIXDEST
|
||||
then [PSEUDOFILENAME (PACKFILENAME 'HOST 'DSK 'BODY
|
||||
(COPYFILE SOURCEFILE (PACKFILENAME
|
||||
'HOST
|
||||
'UNIX
|
||||
'VERSION NIL
|
||||
'BODY
|
||||
(TRUEFILENAME
|
||||
DESTFILE]
|
||||
else (COPYFILE SOURCEFILE (PACKFILENAME.STRING 'VERSION NIL
|
||||
'BODY DESTFILE]
|
||||
(PRIN3 (IF RESULT
|
||||
THEN (TB.DELETE.ITEM CDBROWSER TBITEM)
|
||||
(CONCAT "Copied to " RESULT)
|
||||
@@ -2251,25 +2271,25 @@
|
||||
|
||||
(MOVD? 'NILL 'TEDIT.FILEDATE)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (2673 23163 (COMPAREDIRECTORIES 2683 . 8018) (COMPAREDIRECTORIES.INFOS 8020 . 10978) (
|
||||
COMPAREDIRECTORIES.CANDIDATES 10980 . 14365) (CDENTRIES.SELECT 14367 . 19269) (
|
||||
COMPAREDIRECTORIES.INFOS.TYPE 19271 . 20397) (MATCHNAME 20399 . 21079) (CD.INSURECDVALUE 21081 . 22695
|
||||
) (CD.UPDATEWIDTHS 22697 . 23161)) (23164 33786 (CDFILES 23174 . 29188) (CDFILES.MATCH 29190 . 30815)
|
||||
(CDFILES.PATS 30817 . 33784)) (33787 51805 (CDPRINT 33797 . 36314) (CDPRINT.HEADER 36316 . 37213) (
|
||||
CDPRINT.LINE 37215 . 40644) (CDPRINT.MAXWIDTHS 40646 . 44761) (CDPRINT.COLHEADERS 44763 . 46048) (
|
||||
CDPRINT.COLUMNS 46050 . 51170) (CDTEDIT 51172 . 51803)) (51806 60927 (CDMAP 51816 . 53248) (CDENTRY
|
||||
53250 . 53559) (CDSUBSET 53561 . 55000) (CDMERGE 55002 . 58986) (CDMERGE.COMMON 58988 . 60303) (
|
||||
CD.SORT 60305 . 60925)) (60928 68466 (BINCOMP 60938 . 65227) (EOLTYPE 65229 . 67791) (EOLTYPE.SHOW
|
||||
67793 . 68464)) (68994 81521 (FIND-UNCOMPILED-FILES 69004 . 72647) (FIND-UNSOURCED-FILES 72649 . 75033
|
||||
) (FIND-SOURCE-FILES 75035 . 76773) (FIND-COMPILED-FILES 76775 . 78652) (FIND-UNLOADED-FILES 78654 .
|
||||
79507) (FIND-LOADED-FILES 79509 . 79937) (FIND-MULTICOMPILED-FILES 79939 . 81519)) (81522 89953 (
|
||||
CREATED-AS 81532 . 86329) (SOURCE-FOR-COMPILED-P 86331 . 89258) (COMPILE-SOURCE-DATE-DIFF 89260 .
|
||||
89951)) (89954 100717 (FIX-DIRECTORY-DATES 89964 . 93414) (FIX-EQUIV-DATES 93416 . 94941) (
|
||||
COPY-COMPARED-FILES 94943 . 96764) (COPY-MISSING-FILES 96766 . 98923) (COMPILED-ON-SAME-SOURCE 98925
|
||||
. 100715)) (100911 108749 (CDBROWSER 100921 . 104848) (CDBROWSER.STRINGS 104850 . 108747)) (108911
|
||||
110647 (CD.TABLEITEM 108921 . 109141) (CD.TABLEITEM.PRINTFN 109143 . 109342) (CD.TABLEITEM.COPYFN
|
||||
109344 . 110402) (CDTABLEBROWSER.HEADING.REPAINTFN 110404 . 110645)) (110648 133218 (
|
||||
CDTABLEBROWSER.WHENSELECTEDFN 110658 . 111126) (CD.COMMANDSELECTEDFN 111128 . 116229) (CD-MENUFN
|
||||
116231 . 122457) (CD-COMPARE-FILES 122459 . 125811) (CDBROWSER-COPY 125813 . 129482) (
|
||||
CDBROWSER-DELETE-FILE 129484 . 132697) (CD-SWAPDIRS 132699 . 133216)))))
|
||||
(FILEMAP (NIL (2655 23634 (COMPAREDIRECTORIES 2665 . 8000) (COMPAREDIRECTORIES.INFOS 8002 . 11231) (
|
||||
COMPAREDIRECTORIES.CANDIDATES 11233 . 14618) (CDENTRIES.SELECT 14620 . 19522) (
|
||||
COMPAREDIRECTORIES.INFOS.TYPE 19524 . 20868) (MATCHNAME 20870 . 21550) (CD.INSURECDVALUE 21552 . 23166
|
||||
) (CD.UPDATEWIDTHS 23168 . 23632)) (23635 34340 (CDFILES 23645 . 29742) (CDFILES.MATCH 29744 . 31369)
|
||||
(CDFILES.PATS 31371 . 34338)) (34341 52359 (CDPRINT 34351 . 36868) (CDPRINT.HEADER 36870 . 37767) (
|
||||
CDPRINT.LINE 37769 . 41198) (CDPRINT.MAXWIDTHS 41200 . 45315) (CDPRINT.COLHEADERS 45317 . 46602) (
|
||||
CDPRINT.COLUMNS 46604 . 51724) (CDTEDIT 51726 . 52357)) (52360 61481 (CDMAP 52370 . 53802) (CDENTRY
|
||||
53804 . 54113) (CDSUBSET 54115 . 55554) (CDMERGE 55556 . 59540) (CDMERGE.COMMON 59542 . 60857) (
|
||||
CD.SORT 60859 . 61479)) (61482 69020 (BINCOMP 61492 . 65781) (EOLTYPE 65783 . 68345) (EOLTYPE.SHOW
|
||||
68347 . 69018)) (69548 82075 (FIND-UNCOMPILED-FILES 69558 . 73201) (FIND-UNSOURCED-FILES 73203 . 75587
|
||||
) (FIND-SOURCE-FILES 75589 . 77327) (FIND-COMPILED-FILES 77329 . 79206) (FIND-UNLOADED-FILES 79208 .
|
||||
80061) (FIND-LOADED-FILES 80063 . 80491) (FIND-MULTICOMPILED-FILES 80493 . 82073)) (82076 90507 (
|
||||
CREATED-AS 82086 . 86883) (SOURCE-FOR-COMPILED-P 86885 . 89812) (COMPILE-SOURCE-DATE-DIFF 89814 .
|
||||
90505)) (90508 101271 (FIX-DIRECTORY-DATES 90518 . 93968) (FIX-EQUIV-DATES 93970 . 95495) (
|
||||
COPY-COMPARED-FILES 95497 . 97318) (COPY-MISSING-FILES 97320 . 99477) (COMPILED-ON-SAME-SOURCE 99479
|
||||
. 101269)) (101465 109303 (CDBROWSER 101475 . 105402) (CDBROWSER.STRINGS 105404 . 109301)) (109465
|
||||
111201 (CD.TABLEITEM 109475 . 109695) (CD.TABLEITEM.PRINTFN 109697 . 109896) (CD.TABLEITEM.COPYFN
|
||||
109898 . 110956) (CDTABLEBROWSER.HEADING.REPAINTFN 110958 . 111199)) (111202 134851 (
|
||||
CDTABLEBROWSER.WHENSELECTEDFN 111212 . 111680) (CD.COMMANDSELECTEDFN 111682 . 116783) (CD-MENUFN
|
||||
116785 . 123011) (CD-COMPARE-FILES 123013 . 126365) (CDBROWSER-COPY 126367 . 131115) (
|
||||
CDBROWSER-DELETE-FILE 131117 . 134330) (CD-SWAPDIRS 134332 . 134849)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,13 +1,13 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED " 7-Oct-2025 14:56:00" {WMEDLEY}<lispusers>EDITFONT.;40 26223
|
||||
(FILECREATED "12-Oct-2025 17:39:29" {WMEDLEY}<lispusers>EDITFONT.;41 26261
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (RECORDS CHARITEM)
|
||||
(FNS EDITFONT)
|
||||
(FNS EF.SAVE)
|
||||
|
||||
:PREVIOUS-DATE " 6-Oct-2025 15:58:41" {WMEDLEY}<lispusers>EDITFONT.;39)
|
||||
:PREVIOUS-DATE " 7-Oct-2025 14:56:00" {WMEDLEY}<lispusers>EDITFONT.;40)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT EDITFONTCOMS)
|
||||
@@ -242,7 +242,8 @@
|
||||
(T (LISPERROR "ILLEGAL ARG" BITMAP])
|
||||
|
||||
(EF.SAVE
|
||||
[LAMBDA (WINDOW) (* ; "Edited 2-Sep-2025 23:03 by rmk")
|
||||
[LAMBDA (WINDOW) (* ; "Edited 12-Oct-2025 17:33 by rmk")
|
||||
(* ; "Edited 2-Sep-2025 23:03 by rmk")
|
||||
(* ; "Edited 29-Aug-2025 11:35 by rmk")
|
||||
(* ; "Edited 4-Aug-2025 09:22 by rmk")
|
||||
(* ; "Edited 2-Aug-2025 08:47 by rmk")
|
||||
@@ -310,8 +311,7 @@
|
||||
|
||||
(* ;; "Can this editing change the descent or ascent?")
|
||||
|
||||
(\SETCHARSETINFO (fetch (FONTDESCRIPTOR FONTCHARSETVECTOR) of FONT)
|
||||
CHARSET CSINFO])
|
||||
(\SETCHARSETINFO FONT CHARSET CSINFO])
|
||||
|
||||
(COPYFONT
|
||||
[LAMBDA (FONT) (* ; "Edited 3-Aug-2025 17:37 by rmk")
|
||||
@@ -494,10 +494,10 @@
|
||||
|
||||
(EF.INIT)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (1147 16865 (EF.INIT 1157 . 1791) (EF.PROMPT 1793 . 2375) (EF.MESSAGE 2377 . 2589) (
|
||||
EF.CLOSEFN 2591 . 3118) (EF.CHARITEMS 3120 . 4956) (EF.BUTTONEVENTFN 4958 . 5370) (EF.WHENSELECTEDFN
|
||||
5372 . 5776) (EF.EDITBM 5778 . 7272) (EF.MIDDLEBUTTONFN 7274 . 7519) (EF.CHANGESIZE 7521 . 8850) (
|
||||
EF.DELETE 8852 . 10033) (EF.ENTER 10035 . 10976) (EF.REPLACE 10978 . 11951) (EF.SAVE 11953 . 16157) (
|
||||
COPYFONT 16159 . 16434) (READSTRIKEFONTFILE 16436 . 16863)) (16866 26035 (BLANKCHARSETCREATE 16876 .
|
||||
22961) (EDITFONT 22963 . 26033)))))
|
||||
(FILEMAP (NIL (1146 16903 (EF.INIT 1156 . 1790) (EF.PROMPT 1792 . 2374) (EF.MESSAGE 2376 . 2588) (
|
||||
EF.CLOSEFN 2590 . 3117) (EF.CHARITEMS 3119 . 4955) (EF.BUTTONEVENTFN 4957 . 5369) (EF.WHENSELECTEDFN
|
||||
5371 . 5775) (EF.EDITBM 5777 . 7271) (EF.MIDDLEBUTTONFN 7273 . 7518) (EF.CHANGESIZE 7520 . 8849) (
|
||||
EF.DELETE 8851 . 10032) (EF.ENTER 10034 . 10975) (EF.REPLACE 10977 . 11950) (EF.SAVE 11952 . 16195) (
|
||||
COPYFONT 16197 . 16472) (READSTRIKEFONTFILE 16474 . 16901)) (16904 26073 (BLANKCHARSETCREATE 16914 .
|
||||
22999) (EDITFONT 23001 . 26071)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,12 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED " 6-Apr-2025 23:54:50" {WMEDLEY}<lispusers>EXAMINEDEFS.;57 16827
|
||||
(FILECREATED "25-Oct-2025 10:24:30" {WMEDLEY}<lispusers>EXAMINEDEFS.;59 17123
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (FNS TEDITDEF)
|
||||
:CHANGES-TO (FNS EXAMINEDEFS)
|
||||
|
||||
:PREVIOUS-DATE "31-Mar-2025 13:53:38" {WMEDLEY}<lispusers>EXAMINEDEFS.;56)
|
||||
:PREVIOUS-DATE " 6-Apr-2025 23:54:50" {WMEDLEY}<lispusers>EXAMINEDEFS.;57)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT EXAMINEDEFSCOMS)
|
||||
@@ -20,7 +20,8 @@
|
||||
(DEFINEQ
|
||||
|
||||
(EXAMINEDEFS
|
||||
[LAMBDA (NAME TYPE SOURCE1 SOURCE2 TITLE1 TITLE2 REGION) (* ; "Edited 31-Mar-2025 13:53 by rmk")
|
||||
[LAMBDA (NAME TYPE SOURCE1 SOURCE2 TITLE1 TITLE2 REGION) (* ; "Edited 25-Oct-2025 10:24 by rmk")
|
||||
(* ; "Edited 31-Mar-2025 13:53 by rmk")
|
||||
(* ; "Edited 18-Feb-2025 22:56 by rmk")
|
||||
(* ; "Edited 6-Dec-2024 20:51 by rmk")
|
||||
(* ; "Edited 13-Oct-2023 11:11 by rmk")
|
||||
@@ -148,6 +149,8 @@
|
||||
DEFAULTFONT)))
|
||||
(TEXTHEIGHT 600))
|
||||
(DECLARE (SPECVARS COMPARETEXT.ALLCHUNKS))
|
||||
(SETQ TITLE1 (CONCAT NAME " from " TITLE1))
|
||||
(SETQ TITLE2 (CONCAT NAME " from " TITLE2))
|
||||
(* ;
|
||||
"Reuse an existing CT graph window for this DEF")
|
||||
(OR [FIND W IN (OPENWINDOWS)
|
||||
@@ -281,6 +284,6 @@
|
||||
(FILESLOAD (SYSLOAD)
|
||||
COMPARETEXT VERSIONDEFS)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (662 16596 (EXAMINEDEFS 672 . 10994) (EXAMINEFILES 10996 . 12478) (TEDITDEF 12480 .
|
||||
14802) (EXVV 14804 . 16594)))))
|
||||
(FILEMAP (NIL (665 16892 (EXAMINEDEFS 675 . 11290) (EXAMINEFILES 11292 . 12774) (TEDITDEF 12776 .
|
||||
15098) (EXVV 15100 . 16890)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
466
lispusers/GITFNS
466
lispusers/GITFNS
@@ -1,12 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "23-Sep-2025 21:43:21" {WMEDLEY}<lispusers>GITFNS.;551 134847
|
||||
(FILECREATED "26-Oct-2025 00:01:44" {WMEDLEY}<lispusers>GITFNS.;565 135222
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (FNS GIT-GET-DIFFERENT-FILES)
|
||||
:CHANGES-TO (FNS GIT-WORKING-COMPARE-DIRECTORIES GIT-CD-MENUFN GIT-MAKE-PROJECT GIT-CLONEP)
|
||||
|
||||
:PREVIOUS-DATE "22-Sep-2025 12:52:41" {WMEDLEY}<lispusers>GITFNS.;550)
|
||||
:PREVIOUS-DATE "25-Oct-2025 10:37:40" {WMEDLEY}<lispusers>GITFNS.;562)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT GITFNSCOMS)
|
||||
@@ -135,22 +135,22 @@
|
||||
(DEFINEQ
|
||||
|
||||
(GIT-CLONEP
|
||||
[LAMBDA (HOST/DIR NOERROR CHECKANCESTORS) (* ; "Edited 1-Oct-2023 18:09 by rmk")
|
||||
[LAMBDA (HOST/DIR NOERROR CHECKANCESTORS) (* ; "Edited 25-Oct-2025 15:13 by rmk")
|
||||
(* ; "Edited 14-Oct-2025 11:55 by rmk")
|
||||
(* ; "Edited 1-Oct-2023 18:09 by rmk")
|
||||
(* ; "Edited 12-May-2022 11:44 by rmk")
|
||||
(* ; "Edited 8-May-2022 16:24 by rmk")
|
||||
|
||||
(* ;; "If CHECKANCESTORS, looks back up the directory chain to see if perhaps the .git is somewhere higher up.")
|
||||
(* ;; "If CHECKANCESTORS, looks back up the directory chain to see if perhaps the .git is somewhere higher up. Returns the full true directory name")
|
||||
|
||||
(IF [AND HOST/DIR (LET [(D (SLASHIT (TRUEFILENAME (PACKFILENAME.STRING 'BODY HOST/DIR
|
||||
'HOST
|
||||
'DSK]
|
||||
(IF (DIRECTORYNAMEP (CONCAT D "/.git/"))
|
||||
THEN D
|
||||
ELSEIF (AND CHECKANCESTORS (FIND-ANCESTOR-DIRECTORY
|
||||
D
|
||||
(FUNCTION (LAMBDA (A)
|
||||
(DIRECTORYNAMEP (CONCAT A
|
||||
".git/"]
|
||||
(IF (AND HOST/DIR (LET [(D (SLASHIT (TRUEFILENAME HOST/DIR]
|
||||
(CL:WHEN [OR (DIRECTORYNAMEP (CONCAT D "/.git/"))
|
||||
(SETQ D (AND CHECKANCESTORS
|
||||
(FIND-ANCESTOR-DIRECTORY D
|
||||
(FUNCTION (LAMBDA (A)
|
||||
(DIRECTORYNAMEP (CONCAT
|
||||
A ".git/"]
|
||||
D)))
|
||||
ELSEIF NOERROR
|
||||
THEN NIL
|
||||
ELSE (ERROR "NOT A GIT CLONE" HOST/DIR])
|
||||
@@ -169,6 +169,10 @@
|
||||
|
||||
(GIT-MAKE-PROJECT
|
||||
[LAMBDA (PROJECTNAME CLONEPATH WORKINGPATH EXCLUSIONS DEFAULTSUBDIRS)
|
||||
(* ; "Edited 25-Oct-2025 16:53 by rmk")
|
||||
(* ; "Edited 22-Oct-2025 12:45 by rmk")
|
||||
(* ; "Edited 20-Oct-2025 18:10 by rmk")
|
||||
(* ; "Edited 14-Oct-2025 11:51 by rmk")
|
||||
(* ; "Edited 1-Oct-2023 19:33 by rmk")
|
||||
(* ; "Edited 30-Mar-2023 09:06 by rmk")
|
||||
(* ; "Edited 5-Feb-2023 12:43 by rmk")
|
||||
@@ -222,19 +226,14 @@
|
||||
(ERROR (CONCAT "Can't find a clone directory for " PROJECTNAME))
|
||||
(PRINTOUT T "Note: Can't find a clone directory for "
|
||||
PROJECTNAME T)))
|
||||
elseif (GIT-CLONEP [SLASHIT (PACKFILENAME 'HOST 'DSK 'DIRECTORY
|
||||
(UNPACKFILENAME.STRING (TRUEFILENAME
|
||||
CLONEPATH)
|
||||
'DIRECTORY
|
||||
'RETURN]
|
||||
T T)
|
||||
elseif (GIT-CLONEP CLONEPATH T T)
|
||||
else (ERROR (CONCAT "Can't find the clone directory " CLONEPATH " for "
|
||||
PROJECTNAME]
|
||||
(CL:WHEN CLONEPATH
|
||||
(LET (GITIGNORE PROJECT WP)
|
||||
(CL:WHEN (SETQ GITIGNORE (INFILEP (PACKFILENAME.STRING 'NAME ".gitignore" 'BODY
|
||||
CLONEPATH)))
|
||||
(SETQ GITIGNORE (CL:WITH-OPEN-FILE (STREAM GITIGNORE)
|
||||
(SETQ GITIGNORE (CL:WITH-OPEN-FILE (STREAM GITIGNORE :EXTERNAL-FORMAT :UTF-8)
|
||||
(bind L until (EOFP STREAM)
|
||||
while (SETQ L (CL:READ-LINE STREAM :EOF-ERROR-P NIL
|
||||
:EOF-VALUE NIL))
|
||||
@@ -270,9 +269,10 @@
|
||||
then (UNSLASHIT WP)
|
||||
elseif WORKINGPATH
|
||||
then (ERROR (CONCAT "Can't find the working directory "
|
||||
(AND (EQ WORKINGPATH T)
|
||||
"")
|
||||
" for " PROJECTNAME]
|
||||
(CL:IF WORKINGPATH
|
||||
(CONCAT WORKINGPATH " ")
|
||||
"")
|
||||
"for " PROJECTNAME]
|
||||
(SETQ PROJECT (create GIT-PROJECT
|
||||
PROJECTNAME _ PROJECTNAME
|
||||
GITHOST _ (PACK* "{" (PSEUDOHOST PROJECTNAME CLONEPATH)
|
||||
@@ -828,10 +828,15 @@
|
||||
(DEFINEQ
|
||||
|
||||
(GFILE4MFILE
|
||||
[LAMBDA (MFILE PROJECT) (* ; "Edited 7-May-2022 23:19 by rmk")
|
||||
[LAMBDA (MFILE PROJECT) (* ; "Edited 25-Oct-2025 09:18 by rmk")
|
||||
(* ; "Edited 7-May-2022 23:19 by rmk")
|
||||
(* ; "Edited 4-Feb-2022 18:04 by rmk")
|
||||
(SLASHIT (PACKFILENAME 'HOST (FETCH GITHOST OF PROJECT)
|
||||
'VERSION NIL 'BODY MFILE)
|
||||
|
||||
(* ;; "Switch to UNIX: no versions")
|
||||
|
||||
(SLASHIT (PACKFILENAME 'HOST 'UNIX 'BODY (TRUEFILENAME (PACKFILENAME 'HOST (FETCH GITHOST
|
||||
OF PROJECT)
|
||||
'VERSION NIL 'BODY MFILE)))
|
||||
T])
|
||||
|
||||
(MFILE4GFILE
|
||||
@@ -1080,6 +1085,8 @@
|
||||
(GIT-BRANCH-DIFF
|
||||
[LAMBDA (BRANCH1 BRANCH2 PROJECT)
|
||||
|
||||
(* ;; "Edited 21-Oct-2025 18:31 by rmk")
|
||||
|
||||
(* ;; "Edited 10-Jun-2024 16:43 by mth")
|
||||
|
||||
(* ;; "Edited 2-May-2024 11:28 by mth")
|
||||
@@ -1145,7 +1152,7 @@
|
||||
(GO RETRY))
|
||||
(ERROR "Incomplete branch differences" (LIST BRANCH1 BRANCH2)))
|
||||
else (for L in ELINES do (PRINTOUT T L T))))
|
||||
(RETURN (SORT (for (L FN) in RLINES
|
||||
(RETURN (SORT (for L FN in RLINES
|
||||
collect (SELCHARQ (CHCON1 L)
|
||||
(A (CL:IF (EQ (CHARCODE TAB)
|
||||
(NTHCHARCODE L 2))
|
||||
@@ -1156,13 +1163,14 @@
|
||||
(LIST 'DELETED (SETQ FN (SUBSTRING L 3)))
|
||||
(ERROR "DELETED NOT RECOGNIZED" L)))
|
||||
(M (CL:IF (SETQ POS (STRPOS " " L))
|
||||
[LIST 'CHANGED (SETQ FN (SUBSTRING L (ADD1 POS]
|
||||
[LIST 'MODIFIED (SETQ FN (SUBSTRING L (ADD1 POS]
|
||||
(ERROR "CHANGED NOT RECOGNIZED" L)))
|
||||
(C (if (AND (EQ (CHARCODE TAB)
|
||||
(C (* ;
|
||||
"We coerce a copy to an ADD of the target file")
|
||||
(if (AND (EQ (CHARCODE TAB)
|
||||
(NTHCHARCODE L 5))
|
||||
(SETQ POS (STRPOS " " L 7)))
|
||||
then (LIST 'COPIED (SETQ FN (SUBSTRING L 6
|
||||
(SUB1 POS)))
|
||||
then (LIST 'ADDED (SETQ FN (SUBSTRING L (ADD1 POS)))
|
||||
(OR (FIXP (SUBATOM L 2 4))
|
||||
(HELP "C without a number" L)))
|
||||
else (HELP "COPY NOT RECOGNIZED" L)))
|
||||
@@ -1431,43 +1439,31 @@
|
||||
WHENSELECTEDFN _ (FUNCTION GIT-BRANCH-WHENSELECTEDFN)))])
|
||||
|
||||
(GIT-BRANCH-WHENSELECTEDFN
|
||||
[LAMBDA (ITEM MENU BUTTON) (* ; "Edited 21-Mar-2025 19:07 by rmk")
|
||||
[LAMBDA (ITEM MENU BUTTON) (* ; "Edited 2-Oct-2025 23:08 by rmk")
|
||||
(* ; "Edited 30-Sep-2025 14:58 by rmk")
|
||||
(* ; "Edited 21-Mar-2025 19:07 by rmk")
|
||||
(* ; "Edited 11-May-2024 11:05 by rmk")
|
||||
(* ; "Edited 1-May-2024 18:17 by rmk")
|
||||
(* ; "CAR is git key, 4th is project")
|
||||
|
||||
(* ;; "This executes the comparison in the current TTY window, either by stuffing the command there or by evaluating there. There probably should be a check to make sure that the TTY is in fact an executive--if not, maybe this should be a no-op. Better than getting the comparison form in the middle of anther SEDIT or TEDIT.")
|
||||
|
||||
(* ;; "This could also execute in the mouse process, where the menu is clicked. But in that case a terminal window pops up with the header lines of the compare, and that seems a nuisance.")
|
||||
|
||||
(LET [(PR (CAR (LAST ITEM]
|
||||
(if [AND NIL (PROGN (GETMOUSESTATE)
|
||||
(EQ 'MIDDLE (DECODEBUTTONS]
|
||||
then (LET [(POS (ADD1 (STRPOS "#" (CAR ITEM]
|
||||
(ShellBrowse (fetch PRURL of PR)))
|
||||
elseif (PROGN T)
|
||||
then
|
||||
(* ;; "PROGN because DWIM is screwed up")
|
||||
|
||||
(* ;; "The COPYINSERT causes the compare to run in the TTY process, by stuffing the characters in the input line. Somehow it executes even if the parens are not there, but that looks funny. But it also works if I stuff the parens on both sides.")
|
||||
|
||||
(if (EQ BUTTON 'MIDDLE)
|
||||
then (ShellOpen (CONCAT "https://github.com/Interlisp/medley/pull/"
|
||||
(fetch (PULLREQUEST PRNUMBER) of PR)))
|
||||
else (BKSYSBUF '%()
|
||||
[COPYINSERT `(GIT-PR-COMPARE ,(CADR ITEM)
|
||||
',(fetch PRPROJECT of PR]
|
||||
(BKSYSBUF '%)))
|
||||
(if (EQ BUTTON 'MIDDLE)
|
||||
then (ShellOpen (CONCAT "https://github.com/Interlisp/medley/pull/" (fetch (PULLREQUEST
|
||||
PRNUMBER)
|
||||
of PR)))
|
||||
else
|
||||
(* ;; "This puts the print out after the next event number in the TTY window, unfortunately. We go to the default font so we don't get TTYIN's input bold for this.")
|
||||
(* ;; "This prints notices in its own TTY window")
|
||||
|
||||
(PROCESS.EVAL (TTY.PROCESS)
|
||||
`(RESETLST
|
||||
[RESETSAVE (DSPFONT DEFAULTFONT T)
|
||||
'(PROGN (DSPFONT OLDVALUE T])])
|
||||
(ADD.PROCESS `[GIT-PR-COMPARE ,(CADR ITEM)
|
||||
',(fetch PRPROJECT of PR]
|
||||
'NAME
|
||||
'prc])
|
||||
|
||||
(GIT-PULL-REQUESTS
|
||||
[LAMBDA (INCLUDEDRAFTS PROJECT) (* ; "Edited 9-May-2025 11:39 by rmk")
|
||||
[LAMBDA (INCLUDEDRAFTS PROJECT) (* ; "Edited 20-Oct-2025 10:22 by rmk")
|
||||
(* ; "Edited 9-May-2025 11:39 by rmk")
|
||||
(* ; "Edited 20-May-2024 22:12 by rmk")
|
||||
(* ; "Edited 13-May-2024 18:59 by rmk")
|
||||
(* ; "Edited 11-May-2024 10:51 by rmk")
|
||||
@@ -1495,9 +1491,11 @@
|
||||
PRDESCRIPTION _ (JSON-GET JSOBJ 'title)
|
||||
PRSTATUS _ (CL:IF DRAFT
|
||||
'D
|
||||
(CL:IF (STREQUAL "REVIEW¬REQUIRED"
|
||||
(JSON-GET JSOBJ 'reviewDecision))
|
||||
" "
|
||||
(SELECTQ (MKATOM (JSON-GET JSOBJ 'reviewDecision))
|
||||
(CHANGES¬REQUESTED
|
||||
'C)
|
||||
(REVIEW¬REQUIRED
|
||||
" ")
|
||||
'A))
|
||||
PRPROJECT _ PROJECT
|
||||
PRURL _ (JSON-GET JSOBJ 'url)
|
||||
@@ -1733,6 +1731,8 @@
|
||||
[LAMBDA (BRANCH1 BRANCH2 DIR1 DIR2 PROJECT)
|
||||
(DECLARE (USEDFREE FROMGITN))
|
||||
|
||||
(* ;; "Edited 21-Oct-2025 18:30 by rmk")
|
||||
|
||||
(* ;; "Edited 23-Sep-2025 21:42 by rmk")
|
||||
|
||||
(* ;; "Edited 22-Sep-2025 12:48 by rmk")
|
||||
@@ -1748,101 +1748,106 @@
|
||||
(SETQ PROJECT (GIT-GET-PROJECT PROJECT))
|
||||
(SETQ BRANCH1 (GIT-BRANCH-EXISTS? BRANCH1 NIL PROJECT))
|
||||
(SETQ BRANCH2 (GIT-BRANCH-EXISTS? BRANCH2 NIL PROJECT))
|
||||
(LET (MAPPINGS FROMGIT FROMGITDIR PRNAME (DIFFS (GIT-BRANCH-DIFF BRANCH1 BRANCH2 PROJECT)))
|
||||
(CL:WHEN DIFFS
|
||||
(SETQ FROMGIT (PACK* "{FROMGIT" (add FROMGITN 1)
|
||||
"}"))
|
||||
(LET
|
||||
(MAPPINGS FROMGIT FROMGITDIR PRNAME (DIFFS (GIT-BRANCH-DIFF BRANCH1 BRANCH2 PROJECT)))
|
||||
(CL:WHEN DIFFS
|
||||
(SETQ FROMGIT (PACK* "{FROMGIT" (add FROMGITN 1)
|
||||
"}"))
|
||||
|
||||
(* ;; "If both origin/, strip it out of subdirectories")
|
||||
(* ;; "If both origin/, strip it out of subdirectories")
|
||||
|
||||
(SETQ PRNAME (MTOUSTRING (CL:IF (AND (STRPOS "origin/" BRANCH1 NIL T)
|
||||
(STRPOS "origin/" BRANCH2 NIL T))
|
||||
(SUBSTRING BRANCH2 (CONSTANT (NCHARS "origin/ ")))
|
||||
BRANCH2)))
|
||||
(PSEUDOHOST FROMGIT (CONCAT "{DSK}<tmp>" (fetch PROJECTNAME of PROJECT)
|
||||
"-PR--" PRNAME "--" (DATE)
|
||||
">"))
|
||||
(CL:UNLESS DIR1
|
||||
(SETQ DIR1 (CONCAT FROMGIT "<master>")))
|
||||
(CL:UNLESS DIR2
|
||||
(SETQ DIR2 (CONCAT FROMGIT "<pr>")))
|
||||
(for D in DIFFS
|
||||
do
|
||||
(SELECTQ (CAR D)
|
||||
(ADDED (* ;
|
||||
(SETQ PRNAME (CL:IF (AND (STRPOS "origin/" BRANCH1 NIL T)
|
||||
(STRPOS "origin/" BRANCH2 NIL T))
|
||||
(SUBSTRING BRANCH2 (CONSTANT (NCHARS "origin/ ")))
|
||||
BRANCH2))
|
||||
(PSEUDOHOST FROMGIT (CONCAT "{DSK}<tmp>" (fetch PROJECTNAME of PROJECT)
|
||||
"-PR--" PRNAME "--" (DATE)
|
||||
">"))
|
||||
(CL:UNLESS DIR1
|
||||
(SETQ DIR1 (CONCAT FROMGIT "<master>")))
|
||||
(CL:UNLESS DIR2
|
||||
(SETQ DIR2 (CONCAT FROMGIT "<pr>")))
|
||||
(for D in DIFFS
|
||||
do (SELECTQ (CAR D)
|
||||
(ADDED (* ;
|
||||
"Shouldn't exist in BRANCH2, should exist in BRANCH1, but maybe ADDED and DELETED are mixed up?")
|
||||
(SETQ D (CADR D))
|
||||
(OR (GIT-GET-FILE BRANCH1 D (CONCAT DIR1 D)
|
||||
T PROJECT)
|
||||
(GIT-GET-FILE BRANCH2 D (CONCAT DIR2 D)
|
||||
T PROJECT)))
|
||||
(DELETED
|
||||
(* ;; "Shouldn't exist in BRANCH1, should exist in BRANCH2. But maybe git is just confused in marking a file that exists in the wrong place as a delete instead of an add, or maybe it may think of a file that doesn't exist at all as having been deleted. Try for both, but don't cause an error.")
|
||||
(SETQ D (CADR D))
|
||||
(OR (GIT-GET-FILE BRANCH1 D (CONCAT DIR1 D)
|
||||
T PROJECT)
|
||||
(GIT-GET-FILE BRANCH2 D (CONCAT DIR2 D)
|
||||
T PROJECT)))
|
||||
(DELETED
|
||||
(* ;; "Shouldn't exist in BRANCH1, should exist in BRANCH2. But maybe git is just confused in marking a file that exists in the wrong place as a delete instead of an add, or maybe it may think of a file that doesn't exist at all as having been deleted. Try for both, but don't cause an error.")
|
||||
|
||||
(SETQ D (CADR D))
|
||||
(OR (GIT-GET-FILE BRANCH2 D (CONCAT DIR2 D)
|
||||
T PROJECT)
|
||||
(GIT-GET-FILE BRANCH1 D (CONCAT DIR1 D)
|
||||
T PROJECT)))
|
||||
(CHANGED (* ; "Should exist in both branches")
|
||||
(SETQ D (CADR D))
|
||||
(OR (GIT-GET-FILE BRANCH2 D (CONCAT DIR2 D)
|
||||
T PROJECT)
|
||||
(GIT-GET-FILE BRANCH1 D (CONCAT DIR1 D)
|
||||
T PROJECT)))
|
||||
(MODIFIED (* ; "Should exist in both branches")
|
||||
(SETQ D (CADR D))
|
||||
(GIT-GET-FILE BRANCH1 D (CONCAT DIR1 D)
|
||||
T PROJECT)
|
||||
(GIT-GET-FILE BRANCH2 D (CONCAT DIR2 D)
|
||||
T PROJECT))
|
||||
((RENAMED COPIED)
|
||||
((RENAMED COPIED)
|
||||
|
||||
(* ;; "These entries are from-to filename pairs. If (CADDR) is 100, only need to fetch one, because it presumably has disappeared in BRANCH2 and reappeared in BRANCH1. MAPPINGS is returned so the connection can be reestablished higher up. ")
|
||||
|
||||
|
||||
(* ;; "If renamed and then changed, for now treat as unrelated adds and deletes: put both files in the fromgit directory. Perhaps the mapping should still figure out how to relate them.")
|
||||
|
||||
(* ;; "If renamed and then changed, for now treat as unrelated adds and deletes: put both files in the fromgit directory. Perhaps the mapping should still figure out how to relate them.")
|
||||
|
||||
(* ;; "For copied files, presumably 2 files are exactly the same. But we hope we can show them on the same line, by virtue of the mapping.")
|
||||
(* ;; "For copied files, presumably 2 files are exactly the same. But we hope we can show them on the same line, by virtue of the mapping.")
|
||||
|
||||
[LET ((GFILE (CDR D))
|
||||
F1 F2)
|
||||
(* ;;
|
||||
"GIT %"copy%" to a target file is coerced to ADDED of that target; the source is ignore")
|
||||
|
||||
(* ;; "GFILE is a triple (F2 F1 N )")
|
||||
(LET ((GFILE (CDR D))
|
||||
F1 F2)
|
||||
|
||||
(* ;; "F1 is the file in branch 1, if any, F2 is in branch 2")
|
||||
(* ;; "GFILE is a triple (F2 F1 N )")
|
||||
|
||||
(SETQ F1 (GIT-GET-FILE BRANCH1 (CADR GFILE)
|
||||
(CONCAT DIR1 (CADR GFILE))
|
||||
T PROJECT))
|
||||
(SETQ F2 (GIT-GET-FILE BRANCH2 (CADR GFILE)
|
||||
(CONCAT DIR2 (CADR GFILE))
|
||||
T PROJECT))
|
||||
(* ;; "F1 is the file in branch 1, if any, F2 is in branch 2")
|
||||
|
||||
(* ;; "Let the directories figure it out")
|
||||
(SETQ F1 (GIT-GET-FILE BRANCH1 (CADR GFILE)
|
||||
(CONCAT DIR1 (CADR GFILE))
|
||||
T PROJECT))
|
||||
(SETQ F2 (GIT-GET-FILE BRANCH2 (CADR GFILE)
|
||||
(CONCAT DIR2 (CADR GFILE))
|
||||
T PROJECT))
|
||||
|
||||
(AND NIL (if (EQ (CADDR GFILE)
|
||||
100)
|
||||
then
|
||||
(* ;; "Let the directories figure it out")
|
||||
|
||||
(AND NIL (if (EQ (CADDR GFILE)
|
||||
100)
|
||||
then
|
||||
|
||||
(* ;; "A little tricky to figure out what corresponds to the real file in the mapping, which directory it belongs to. Maybe the first one should always be one that exists, the second may just be a useful name. But we have to know whether to match against INFO1 or INFO2")
|
||||
|
||||
(HELP GFILE 100)
|
||||
(push MAPPINGS
|
||||
(LIST (LIST)
|
||||
(FULLNAME F1)
|
||||
(SLASHIT (U-CASE (CONCAT DIR2
|
||||
(CAR GFILE)))
|
||||
T)
|
||||
(NTHCHAR (CAR D)
|
||||
1)
|
||||
100))
|
||||
else
|
||||
(* ;;
|
||||
(HELP GFILE 100)
|
||||
(push MAPPINGS
|
||||
(LIST (LIST)
|
||||
(FULLNAME F1)
|
||||
(SLASHIT (U-CASE (CONCAT DIR2 (CAR GFILE))
|
||||
)
|
||||
T)
|
||||
(NTHCHAR (CAR D)
|
||||
1)
|
||||
100))
|
||||
else
|
||||
(* ;;
|
||||
"If not a perfect match, then the directory should figure it out")
|
||||
|
||||
(GIT-GET-FILE BRANCH2 (CAR GFILE)
|
||||
(CONCAT DIR2 (CAR GFILE))
|
||||
T PROJECT])
|
||||
(HELP "UNKNOWN GIT-DIFF TAG" D)))
|
||||
(LIST DIR1 DIR2 MAPPINGS))])
|
||||
(GIT-GET-FILE BRANCH2 (CAR GFILE)
|
||||
(CONCAT DIR2 (CAR GFILE))
|
||||
T PROJECT)))
|
||||
F2))
|
||||
(HELP "UNKNOWN GIT-DIFF TAG" D)))
|
||||
(LIST DIR1 DIR2 MAPPINGS))])
|
||||
|
||||
(GIT-BRANCHES-COMPARE-DIRECTORIES
|
||||
[LAMBDA (BRANCH1 BRANCH2 LOCAL PROJECT) (* ; "Edited 12-Jun-2024 22:52 by mth")
|
||||
[LAMBDA (BRANCH1 BRANCH2 LOCAL PROJECT) (* ; "Edited 2-Oct-2025 23:12 by rmk")
|
||||
(* ; "Edited 12-Jun-2024 22:52 by mth")
|
||||
(* ; "Edited 10-Jun-2024 18:42 by mth")
|
||||
(* ; "Edited 1-May-2024 14:58 by rmk")
|
||||
(* ; "Edited 26-Sep-2023 22:40 by rmk")
|
||||
@@ -1860,8 +1865,10 @@
|
||||
(SHORT2 (GIT-SHORT-BRANCH-NAME BRANCH2)))
|
||||
(PRINTOUT T "Comparing all " (L-CASE (fetch PROJECTNAME of PROJECT)
|
||||
T)
|
||||
" subdirectories of " SHORT1 " and " SHORT2 T)
|
||||
(PRINTOUT T "Fetching differences" T)
|
||||
" subdirectories of" T)
|
||||
(PRINTOUT T 5 .FONT BOLDFONT SHORT1 .FONT DEFAULTFONT " and " .FONT BOLDFONT SHORT2 .FONT
|
||||
DEFAULTFONT T)
|
||||
(PRINTOUT T "Fetching differences")
|
||||
(SETQ DIRS (GIT-GET-DIFFERENT-FILES BRANCH1 BRANCH2 NIL NIL PROJECT))
|
||||
(SETQ MAPPINGS (CADDR DIRS))
|
||||
(if DIRS
|
||||
@@ -1874,10 +1881,10 @@
|
||||
'(> < ~= -* *-)
|
||||
'(*.* *>*.* .* *>.*)
|
||||
(GIT-GET-PROJECT PROJECT 'EXCLUSIONS)
|
||||
NIL NIL NIL NIL (LIST (PACKFILENAME 'HOST NIL 'BODY
|
||||
(CAR DIRS))
|
||||
(PACKFILENAME 'HOST NIL 'BODY
|
||||
(CADR DIRS]
|
||||
NIL NIL NIL NIL (LIST (FILENAMEFIELD (CAR DIRS)
|
||||
'DIRECTORY)
|
||||
(FILENAMEFIELD (CADR DIRS)
|
||||
'DIRECTORY]
|
||||
|
||||
(* ;; "We know that both sides come from Unix/unversioned, even if they have been copied into versioned FROMGIT, so we make a pass to remove the misleading versions.")
|
||||
|
||||
@@ -1942,100 +1949,103 @@
|
||||
else '(0 differences))
|
||||
else '(0 differences])
|
||||
|
||||
(GIT-WORKING-COMPARE-DIRECTORIES
|
||||
(GIT-WORKING-COMPARE-DIRECTORIES
|
||||
[LAMBDA (SUBDIRS SELECT EXCLUDEDFILES FIXDIRECTORYDATES UPDATE PROJECT)
|
||||
|
||||
(* ;; "Edited 29-Apr-2025 15:14 by rmk")
|
||||
(* ;; "Edited 25-Oct-2025 23:32 by rmk")
|
||||
|
||||
(* ;; "Edited 12-Jun-2024 22:52 by mth")
|
||||
(* ;; "Edited 29-Apr-2025 15:14 by rmk")
|
||||
|
||||
(* ;; "Edited 26-Sep-2023 22:41 by rmk")
|
||||
(* ;; "Edited 12-Jun-2024 22:52 by mth")
|
||||
|
||||
(* ;; "Edited 17-Jun-2023 22:54 by rmk")
|
||||
(* ;; "Edited 26-Sep-2023 22:41 by rmk")
|
||||
|
||||
(* ;; "Edited 10-Jun-2023 21:32 by rmk")
|
||||
(* ;; "Edited 17-Jun-2023 22:54 by rmk")
|
||||
|
||||
(* ;; "Edited 20-Jul-2022 21:18 by rmk")
|
||||
(* ;; "Edited 10-Jun-2023 21:32 by rmk")
|
||||
|
||||
(* ;; "Edited 25-Jun-2022 21:37 by rmk")
|
||||
(* ;; "Edited 20-Jul-2022 21:18 by rmk")
|
||||
|
||||
(* ;; "Edited 17-May-2022 17:39 by rmk")
|
||||
(* ;; "Edited 25-Jun-2022 21:37 by rmk")
|
||||
|
||||
(* ;; "Edited 10-May-2022 10:41 by rmk")
|
||||
(* ;; "Edited 17-May-2022 17:39 by rmk")
|
||||
|
||||
(* ;; "Edited 10-May-2022 10:41 by rmk")
|
||||
|
||||
(* ;;
|
||||
"Edited 29-Mar-2022 13:58 by rmk: working medley subdirectories with the current local git branch.")
|
||||
"Edited 29-Mar-2022 13:58 by rmk: working medley subdirectories with the current local git branch.")
|
||||
|
||||
(SETQ PROJECT (GIT-GET-PROJECT PROJECT))
|
||||
(CL:WHEN UPDATE (GIT-REMOTE-UPDATE NIL PROJECT)) (* ; "Doesn't matter if we are looking only at local files in the current branch. We aren't fetching or checking out.")
|
||||
(CL:UNLESS (AND (fetch GITHOST of PROJECT)
|
||||
(fetch WHOST of PROJECT))
|
||||
(ERROR (fetch PROJECTNAME of PROJECT)
|
||||
(SETQ PROJECT (GIT-GET-PROJECT PROJECT))
|
||||
(CL:WHEN UPDATE (GIT-REMOTE-UPDATE NIL PROJECT)) (* ; "Doesn't matter if we are looking only at local files in the current branch. We aren't fetching or checking out.")
|
||||
(CL:UNLESS (AND (fetch GITHOST of PROJECT)
|
||||
(fetch WHOST of PROJECT))
|
||||
(ERROR (fetch PROJECTNAME of PROJECT)
|
||||
" does not have both git and working directories"))
|
||||
(CL:WHEN (AND (LISTP SUBDIRS)
|
||||
(NULL (CDR SUBDIRS)))
|
||||
(SETQ SUBDIRS (CAR SUBDIRS)))
|
||||
(CL:WHEN (AND (LISTP SUBDIRS)
|
||||
(NULL (CDR SUBDIRS)))
|
||||
(SETQ SUBDIRS (CAR SUBDIRS)))
|
||||
(CL:UNLESS SUBDIRS
|
||||
(SETQ SUBDIRS (OR (fetch DEFAULTSUBDIRS of PROJECT)
|
||||
(SETQ SUBDIRS (OR (fetch DEFAULTSUBDIRS of PROJECT)
|
||||
'ALL)))
|
||||
(SETQ SUBDIRS (L-CASE SUBDIRS))
|
||||
(LET ((SUBDIRSTRING (if (EQ SUBDIRS 'all)
|
||||
then (SETQ SUBDIRS (ALLSUBDIRS PROJECT))
|
||||
(SETQ SUBDIRS (L-CASE SUBDIRS))
|
||||
(LET ((SUBDIRSTRING (if (EQ SUBDIRS 'all)
|
||||
then (SETQ SUBDIRS (ALLSUBDIRS PROJECT))
|
||||
"ALL subdirectories"
|
||||
else SUBDIRS)))
|
||||
(for SUBDIR TITLE CDVAL (WPROJ _ (CONCAT "Working " (L-CASE (fetch PROJECTNAME of PROJECT)
|
||||
else SUBDIRS)))
|
||||
(for SUBDIR TITLE CDVAL (WPROJ _ (CONCAT "Working " (L-CASE (fetch PROJECTNAME of PROJECT)
|
||||
T)))
|
||||
(NENTRIES _ 0)
|
||||
(BRANCH2 _ (GIT-WHICH-BRANCH PROJECT T))
|
||||
first (PRINTOUT T "Comparing " SUBDIRSTRING 6 " of " WPROJ " and Git " BRANCH2 T)
|
||||
(BKSYSBUF " ") inside SUBDIRS
|
||||
collect (TERPRI T)
|
||||
(SETQ CDVAL (COMPAREDIRECTORIES (MYMEDLEYSUBDIR SUBDIR T PROJECT)
|
||||
(GITSUBDIR SUBDIR T PROJECT)
|
||||
(OR SELECT '(> < ~= -* *-))
|
||||
(BRANCH2 _ (GIT-WHICH-BRANCH PROJECT T))
|
||||
first (PRINTOUT T "Comparing " SUBDIRSTRING 6 " of " WPROJ " and Git " BRANCH2 T)
|
||||
(BKSYSBUF " ") inside SUBDIRS
|
||||
collect (TERPRI T)
|
||||
(SETQ CDVAL (COMPAREDIRECTORIES (MYMEDLEYSUBDIR SUBDIR T PROJECT)
|
||||
(GITSUBDIR SUBDIR T PROJECT)
|
||||
(OR SELECT '(> < ~= -* *-))
|
||||
'(*.* *>*.* .* *>.*)
|
||||
(for E DPOS in (GIT-GET-PROJECT PROJECT 'EXCLUSIONS)
|
||||
collect (SETQ DPOS (STRPOS SUBDIR (FILENAMEFIELD E
|
||||
(for E DPOS in (GIT-GET-PROJECT PROJECT 'EXCLUSIONS)
|
||||
collect (SETQ DPOS (STRPOS SUBDIR (FILENAMEFIELD E
|
||||
'DIRECTORY)
|
||||
1 NIL T T FILEDIRCASEARRAY))
|
||||
(CL:IF DPOS
|
||||
(SUBSTRING E (ADD1 DPOS))
|
||||
(SUBSTRING E (ADD1 DPOS))
|
||||
E))
|
||||
NIL NIL NIL FIXDIRECTORYDATES))
|
||||
[for CDE in (fetch CDENTRIES of CDVAL)
|
||||
do (CL:WHEN (fetch INFO1 of CDE)
|
||||
(change (fetch (CDINFO FULLNAME) of (fetch INFO1 of CDE))
|
||||
(UNSLASHIT DATUM T)))
|
||||
(CL:WHEN (fetch INFO2 of CDE)
|
||||
(change (fetch (CDINFO FULLNAME) of (fetch INFO2 of CDE))
|
||||
(SLASHIT DATUM T)))]
|
||||
[for CDE in (fetch CDENTRIES of CDVAL)
|
||||
do (CL:WHEN (fetch INFO1 of CDE)
|
||||
(change (fetch (CDINFO FULLNAME) of (fetch INFO1 of CDE))
|
||||
(UNSLASHIT DATUM T)))
|
||||
(CL:WHEN (fetch INFO2 of CDE)
|
||||
(change (fetch (CDINFO FULLNAME) of (fetch INFO2 of CDE))
|
||||
(SLASHIT DATUM T)))]
|
||||
CDVAL
|
||||
finally
|
||||
finally
|
||||
|
||||
(* ;; "Set up the browsers after everything has been done, otherwise if the user doesn't pay attention it might hang waiting for a region.")
|
||||
(* ;; "Set up the browsers after everything has been done, otherwise if the user doesn't pay attention it might hang waiting for a region.")
|
||||
|
||||
(CL:WHEN (AND (CDR $$VAL)
|
||||
(CL:WHEN (AND (CDR $$VAL)
|
||||
GIT-MERGE-COMPARES)
|
||||
(SETQ $$VAL (CDMERGE $$VAL))
|
||||
[SETQ SUBDIRS (CONCATLIST (for SUBDIR in SUBDIRS collect (CONCAT SUBDIR " "])
|
||||
[for CDVAL TITLE in $$VAL as SUBDIR inside SUBDIRS
|
||||
do (SETQ TITLE (CONCAT WPROJ " vs. " BRANCH2 " " SUBDIR " "
|
||||
(LENGTH (fetch (CDVALUE CDENTRIES) of CDVAL))
|
||||
(SETQ $$VAL (CDMERGE $$VAL))
|
||||
[SETQ SUBDIRS (CONCATLIST (for SUBDIR in SUBDIRS collect (CONCAT SUBDIR " "])
|
||||
[for CDVAL TITLE in $$VAL as SUBDIR inside SUBDIRS
|
||||
do (SETQ TITLE (CONCAT WPROJ " vs. " BRANCH2 " " SUBDIR " "
|
||||
(LENGTH (fetch (CDVALUE CDENTRIES) of CDVAL))
|
||||
" files"))
|
||||
[CDBROWSER CDVAL TITLE `(,WPROJ ,BRANCH2)
|
||||
[CDBROWSER CDVAL TITLE `(,WPROJ ,BRANCH2)
|
||||
`(BRANCH1 ,WPROJ BRANCH2 ,BRANCH2 SUBDIR ,SUBDIR LABELFN
|
||||
GIT-CD-LABELFN PROJECT ,PROJECT)
|
||||
GIT-CDBROWSER-SEPARATE-DIRECTIONS
|
||||
`(Compare See "" Copy% <- (|Delete ALL <-| GIT-CD-MENUFN)
|
||||
,@(CL:UNLESS (GIT-MAINBRANCH? BRANCH2 PROJECT T)
|
||||
'("" Copy% -> (Delete% -> GIT-CD-MENUFN)))]
|
||||
(CONS (CONCAT SUBDIR "/")
|
||||
(for CDENTRY in (fetch CDENTRIES of CDVAL)
|
||||
collect (fetch MATCHNAME of CDENTRY)))
|
||||
(add NENTRIES (LENGTH (fetch (CDVALUE CDENTRIES) of CDVAL]
|
||||
(SETQ LAST-WMEDLEY-CDVALUES $$VAL)
|
||||
(TERPRI T)
|
||||
(RETURN (LIST NENTRIES (CL:IF (EQ NENTRIES 1)
|
||||
,@(CL:UNLESS (GIT-MAINBRANCH? BRANCH2 PROJECT T)
|
||||
'("" (Copy% -> GIT-CD-MENUFN NIL T)
|
||||
(Delete% -> GIT-CD-MENUFN)))]
|
||||
(CONS (CONCAT SUBDIR "/")
|
||||
(for CDENTRY in (fetch CDENTRIES of CDVAL)
|
||||
collect (fetch MATCHNAME of CDENTRY)))
|
||||
(add NENTRIES (LENGTH (fetch (CDVALUE CDENTRIES) of CDVAL]
|
||||
(SETQ LAST-WMEDLEY-CDVALUES $$VAL)
|
||||
(TERPRI T)
|
||||
(RETURN (LIST NENTRIES (CL:IF (EQ NENTRIES 1)
|
||||
'difference
|
||||
'differences)])
|
||||
|
||||
@@ -2203,7 +2213,8 @@
|
||||
(OR LABEL2 FILE2])
|
||||
|
||||
(GIT-CD-MENUFN
|
||||
[LAMBDA (TBITEM MENUITEM CDBROWSER KEY) (* ; "Edited 21-Sep-2022 21:34 by rmk")
|
||||
[LAMBDA (TBITEM MENUITEM CDBROWSER KEY) (* ; "Edited 25-Oct-2025 23:44 by rmk")
|
||||
(* ; "Edited 21-Sep-2022 21:34 by rmk")
|
||||
(* ; "Edited 22-May-2022 19:13 by rmk")
|
||||
(* ; "Edited 8-May-2022 09:26 by rmk")
|
||||
(* ; "Edited 10-Dec-2021 08:52 by rmk")
|
||||
@@ -2239,6 +2250,7 @@
|
||||
(GIT-DELETE-FILE FILE2 (LISTGET USERDATA 'PROJECT))
|
||||
(MYMEDLEY-DELETE-FILES FILE1 (LISTGET USERDATA 'PROJECT))
|
||||
(TB.DELETE.ITEM CDBROWSER TBITEM)))
|
||||
(Copy% -> (CDBROWSER-COPY CDBROWSER TBITEM 'LEFT (CADDDR MENUITEM)))
|
||||
(SHOULDNT])
|
||||
|
||||
(GIT-WORKING-COMPARE-FILES
|
||||
@@ -2439,33 +2451,33 @@
|
||||
|
||||
(PUTPROPS GITFNS FILETYPE :TCOMPL)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (4193 20772 (GIT-CLONEP 4203 . 5531) (GIT-INIT 5533 . 6163) (GIT-MAKE-PROJECT 6165 .
|
||||
13830) (GIT-GET-PROJECT 13832 . 15757) (GIT-PUT-PROJECT-FIELD 15759 . 17400) (GIT-PROJECT-PATH 17402
|
||||
. 18446) (FIND-ANCESTOR-DIRECTORY 18448 . 18797) (GIT-FIND-CLONE 18799 . 19880) (GIT-MAINBRANCH 19882
|
||||
. 20277) (GIT-MAINBRANCH? 20279 . 20770)) (26235 31164 (PRC-COMMAND 26245 . 31162)) (31220 34008 (
|
||||
ALLSUBDIRS 31230 . 32516) (MEDLEYSUBDIRS 32518 . 33211) (GITSUBDIRS 33213 . 34006)) (34009 38799 (
|
||||
TOGIT 34019 . 35425) (FROMGIT 35427 . 36408) (GIT-DELETE-FILE 36410 . 37256) (MYMEDLEY-DELETE-FILES
|
||||
37258 . 38797)) (38800 41803 (MYMEDLEYSUBDIR 38810 . 39266) (GITSUBDIR 39268 . 39711) (STRIPDIR 39713
|
||||
. 40084) (STRIPHOST 40086 . 40326) (STRIPNAME 40328 . 41081) (STRIPWHERE 41083 . 41801)) (41804 43706
|
||||
(GFILE4MFILE 41814 . 42177) (MFILE4GFILE 42179 . 42748) (GIT-REPO-FILENAME 42750 . 43704)) (43755
|
||||
54010 (GIT-COMMIT 43765 . 44591) (GIT-PUSH 44593 . 45353) (GIT-PULL 45355 . 46107) (GIT-APPROVAL 46109
|
||||
. 46458) (GIT-GET-FILE 46460 . 48375) (GIT-FILE-EXISTS? 48377 . 48651) (GIT-REMOTE-UPDATE 48653 .
|
||||
49488) (GIT-REMOTE-ADD 49490 . 49797) (GIT-FILE-DATE 49799 . 50846) (GIT-FILE-HISTORY 50848 . 52782) (
|
||||
GIT-PRINT-FILE-HISTORY 52784 . 53834) (GIT-FETCH 53836 . 54008)) (54040 65378 (GIT-BRANCH-DIFF 54050
|
||||
. 60797) (GIT-COMMIT-DIFFS 60799 . 61690) (GIT-BRANCH-RELATIONS 61692 . 65376)) (65423 84918 (
|
||||
GIT-BRANCH-NUM 65433 . 66006) (GIT-CHECKOUT 66008 . 67294) (GIT-WHICH-BRANCH 67296 . 67703) (
|
||||
GIT-MAKE-BRANCH 67705 . 70284) (GIT-BRANCHES 70286 . 72881) (GIT-BRANCH-EXISTS? 72883 . 73754) (
|
||||
GIT-PICK-BRANCH 73756 . 74246) (GIT-BRANCH-MENU 74248 . 75129) (GIT-BRANCH-WHENSELECTEDFN 75131 .
|
||||
77670) (GIT-PULL-REQUESTS 77672 . 81299) (GIT-SHORT-BRANCH-NAME 81301 . 81592) (GIT-LONG-NAME 81594 .
|
||||
81911) (GIT-PRC-BRANCHES 81913 . 84916)) (84948 88396 (GIT-MY-CURRENT-BRANCH 84958 . 85328) (
|
||||
GIT-MY-BRANCHP 85330 . 85948) (GIT-MY-NEXT-BRANCH 85950 . 86444) (GIT-MY-BRANCHES 86446 . 88394)) (
|
||||
88442 92517 (GIT-ADD-WORKTREE 88452 . 90059) (GIT-REMOVE-WORKTREE 90061 . 90991) (GIT-LIST-WORKTREES
|
||||
90993 . 91797) (WORKTREEDIR 91799 . 92515)) (92565 126387 (GIT-GET-DIFFERENT-FILES 92575 . 99428) (
|
||||
GIT-BRANCHES-COMPARE-DIRECTORIES 99430 . 106661) (GIT-WORKING-COMPARE-DIRECTORIES 106663 . 112370) (
|
||||
GIT-COMPARE-WORKTREE 112372 . 116350) (GITCDOBJBUTTONFN 116352 . 120842) (GIT-CD-LABELFN 120844 .
|
||||
121926) (GIT-CD-MENUFN 121928 . 124368) (GIT-WORKING-COMPARE-FILES 124370 . 124990) (
|
||||
GIT-BRANCHES-COMPARE-FILES 124992 . 126156) (GIT-PR-COMPARE 126158 . 126385)) (126457 134780 (CDGITDIR
|
||||
126467 . 127154) (GIT-COMMAND 127156 . 128714) (GITORIGIN 128716 . 129413) (GIT-INITIALS 129415 .
|
||||
129719) (GIT-COMMAND-TO-FILE 129721 . 133206) (GIT-RESULT-TO-LINES 133208 . 134113) (STRIPLOCAL 134115
|
||||
. 134778)))))
|
||||
(FILEMAP (NIL (4243 21049 (GIT-CLONEP 4253 . 5684) (GIT-INIT 5686 . 6316) (GIT-MAKE-PROJECT 6318 .
|
||||
14107) (GIT-GET-PROJECT 14109 . 16034) (GIT-PUT-PROJECT-FIELD 16036 . 17677) (GIT-PROJECT-PATH 17679
|
||||
. 18723) (FIND-ANCESTOR-DIRECTORY 18725 . 19074) (GIT-FIND-CLONE 19076 . 20157) (GIT-MAINBRANCH 20159
|
||||
. 20554) (GIT-MAINBRANCH? 20556 . 21047)) (26512 31441 (PRC-COMMAND 26522 . 31439)) (31497 34285 (
|
||||
ALLSUBDIRS 31507 . 32793) (MEDLEYSUBDIRS 32795 . 33488) (GITSUBDIRS 33490 . 34283)) (34286 39076 (
|
||||
TOGIT 34296 . 35702) (FROMGIT 35704 . 36685) (GIT-DELETE-FILE 36687 . 37533) (MYMEDLEY-DELETE-FILES
|
||||
37535 . 39074)) (39077 42080 (MYMEDLEYSUBDIR 39087 . 39543) (GITSUBDIR 39545 . 39988) (STRIPDIR 39990
|
||||
. 40361) (STRIPHOST 40363 . 40603) (STRIPNAME 40605 . 41358) (STRIPWHERE 41360 . 42078)) (42081 44316
|
||||
(GFILE4MFILE 42091 . 42787) (MFILE4GFILE 42789 . 43358) (GIT-REPO-FILENAME 43360 . 44314)) (44365
|
||||
54620 (GIT-COMMIT 44375 . 45201) (GIT-PUSH 45203 . 45963) (GIT-PULL 45965 . 46717) (GIT-APPROVAL 46719
|
||||
. 47068) (GIT-GET-FILE 47070 . 48985) (GIT-FILE-EXISTS? 48987 . 49261) (GIT-REMOTE-UPDATE 49263 .
|
||||
50098) (GIT-REMOTE-ADD 50100 . 50407) (GIT-FILE-DATE 50409 . 51456) (GIT-FILE-HISTORY 51458 . 53392) (
|
||||
GIT-PRINT-FILE-HISTORY 53394 . 54444) (GIT-FETCH 54446 . 54618)) (54650 66130 (GIT-BRANCH-DIFF 54660
|
||||
. 61549) (GIT-COMMIT-DIFFS 61551 . 62442) (GIT-BRANCH-RELATIONS 62444 . 66128)) (66175 84914 (
|
||||
GIT-BRANCH-NUM 66185 . 66758) (GIT-CHECKOUT 66760 . 68046) (GIT-WHICH-BRANCH 68048 . 68455) (
|
||||
GIT-MAKE-BRANCH 68457 . 71036) (GIT-BRANCHES 71038 . 73633) (GIT-BRANCH-EXISTS? 73635 . 74506) (
|
||||
GIT-PICK-BRANCH 74508 . 74998) (GIT-BRANCH-MENU 75000 . 75881) (GIT-BRANCH-WHENSELECTEDFN 75883 .
|
||||
77422) (GIT-PULL-REQUESTS 77424 . 81295) (GIT-SHORT-BRANCH-NAME 81297 . 81588) (GIT-LONG-NAME 81590 .
|
||||
81907) (GIT-PRC-BRANCHES 81909 . 84912)) (84944 88392 (GIT-MY-CURRENT-BRANCH 84954 . 85324) (
|
||||
GIT-MY-BRANCHP 85326 . 85944) (GIT-MY-NEXT-BRANCH 85946 . 86440) (GIT-MY-BRANCHES 86442 . 88390)) (
|
||||
88438 92513 (GIT-ADD-WORKTREE 88448 . 90055) (GIT-REMOVE-WORKTREE 90057 . 90987) (GIT-LIST-WORKTREES
|
||||
90989 . 91793) (WORKTREEDIR 91795 . 92511)) (92561 126762 (GIT-GET-DIFFERENT-FILES 92571 . 99479) (
|
||||
GIT-BRANCHES-COMPARE-DIRECTORIES 99481 . 106920) (GIT-WORKING-COMPARE-DIRECTORIES 106922 . 112559) (
|
||||
GIT-COMPARE-WORKTREE 112561 . 116539) (GITCDOBJBUTTONFN 116541 . 121031) (GIT-CD-LABELFN 121033 .
|
||||
122115) (GIT-CD-MENUFN 122117 . 124743) (GIT-WORKING-COMPARE-FILES 124745 . 125365) (
|
||||
GIT-BRANCHES-COMPARE-FILES 125367 . 126531) (GIT-PR-COMPARE 126533 . 126760)) (126832 135155 (CDGITDIR
|
||||
126842 . 127529) (GIT-COMMAND 127531 . 129089) (GITORIGIN 129091 . 129788) (GIT-INITIALS 129790 .
|
||||
130094) (GIT-COMMAND-TO-FILE 130096 . 133581) (GIT-RESULT-TO-LINES 133583 . 134488) (STRIPLOCAL 134490
|
||||
. 135153)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
Binary file not shown.
@@ -1,12 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "20-Apr-2025 12:57:07" {WMEDLEY}<lispusers>REGIONMANAGER.;137 42626
|
||||
(FILECREATED "23-Oct-2025 20:12:38" {WMEDLEY}<lispusers>REGIONMANAGER.;139 43219
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (FNS RM-CLOSEW)
|
||||
:CHANGES-TO (FNS GRAB-TYPED-REGION)
|
||||
|
||||
:PREVIOUS-DATE "25-Nov-2024 17:59:00" {WMEDLEY}<lispusers>REGIONMANAGER.;135)
|
||||
:PREVIOUS-DATE "20-Apr-2025 12:57:07" {WMEDLEY}<lispusers>REGIONMANAGER.;137)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT REGIONMANAGERCOMS)
|
||||
@@ -88,20 +88,28 @@
|
||||
else (push TYPED-REGIONS (CONS TYPE REGIONS])
|
||||
|
||||
(GRAB-TYPED-REGION
|
||||
[LAMBDA (REGION-TYPE MINWIDTH MINHEIGHT) (* ; "Edited 10-Oct-2023 13:41 by rmk")
|
||||
[LAMBDA (REGION-TYPE MINWIDTH MINHEIGHT MARGIN) (* ; "Edited 23-Oct-2025 20:12 by rmk")
|
||||
(* ; "Edited 10-Oct-2023 13:41 by rmk")
|
||||
(* ; "Edited 14-Sep-2023 07:30 by rmk")
|
||||
|
||||
(* ;; "Returns a REGIONTYPE region that satisfies MINWIDTH and MINHEIGHT, if specified")
|
||||
(* ;; "Returns a REGIONTYPE region that is larger than MINWIDTH and MINHEIGHT, if specified, and smaller than those numbers times MARGIN, if specified. MARGIN=1.1 allows a size 10%% bigger than MINWIDTH.")
|
||||
|
||||
(for R in (CDR (ASSOC REGION-TYPE TYPED-REGIONS)) unless (fetch REGION-INUSE of R)
|
||||
when [AND (OR (NULL MINWIDTH)
|
||||
(ILEQ MINWIDTH (fetch WIDTH of R)))
|
||||
(OR (NULL MINHEIGHT)
|
||||
(ILEQ MINHEIGHT (fetch HEIGHT of R] do
|
||||
(CL:UNLESS MINWIDTH (SETQ MINWIDTH 0))
|
||||
(CL:UNLESS MINHEIGHT (SETQ MINHEIGHT 0))
|
||||
(for R MAXWIDTH MAXHEIGHT in (CDR (ASSOC REGION-TYPE TYPED-REGIONS))
|
||||
first (if (AND MARGIN (GREATERP MARGIN 1))
|
||||
then (SETQ MAXWIDTH (FIXR (FTIMES MARGIN MINWIDTH)))
|
||||
(SETQ MAXHEIGHT (FIXR (FTIMES MARGIN MINHEIGHT)))
|
||||
else (SETQ MAXWIDTH MAX.FIXP)
|
||||
(SETQ MAXHEIGHT MAX.FIXP)) unless (fetch REGION-INUSE of R)
|
||||
when (AND (<= MINWIDTH (fetch WIDTH of R)
|
||||
MAXWIDTH)
|
||||
(<= MINHEIGHT (fetch HEIGHT of R)
|
||||
MAXHEIGHT)) do
|
||||
|
||||
(* ;; "We don't mark it as inuse here, leave that gets done by INSTALL-TYPED-REGION when ownership is given to a window. The only downside is that the region could be reallocated before that happens, and 2 window would come up in the same place.")
|
||||
|
||||
(RETURN R])
|
||||
(RETURN R])
|
||||
|
||||
(REGISTER-TYPED-REGION
|
||||
[LAMBDA (REGION REGION-TYPE WINDOW) (* ; "Edited 10-Oct-2023 13:30 by rmk")
|
||||
@@ -752,11 +760,11 @@
|
||||
)
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (1611 6729 (SET-TYPED-REGIONS 1621 . 3796) (GRAB-TYPED-REGION 3798 . 4824) (
|
||||
REGISTER-TYPED-REGION 4826 . 6123) (REGION-TYPE 6125 . 6727)) (6730 15428 (RM-CREATEW 6740 . 8863) (
|
||||
RM-CLOSEW 8865 . 12512) (RM-GETREGION 12514 . 14663) (CLOSE-TYPED-W 14665 . 15426)) (16071 23550 (
|
||||
RELCREATEREGION 16081 . 20704) (RELGETREGION 20706 . 23313) (RELCREATEPOSITION 23315 . 23548)) (23551
|
||||
31126 (\RELCREATEREGION.REF 23561 . 28083) (\RELCREATEREGION.SIZE 28085 . 31124)) (31179 40521 (
|
||||
RM-ATTACHWINDOW 31189 . 40519)) (40522 42256 (CLOSEWITH 40532 . 41059) (CLOSEWITH.DOIT 41061 . 41341)
|
||||
(MOVEWITH 41343 . 41866) (MOVEWITH.DOIT 41868 . 42254)))))
|
||||
(FILEMAP (NIL (1619 7322 (SET-TYPED-REGIONS 1629 . 3804) (GRAB-TYPED-REGION 3806 . 5417) (
|
||||
REGISTER-TYPED-REGION 5419 . 6716) (REGION-TYPE 6718 . 7320)) (7323 16021 (RM-CREATEW 7333 . 9456) (
|
||||
RM-CLOSEW 9458 . 13105) (RM-GETREGION 13107 . 15256) (CLOSE-TYPED-W 15258 . 16019)) (16664 24143 (
|
||||
RELCREATEREGION 16674 . 21297) (RELGETREGION 21299 . 23906) (RELCREATEPOSITION 23908 . 24141)) (24144
|
||||
31719 (\RELCREATEREGION.REF 24154 . 28676) (\RELCREATEREGION.SIZE 28678 . 31717)) (31772 41114 (
|
||||
RM-ATTACHWINDOW 31782 . 41112)) (41115 42849 (CLOSEWITH 41125 . 41652) (CLOSEWITH.DOIT 41654 . 41934)
|
||||
(MOVEWITH 41936 . 42459) (MOVEWITH.DOIT 42461 . 42847)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -34,8 +34,9 @@ where each regionsi is a possibly empty list of regions. For convenience, if TY
|
||||
Typically, a call to SET-TYPED-REGIONS would be placed in a user's INIT file to set up the preference order for the regions that the user wants to participate in this reallocation scheme. If an application uses a type that is not on TYPED-REGIONS, then that type-atom is treated as NIL and always gives rise to the normal ghost-region prompting. Thus a user will observe no change in system behavior if TYPED-REGIONS is left with its initial value NIL. A type that is added with an empty region list (as opposed to not being on the list at all) will allow new regions to accumulate for recycling.
|
||||
The function REGION-TYPE returns NIL if X is not a typed-region or not a region of type TYPE.
|
||||
(REGION-TYPE X TYPE) [Function]
|
||||
In most scenarios the interpretation of a typed region specification is handled automatically by the extended CREATEW and GETREGION functions. Sometimes it may be useful to perform to for the regions dimensions to be entered into other calculations before it is installed in a window. The function GRAB-TYPED-REGION recycles an existing REGION-TYPE window if one meets the optional minimum width and height requirements, otherwise a new region is returned.
|
||||
(GRAB-TYPED-REGION REGION-TYPE MINWIDTH MINHEIGHT) [Function]
|
||||
In most scenarios the interpretation of a typed region specification is handled automatically by the extended CREATEW and GETREGION functions. Sometimes it may be useful to perform to for the regions dimensions to be entered into other calculations before it is installed in a window. The function GRAB-TYPED-REGION recycles an existing REGION-TYPE window if one meets the optional minimum width, height , and margin requirements, otherwise a new region is returned.
|
||||
(GRAB-TYPED-REGION REGION-TYPE MINWIDTH MINHEIGHT MARGIN) [Function]
|
||||
If MINWIDTH is specified, the recyled window must be at least that wide, and if MARGIN is specified it can be no larger than MARGIN x MINWIDTH. Thus, if MINWIDTH is 200 and MARGIN is 1.1, only regions REGION-TYPE regions of width between 200 and 220 points will satisfy. MINHEIGHT restricts the height in the same way.
|
||||
A type can be assigned to an untyped region and installed in a window by the function REGISTER-TYPED-REGION. That region will then be recycled when the window is closed.
|
||||
(REGISTER-TYPED-REGION REGION REGION-TYPE WINDOW) [Function]
|
||||
If REGION is NIL, the (presumably) untyped region of WINDOW will be registered. An entry in TYPED-REGIONS will be created for REGION-TYPE if it is not already present.
|
||||
@@ -79,14 +80,16 @@ Establishes a link between the PARENT window and any number of CHILDREN windows
|
||||
If NEWPOS is the new position of PARENT, moves each of the move-children so that they stand in the same relation to PARENT after it moves as before.
|
||||
|
||||
|
||||
(SEQUENCE NIL NIL (0 0 0 0) ((PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC) STARTINGPAGE# 1) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC)) (174 36 288 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (84 744 528 36) NIL) (TEXT NIL NIL (84 96 456 600) NIL))) (ALTERNATE NIL NIL (0 0 0 0) ((PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC)) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC)) (174 36 288 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (84 744 528 36) NIL) (TEXT NIL NIL (84 96 456 600) NIL))) (PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC)) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC)) (174 36 288 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (84 744 528 36) NIL) (TEXT NIL NIL (84 96 456 600) NIL)))))))
1 $ 4 È $È 4 È $È 1 $È $ 1 È $ 4 È $È 4 È $È 4 È $È 4 È $È 1 È $ 1 Š Š8 $ 1 Š Š8 $ J È $È PAGEHEADING RUNNINGHEAD MODERN
|
||||
CLASSIC
|
||||
TERMINAL MODERN TERMINAL ÿü TERMINAL ÿü
|
||||
TIMESROMAN $
HRULE.GETFN
HRULE.GETFN HRULE.GETFN HRULE.GETFN HRULE.GETFN
|
||||
@ È „ • ‘ } / ¯ [ <01> C * § <00> T Û ¬ @
Á 1
|
||||
|
||||
; 3 o ) Ä
ž
’
4 n © o 2 V @ 1 % !
A & M m I S - g <
|
||||
3 E
|
||||
"
|
||||
|
||||
l / 4 v 2 C ƒ & % " O = , l ¬ ) 9 š ¥ Ç
W ~ æ & 4 ! U h ' š 2 & µ $ " & (
) M DATE:iÏ*ø 5V®zº
|
||||
(SEQUENCE NIL NIL (0 0 0 0) ((PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC) STARTINGPAGE# 1) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC)) (174 36 288 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (84 744 528 36) NIL) (TEXT NIL NIL (84 96 456 600) NIL))) (ALTERNATE NIL NIL (0 0 0 0) ((PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC)) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC)) (174 36 288 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (84 744 528 36) NIL) (TEXT NIL NIL (84 96 456 600) NIL))) (PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC)) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC)) (174 36 288 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (84 744 528 36) NIL) (TEXT NIL NIL (84 96 456 600) NIL))))))) 1 $ 4 È $È 4 È $È 1 $È $ 1 È $ 4 È $È 4 È $È 4 È $È 4 È $È 4 È $È 1 È $ 1 Š Š8 $ 1 Š Š8 $ J È $È PAGEHEADING RUNNINGHEAD 1 TERMINAL (CHARPROPS (COLOR . BLACK)) 0 CLASSIC
|
||||
(CHARPROPS (COLOR . BLACK)) / MODERN
|
||||
(CHARPROPS (COLOR . BLACK)) / MODERN (CHARPROPS (COLOR . BLACK)) 1 TERMINAL ÿü (CHARPROPS (COLOR . BLACK)) 1 TERMINAL ÿü (CHARPROPS (COLOR . BLACK)) 3
|
||||
TIMESROMAN $ (CHARPROPS (COLOR . BLACK)) HRULE.GETFN HRULE.GETFN HRULE.GETFN
HRULE.GETFN HRULE.GETFN @ È
|
||||
„
|
||||
•
|
||||
‘ } / ¯ [ <01> C * § <00> T Û ¬ @
Á 1
|
||||
|
||||
; 3 o ) Ä
ž
’
4 n © y 9 E ' < 0 V @ 1 % !
A & M m I S - g <
|
||||
3 E
|
||||
"
|
||||
|
||||
l / 4 v 2 C ƒ & % " O = , l ¬ ) 9 š ¥ Ç
W ~ æ & 4 ! U h ' š 2 & µ $ " & (
) M (((CHARENCODING . MCCS)))PROPS: #DATE:jÄ"< 6©Àzº
|
||||
@@ -1,12 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "23-Jan-2025 15:47:23" {WMEDLEY}<lispusers>WHICHKEY.;3 1037
|
||||
(FILECREATED "21-Oct-2025 08:40:16" {WMEDLEY}<lispusers>WHICHKEY.;5 1172
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (FNS WHICHKEY)
|
||||
:CHANGES-TO (FNS DOWNP)
|
||||
|
||||
:PREVIOUS-DATE "23-Jan-2025 15:46:57" {WMEDLEY}<lispusers>WHICHKEY.;2)
|
||||
:PREVIOUS-DATE "12-Oct-2025 20:53:41" {WMEDLEY}<lispusers>WHICHKEY.;4)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT WHICHKEYCOMS)
|
||||
@@ -14,15 +14,19 @@
|
||||
(RPAQQ WHICHKEYCOMS ((FNS DOWNP WHICHKEY)))
|
||||
(DEFINEQ
|
||||
|
||||
(DOWNP
|
||||
(DOWNP
|
||||
[LAMBDA (KEYNAME DELAY) (* ; "Edited 21-Oct-2025 08:37 by rmk")
|
||||
(DISMISS (OR DELAY 3000))
|
||||
(KEYDOWNP KEYNAME])
|
||||
|
||||
(WHICHKEY
|
||||
(KEYDOWNP KEYNAME])
|
||||
[LAMBDA (DELAY) (* ; "Edited 12-Oct-2025 11:52 by rmk")
|
||||
(* ; "Edited 23-Jan-2025 15:44 by rmk")
|
||||
(* ; "Edited 4-Dec-2023 16:04 by rmk")
|
||||
(* ; "Edited 18-May-2018 13:09 by rmk:")
|
||||
(PROGN (DISMISS (OR DELAY 3000))
|
||||
(* ; "Edited 4-Dec-2023 16:04 by rmk")
|
||||
(for X IN \KEYNAMES as I from 0 when (KEYDOWNP (CAR X)) collect (LIST I X])
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(for X IN \KEYNAMES when (KEYDOWNP (CAR X)) collect X])
|
||||
(FILEMAP (NIL (365 1149 (DOWNP 375 . 548) (WHICHKEY 550 . 1147)))))
|
||||
STOP
|
||||
|
||||
BIN
lispusers/WHICHKEY.TEDIT
Normal file
BIN
lispusers/WHICHKEY.TEDIT
Normal file
Binary file not shown.
31
sources/ADIR
31
sources/ADIR
@@ -1,10 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED " 6-Feb-2025 17:48:54" {DSK}<home>frank>il>medley>sources>ADIR.;6 70091
|
||||
(FILECREATED "15-Oct-2025 15:20:48" {WMEDLEY}<sources>ADIR.;62 70135
|
||||
|
||||
:CHANGES-TO (FNS INTERPRET.REM.CM)
|
||||
:EDIT-BY rmk
|
||||
|
||||
:PREVIOUS-DATE "20-Jan-2025 13:37:28" {DSK}<home>frank>il>medley>sources>ADIR.;3)
|
||||
:CHANGES-TO (MACROS \UPF.EXTRACT)
|
||||
|
||||
:PREVIOUS-DATE " 6-Feb-2025 17:48:54" {WMEDLEY}<sources>ADIR.;61)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT ADIRCOMS)
|
||||
@@ -742,7 +744,8 @@
|
||||
OFFST _ STARTOFFSET
|
||||
LENGTH _ (ADD1 (IDIFFERENCE ENDOFFSET STARTOFFSET))
|
||||
BASE _ $$BASE
|
||||
READONLY _ $$READONLY)))
|
||||
READONLY _ $$READONLY
|
||||
FATSTRINGP _ $$FATP)))
|
||||
|
||||
(PUTPROPS \UPF.DIRTYPE MACRO [(DIRSTART) (* ; "Edited 20-Apr-2022 20:14 by rmk")
|
||||
(SELCHARQ (\GETBASECHAR $$FATP $$BASE DIRSTART)
|
||||
@@ -1279,14 +1282,14 @@
|
||||
(ADDTOVAR LAMA PACKFILENAME.STRING PACKFILENAME)
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (3183 16010 (DELFILE 3193 . 3354) (FULLNAME 3356 . 3723) (INFILE 3725 . 3984) (INFILEP
|
||||
3986 . 4121) (IOFILE 4123 . 4374) (OPENFILE 4376 . 4679) (OPENSTREAM 4681 . 9021) (OUTFILE 9023 . 9285
|
||||
) (OUTFILEP 9287 . 9423) (RENAMEFILE 9425 . 9731) (SIMPLE.FINDFILE 9733 . 10143) (VMEMSIZE 10145 .
|
||||
10312) (\COPYSYS 10314 . 14605) (\FLUSHVM 14607 . 15679) (\LOGOUT0 15681 . 16008)) (16509 41169 (
|
||||
UNPACKFILENAME.STRING 16519 . 38355) (\UPF.DIRECTORY 38357 . 41167)) (42697 45003 (UNPACKFILENAME
|
||||
42707 . 42893) (LASTCHPOS 42895 . 43589) (FILENAMEFIELD 43591 . 43885) (FILENAMEFIELD.STRING 43887 .
|
||||
44291) (PACKFILENAME 44293 . 44636) (PACKFILENAME.STRING 44638 . 45001)) (59473 60386 (
|
||||
FILEDIRCASEARRAY 59483 . 60384)) (60553 67850 (LOGOUT 60563 . 61608) (MAKESYS 61610 . 63239) (SYSOUT
|
||||
63241 . 64793) (SAVEVM 64795 . 65595) (HERALD 65597 . 65757) (INTERPRET.REM.CM 65759 . 67473) (
|
||||
\USEREVENT 67475 . 67848)) (68032 69759 (USERNAME 68042 . 68998) (SETUSERNAME 69000 . 69757)))))
|
||||
(FILEMAP (NIL (3170 15997 (DELFILE 3180 . 3341) (FULLNAME 3343 . 3710) (INFILE 3712 . 3971) (INFILEP
|
||||
3973 . 4108) (IOFILE 4110 . 4361) (OPENFILE 4363 . 4666) (OPENSTREAM 4668 . 9008) (OUTFILE 9010 . 9272
|
||||
) (OUTFILEP 9274 . 9410) (RENAMEFILE 9412 . 9718) (SIMPLE.FINDFILE 9720 . 10130) (VMEMSIZE 10132 .
|
||||
10299) (\COPYSYS 10301 . 14592) (\FLUSHVM 14594 . 15666) (\LOGOUT0 15668 . 15995)) (16496 41156 (
|
||||
UNPACKFILENAME.STRING 16506 . 38342) (\UPF.DIRECTORY 38344 . 41154)) (42741 45047 (UNPACKFILENAME
|
||||
42751 . 42937) (LASTCHPOS 42939 . 43633) (FILENAMEFIELD 43635 . 43929) (FILENAMEFIELD.STRING 43931 .
|
||||
44335) (PACKFILENAME 44337 . 44680) (PACKFILENAME.STRING 44682 . 45045)) (59517 60430 (
|
||||
FILEDIRCASEARRAY 59527 . 60428)) (60597 67894 (LOGOUT 60607 . 61652) (MAKESYS 61654 . 63283) (SYSOUT
|
||||
63285 . 64837) (SAVEVM 64839 . 65639) (HERALD 65641 . 65801) (INTERPRET.REM.CM 65803 . 67517) (
|
||||
\USEREVENT 67519 . 67892)) (68076 69803 (USERNAME 68086 . 69042) (SETUSERNAME 69044 . 69801)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
513
sources/UFS
513
sources/UFS
@@ -1,12 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "18-Dec-2024 12:52:23" {WMEDLEY}<sources>UFS.;39 79633
|
||||
(FILECREATED "27-Oct-2025 11:10:55" {WMEDLEY}<sources>UFS.;61 91949
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (FNS \UFSRenameFile)
|
||||
:CHANGES-TO (FNS \UFSDeleteFile)
|
||||
|
||||
:PREVIOUS-DATE "16-Sep-2023 09:22:55" {WMEDLEY}<sources>UFS.;38)
|
||||
:PREVIOUS-DATE "17-Oct-2025 08:49:57" {WMEDLEY}<sources>UFS.;60)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT UFSCOMS)
|
||||
@@ -14,6 +14,11 @@
|
||||
(RPAQQ UFSCOMS
|
||||
[(PROP (FILETYPE MAKEFILE-ENVIRONMENT)
|
||||
UFS)
|
||||
[COMS
|
||||
(* ;; "For filename coercion before UNICODE-TABLES and UNICODE are loaded. Until then, only files with 7-bit MCCS names are allowed.")
|
||||
|
||||
(P (MOVD? 'EVQ 'UTF8TOMSTRING)
|
||||
(MOVD? 'EVQ 'MTOUTF8STRING]
|
||||
(DECLARE%: EVAL@COMPILE DONTEVAL@LOAD DONTCOPY (FILES (LOADCOMP)
|
||||
DIRECTORY FILEIO))
|
||||
(INITVARS (\UFS.DEFAULT.EOLC NIL))
|
||||
@@ -130,6 +135,17 @@
|
||||
(PUTPROPS UFS FILETYPE :BCOMPL)
|
||||
|
||||
(PUTPROPS UFS MAKEFILE-ENVIRONMENT (:PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10))
|
||||
|
||||
|
||||
|
||||
(* ;;
|
||||
"For filename coercion before UNICODE-TABLES and UNICODE are loaded. Until then, only files with 7-bit MCCS names are allowed."
|
||||
)
|
||||
|
||||
|
||||
(MOVD? 'EVQ 'UTF8TOMSTRING)
|
||||
|
||||
(MOVD? 'EVQ 'MTOUTF8STRING)
|
||||
(DECLARE%: EVAL@COMPILE DONTEVAL@LOAD DONTCOPY
|
||||
|
||||
(FILESLOAD (LOADCOMP)
|
||||
@@ -274,23 +290,160 @@
|
||||
(DEFINEQ
|
||||
|
||||
(\UFSOpenFile
|
||||
(LAMBDA (FILE ACCESS RECOG OTHERINFO FDEV OLDSTREAM) (* ; "Edited 6-Jun-90 12:18 by nm") (* ;;; "Open a file.") (WITH.MONITOR (\UFSGetMonitor FDEV) (PROG ((ACC (SELECTQ ACCESS (INPUT ACCESS-INPUT) (OUTPUT ACCESS-OUTPUT) (BOTH ACCESS-BOTH) (APPEND ACCESS-APPEND) ACCESS-OTHER)) (REC (SELECTQ RECOG (OLD RECOG-OLD) (OLDEST RECOG-OLDEST) (NEW RECOG-NEW) (OLD/NEW RECOG-NEW-OLD) (SELECTQ ACCESS (INPUT RECOG-OLD) (OUTPUT RECOG-NEW) ((BOTH APPEND) RECOG-NEW-OLD) RECOG-OTHER))) (EOF-FN (FUNCTION \EOSERROR)) (ERRNO (CREATECELL \FIXP)) OTHER FILEID BYTESIZE CDATE FULLNAME CINFO STRM CASE.CORRECT.NAME CASE.CORRECT.FULLFILENAME) (SETQ CASE.CORRECT.NAME (if (type? STREAM FILE) then (COND ((fetch (UFSSTREAM FILEID) of FILE) (* ; "Already open--this really ought to be an error") (RETURN FILE)) (T (LET ((FULLNAME (fetch (UFSSTREAM UNIXNAME) of FILE))) (SETQ STRM FILE) (* ; "Re use the old stream") (SUBSTRING FULLNAME (ADD1 (STRPOS "}" FULLNAME)))))) else (\UFS.RECOGNIZE.FILE FILE RECOG FDEV))) (COND ((NOT CASE.CORRECT.NAME) (RETURN NIL)) ((AND (NULL OLDSTREAM) (EQ (fetch (FDEV DEVICENAME) of FDEV) (QUOTE DSK)) (SETQ OTHER (\UFS.OPENP CASE.CORRECT.NAME FDEV)) (SELECTQ ACCESS (INPUT (* ; "ok if other file is also input") (DIRTYABLE OTHER)) T)) (* ; "Access conflict. Don't check this when just revalidating, of course. I also don't mess with this on UNIX device--let user get in trouble...") (CL:ERROR (QUOTE XCL:FILE-WONT-OPEN) :PATHNAME (\UFS.FULLNAME CASE.CORRECT.NAME FDEV)))) (SETQ CASE.CORRECT.FULLFILENAME (\UFS.ADD.HOST.FIELD CASE.CORRECT.NAME FDEV)) (* ;; "DSK cannot open a directory.") (AND (DSKP FDEV) (DIRECTORYNAMEP CASE.CORRECT.FULLFILENAME) (PROGN (PROMPTPRINT "{DSK} cannot open a directory file. Use {UNIX} device.") (\UFSError CASE.CORRECT.NAME 23 FDEV))) (SETQ CDATE (CREATECELL \FIXP)) (SETQ BYTESIZE (CREATECELL \FIXP)) (SETQ FILEID (OR (\UFSOpenFile-C CASE.CORRECT.FULLFILENAME REC ACC CDATE BYTESIZE ERRNO) (RETURN (\UFSError CASE.CORRECT.NAME ERRNO FDEV)))) (if (= (IPLUS BYTESIZE 0) -1) then (SETQ EOF-FN (FUNCTION \DEVICEFILE.EOSERROR)) (SETQ BYTESIZE 0) elseif (EQ ACCESS (QUOTE OUTPUT)) then (SETQ BYTESIZE 0)) (if STRM then (replace (STREAM FULLFILENAME) of STRM with (\UFS.FULLNAME CASE.CORRECT.NAME FDEV T)) (replace (STREAM DEVICE) of STRM with FDEV) (replace (STREAM EPAGE) of STRM with (FOLDLO BYTESIZE BYTESPERPAGE)) (replace (STREAM EOFFSET) of STRM with (IMOD BYTESIZE BYTESPERPAGE)) (replace (STREAM EOLCONVENTION) of STRM with (\UFSeol CASE.CORRECT.NAME (FASSOC (QUOTE TYPE) OTHERINFO))) (replace (STREAM VALIDATION) of STRM with CDATE) (replace (STREAM ENDOFSTREAMOP) of STRM with EOF-FN) else (SETQ STRM (create STREAM FULLFILENAME _ (\UFS.FULLNAME CASE.CORRECT.NAME FDEV T) DEVICE _ FDEV EPAGE _ (FOLDLO BYTESIZE BYTESPERPAGE) EOFFSET _ (IMOD BYTESIZE BYTESPERPAGE) EOLCONVENTION _ (\UFSeol CASE.CORRECT.NAME (FASSOC (QUOTE TYPE) OTHERINFO)) VALIDATION _ CDATE ENDOFSTREAMOP _ EOF-FN))) (replace (UFSSTREAM FILEID) of STRM with FILEID) (replace (UFSSTREAM CDATE) of STRM with (if (SETQ CINFO (FASSOC (QUOTE CREATIONDATE) OTHERINFO)) then (IDATE (CADR CINFO)) else 0)) (replace (UFSSTREAM UNIXNAME) of STRM with CASE.CORRECT.FULLFILENAME) (* ; "Save the case sensitive full file name for closef & getfileinfo.") (RETURN STRM))))
|
||||
)
|
||||
[LAMBDA (FILE ACCESS RECOG OTHERINFO FDEV OLDSTREAM) (* ; "Edited 16-Oct-2025 08:52 by rmk")
|
||||
(* ; "Edited 6-Jun-90 12:18 by nm")
|
||||
|
||||
(* ;;; "Open a file.")
|
||||
|
||||
(WITH.MONITOR (\UFSGetMonitor FDEV)
|
||||
(PROG ((ACC (SELECTQ ACCESS
|
||||
(INPUT ACCESS-INPUT)
|
||||
(OUTPUT ACCESS-OUTPUT)
|
||||
(BOTH ACCESS-BOTH)
|
||||
(APPEND ACCESS-APPEND)
|
||||
ACCESS-OTHER))
|
||||
(REC (SELECTQ RECOG
|
||||
(OLD RECOG-OLD)
|
||||
(OLDEST RECOG-OLDEST)
|
||||
(NEW RECOG-NEW)
|
||||
(OLD/NEW RECOG-NEW-OLD)
|
||||
(SELECTQ ACCESS
|
||||
(INPUT RECOG-OLD)
|
||||
(OUTPUT RECOG-NEW)
|
||||
((BOTH APPEND)
|
||||
RECOG-NEW-OLD)
|
||||
RECOG-OTHER)))
|
||||
(EOF-FN (FUNCTION \EOSERROR))
|
||||
(ERRNO (CREATECELL \FIXP))
|
||||
OTHER FILEID BYTESIZE CDATE FULLNAME CINFO STRM CASE.CORRECT.NAME
|
||||
CASE.CORRECT.FULLFILENAME)
|
||||
|
||||
(* ;; "CASE.CORRECT.NAME is MCCS")
|
||||
|
||||
(SETQ CASE.CORRECT.NAME (if (type? STREAM FILE)
|
||||
then [COND
|
||||
((fetch (UFSSTREAM FILEID) of FILE)
|
||||
(* ;
|
||||
"Already open--this really ought to be an error")
|
||||
(RETURN FILE))
|
||||
(T (LET ((FULLNAME (fetch (UFSSTREAM UNIXNAME)
|
||||
of FILE)))
|
||||
(SETQ STRM FILE)
|
||||
(* ; "Re use the old stream")
|
||||
(SUBSTRING FULLNAME (ADD1 (STRPOS "}"
|
||||
FULLNAME]
|
||||
else (\UFS.RECOGNIZE.FILE FILE RECOG FDEV)))
|
||||
[COND
|
||||
((NOT CASE.CORRECT.NAME)
|
||||
(RETURN NIL))
|
||||
((AND (NULL OLDSTREAM)
|
||||
(EQ (fetch (FDEV DEVICENAME) of FDEV)
|
||||
'DSK)
|
||||
(SETQ OTHER (\UFS.OPENP CASE.CORRECT.NAME FDEV))
|
||||
(SELECTQ ACCESS
|
||||
(INPUT (* ; "ok if other file is also input")
|
||||
(DIRTYABLE OTHER))
|
||||
T)) (* ; "Access conflict. Don't check this when just revalidating, of course. I also don't mess with this on UNIX device--let user get in trouble...")
|
||||
(CL:ERROR 'XCL:FILE-WONT-OPEN :PATHNAME (\UFS.FULLNAME CASE.CORRECT.NAME FDEV]
|
||||
(SETQ CASE.CORRECT.FULLFILENAME (\UFS.ADD.HOST.FIELD CASE.CORRECT.NAME FDEV))
|
||||
|
||||
(* ;; "DSK cannot open a directory.")
|
||||
|
||||
(AND (DSKP FDEV)
|
||||
(DIRECTORYNAMEP CASE.CORRECT.FULLFILENAME)
|
||||
(PROGN (PROMPTPRINT "{DSK} cannot open a directory file. Use {UNIX} device.")
|
||||
(\UFSError CASE.CORRECT.NAME 23 FDEV)))
|
||||
(SETQ CDATE (CREATECELL \FIXP))
|
||||
(SETQ BYTESIZE (CREATECELL \FIXP))
|
||||
[SETQ FILEID (OR (\UFSOpenFile-C (MTOUTF8STRING CASE.CORRECT.FULLFILENAME)
|
||||
REC ACC CDATE BYTESIZE ERRNO)
|
||||
(RETURN (\UFSError CASE.CORRECT.NAME ERRNO FDEV]
|
||||
(if (= (IPLUS BYTESIZE 0)
|
||||
-1)
|
||||
then (SETQ EOF-FN (FUNCTION \DEVICEFILE.EOSERROR))
|
||||
(SETQ BYTESIZE 0)
|
||||
elseif (EQ ACCESS 'OUTPUT)
|
||||
then (SETQ BYTESIZE 0))
|
||||
(if STRM
|
||||
then (replace (STREAM FULLFILENAME) of STRM with (\UFS.FULLNAME CASE.CORRECT.NAME
|
||||
FDEV T))
|
||||
(replace (STREAM DEVICE) of STRM with FDEV)
|
||||
(replace (STREAM EPAGE) of STRM with (FOLDLO BYTESIZE BYTESPERPAGE))
|
||||
(replace (STREAM EOFFSET) of STRM with (IMOD BYTESIZE BYTESPERPAGE))
|
||||
(replace (STREAM EOLCONVENTION) of STRM with (\UFSeol CASE.CORRECT.NAME
|
||||
(FASSOC 'TYPE OTHERINFO)))
|
||||
(replace (STREAM VALIDATION) of STRM with CDATE)
|
||||
(replace (STREAM ENDOFSTREAMOP) of STRM with EOF-FN)
|
||||
else (SETQ STRM (create STREAM
|
||||
FULLFILENAME _ (\UFS.FULLNAME CASE.CORRECT.NAME FDEV T)
|
||||
DEVICE _ FDEV
|
||||
EPAGE _ (FOLDLO BYTESIZE BYTESPERPAGE)
|
||||
EOFFSET _ (IMOD BYTESIZE BYTESPERPAGE)
|
||||
EOLCONVENTION _ (\UFSeol CASE.CORRECT.NAME (FASSOC
|
||||
'TYPE OTHERINFO))
|
||||
VALIDATION _ CDATE
|
||||
ENDOFSTREAMOP _ EOF-FN)))
|
||||
(replace (UFSSTREAM FILEID) of STRM with FILEID)
|
||||
(replace (UFSSTREAM CDATE) of STRM with (if (SETQ CINFO (FASSOC 'CREATIONDATE OTHERINFO
|
||||
))
|
||||
then (IDATE (CADR CINFO))
|
||||
else 0))
|
||||
(replace (UFSSTREAM UNIXNAME) of STRM with CASE.CORRECT.FULLFILENAME)
|
||||
(* ;
|
||||
"Save the case sensitive full file name for closef & getfileinfo.")
|
||||
(RETURN STRM)))])
|
||||
|
||||
(\UFS.OPENP
|
||||
(LAMBDA (UNIXNAME DEV) (* ; "Edited 3-Mar-89 11:47 by bvm") (* ;; "Returns first open file having specified unix name") (for S in (fetch (FDEV OPENFILELST) of DEV) bind (COMPAREFN _ (if (EQ (fetch (FDEV DEVICENAME) of DEV) (QUOTE DSK)) then (* ; "We're case-insensitive, and it seems like not all functions return the correct Unix case") (FUNCTION STRING-EQUAL) else (* ; "Exact") (FUNCTION STREQUAL))) thereis (CL:FUNCALL COMPAREFN UNIXNAME (fetch (UFSSTREAM UNIXNAME) of S))))
|
||||
)
|
||||
|
||||
(\UFS.RECOGNIZE.FILE
|
||||
(LAMBDA (FILENAME RECOG DEV) (* ; "Edited 13-Mar-90 11:19 by nm") (* ;; "Perform recognition on FILENAME, returning the %"true%" name for the file, or NIL. The result file name is following the Xerox Lisp file naming convention but does not include HOST field. It will be supplied by \UFS.FULLNAME.") (WITH.MONITOR (\UFSGetMonitor DEV) (LET ((NAMEAREA (ALLOCSTRING MAX-PATHNAME-LEN)) (ERRNO (CREATECELL \FIXP)) LEN) (SETQ LEN (CL:FUNCALL (\UFS.FILE.RECOGNIZER DEV) (\UFS.REMOVE.HOST.FIELD FILENAME DEV) (SELECTQ RECOG (OLD RECOG-OLD) (OLDEST RECOG-OLDEST) (NEW RECOG-NEW) (OLD/NEW RECOG-NEW-OLD) (NON RECOG-NON) RECOG-NEW-OLD) NAMEAREA ERRNO)) (COND ((FIXP LEN) (SUBSTRING NAMEAREA 1 LEN)) (T (\UFSError FILENAME ERRNO))))))
|
||||
)
|
||||
[LAMBDA (FILENAME RECOG DEV) (* ; "Edited 16-Oct-2025 10:19 by rmk")
|
||||
(* ; "Edited 13-Mar-90 11:19 by nm")
|
||||
|
||||
(* ;; "This assumes that input FILENAME is MCCS, returns MCCS")
|
||||
|
||||
(* ;; "Perform recognition on FILENAME, returning the %"true%" name for the file, or NIL. The result file name is following the Xerox Lisp file naming convention but does not include HOST field. It will be supplied by \UFS.FULLNAME.")
|
||||
|
||||
(WITH.MONITOR (\UFSGetMonitor DEV)
|
||||
[LET ((NAMEAREA (ALLOCSTRING MAX-PATHNAME-LEN))
|
||||
(ERRNO (CREATECELL \FIXP))
|
||||
LEN)
|
||||
(SETQ LEN (CL:FUNCALL (\UFS.FILE.RECOGNIZER DEV)
|
||||
(MTOUTF8STRING (\UFS.REMOVE.HOST.FIELD FILENAME DEV))
|
||||
(SELECTQ RECOG
|
||||
(OLD RECOG-OLD)
|
||||
(OLDEST RECOG-OLDEST)
|
||||
(NEW RECOG-NEW)
|
||||
(OLD/NEW RECOG-NEW-OLD)
|
||||
(NON RECOG-NON)
|
||||
RECOG-NEW-OLD)
|
||||
NAMEAREA ERRNO))
|
||||
(COND
|
||||
((FIXP LEN)
|
||||
(UTF8TOMSTRING (SUBSTRING NAMEAREA 1 LEN)))
|
||||
(T (\UFSError FILENAME ERRNO])])
|
||||
|
||||
(\UFS.DIRECTORY.NAME
|
||||
(LAMBDA (DIRSTRING NAMEAREA DEV) (* ; "Edited 1-Apr-90 23:36 by nm") (* ;;; "Accepts a Xerox Lisp canonical directory name, and recognize it. If such directory exists, sets the %"ture%" name of the directory in NAMEAREA and returns the length of the name. If such directory does not exist, returns NIL. The canonical directory name does not include the initial directory delimiter and the trail directory delimiter, but the result %"ture%" name includes both of them. If DIRSTRING is %"<%", it means the root directory.") (if (STREQUAL DIRSTRING "<") then (RPLSTRING NAMEAREA 1 "<") 1 else (WITH.MONITOR (\UFSGetMonitor DEV) (CL:FUNCALL (\UFS.DIRECTORY.RECOGNIZER DEV) DIRSTRING NAMEAREA (CREATECELL \FIXP)))))
|
||||
)
|
||||
[LAMBDA (DIRSTRING NAMEAREA DEV) (* ; "Edited 15-Oct-2025 16:30 by rmk")
|
||||
(* ; "Edited 1-Apr-90 23:36 by nm")
|
||||
|
||||
(* ;;; "Accepts a Xerox Lisp canonical directory name, and recognize it. If such directory exists, sets the %"true%" name of the directory in NAMEAREA and returns the length of the name. If such directory does not exist, returns NIL. The canonical directory name does not include the initial directory delimiter and the trail directory delimiter, but the result %"true%" name includes both of them. If DIRSTRING is %"<%", it means the root directory.")
|
||||
|
||||
(* ;; "DIRSTRING is MCCS, the true name is not")
|
||||
|
||||
(if (STREQUAL DIRSTRING "<")
|
||||
then (RPLSTRING NAMEAREA 1 "<")
|
||||
1
|
||||
else (WITH.MONITOR (\UFSGetMonitor DEV)
|
||||
(CL:FUNCALL (\UFS.DIRECTORY.RECOGNIZER DEV)
|
||||
(MTOUTF8STRING DIRSTRING)
|
||||
NAMEAREA
|
||||
(CREATECELL \FIXP)))])
|
||||
|
||||
(\UFSCloseFile
|
||||
[LAMBDA (STREAMFILE) (* ; "Edited 16-Sep-2023 09:21 by briggs")
|
||||
[LAMBDA (STREAMFILE) (* ; "Edited 16-Oct-2025 13:47 by rmk")
|
||||
(* ; "Edited 16-Sep-2023 09:21 by briggs")
|
||||
(* ; "Edited 30-Mar-90 10:39 by nm")
|
||||
(* ; "return stream")
|
||||
|
||||
@@ -314,7 +467,8 @@
|
||||
then (* ; "Open for output")
|
||||
(FDEVOP 'TRUNCATEFILE DEVICE STREAMFILE)
|
||||
(SETQ CDATE (fetch (UFSSTREAM CDATE) of STREAMFILE)))
|
||||
(RETURN (if (\UFSCloseFile-C UNIXNAME (fetch (UFSSTREAM FILEID) of STREAMFILE)
|
||||
(RETURN (if (\UFSCloseFile-C (MTOUTF8STRING UNIXNAME)
|
||||
(fetch (UFSSTREAM FILEID) of STREAMFILE)
|
||||
CDATE ERRNO)
|
||||
then (replace (UFSSTREAM FILEID) of STREAMFILE with NIL)
|
||||
(replace (UFSSTREAM CDATE) of STREAMFILE with NIL)
|
||||
@@ -328,11 +482,26 @@
|
||||
)
|
||||
|
||||
(\UFSDeleteFile
|
||||
(LAMBDA (FILENAME DEV) (* ; "Edited 30-Mar-90 10:46 by nm") (* ; "return deleted file name") (* ; "if error, return NIL") (WITH.MONITOR (\UFSGetMonitor DEV) (LET ((NAME (\UFS.RECOGNIZE.FILE FILENAME (QUOTE OLDEST) DEV))) (COND ((AND NAME (NOT (\UFS.OPENP NAME DEV))) (* ; "file found and not open, so try to delete") (LET ((ERRNO (CREATECELL \FIXP))) (COND ((\UFSDeleteFile-C (\UFS.REMOVE.HOST.FIELD NAME DEV) DEV ERRNO) (* ; "Success") (\UFS.FULLNAME NAME DEV T)) (T (* ; "Failure") (\UFSError NAME ERRNO DEV)))))))))
|
||||
)
|
||||
[LAMBDA (FILENAME DEV) (* ; "Edited 27-Oct-2025 11:10 by rmk")
|
||||
(* ; "Edited 30-Mar-90 10:46 by nm")
|
||||
(* ; "return deleted file name")
|
||||
(* ; "if error, return NIL")
|
||||
(WITH.MONITOR (\UFSGetMonitor DEV)
|
||||
[LET ((NAME (\UFS.RECOGNIZE.FILE FILENAME 'OLDEST DEV)))
|
||||
(COND
|
||||
((AND NAME (NOT (\UFS.OPENP NAME DEV))) (* ;
|
||||
"file found and not open, so try to delete")
|
||||
(LET ((ERRNO (CREATECELL \FIXP)))
|
||||
(COND
|
||||
((\UFSDeleteFile-C (MTOUTF8STRING (\UFS.REMOVE.HOST.FIELD NAME DEV))
|
||||
DEV ERRNO) (* ; "Success")
|
||||
(\UFS.FULLNAME NAME DEV T))
|
||||
(T (* ; "Failure")
|
||||
(\UFSError NAME ERRNO DEV])])
|
||||
|
||||
(\UFSRenameFile
|
||||
[LAMBDA (OLD-DEVICE OLD-NAME NEW-DEVICE NEW-NAME) (* ; "Edited 18-Dec-2024 12:52 by rmk")
|
||||
[LAMBDA (OLD-DEVICE OLD-NAME NEW-DEVICE NEW-NAME) (* ; "Edited 16-Oct-2025 08:46 by rmk")
|
||||
(* ; "Edited 18-Dec-2024 12:52 by rmk")
|
||||
(* ; "Edited 16-Apr-90 13:46 by nm")
|
||||
(if (NEQ OLD-DEVICE NEW-DEVICE)
|
||||
then
|
||||
@@ -349,8 +518,10 @@
|
||||
(LET ((NEWUNIXNAME (\UFS.RECOGNIZE.FILE NEW-NAME 'NEW NEW-DEVICE))
|
||||
(ERRNO (CREATECELL \FIXP)))
|
||||
(COND
|
||||
((\UFSRenameFile-C (\UFS.REMOVE.HOST.FIELD OLDUNIXNAME OLD-DEVICE)
|
||||
(\UFS.REMOVE.HOST.FIELD NEWUNIXNAME NEW-DEVICE)
|
||||
((\UFSRenameFile-C (MTOUTF8STRING (\UFS.REMOVE.HOST.FIELD
|
||||
OLDUNIXNAME OLD-DEVICE))
|
||||
(MTOUTF8STRING (\UFS.REMOVE.HOST.FIELD NEWUNIXNAME
|
||||
NEW-DEVICE))
|
||||
NEW-DEVICE ERRNO)
|
||||
(\UFS.FULLNAME NEWUNIXNAME NEW-DEVICE))
|
||||
(T (if (EQL (IPLUS ERRNO 0)
|
||||
@@ -372,32 +543,200 @@
|
||||
)
|
||||
|
||||
(\UFSTruncateFile
|
||||
(LAMBDA (STREAM PAGE# OFFSET) (* ; "Edited 22-Aug-90 16:46 by nm") (* ;;; "Used to shorten or lengthen STREAM. If lengthening, pad the file with nulls. Used by SETEOFPTR and FORCEOUTPUT.") (\UPDATEOF STREAM) (OR (FIXP PAGE#) (SETQ PAGE# (fetch (STREAM EPAGE) of STREAM))) (OR (FIXP OFFSET) (SETQ OFFSET (fetch (STREAM EOFFSET) of STREAM))) (* ; "Truncate size was set to PAGE# and OFFSET") (PROG ((curEof (+ (UNFOLD (fetch (STREAM EPAGE) of STREAM) BYTESPERPAGE) (fetch (STREAM EOFFSET) of STREAM))) (needSize (+ (UNFOLD PAGE# BYTESPERPAGE) OFFSET)) (ERRNO (CREATECELL \FIXP))) (if (> needSize curEof) then (* ; "Push 0 to extend file.") (LET ((FILEPTR (\GETFILEPTR STREAM))) (\SETFILEPTR STREAM curEof) (to (- needSize curEof) do (\BOUT STREAM 0)) (\SETFILEPTR STREAM FILEPTR)) elseif T then (* ; "Call c to shorten file. It would be good if we kept track of the file's eof, so that we wouldn't have to do this on closef when nothing had changed") (OR (\UFSGetSize-C (fetch (UFSSTREAM FILEID) of STREAM) needSize ERRNO) (RETURN (\UFSError STREAM ERRNO))) else (RETURN)) (* ;; "Set new value to stream") (replace (STREAM EPAGE) of STREAM with PAGE#) (replace (STREAM EOFFSET) of STREAM with OFFSET) (LET ((DT (CREATECELL \FIXP))) (* ;; "Set new validation value. UNIX mtime is updated, so Lisp stream validation must be updated.") (if (\UFSGetFileInfo-C (fetch (UFSSTREAM UNIXNAME) of STREAM) ATTR-WDATE DT ERRNO) then (replace (STREAM VALIDATION) of STREAM with DT)))))
|
||||
)
|
||||
[LAMBDA (STREAM PAGE# OFFSET) (* ; "Edited 16-Oct-2025 08:56 by rmk")
|
||||
(* ; "Edited 22-Aug-90 16:46 by nm")
|
||||
|
||||
(* ;;; "Used to shorten or lengthen STREAM. If lengthening, pad the file with nulls. Used by SETEOFPTR and FORCEOUTPUT.")
|
||||
|
||||
(\UPDATEOF STREAM)
|
||||
(OR (FIXP PAGE#)
|
||||
(SETQ PAGE# (fetch (STREAM EPAGE) of STREAM)))
|
||||
(OR (FIXP OFFSET)
|
||||
(SETQ OFFSET (fetch (STREAM EOFFSET) of STREAM))) (* ;
|
||||
"Truncate size was set to PAGE# and OFFSET")
|
||||
(PROG ((curEof (+ (UNFOLD (fetch (STREAM EPAGE) of STREAM)
|
||||
BYTESPERPAGE)
|
||||
(fetch (STREAM EOFFSET) of STREAM)))
|
||||
(needSize (+ (UNFOLD PAGE# BYTESPERPAGE)
|
||||
OFFSET))
|
||||
(ERRNO (CREATECELL \FIXP)))
|
||||
(if (> needSize curEof)
|
||||
then (* ; "Push 0 to extend file.")
|
||||
(LET ((FILEPTR (\GETFILEPTR STREAM)))
|
||||
(\SETFILEPTR STREAM curEof)
|
||||
(to (- needSize curEof) do (\BOUT STREAM 0))
|
||||
(\SETFILEPTR STREAM FILEPTR))
|
||||
else (* ; "Call c to shorten file. It would be good if we kept track of the file's eof, so that we wouldn't have to do this on closef when nothing had changed")
|
||||
(OR (\UFSGetSize-C (fetch (UFSSTREAM FILEID) of STREAM)
|
||||
needSize ERRNO)
|
||||
(RETURN (\UFSError STREAM ERRNO)))
|
||||
else (RETURN))
|
||||
|
||||
(* ;; "Set new value to stream")
|
||||
|
||||
(replace (STREAM EPAGE) of STREAM with PAGE#)
|
||||
(replace (STREAM EOFFSET) of STREAM with OFFSET)
|
||||
(LET ((DT (CREATECELL \FIXP)))
|
||||
|
||||
(* ;;
|
||||
"Set new validation value. UNIX mtime is updated, so Lisp stream validation must be updated.")
|
||||
|
||||
(if (\UFSGetFileInfo-C (MTOUTF8STRING (fetch (UFSSTREAM UNIXNAME) of STREAM))
|
||||
ATTR-WDATE DT ERRNO)
|
||||
then (replace (STREAM VALIDATION) of STREAM with DT])
|
||||
|
||||
(\UFSDirectoryNameP
|
||||
(LAMBDA (DIRSPEC DEV) (* ; "Edited 21-Sep-92 15:27 by jds") (* ;;; " DIRECTORYNAMEP FDEV method. Performs a recognition as well and returns the %"true%" name if it exists.") (LET ((DIRECTORY (CONCAT (OR (UNPACKFILENAME.STRING DIRSPEC (QUOTE DEVICE)) "") (OR (UNPACKFILENAME.STRING DIRSPEC (QUOTE DIRECTORY) (QUOTE RETURN)) (\UFS.HANDLE.RELATIVEDIRECTORY (UNPACKFILENAME.STRING DIRSPEC (QUOTE RELATIVEDIRECTORY) (QUOTE RETURN)) DEV) (\UFS.DEFAULT.DIR DEV)))) NAMEAREA LEN) (* ;; " HOST field of DIRSPEC has been defaulted by the generic file system code. Thus we don't have to worry about the subdirectory case.") (COND (DIRECTORY (SETQ NAMEAREA (ALLOCSTRING MAX-PATHNAME-LEN)) (* ; "NAMEAREA will be modified by C code and hold the %"true%" name of DIRECTORY if DIRECTORY is recognized as a valid directory name.") (SETQ LEN (\UFS.DIRECTORY.NAME DIRECTORY NAMEAREA DEV)) (COND ((FIXP LEN) (* ; "LEN holds the length of the %"true%" name of DIRECTORY.") (\UFS.FULLNAME (SUBSTRING NAMEAREA 1 LEN) DEV NIL)) (T NIL))) (T NIL))))
|
||||
)
|
||||
[LAMBDA (DIRSPEC DEV) (* ; "Edited 16-Oct-2025 10:23 by rmk")
|
||||
(* ; "Edited 21-Sep-92 15:27 by jds")
|
||||
|
||||
(* ;;; " DIRECTORYNAMEP FDEV method. Performs a recognition as well and returns the %"true%" name if it exists.")
|
||||
|
||||
(LET ([DIRECTORY (CONCAT (OR (UNPACKFILENAME.STRING DIRSPEC 'DEVICE)
|
||||
"")
|
||||
(OR (UNPACKFILENAME.STRING DIRSPEC 'DIRECTORY 'RETURN)
|
||||
(\UFS.HANDLE.RELATIVEDIRECTORY (UNPACKFILENAME.STRING DIRSPEC
|
||||
'RELATIVEDIRECTORY
|
||||
'RETURN)
|
||||
DEV)
|
||||
(\UFS.DEFAULT.DIR DEV]
|
||||
NAMEAREA LEN)
|
||||
|
||||
(* ;; " HOST field of DIRSPEC has been defaulted by the generic file system code. Thus we don't have to worry about the subdirectory case.")
|
||||
|
||||
(COND
|
||||
(DIRECTORY (SETQ NAMEAREA (ALLOCSTRING MAX-PATHNAME-LEN))
|
||||
(* ; "NAMEAREA will be modified by C code and hold the %"true%" name of DIRECTORY if DIRECTORY is recognized as a valid directory name.")
|
||||
(SETQ LEN (\UFS.DIRECTORY.NAME DIRECTORY NAMEAREA DEV))
|
||||
(COND
|
||||
((FIXP LEN) (* ;
|
||||
"LEN holds the length of the %"true%" name of DIRECTORY.")
|
||||
(UTF8TOMSTRING (\UFS.FULLNAME (SUBSTRING NAMEAREA 1 LEN)
|
||||
DEV NIL)))
|
||||
(T NIL)))
|
||||
(T NIL])
|
||||
|
||||
(\UFSEventFn
|
||||
(LAMBDA (Dev Event) (DECLARE (GLOBALVARS \UFS.GFS.TABLE)) (* ; "Edited 3-May-90 17:35 by nm") (WITH.MONITOR \UFStopMonitor (SELECTQ Event ((AFTERLOGOUT AFTERSYSOUT AFTERMAKESYS AFTERSAVEVM) (\UFSCloseDevice) (SELECTQ (MACHINETYPE) ((MAIKO) (\UFSOpenDevice) (* ;; "revalidate open streams (should probably move this into the SELECTQ above) ") (\UNVISIBLE.PAGED.REVALIDATEFILELST Dev) (\PAGED.REVALIDATEFILELST Dev) (MAPHASH \UFS.GFS.TABLE (FUNCTION (LAMBDA (VAL KEY) (\UFS.UNREGISTER.GFS VAL)))) (CLRHASH \UFS.GFS.TABLE)) NIL)) ((BEFORELOGOUT) (\UNVISIBLE.FLUSH.OPEN.STREAMS Dev) (* ; "flush output buffers.") (\FLUSH.OPEN.STREAMS Dev)) NIL)))
|
||||
)
|
||||
|
||||
(\UFSGetFileInfo
|
||||
(LAMBDA (STREAM ATTRIBUTE DEVICE) (* ; "Edited 30-Mar-90 12:27 by nm") (* ;;; "Get the value of the attribute for a file.") (* ;;; "Allocate buffer to store the value.") (* ;;; "If attribute is AUTHOR, the type of the buffer is STRING.") (* ;;; "Otherwise the type of the buffer is FIXP.") (WITH.MONITOR (\UFSGetMonitor DEVICE) (LET ((FILENAME (if (type? STREAM STREAM) then (fetch (UFSSTREAM UNIXNAME) of STREAM) else (\UFS.FULLNAME (\UFS.RECOGNIZE.FILE STREAM (QUOTE OLD) DEVICE) DEVICE NIL))) (ERRNO (CREATECELL \FIXP)) BUFFER NAMESIZE) (if FILENAME then (SELECTQ ATTRIBUTE (LENGTH (SETQ BUFFER (CREATECELL \FIXP)) (if (\UFSGetFileInfo-C FILENAME ATTR-LENGTH BUFFER ERRNO) then BUFFER else (\UFSError FILENAME ERRNO DEVICE))) (SIZE (SETQ BUFFER (CREATECELL \FIXP)) (if (\UFSGetFileInfo-C FILENAME ATTR-LENGTH BUFFER ERRNO) then (FOLDHI BUFFER BYTESPERPAGE) else (\UFSError FILENAME ERRNO DEVICE))) (TYPE (\UFSGetFileType FILENAME)) ((CREATIONDATE WRITEDATE) (SETQ BUFFER (CREATECELL \FIXP)) (if (\UFSGetFileInfo-C FILENAME ATTR-WDATE BUFFER ERRNO) then (GDATE BUFFER) else (\UFSError FILENAME ERRNO DEVICE))) (READDATE (SETQ BUFFER (CREATECELL \FIXP)) (if (\UFSGetFileInfo-C FILENAME ATTR-RDATE BUFFER ERRNO) then (GDATE BUFFER) else (\UFSError FILENAME ERRNO DEVICE))) ((ICREATIONDATE IWRITEDATE) (SETQ BUFFER (CREATECELL \FIXP)) (if (\UFSGetFileInfo-C FILENAME ATTR-WDATE BUFFER ERRNO) then BUFFER else (\UFSError FILENAME ERRNO DEVICE))) (IREADDATE (SETQ BUFFER (CREATECELL \FIXP)) (if (\UFSGetFileInfo-C FILENAME ATTR-RDATE BUFFER ERRNO) then BUFFER else (\UFSError FILENAME ERRNO DEVICE))) (AUTHOR (SETQ BUFFER (ALLOCSTRING MAX-UNAME-LEN)) (if (SETQ NAMESIZE (\UFSGetFileInfo-C FILENAME ATTR-AUTHOR BUFFER ERRNO)) then (CL:SUBSEQ BUFFER 0 NAMESIZE) else (\UFSError FILENAME ERRNO DEVICE))) (PROTECTION (SETQ BUFFER (CREATECELL \FIXP)) (if (\UFSGetFileInfo-C FILENAME ATTR-PROTECTION BUFFER ERRNO) then BUFFER else (\UFSError FILENAME ERRNO DEVICE))) (ALL (SETQ BUFFER (\UFS.CREATE.PROPS)) (if (SETQ NAMESIZE (\UFSGetFileInfo-C FILENAME ATTR-ALL BUFFER ERRNO)) then (LET ((ALIST (ASSOC (QUOTE AUTHOR) BUFFER))) (* ; "Copy string out of buffer") (RPLACD ALIST (CL:SUBSEQ (CDR ALIST) 0 NAMESIZE)) BUFFER) else (\UFSError FILENAME ERRNO DEVICE))) NIL)))))
|
||||
)
|
||||
[LAMBDA (STREAM ATTRIBUTE DEVICE) (* ; "Edited 16-Oct-2025 08:49 by rmk")
|
||||
(* ; "Edited 30-Mar-90 12:27 by nm")
|
||||
|
||||
(* ;;; "Get the value of the attribute for a file.")
|
||||
|
||||
(* ;;; "Allocate buffer to store the value.")
|
||||
|
||||
(* ;;; "If attribute is AUTHOR, the type of the buffer is STRING.")
|
||||
|
||||
(* ;;; "Otherwise the type of the buffer is FIXP.")
|
||||
|
||||
(WITH.MONITOR (\UFSGetMonitor DEVICE)
|
||||
(LET ((FILENAME (if (type? STREAM STREAM)
|
||||
then (fetch (UFSSTREAM UNIXNAME) of STREAM)
|
||||
else (\UFS.FULLNAME (\UFS.RECOGNIZE.FILE STREAM 'OLD DEVICE)
|
||||
DEVICE NIL)))
|
||||
(ERRNO (CREATECELL \FIXP))
|
||||
BUFFER NAMESIZE)
|
||||
(if FILENAME
|
||||
then (SETQ FILENAME (MTOUTF8STRING FILENAME))
|
||||
(SELECTQ ATTRIBUTE
|
||||
(LENGTH (SETQ BUFFER (CREATECELL \FIXP))
|
||||
(if (\UFSGetFileInfo-C FILENAME ATTR-LENGTH BUFFER ERRNO)
|
||||
then BUFFER
|
||||
else (\UFSError FILENAME ERRNO DEVICE)))
|
||||
(SIZE (SETQ BUFFER (CREATECELL \FIXP))
|
||||
(if (\UFSGetFileInfo-C FILENAME ATTR-LENGTH BUFFER ERRNO)
|
||||
then (FOLDHI BUFFER BYTESPERPAGE)
|
||||
else (\UFSError FILENAME ERRNO DEVICE)))
|
||||
(TYPE (\UFSGetFileType FILENAME))
|
||||
((CREATIONDATE WRITEDATE)
|
||||
(SETQ BUFFER (CREATECELL \FIXP))
|
||||
(if (\UFSGetFileInfo-C FILENAME ATTR-WDATE BUFFER ERRNO)
|
||||
then (GDATE BUFFER)
|
||||
else (\UFSError FILENAME ERRNO DEVICE)))
|
||||
(READDATE (SETQ BUFFER (CREATECELL \FIXP))
|
||||
(if (\UFSGetFileInfo-C FILENAME ATTR-RDATE BUFFER ERRNO)
|
||||
then (GDATE BUFFER)
|
||||
else (\UFSError FILENAME ERRNO DEVICE)))
|
||||
((ICREATIONDATE IWRITEDATE)
|
||||
(SETQ BUFFER (CREATECELL \FIXP))
|
||||
(if (\UFSGetFileInfo-C FILENAME ATTR-WDATE BUFFER ERRNO)
|
||||
then BUFFER
|
||||
else (\UFSError FILENAME ERRNO DEVICE)))
|
||||
(IREADDATE (SETQ BUFFER (CREATECELL \FIXP))
|
||||
(if (\UFSGetFileInfo-C FILENAME ATTR-RDATE BUFFER ERRNO)
|
||||
then BUFFER
|
||||
else (\UFSError FILENAME ERRNO DEVICE)))
|
||||
(AUTHOR (SETQ BUFFER (ALLOCSTRING MAX-UNAME-LEN))
|
||||
(if (SETQ NAMESIZE (\UFSGetFileInfo-C FILENAME ATTR-AUTHOR BUFFER
|
||||
ERRNO))
|
||||
then (UTF8TOMSTRING (CL:SUBSEQ BUFFER 0 NAMESIZE))
|
||||
else (\UFSError FILENAME ERRNO DEVICE)))
|
||||
(PROTECTION (SETQ BUFFER (CREATECELL \FIXP))
|
||||
(if (\UFSGetFileInfo-C FILENAME ATTR-PROTECTION BUFFER ERRNO)
|
||||
then BUFFER
|
||||
else (\UFSError FILENAME ERRNO DEVICE)))
|
||||
(ALL (SETQ BUFFER (\UFS.CREATE.PROPS))
|
||||
(if (SETQ NAMESIZE (\UFSGetFileInfo-C FILENAME ATTR-ALL BUFFER ERRNO))
|
||||
then (LET ((ALIST (ASSOC 'AUTHOR BUFFER)))
|
||||
(* ; "Copy string out of buffer")
|
||||
(RPLACD ALIST (CL:SUBSEQ (CDR ALIST)
|
||||
0 NAMESIZE))
|
||||
BUFFER)
|
||||
else (\UFSError FILENAME ERRNO DEVICE)))
|
||||
NIL))))])
|
||||
|
||||
(\UFS.CREATE.PROPS
|
||||
(LAMBDA NIL (* ; "Edited 2-Mar-89 12:10 by bvm") (* ;; "Returns a data structure suitable for passing to the GetFileInfo ALL routine") (BQUOTE ((LENGTH (\,@ (CREATECELL \FIXP))) (WDATE (\,@ (CREATECELL \FIXP))) (RDATE (\,@ (CREATECELL \FIXP))) (PROTECTION (\,@ (CREATECELL \FIXP))) (AUTHOR (\,@ (ALLOCSTRING MAX-UNAME-LEN))))))
|
||||
)
|
||||
|
||||
(\UFSSetFileInfo
|
||||
(LAMBDA (STREAM ATTRIBUTE VALUE DEVICE) (* ; "Edited 30-Mar-90 12:31 by nm") (* ;;; "Get the VALUE of the ATTRIBUTE for a file.") (* ;;; "Allocate buffer to store the value.") (* ;;; "If attribute is AUTOR, the type of the buffer is STRING.") (* ;;; " Otherwise the type of the buffer is FIXP.") (WITH.MONITOR (\UFSGetMonitor DEVICE) (LET ((FILENAME (if (type? STREAM STREAM) then (fetch (UFSSTREAM UNIXNAME) of STREAM) else (\UFS.FULLNAME (\UFS.RECOGNIZE.FILE STREAM (QUOTE OLD) DEVICE) DEVICE NIL))) (ERRNO (CREATECELL \FIXP)) BUFFER NAMESIZE PATHNAME) (if FILENAME then (SELECTQ ATTRIBUTE (TYPE (\UFSSetFileType FILENAME VALUE)) ((CREATIONDATE WRITEDATE) (if (AND (STRINGP VALUE) (SETQ VALUE (IDATE VALUE))) then (OR (\UFSSetFileInfo-C FILENAME ATTR-WDATE VALUE ERRNO) (\UFSError FILENAME ERRNO DEVICE)) else (ERROR "Invalid argument" VALUE))) ((ICREATIONDATE IWRITEDATE) (if (FIXP VALUE) then (OR (\UFSSetFileInfo-C FILENAME ATTR-WDATE VALUE ERRNO) (\UFSError FILENAME ERRNO DEVICE)) else (ERROR "Invalid argument" VALUE))) (PROTECTION (if (FIXP VALUE) then (OR (\UFSSetFileInfo-C FILENAME ATTR-PROTECTION VALUE ERRNO) (\UFSError FILENAME ERRNO DEVICE)) else (ERROR "Invalid argument" VALUE))) NIL)))))
|
||||
)
|
||||
[LAMBDA (STREAM ATTRIBUTE VALUE DEVICE) (* ; "Edited 16-Oct-2025 08:51 by rmk")
|
||||
(* ; "Edited 30-Mar-90 12:31 by nm")
|
||||
|
||||
(* ;;; "Get the VALUE of the ATTRIBUTE for a file.")
|
||||
|
||||
(* ;;; "Allocate buffer to store the value.")
|
||||
|
||||
(* ;;; "If attribute is AUTOR, the type of the buffer is STRING.")
|
||||
|
||||
(* ;;; " Otherwise the type of the buffer is FIXP.")
|
||||
|
||||
(WITH.MONITOR (\UFSGetMonitor DEVICE)
|
||||
(LET ((FILENAME (if (type? STREAM STREAM)
|
||||
then (fetch (UFSSTREAM UNIXNAME) of STREAM)
|
||||
else (\UFS.FULLNAME (\UFS.RECOGNIZE.FILE STREAM 'OLD DEVICE)
|
||||
DEVICE NIL)))
|
||||
(ERRNO (CREATECELL \FIXP))
|
||||
BUFFER NAMESIZE PATHNAME)
|
||||
(if FILENAME
|
||||
then (SETQ FILENAME (MTOUTF8STRING FILENAME))
|
||||
(SELECTQ ATTRIBUTE
|
||||
(TYPE (\UFSSetFileType FILENAME VALUE))
|
||||
((CREATIONDATE WRITEDATE)
|
||||
(if (AND (STRINGP VALUE)
|
||||
(SETQ VALUE (IDATE VALUE)))
|
||||
then (OR (\UFSSetFileInfo-C FILENAME ATTR-WDATE VALUE ERRNO)
|
||||
(\UFSError FILENAME ERRNO DEVICE))
|
||||
else (ERROR "Invalid argument" VALUE)))
|
||||
((ICREATIONDATE IWRITEDATE)
|
||||
(if (FIXP VALUE)
|
||||
then (OR (\UFSSetFileInfo-C FILENAME ATTR-WDATE VALUE ERRNO)
|
||||
(\UFSError FILENAME ERRNO DEVICE))
|
||||
else (ERROR "Invalid argument" VALUE)))
|
||||
(PROTECTION (if (FIXP VALUE)
|
||||
then (OR (\UFSSetFileInfo-C FILENAME ATTR-PROTECTION VALUE
|
||||
ERRNO)
|
||||
(\UFSError FILENAME ERRNO DEVICE))
|
||||
else (ERROR "Invalid argument" VALUE)))
|
||||
NIL))))])
|
||||
|
||||
(\UFSGenerateFiles
|
||||
[LAMBDA (FDEV PATTERN DESIREDPROPS OPTIONS)
|
||||
|
||||
(* ;; "Edited 16-Oct-2025 11:06 by rmk")
|
||||
|
||||
(* ;; "Edited 27-Mar-2022 15:55 by rmk: Use the EXTENSION and VERFSION in the pattern instead of the inherited defaults")
|
||||
|
||||
(* ;; "rmk; Use the EXTENSION and VERFSION in the pattern instead of the inherited defaults")
|
||||
@@ -435,19 +774,22 @@
|
||||
(COND
|
||||
((STREQUAL DIRECTORY "/")
|
||||
(SETQ DIRECTORY "<")))
|
||||
[SETQ FILTER (COND
|
||||
((STREQUAL DIRECTORY "<")
|
||||
(CONCAT "{" (LISTGET PARSED 'HOST)
|
||||
"}"
|
||||
(OR DEVICE "")
|
||||
"<"
|
||||
(PACKFILENAME.STRING 'NAME NAME 'EXTENSION EXTENSION
|
||||
'VERSION VERSION)))
|
||||
(T (PACKFILENAME.STRING 'DIRECTORY DIRECTORY 'HOST (LISTGET
|
||||
PARSED
|
||||
'HOST)
|
||||
'DEVICE DEVICE 'NAME NAME 'EXTENSION EXTENSION 'VERSION
|
||||
VERSION]
|
||||
|
||||
(* ;; "DIRECTORY is MCCS, FILTER is UTF8")
|
||||
|
||||
[SETQ FILTER (MTOUTF8STRING (COND
|
||||
((STREQUAL DIRECTORY "<")
|
||||
(CONCAT "{" (LISTGET PARSED 'HOST)
|
||||
"}"
|
||||
(OR DEVICE "")
|
||||
"<"
|
||||
(PACKFILENAME.STRING 'NAME NAME 'EXTENSION
|
||||
EXTENSION 'VERSION VERSION)))
|
||||
(T (PACKFILENAME.STRING 'DIRECTORY DIRECTORY
|
||||
'HOST
|
||||
(LISTGET PARSED 'HOST)
|
||||
'DEVICE DEVICE 'NAME NAME 'EXTENSION
|
||||
EXTENSION 'VERSION VERSION]
|
||||
(SETQ LEN (\UFS.DIRECTORY.NAME (CONCAT (OR DEVICE "")
|
||||
DIRECTORY)
|
||||
NAMEAREA FDEV))
|
||||
@@ -455,7 +797,7 @@
|
||||
((NOT (FIXP LEN)) (* ; "No such directory. We go thru this recognition step so that \UFSFindFile gives us name in the correct case")
|
||||
(PRINTOUT PROMPTWINDOW T "Can't enumerate " PATTERN " because no such directory")
|
||||
(RETURN (\NULLFILEGENERATOR]
|
||||
(SETQ DIRECTORY (SUBSTRING NAMEAREA 1 LEN))
|
||||
(SETQ DIRECTORY (SUBSTRING NAMEAREA 1 LEN)) (* ; "DIRECTORY is now UTF8")
|
||||
|
||||
(* ;; "The information about enumerated files are cached in the emulator. We receive the ID and the total number of enumerated files. The ID is used to identify the object corresponding to the enumerated file.")
|
||||
|
||||
@@ -466,7 +808,8 @@
|
||||
(SETQ TOTALNUM (\UFSReadDir-C FILTER PROPP ID ERRNO))
|
||||
(COND
|
||||
[(< TOTALNUM 0)
|
||||
(OR (\UFSError DIRECTORY ERRNO FDEV)
|
||||
(OR (\UFSError (UTF8TOMSTRING DIRECTORY)
|
||||
ERRNO FDEV)
|
||||
(RETURN (\NULLFILEGENERATOR]
|
||||
(T (COND
|
||||
((ZEROP TOTALNUM)
|
||||
@@ -475,6 +818,9 @@
|
||||
(EQ OPTIONS 'RESETLST))
|
||||
(FMEMB 'RESETLST OPTIONS))
|
||||
(RESETSAVE NIL '(AND RESETSTATE (\UFSFinishFileInfo-C ID]
|
||||
|
||||
(* ;; "Everything in FILEGENOBJ is UTF8")
|
||||
|
||||
(RETURN (create FILEGENOBJ
|
||||
NEXTFILEFN _ (FUNCTION \UFS.NEXTFILEFN)
|
||||
FILEINFOFN _ (FUNCTION \UFS.FILEINFOFN)
|
||||
@@ -496,24 +842,31 @@
|
||||
CURRENT-DEPTH _ 1
|
||||
MAX-DEPTH _
|
||||
FILING.ENUMERATION.DEPTH
|
||||
FILTER _ (
|
||||
PACKFILENAME.STRING
|
||||
'NAME NAME
|
||||
'EXTENSION
|
||||
EXTENSION
|
||||
'VERSION VERSION])
|
||||
])
|
||||
FILTER _
|
||||
(PACKFILENAME.STRING
|
||||
'NAME
|
||||
(AND NAME (MTOUTF8STRING
|
||||
NAME))
|
||||
'EXTENSION
|
||||
(AND EXTENSION (
|
||||
MTOUTF8STRING
|
||||
EXTENSION))
|
||||
'VERSION VERSION])])
|
||||
|
||||
(\UFS.NEXTFILEFN
|
||||
[LAMBDA (GENFILESTATE NAMEONLY)
|
||||
|
||||
(* ;; "Edited 16-Oct-2025 16:59 by rmk")
|
||||
|
||||
(* ;;
|
||||
"Edited 27-Mar-2022 21:59 by rmk: Add FILTER to construct proper generator for subdirectories")
|
||||
|
||||
(* ;; "Edited 7-Oct-93 14:31 by jds")
|
||||
|
||||
(* ;; "Given a UFS filesystem generator, return the %"next%" file in line.")
|
||||
(* ; "")
|
||||
|
||||
(* ;; "All the fields of the UFSGENFILESTATE are UTF8. FILENAME is MCCS")
|
||||
|
||||
(LET ((SUBGEN (fetch (UFSGENFILESTATE SUBGENERATOR) of GENFILESTATE))
|
||||
FILENAME NAMELEN NEWNAME)
|
||||
(COND
|
||||
@@ -556,6 +909,9 @@
|
||||
GENFILESTATE
|
||||
)
|
||||
0 NAMELEN))
|
||||
|
||||
(* ;; "NEWNAME and DIRECTORY are both UTF8")
|
||||
|
||||
(SETQ FILENAME (\UFS.FULLNAME.M (fetch (UFSGENFILESTATE DIRECTORY)
|
||||
of GENFILESTATE)
|
||||
NEWNAME
|
||||
@@ -607,8 +963,8 @@
|
||||
(* ;; "We're set up to recurse into the SUBGEN above")
|
||||
|
||||
(\UFS.NEXTFILEFN GENFILESTATE NAMEONLY))
|
||||
(NAMEONLY NEWNAME)
|
||||
(T FILENAME)))
|
||||
(NAMEONLY (UTF8TOMSTRING NEWNAME))
|
||||
(T (UTF8TOMSTRING FILENAME))))
|
||||
(AND RESETSTATE (\UFS.UNREGISTER.GFS GENFILESTATE T)))])
|
||||
|
||||
(\UFS.FILEINFOFN
|
||||
@@ -720,8 +1076,25 @@
|
||||
(DEFINEQ
|
||||
|
||||
(CHDIR
|
||||
(LAMBDA (PATHNAME) (* ; "Edited 2-Apr-90 01:07 by nm") (* ;;; "(\CALL-C SUBR-UFS-DIRECTORYNAMEP ..) returns T(=1) or NIL.") (WITH.MONITOR \UFStopMonitor (LET ((PATH (\ADD.CONNECTED.DIR PATHNAME)) HOST) (if PATH then (SETQ HOST (U-CASE (FILENAMEFIELD PATH (QUOTE HOST)))) (if (OR (EQ HOST (QUOTE DSK)) (EQ HOST (QUOTE UNIX))) then (if (SETQ PATH (DIRECTORYNAME PATH)) then (if (\UFSCHDIR-C PATH) then (DIRECTORYNAME PATH) else (ERROR "NO-SUCH-DIRECTORY" PATHNAME)) else (ERROR "NO-SUCH-DIRECTORY" PATHNAME)) else (ERROR "Bad Host Name" HOST)) else (ERROR "NO-SUCH-DIRECTORY" PATHNAME)))))
|
||||
)
|
||||
[LAMBDA (PATHNAME) (* ; "Edited 16-Oct-2025 18:22 by rmk")
|
||||
(* ; "Edited 2-Apr-90 01:07 by nm")
|
||||
|
||||
(* ;;; "(\CALL-C SUBR-UFS-DIRECTORYNAMEP ..) returns T(=1) or NIL.")
|
||||
|
||||
(WITH.MONITOR \UFStopMonitor
|
||||
(LET ((PATH (\ADD.CONNECTED.DIR PATHNAME))
|
||||
HOST)
|
||||
(if PATH
|
||||
then [SETQ HOST (U-CASE (FILENAMEFIELD PATH 'HOST]
|
||||
(if (OR (EQ HOST 'DSK)
|
||||
(EQ HOST 'UNIX))
|
||||
then (if (SETQ PATH (DIRECTORYNAME PATH))
|
||||
then (if (\UFSCHDIR-C (MTOUTF8STRING PATH))
|
||||
then (DIRECTORYNAME PATH)
|
||||
else (ERROR "NO-SUCH-DIRECTORY" PATHNAME))
|
||||
else (ERROR "NO-SUCH-DIRECTORY" PATHNAME))
|
||||
else (ERROR "Bad Host Name" HOST))
|
||||
else (ERROR "NO-SUCH-DIRECTORY" PATHNAME))))])
|
||||
)
|
||||
|
||||
|
||||
@@ -1184,23 +1557,23 @@ update the map") (SETQ PAGES (RESTOREMAP STREAM))) (DELETED (* ; "the file disap
|
||||
(ADDTOVAR LAMA )
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (8857 10410 (\UFSCreateDevice 8867 . 9232) (\UFS.CREATE.DEVICE 9234 . 10090) (
|
||||
\UFSOpenDevice 10092 . 10269) (\UFSCloseDevice 10271 . 10408)) (14673 52047 (\UFSOpenFile 14683 .
|
||||
17977) (\UFS.OPENP 17979 . 18476) (\UFS.RECOGNIZE.FILE 18478 . 19231) (\UFS.DIRECTORY.NAME 19233 .
|
||||
19976) (\UFSCloseFile 19978 . 21883) (\UFSGetFileName 21885 . 22084) (\UFSDeleteFile 22086 . 22626) (
|
||||
\UFSRenameFile 22628 . 24665) (\UFSReadPages 24667 . 25802) (\UFSWritePages 25804 . 27024) (
|
||||
\UFSTruncateFile 27026 . 28523) (\UFSDirectoryNameP 28525 . 29579) (\UFSEventFn 29581 . 30243) (
|
||||
\UFSGetFileInfo 30245 . 32527) (\UFS.CREATE.PROPS 32529 . 32882) (\UFSSetFileInfo 32884 . 34113) (
|
||||
\UFSGenerateFiles 34115 . 40995) (\UFS.NEXTFILEFN 40997 . 48635) (\UFS.FILEINFOFN 48637 . 50086) (
|
||||
\UFS.VALID.PROPP 50088 . 50380) (\UFS.REGISTER.GFS 50382 . 50637) (\UFS.UNREGISTER.GFS 50639 . 51222)
|
||||
(\UFS.ABORT.DIRECTORY 51224 . 51572) (\UFS.ABORT.CL-DIRECTORY 51574 . 51861) (\UFS.CLEANUP.GFS.TABLE
|
||||
51863 . 52045)) (52082 58766 (\UFSMakeUnixFormatName 52092 . 53113) (\UFSParseNameString 53115 . 53489
|
||||
) (\UFSParse-Directory 53491 . 54032) (\UFS.PARSE.BODY 54034 . 54579) (\UFS.ADJUST.HOST 54581 . 54740)
|
||||
(\UFS.FULLNAME 54742 . 55950) (\UFS.ADD.HOST.FIELD 55952 . 56312) (\UFS.REMOVE.HOST.FIELD 56314 .
|
||||
57984) (\UFS.HANDLE.RELATIVEDIRECTORY 57986 . 58764)) (59582 60195 (CHDIR 59592 . 60193)) (60267 61253
|
||||
(\DEVICEFILE.EOSERROR 60277 . 61251)) (61326 62563 (\UNVISIBLE.PAGED.REVALIDATEFILELST 61336 . 62181)
|
||||
(\UNVISIBLE.FLUSH.OPEN.STREAMS 62183 . 62561)) (62596 64222 (\UFSError 62606 . 64220)) (64266 66681 (
|
||||
\UFSGetFileType 64276 . 64877) (\UFSSetFileType 64879 . 65476) (\UFSeol 65478 . 66679)) (75328 76452 (
|
||||
\UFSGetPrintFileType 75338 . 75750) (\UFSGetFileTypeConfirm 75752 . 76200) (\UFSPrintTypeMenu 76202 .
|
||||
76450)) (76482 79320 (\UFStoOtherCopyMess 76492 . 78170) (\UFStoOtherRenameMess 78172 . 79318)))))
|
||||
(FILEMAP (NIL (9321 10874 (\UFSCreateDevice 9331 . 9696) (\UFS.CREATE.DEVICE 9698 . 10554) (
|
||||
\UFSOpenDevice 10556 . 10733) (\UFSCloseDevice 10735 . 10872)) (15137 63831 (\UFSOpenFile 15147 .
|
||||
21723) (\UFS.OPENP 21725 . 22222) (\UFS.RECOGNIZE.FILE 22224 . 23654) (\UFS.DIRECTORY.NAME 23656 .
|
||||
24746) (\UFSCloseFile 24748 . 26807) (\UFSGetFileName 26809 . 27008) (\UFSDeleteFile 27010 . 28204) (
|
||||
\UFSRenameFile 28206 . 30523) (\UFSReadPages 30525 . 31660) (\UFSWritePages 31662 . 32882) (
|
||||
\UFSTruncateFile 32884 . 35290) (\UFSDirectoryNameP 35292 . 37155) (\UFSEventFn 37157 . 37819) (
|
||||
\UFSGetFileInfo 37821 . 42284) (\UFS.CREATE.PROPS 42286 . 42639) (\UFSSetFileInfo 42641 . 44987) (
|
||||
\UFSGenerateFiles 44989 . 52601) (\UFS.NEXTFILEFN 52603 . 60419) (\UFS.FILEINFOFN 60421 . 61870) (
|
||||
\UFS.VALID.PROPP 61872 . 62164) (\UFS.REGISTER.GFS 62166 . 62421) (\UFS.UNREGISTER.GFS 62423 . 63006)
|
||||
(\UFS.ABORT.DIRECTORY 63008 . 63356) (\UFS.ABORT.CL-DIRECTORY 63358 . 63645) (\UFS.CLEANUP.GFS.TABLE
|
||||
63647 . 63829)) (63866 70550 (\UFSMakeUnixFormatName 63876 . 64897) (\UFSParseNameString 64899 . 65273
|
||||
) (\UFSParse-Directory 65275 . 65816) (\UFS.PARSE.BODY 65818 . 66363) (\UFS.ADJUST.HOST 66365 . 66524)
|
||||
(\UFS.FULLNAME 66526 . 67734) (\UFS.ADD.HOST.FIELD 67736 . 68096) (\UFS.REMOVE.HOST.FIELD 68098 .
|
||||
69768) (\UFS.HANDLE.RELATIVEDIRECTORY 69770 . 70548)) (71366 72511 (CHDIR 71376 . 72509)) (72583 73569
|
||||
(\DEVICEFILE.EOSERROR 72593 . 73567)) (73642 74879 (\UNVISIBLE.PAGED.REVALIDATEFILELST 73652 . 74497)
|
||||
(\UNVISIBLE.FLUSH.OPEN.STREAMS 74499 . 74877)) (74912 76538 (\UFSError 74922 . 76536)) (76582 78997 (
|
||||
\UFSGetFileType 76592 . 77193) (\UFSSetFileType 77195 . 77792) (\UFSeol 77794 . 78995)) (87644 88768 (
|
||||
\UFSGetPrintFileType 87654 . 88066) (\UFSGetFileTypeConfirm 88068 . 88516) (\UFSPrintTypeMenu 88518 .
|
||||
88766)) (88798 91636 (\UFStoOtherCopyMess 88808 . 90486) (\UFStoOtherRenameMess 90488 . 91634)))))
|
||||
STOP
|
||||
|
||||
BIN
sources/UFS.LCOM
BIN
sources/UFS.LCOM
Binary file not shown.
Reference in New Issue
Block a user