Compare commits
17 Commits
fgh_new-li
...
medley-240
| Author | SHA1 | Date | |
|---|---|---|---|
|
|
e276460836 | ||
|
|
ab818ff335 | ||
|
|
47d77542be | ||
|
|
934d0fb7a4 | ||
|
|
6420bdcf27 | ||
|
|
1d6e43e1ea | ||
|
|
8837c61f85 | ||
|
|
18aae01362 | ||
|
|
a84242561a | ||
|
|
70885c5a19 | ||
|
|
57de705f39 | ||
|
|
7c3fa261c7 | ||
|
|
7fe4d2dcca | ||
|
|
30a4697d75 | ||
|
|
60a766574d | ||
|
|
25a18f6bc0 | ||
|
|
6558a49adb |
@@ -1,16 +1,13 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "25-Jul-2022 15:09:26" {DSK}<Users>kaplan>Local>medley3.5>working-medley>library>HRULE.;4 23801
|
||||
(FILECREATED "26-Nov-2023 09:46:44" {WMEDLEY}<library>HRULE.;5 23918
|
||||
|
||||
:CHANGES-TO (VARS HRULECOMS)
|
||||
:EDIT-BY rmk
|
||||
|
||||
:PREVIOUS-DATE "25-Jul-2022 15:07:00"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>working-medley>library>HRULE.;3)
|
||||
:CHANGES-TO (FNS HRULE.CREATE VRULE.CREATE CROPMARK.CREATE)
|
||||
|
||||
:PREVIOUS-DATE "25-Jul-2022 15:09:26" {WMEDLEY}<library>HRULE.;4)
|
||||
|
||||
(* ; "
|
||||
Copyright (c) 1985, 1990-1992 by Venue & Xerox Corporation.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT HRULECOMS)
|
||||
|
||||
@@ -90,30 +87,27 @@ Copyright (c) 1985, 1990-1992 by Venue & Xerox Corporation.
|
||||
(DEFINEQ
|
||||
|
||||
(HRULE.CREATE
|
||||
[LAMBDA (WIDTH) (* jds "11-Sep-85 16:36")
|
||||
[LAMBDA (WIDTH) (* ; "Edited 26-Nov-2023 09:45 by rmk")
|
||||
(* jds "11-Sep-85 16:36")
|
||||
|
||||
(* * Create a Horizontal-Rule image object.
|
||||
WIDTH may be NIL to default, a number, for a single rule with its width in
|
||||
points (and fractions thereof)%, or a list of alternating black and white
|
||||
widths. E.g., to get a hairline over 1pt white over 3pt rule, specify
|
||||
(0.5 1 3))
|
||||
(* ;;; "Create a Horizontal-Rule image object. WIDTH may be NIL to default, a number, for a single rule with its width in points (and fractions thereof), or a list of alternating black and white widths. E.g., to get a hairline over 1pt white over 3pt rule, specify (0.5 1 3)")
|
||||
|
||||
(PROG ((HRULE (IMAGEOBJCREATE NIL HRULE.IMAGEFNS)))
|
||||
(COND
|
||||
((NOT WIDTH) (* USe the default width)
|
||||
((NOT WIDTH) (* ; "USe the default width")
|
||||
(IMAGEOBJPROP HRULE 'RULE.WIDTH HRULE.DEFAULT.WIDTH)
|
||||
(RETURN HRULE))
|
||||
((NUMBERP WIDTH)
|
||||
(IMAGEOBJPROP HRULE 'RULE.WIDTH WIDTH)
|
||||
(RETURN HRULE))
|
||||
((AND (LISTP WIDTH)
|
||||
(EVERY WIDTH (FUNCTION NUMBERP))) (* It's a list of numbers.
|
||||
Add (QUOTE em) up)
|
||||
(EVERY WIDTH (FUNCTION NUMBERP))) (* ;
|
||||
"It's a list of numbers. Add (QUOTE em) up")
|
||||
(IMAGEOBJPROP HRULE 'RULE.WIDTH WIDTH)
|
||||
(RETURN HRULE))
|
||||
(T (* Something was specified, and
|
||||
there was a non-number in it...)
|
||||
(TEDIT.PROMPTPRINT TEXTOBJ (CONCAT "Non-numeric widths not desirable: " WIDTH)
|
||||
(T (* ;
|
||||
"Something was specified, and there was a non-number in it...")
|
||||
(TEDIT.PROMPTPRINT TEXTOBJ (CONCAT "HRULE with non-numeric width: " WIDTH)
|
||||
T])
|
||||
|
||||
(HRULE.DISPLAYFN
|
||||
@@ -233,8 +227,9 @@ Copyright (c) 1985, 1990-1992 by Venue & Xerox Corporation.
|
||||
(DEFINEQ
|
||||
|
||||
(VRULE.CREATE
|
||||
[LAMBDA (WIDTH HEIGHT DASHING) (* ;
|
||||
"Edited 8-Oct-92 16:46 by sybalsky:mv:envos")
|
||||
[LAMBDA (WIDTH HEIGHT DASHING) (* ; "Edited 26-Nov-2023 09:45 by rmk")
|
||||
(* ;
|
||||
"Edited 8-Oct-92 16:46 by sybalsky:mv:envos")
|
||||
|
||||
(* ;; "Create a Vertical-Rule image object. HEIGHT may be NIL to default, a number, for a single rule with its width in points (and fractions thereof), or a list of alternating black and white widths. E.g., to get a hairline over 1pt white over 3pt rule, specify (0.5 1 3)")
|
||||
|
||||
@@ -246,7 +241,7 @@ Copyright (c) 1985, 1990-1992 by Venue & Xerox Corporation.
|
||||
(IMAGEOBJPROP VRULE 'RULE.WIDTH WIDTH))
|
||||
((AND (LISTP WIDTH)
|
||||
(EVERY WIDTH (FUNCTION NUMBERP))) (* ;
|
||||
"It's a list of numbers. Add 'em up")
|
||||
"It's a list of numbers. Add 'em up")
|
||||
(IMAGEOBJPROP VRULE 'RULE.WIDTH WIDTH)))
|
||||
(COND
|
||||
((NOT HEIGHT) (* ; "Use the default width")
|
||||
@@ -257,12 +252,12 @@ Copyright (c) 1985, 1990-1992 by Venue & Xerox Corporation.
|
||||
(RETURN VRULE))
|
||||
((AND (LISTP HEIGHT)
|
||||
(EVERY HEIGHT (FUNCTION NUMBERP))) (* ;
|
||||
"It's a list of numbers. Add 'em up")
|
||||
"It's a list of numbers. Add 'em up")
|
||||
(IMAGEOBJPROP VRULE 'RULE.HEIGHT HEIGHT)
|
||||
(RETURN VRULE))
|
||||
(T (* ;
|
||||
"Something was specified, and there was a non-number in it...")
|
||||
(TEDIT.PROMPTPRINT TEXTOBJ (CONCAT "Non-numeric widths not desirable: " HEIGHT)
|
||||
"Something was specified, and there was a non-number in it...")
|
||||
(TEDIT.PROMPTPRINT TEXTOBJ (CONCAT "VRULE with non-numeric height: " HEIGHT)
|
||||
T)))
|
||||
(IMAGEOBJPROP VRULE 'RULE.DASHING DASHING])
|
||||
|
||||
@@ -392,7 +387,8 @@ Copyright (c) 1985, 1990-1992 by Venue & Xerox Corporation.
|
||||
(DEFINEQ
|
||||
|
||||
(CROPMARK.CREATE
|
||||
[LAMBDA (WIDTH HEIGHT) (* ; "Edited 5-Jun-91 14:56 by jds")
|
||||
[LAMBDA (WIDTH HEIGHT) (* ; "Edited 26-Nov-2023 09:46 by rmk")
|
||||
(* ; "Edited 5-Jun-91 14:56 by jds")
|
||||
|
||||
(* ;; "Create a CROPMARK, that prints crop-marks for a page that is WIDTH points wide and HEIGHT points high.")
|
||||
|
||||
@@ -406,12 +402,12 @@ Copyright (c) 1985, 1990-1992 by Venue & Xerox Corporation.
|
||||
(RETURN CROPMARK))
|
||||
((AND (LISTP HEIGHT)
|
||||
(EVERY HEIGHT (FUNCTION NUMBERP))) (* ;
|
||||
"It's a list of numbers. Add 'em up")
|
||||
"It's a list of numbers. Add 'em up")
|
||||
(IMAGEOBJPROP CROPMARK 'PAGE.SIZE (LIST WIDTH HEIGHT))
|
||||
(RETURN CROPMARK))
|
||||
(T (* ;
|
||||
"Something was specified, and there was a non-number in it...")
|
||||
(TEDIT.PROMPTPRINT TEXTOBJ (CONCAT "Non-numeric widths not desirable: " HEIGHT)
|
||||
"Something was specified, and there was a non-number in it...")
|
||||
(TEDIT.PROMPTPRINT TEXTOBJ (CONCAT "CROPMARK with non-numeric height: " HEIGHT)
|
||||
T])
|
||||
|
||||
(CROPMARK.DISPLAYFN
|
||||
@@ -508,14 +504,13 @@ Copyright (c) 1985, 1990-1992 by Venue & Xerox Corporation.
|
||||
(FUNCTION NILL)
|
||||
(FUNCTION CROPMARK.WHENOPERATEDONFN)
|
||||
(FUNCTION NILL)))
|
||||
(PUTPROPS HRULE COPYRIGHT ("Venue & Xerox Corporation" 1985 1990 1991 1992))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (4512 10691 (HRULE.CREATE 4522 . 5944) (HRULE.DISPLAYFN 5946 . 8515) (HRULE.GETFN 8517
|
||||
. 8837) (HRULE.IMAGEBOXFN 8839 . 9641) (HRULE.PUTFN 9643 . 10021) (HRULE.COPYFN 10023 . 10487) (
|
||||
HRULE.WHENOPERATEDONFN 10489 . 10689)) (11583 17788 (VRULE.CREATE 11593 . 13592) (VRULE.DISPLAYFN
|
||||
13594 . 15788) (VRULE.GETFN 15790 . 16011) (VRULE.GETFN2 16013 . 16349) (VRULE.IMAGEBOXFN 16351 .
|
||||
16779) (VRULE.PUTFN 16781 . 17179) (VRULE.COPYFN 17181 . 17584) (VRULE.WHENOPERATEDONFN 17586 . 17786)
|
||||
) (18427 23077 (CROPMARK.CREATE 18437 . 19704) (CROPMARK.DISPLAYFN 19706 . 21206) (CROPMARK.GETFN
|
||||
21208 . 21502) (CROPMARK.IMAGEBOXFN 21504 . 22205) (CROPMARK.PUTFN 22207 . 22485) (CROPMARK.COPYFN
|
||||
22487 . 22870) (CROPMARK.WHENOPERATEDONFN 22872 . 23075)))))
|
||||
(FILEMAP (NIL (4411 10637 (HRULE.CREATE 4421 . 5890) (HRULE.DISPLAYFN 5892 . 8461) (HRULE.GETFN 8463
|
||||
. 8783) (HRULE.IMAGEBOXFN 8785 . 9587) (HRULE.PUTFN 9589 . 9967) (HRULE.COPYFN 9969 . 10433) (
|
||||
HRULE.WHENOPERATEDONFN 10435 . 10635)) (11529 17865 (VRULE.CREATE 11539 . 13669) (VRULE.DISPLAYFN
|
||||
13671 . 15865) (VRULE.GETFN 15867 . 16088) (VRULE.GETFN2 16090 . 16426) (VRULE.IMAGEBOXFN 16428 .
|
||||
16856) (VRULE.PUTFN 16858 . 17256) (VRULE.COPYFN 17258 . 17661) (VRULE.WHENOPERATEDONFN 17663 . 17863)
|
||||
) (18504 23271 (CROPMARK.CREATE 18514 . 19898) (CROPMARK.DISPLAYFN 19900 . 21400) (CROPMARK.GETFN
|
||||
21402 . 21696) (CROPMARK.IMAGEBOXFN 21698 . 22399) (CROPMARK.PUTFN 22401 . 22679) (CROPMARK.COPYFN
|
||||
22681 . 23064) (CROPMARK.WHENOPERATEDONFN 23066 . 23269)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
437
library/UNICODE
437
library/UNICODE
@@ -1,12 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "19-Jul-2023 09:26:13" {WMEDLEY}<library>UNICODE.;199 65282
|
||||
(FILECREATED " 8-Jan-2024 10:58:06" {WMEDLEY}<library>UNICODE.;212 72240
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (VARS UNICODECOMS)
|
||||
:CHANGES-TO (FNS NUTF8CODEBYTES)
|
||||
|
||||
:PREVIOUS-DATE "19-Jul-2022 15:36:40" {WMEDLEY}<library>UNICODE.;198)
|
||||
:PREVIOUS-DATE " 5-Jan-2024 17:25:29" {WMEDLEY}<library>UNICODE.;211)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT UNICODECOMS)
|
||||
@@ -23,7 +23,7 @@
|
||||
(ADDVARS (*DEFAULT-EXTERNALFORMATS* (UNIX :UTF-8)))
|
||||
(FNS UNICODE.UNMAPPED)
|
||||
(FNS XCCS-UTF8-AFTER-OPEN)
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY (MACROS UNICODE.TRANSLATE))
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY (MACROS UNICODE.TRANSLATE \UTF8.GETBASEBYTE))
|
||||
(FNS XTOUCODE UTOXCODE))
|
||||
(COMS
|
||||
(* ;; "Unicode mapping files")
|
||||
@@ -45,8 +45,10 @@
|
||||
(* ;; "Set up translation tables for UTF8 and UTFBE external formats")
|
||||
|
||||
(FNS MAKE-UNICODE-TRANSLATION-TABLES)
|
||||
[INITVARS (DEFAULT-XCCS-CHARSETS '(LATIN SYMBOLS1 SYMBOLS2 EXTENDED-LATIN FORMS
|
||||
SYMBOLS3 SYMBOLS4 ACCENTED-LATIN GREEK]
|
||||
[INITVARS (DEFAULT-XCCS-CHARSETS '(LATIN JAPANESE-SYMBOLS1 JAPANESE-SYMBOLS2
|
||||
EXTENDED-LATIN FORMS SYMBOLS1 SYMBOLS2
|
||||
ACCENTED-LATIN1 GREEK))
|
||||
(DEFAULT-XCCS-JAPANESE-CHARSETS '(HIRAGANA KATAKANA JIS]
|
||||
[DECLARE%: DONTEVAL@LOAD DOCOPY (P (MAKE-UNICODE-TRANSLATION-TABLES (
|
||||
READ-UNICODE-MAPPING
|
||||
|
||||
@@ -55,7 +57,9 @@
|
||||
'*XCCSTOUNICODE*
|
||||
'*UNICODETOXCCS*]
|
||||
(GLOBALVARS *XCCSTOUNICODE* *UNICODETOXCCS*))
|
||||
(FNS HEXSTRING UTF8HEXSTRING NUTF8CODEBYTES NUTF8STRINGBYTES XTOUSTRING XCCSSTRING)
|
||||
(FNS UTF-8.VALIDATE HEXSTRING UTF8HEXSTRING NUTF8CODEBYTES NUTF8STRINGBYTES XTOUSTRING
|
||||
XCCSSTRING)
|
||||
(FNS \UTF8.FETCHCODE)
|
||||
(FNS SHOWCHARS)
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY (FILES (FROM LOADUPS)
|
||||
EXPORTS.ALL)
|
||||
@@ -402,7 +406,8 @@
|
||||
(DEFINEQ
|
||||
|
||||
(MAKE-UNICODE-FORMATS
|
||||
[LAMBDA (EXTERNALEOL) (* ; "Edited 19-Jul-2022 15:36 by rmk")
|
||||
[LAMBDA (EXTERNALEOL) (* ; "Edited 8-Dec-2023 15:19 by rmk")
|
||||
(* ; "Edited 19-Jul-2022 15:36 by rmk")
|
||||
(* ; "Edited 6-Aug-2021 16:08 by rmk:")
|
||||
|
||||
(* ;; "RAW formats do not do XCCS/Unicode translation, just deal with the byte encoding.")
|
||||
@@ -413,7 +418,7 @@
|
||||
(FUNCTION UTF8.PEEKCCODEFN)
|
||||
(FUNCTION \UTF8.BACKCCODEFN)
|
||||
(FUNCTION UTF8.OUTCHARFN)
|
||||
NIL EXTERNALEOL)
|
||||
NIL EXTERNALEOL NIL NIL NIL (FUNCTION NILL))
|
||||
(MAKE-EXTERNALFORMAT :UTF-8-RAW [FUNCTION (LAMBDA (STREAM COUNTP)
|
||||
(UTF8.INCCODEFN STREAM COUNTP T]
|
||||
[FUNCTION (LAMBDA (STREAM NOERROR)
|
||||
@@ -422,12 +427,12 @@
|
||||
(\UTF8.BACKCCODEFN STREAM COUNTP T]
|
||||
[FUNCTION (LAMBDA (STREAM CHARCODE)
|
||||
(UTF8.OUTCHARFN STREAM CHARCODE T]
|
||||
NIL EXTERNALEOL)
|
||||
NIL EXTERNALEOL NIL NIL NIL (FUNCTION NILL))
|
||||
(MAKE-EXTERNALFORMAT :UTF-16BE (FUNCTION UTF16BE.INCCODEFN)
|
||||
(FUNCTION UTF16BE.PEEKCCODEFN)
|
||||
(FUNCTION \UTF16BE.BACKCCODEFN)
|
||||
(FUNCTION UTF16BE.OUTCHARFN)
|
||||
NIL EXTERNALEOL)
|
||||
NIL EXTERNALEOL NIL NIL NIL (FUNCTION NILL))
|
||||
(MAKE-EXTERNALFORMAT :UTF-16BE-RAW [FUNCTION (LAMBDA (STREAM COUNTP)
|
||||
(UTF16BE.INCCODEFN STREAM COUNTP T]
|
||||
[FUNCTION (LAMBDA (STREAM NOERROR)
|
||||
@@ -436,7 +441,7 @@
|
||||
(\UTF16BE.BACKCCODEFN STREAM COUNTP T]
|
||||
[FUNCTION (LAMBDA (STREAM CHARCODE)
|
||||
(UTF16BE.OUTCHARFN STREAM CHARCODE T]
|
||||
NIL EXTERNALEOL])
|
||||
NIL EXTERNALEOL NIL NIL NIL (FUNCTION NILL])
|
||||
)
|
||||
|
||||
(MAKE-UNICODE-FORMATS EXTERNALEOL)
|
||||
@@ -469,15 +474,17 @@
|
||||
(DEFINEQ
|
||||
|
||||
(XCCS-UTF8-AFTER-OPEN
|
||||
[LAMBDA (STREAM ACCESS PARAMETERS) (* ; "Edited 13-Aug-2020 11:54 by rmk:")
|
||||
[LAMBDA (STREAM ACCESS PARAMETERS) (* ; "Edited 3-Jan-2024 10:27 by rmk")
|
||||
(* ; "Edited 13-Aug-2020 11:54 by rmk:")
|
||||
|
||||
(* ;; "If added to STREAM-AFTER-OPEN-FNS, causes mapping files to be opened as UTF8.")
|
||||
(* ;;
|
||||
"If added to STREAM-AFTER-OPEN-FNS, causes mapping files to be opened as UTF-8. For development")
|
||||
|
||||
(CL:WHEN (AND (STRPOS "XCCS-" (U-CASE (FULLNAME STREAM)))
|
||||
[EQ 'TXT (U-CASE (FILENAMEFIELD (FULLNAME STREAM)
|
||||
'EXTENSION]
|
||||
(NOT (ASSOC 'EXTERNALFORMAT PARAMETERS)))
|
||||
(STREAMPROP STREAM 'EXTERNALFORMAT :UTF8))])
|
||||
(STREAMPROP STREAM 'EXTERNALFORMAT :UTF-8))])
|
||||
)
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
@@ -492,6 +499,15 @@
|
||||
CODE))
|
||||
[(AND X (CL:SVREF X (LOGAND CODE TRANSLATION-MASK]
|
||||
(T (UNICODE.UNMAPPED CODE TRANSLATION-TABLE])
|
||||
|
||||
(PUTPROPS \UTF8.GETBASEBYTE MACRO ((BASE OFFSET ERROR?) (* ;
|
||||
"Fetches the OFFSET'th byte from BASE, checking for UTF-8 validity if ERROR?")
|
||||
(IF ERROR?
|
||||
THEN (LET ((BYTE (\GETBASEBYTE BASE OFFSET)))
|
||||
(CL:WHEN (ILESSP BYTE 128)
|
||||
(ERROR "INVALID UTF8 BYTE" BYTE))
|
||||
BYTE)
|
||||
ELSE (\GETBASEBYTE BASE OFFSET))))
|
||||
)
|
||||
)
|
||||
(DEFINEQ
|
||||
@@ -512,24 +528,40 @@
|
||||
(DEFINEQ
|
||||
|
||||
(READ-UNICODE-MAPPING-FILENAMES
|
||||
[LAMBDA (FILESPEC) (* ; "Edited 5-Aug-2020 15:59 by kaplan")
|
||||
[LAMBDA (FILESPEC DIRS) (* ; "Edited 5-Jan-2024 17:24 by rmk")
|
||||
(* ; "Edited 5-Aug-2020 15:59 by kaplan")
|
||||
(* ; "Edited 4-Aug-2020 17:31 by rmk:")
|
||||
(FOR F X CSI INSIDE FILESPEC
|
||||
COLLECT (IF (FINDFILE (PACKFILENAME 'BODY F 'EXTENSION 'TXT)
|
||||
T UNICODEDIRECTORIES)
|
||||
ELSEIF [SETQ CSI (OR (SASSOC F XCCS-SET-NAMES)
|
||||
(FIND N IN XCCS-SET-NAMES
|
||||
SUCHTHAT (EQ F (CADR N]
|
||||
THEN (FINDFILE (PACKFILENAME 'BODY (CONCAT 'XCCS- (CAR CSI)
|
||||
'=
|
||||
(CADR CSI))
|
||||
'EXTENSION
|
||||
'TXT)
|
||||
T UNICODEDIRECTORIES)
|
||||
ELSE F])
|
||||
(CL:UNLESS DIRS (SETQ DIRS UNICODEDIRECTORIES))
|
||||
(FOR F X CSI INSIDE FILESPEC JOIN
|
||||
(* ;;
|
||||
"Last case hopes to pick up tables that are gruped together in a subdirectory (e.g. JIS)")
|
||||
|
||||
(OR (FINDFILE (PACKFILENAME 'BODY F 'EXTENSION 'TXT)
|
||||
T DIRS)
|
||||
(for D inside DIRS
|
||||
when (SETQ D (FILDIR (PACKFILENAME 'NAME
|
||||
(CONCAT "XCCS-*=" F)
|
||||
'EXTENSION
|
||||
'TXT
|
||||
'BODY D)))
|
||||
do (RETURN D))
|
||||
(AND [SETQ CSI (OR (SASSOC F XCCS-SET-NAMES)
|
||||
(FIND N IN XCCS-SET-NAMES
|
||||
SUCHTHAT (EQ F (CADR N]
|
||||
(MKLIST (FINDFILE (PACKFILENAME 'BODY
|
||||
(CONCAT 'XCCS- (CAR CSI)
|
||||
'=
|
||||
(CADR CSI))
|
||||
'EXTENSION
|
||||
'TXT)
|
||||
T DIRS)))
|
||||
(for D inside DIRS
|
||||
when (DIRECTORYNAMEP (SETQ D (CONCAT D ">" F ">")))
|
||||
join (FILDIR (CONCAT D ">*.TXT;*"])
|
||||
|
||||
(READ-UNICODE-MAPPING
|
||||
[LAMBDA (FILESPEC NOPRINT NOERROR) (* ; "Edited 3-Jul-2021 13:37 by rmk:")
|
||||
[LAMBDA (FILESPEC NOPRINT NOERROR) (* ; "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")
|
||||
|
||||
@@ -539,8 +571,7 @@
|
||||
|
||||
(* ;; " 0xXXXX ... 0xYYYY")
|
||||
|
||||
(* ;;
|
||||
" Column 3: (after #) Character name in some mapping files, utf-8 character")
|
||||
(* ;; " Column 3: (after #) Character name in some mapping files, utf-8 character")
|
||||
|
||||
(* ;; " for XCCS mapping files")
|
||||
|
||||
@@ -548,37 +579,34 @@
|
||||
|
||||
(* ;; "Result is a list of (fromcode tocode1 ... tocoden) integer lists (almost always with only a single tocode")
|
||||
|
||||
(FOR FILE [SEPBITTABLE _ (MAKEBITTABLE (CHARCODE (TAB SPACE] IN (
|
||||
READ-UNICODE-MAPPING-FILENAMES
|
||||
FILESPEC)
|
||||
(FOR FILE [SEPBITTABLE _ (MAKEBITTABLE (CHARCODE (TAB SPACE] IN (READ-UNICODE-MAPPING-FILENAMES
|
||||
FILESPEC)
|
||||
JOIN (CL:WITH-OPEN-FILE (STREAM FILE :DIRECTION :INPUT :EXTERNAL-FORMAT :UTF-8-RAW)
|
||||
(BIND LINE START FIRST (CL:UNLESS
|
||||
(FILEPOS "Name:" STREAM NIL NIL NIL T)
|
||||
(ERROR "NOT A UNICODE MAPPING FILE"
|
||||
(FULLNAME STREAM)))
|
||||
(SETQ LINE (CL:READ-LINE STREAM NIL NIL))
|
||||
(CL:UNLESS NOPRINT
|
||||
(PRINTOUT T T "Unicode mapping: "
|
||||
(CL:STRING-TRIM " " LINE)
|
||||
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 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])
|
||||
(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:UNLESS NOPRINT (* ; "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 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])
|
||||
|
||||
(WRITE-UNICODE-MAPPING
|
||||
[LAMBDA (MAPPING INCLUDECHARSETS FILE EMPTYOK) (* ; "Edited 16-Aug-2020 16:56 by rmk:")
|
||||
[LAMBDA (MAPPING INCLUDECHARSETS FILE EMPTYOK) (* ; "Edited 4-Jan-2024 22:44 by rmk")
|
||||
(* ; "Edited 16-Aug-2020 16:56 by rmk:")
|
||||
|
||||
(* ;; "Writes a symbol unicode mapping file. Mapping is a list of (XCCS-code Unicode) pairs, which may contain codes in multiple character sets.")
|
||||
|
||||
@@ -587,21 +615,18 @@
|
||||
(* ;; "The output lines are of the form x0XXX<tab>x0UUUU<tab># Unicode-char")
|
||||
|
||||
(* ;;
|
||||
"If INCLUDECHARSETS=T then the mappings are split up into separate per-character set files.")
|
||||
"If INCLUDECHARSETS=T then the mappings are split up into separate per-character set files.")
|
||||
|
||||
(* ;; "Otherwise, all and only mappings included in thos charsets are included in a single output file--an implicit subset.")
|
||||
|
||||
(IF (AND (EQ INCLUDECHARSETS T)
|
||||
(NULL FILE))
|
||||
(NULL FILE))
|
||||
THEN (IF MAPPING
|
||||
THEN (FOR CSI F IN XCCS-SET-NAMES WHEN (SETQ F
|
||||
(WRITE-UNICODE-MAPPING
|
||||
MAPPING
|
||||
(CAR CSI)
|
||||
NIL T)) COLLECT
|
||||
F)
|
||||
ELSE (PRINTOUT T "THERE ARE NO MAPPINGS" T)
|
||||
NIL)
|
||||
THEN (FOR CSI F IN XCCS-SET-NAMES WHEN (SETQ F (WRITE-UNICODE-MAPPING MAPPING
|
||||
(CAR CSI)
|
||||
NIL T)) COLLECT F)
|
||||
ELSE (PRINTOUT T "THERE ARE NO MAPPINGS" T)
|
||||
NIL)
|
||||
ELSE
|
||||
(LET
|
||||
(IMAPPING CSETINFO RANGES)
|
||||
@@ -609,47 +634,45 @@
|
||||
(WRITE-UNICODE-INCLUDED MAPPING INCLUDECHARSETS))
|
||||
(IF IMAPPING
|
||||
THEN (CL:WITH-OPEN-FILE
|
||||
(STREAM (WRITE-UNICODE-MAPPING-FILENAME FILE CSETINFO RANGES)
|
||||
:DIRECTION :OUTPUT :IF-EXISTS :NEW-VERSION :EXTERNAL-FORMAT :UTF8-RAW)
|
||||
(WRITE-UNICODE-MAPPING-HEADER STREAM CSETINFO RANGES)
|
||||
(SORT IMAPPING T)
|
||||
(FOR M CSET LEFTC FIRSTRIGHTC CSI IN IMAPPING
|
||||
DO (SETQ LEFTC (CAR M))
|
||||
(SETQ FIRSTRIGHTC (CADR M))
|
||||
(CL:UNLESS (EQ CSET (LRSH LEFTC 8))
|
||||
(SETQ CSET (LRSH LEFTC 8))
|
||||
(SETQ CSI (ASSOC CSET CSETINFO))
|
||||
(PRINTOUT STREAM T "# " .P2 (CADR CSI)
|
||||
" "
|
||||
(CADDR CSI)
|
||||
T))
|
||||
(PRINTOUT STREAM "0x" (HEXSTRING LEFTC 4)
|
||||
%#
|
||||
(FOR RIGHTC IN (CDR M)
|
||||
DO (PRINTOUT NIL " " "0x" (HEXSTRING RIGHTC 4)))
|
||||
" # "
|
||||
(SELECTC FIRSTRIGHTC
|
||||
(UNDEFINEDCODE
|
||||
(* ;; "FFFF")
|
||||
(STREAM (WRITE-UNICODE-MAPPING-FILENAME FILE CSETINFO RANGES)
|
||||
:DIRECTION :OUTPUT :IF-EXISTS :NEW-VERSION :EXTERNAL-FORMAT :UTF-8-RAW)
|
||||
(WRITE-UNICODE-MAPPING-HEADER STREAM CSETINFO RANGES)
|
||||
(SORT IMAPPING T)
|
||||
(FOR M CSET LEFTC FIRSTRIGHTC CSI IN IMAPPING
|
||||
DO (SETQ LEFTC (CAR M))
|
||||
(SETQ FIRSTRIGHTC (CADR M))
|
||||
(CL:UNLESS (EQ CSET (LRSH LEFTC 8))
|
||||
(SETQ CSET (LRSH LEFTC 8))
|
||||
(SETQ CSI (ASSOC CSET CSETINFO))
|
||||
(PRINTOUT STREAM T "# " .P2 (CADR CSI)
|
||||
" "
|
||||
(CADDR CSI)
|
||||
T))
|
||||
(PRINTOUT STREAM "0x" (HEXSTRING LEFTC 4)
|
||||
%#
|
||||
(FOR RIGHTC IN (CDR M) DO (PRINTOUT NIL " " "0x" (HEXSTRING RIGHTC 4)))
|
||||
" # "
|
||||
(SELECTC FIRSTRIGHTC
|
||||
(UNDEFINEDCODE
|
||||
(* ;; "FFFF")
|
||||
|
||||
"UNDEFINED")
|
||||
(MISSINGCODE
|
||||
(* ;; "FFFE")
|
||||
"UNDEFINED")
|
||||
(MISSINGCODE
|
||||
(* ;; "FFFE")
|
||||
|
||||
"MISSING")
|
||||
(IF (ILESSP FIRSTRIGHTC 32)
|
||||
THEN (* ; "Control chars")
|
||||
[CONCAT "^" (CHARACTER (IPLUS FIRSTRIGHTC
|
||||
(CHARCODE @]
|
||||
ELSE (CHARACTER FIRSTRIGHTC)))
|
||||
T))
|
||||
(FULLNAME STREAM))
|
||||
"MISSING")
|
||||
(IF (ILESSP FIRSTRIGHTC 32)
|
||||
THEN (* ; "Control chars")
|
||||
[CONCAT "^" (CHARACTER (IPLUS FIRSTRIGHTC (CHARCODE @]
|
||||
ELSE (CHARACTER FIRSTRIGHTC)))
|
||||
T))
|
||||
(FULLNAME STREAM))
|
||||
ELSEIF (NOT EMPTYOK)
|
||||
THEN (PRINTOUT T "THERE ARE NO MAPPINGS")
|
||||
(CL:WHEN INCLUDECHARSETS
|
||||
(PRINTOUT T " FOR " .PPVTL (MKLIST INCLUDECHARSETS)
|
||||
T))
|
||||
NIL])
|
||||
(CL:WHEN INCLUDECHARSETS
|
||||
(PRINTOUT T " FOR " .PPVTL (MKLIST INCLUDECHARSETS)
|
||||
T))
|
||||
NIL])
|
||||
|
||||
(WRITE-UNICODE-INCLUDED
|
||||
[LAMBDA (MAPPING INCLUDECHARSETS) (* ; "Edited 4-Aug-2020 17:47 by rmk:")
|
||||
@@ -724,28 +747,28 @@
|
||||
(CL:VALUES IMAPPING CSETINFO RANGES])
|
||||
|
||||
(WRITE-UNICODE-MAPPING-HEADER
|
||||
[LAMBDA (STREAM CSETINFO RANGES) (* ; "Edited 4-Aug-2020 17:38 by rmk:")
|
||||
[LAMBDA (STREAM CSETINFO RANGES) (* ; "Edited 5-Jan-2024 13:24 by rmk")
|
||||
(* ; "Edited 4-Aug-2020 17:38 by rmk:")
|
||||
|
||||
(* ;; "Writes the standard per-file header information")
|
||||
|
||||
(FOR LINE IN UNICODE-MAPPING-HEADER
|
||||
DO (PRINTOUT STREAM "#" 2)
|
||||
(SELECTQ LINE
|
||||
(XCCSCHARACTERSETS
|
||||
(PRINTOUT STREAM " XCCS charset")
|
||||
(IF (CDR CSETINFO)
|
||||
THEN (PRINTOUT STREAM "s:" -4)
|
||||
(FOR R IN RANGES DO (PRINTOUT STREAM R " "))
|
||||
(TERPRI STREAM)
|
||||
ELSE (* ; "Singleton")
|
||||
(PRINTOUT STREAM ": " -4 (CADAR CSETINFO)
|
||||
" "
|
||||
(CADDAR CSETINFO)))
|
||||
(TERPRI STREAM))
|
||||
(DATE (PRINTOUT STREAM " Date:" -13 (DATE (DATEFORMAT NO.TIME
|
||||
NO.LEADING.SPACES))
|
||||
T))
|
||||
(PRINTOUT STREAM LINE T)))
|
||||
(SELECTQ LINE
|
||||
(XCCSCHARACTERSETS
|
||||
(PRINTOUT STREAM " XCCS charset")
|
||||
(IF (CDR CSETINFO)
|
||||
THEN (PRINTOUT STREAM "s:" -4)
|
||||
(FOR R IN RANGES DO (PRINTOUT STREAM R " "))
|
||||
ELSE (* ; "Singleton")
|
||||
(PRINTOUT STREAM ": " -4 (CADAR CSETINFO)
|
||||
" "
|
||||
(CADDAR CSETINFO)))
|
||||
(TERPRI STREAM))
|
||||
(DATE (PRINTOUT STREAM " Date:" -13 (DATE (DATEFORMAT NO.TIME NO.LEADING.SPACES)
|
||||
)
|
||||
T))
|
||||
(PRINTOUT STREAM LINE T)))
|
||||
(TERPRI STREAM])
|
||||
|
||||
(WRITE-UNICODE-MAPPING-FILENAME
|
||||
@@ -774,24 +797,28 @@
|
||||
|
||||
(RPAQQ XCCS-SET-NAMES
|
||||
(("0" LATIN)
|
||||
("41" SYMBOLS1)
|
||||
("42" SYMBOLS2)
|
||||
("41" JAPANESE-SYMBOLS1)
|
||||
("42" JAPANESE-SYMBOLS2)
|
||||
("43" EXTENDED-LATIN)
|
||||
("44" HIRAGANA)
|
||||
("45" KATAKANA)
|
||||
("46" GREEK)
|
||||
("47" CYRILLIC)
|
||||
("50" FORMS)
|
||||
("60-172" JIS)
|
||||
("60-166" JIS)
|
||||
("340" ARABIC)
|
||||
("341" HEBREW)
|
||||
("342" IPA)
|
||||
("343" HANGUL)
|
||||
("344" GEORGIAN-ARMENIAN)
|
||||
("356" SYMBOLS3)
|
||||
("357" SYMBOLS4)
|
||||
("345" DEVANAGRI)
|
||||
("346" BENGALI)
|
||||
("347" GURMUKHI)
|
||||
("350" THAI-LAO)
|
||||
("356" SYMBOLS2)
|
||||
("357" SYMBOLS1)
|
||||
("360" LIGATURES)
|
||||
("361" ACCENTED-LATIN)
|
||||
("361" ACCENTED-LATIN1)
|
||||
("365" MORE-ARABIC)
|
||||
("375" GRAPHIC-VARIANTS)))
|
||||
|
||||
@@ -813,22 +840,21 @@
|
||||
)
|
||||
|
||||
(RPAQQ UNICODE-MAPPING-HEADER
|
||||
("" " Name: XCCS (XC-3-1-1-0) to Unicode" " Unicode version: 3.0"
|
||||
("" " Name: XCCS (Version 2.0) to Unicode" " Unicode version: 3.0"
|
||||
XCCSCHARACTERSETS " Table version: 0.1" " Table format: Format A"
|
||||
DATE " Author: Ron Kaplan <Ron.Kaplan@post.harvard.edu>" ""
|
||||
"This file contains mappings from the Xerox Character Code Standard (version"
|
||||
"XC1-3-3-0, 1987) into Unicode 3.0. standard codes. That is the version of"
|
||||
"XCCS corresponding to the fonts in the Medley system." ""
|
||||
"2.0, 1990) into Unicode 3.0. standard codes. That is an extension of the"
|
||||
"version of XCCS corresponding to the fonts in the Medley system." ""
|
||||
"The format of this file conforms to the format of the other Unicode-supplied"
|
||||
"mapping files:" " Three white-space (tab or spaces) separated columns:"
|
||||
" Column 1 is the XCCS code (as hex 0xXXXX)"
|
||||
" Column 2 is the corresponding Unicode (as hex 0xXXXX)"
|
||||
" Column 3 (after #) is a comment column. For convenience, it contains the"
|
||||
" Unicode character itself (since the Unicode character names"
|
||||
" are not available)"
|
||||
" Unicode character itself and the Unicode character names when available."
|
||||
"Unicode FFFF is used for undefined XCCS codes (Column 3 = UNDEFINED"
|
||||
"Unicode FFFE is used for XCCS codes that have not yet been filled in."
|
||||
"(Column 3 = MISSING)" "" "This file is encoded in UTF8, so that the Unicode characters"
|
||||
"(Column 3 = MISSING)" "" "This file is encoded in UTF-8, so that the Unicode characters"
|
||||
"are properly displayed in Column 3 and can be edited by standard"
|
||||
"Unicode-enabled editors (e.g. Mac Textedit)." ""
|
||||
"This file can also be read by the function"
|
||||
@@ -991,8 +1017,10 @@
|
||||
(LIST LTORARRAY RTOLARRAY])
|
||||
)
|
||||
|
||||
(RPAQ? DEFAULT-XCCS-CHARSETS '(LATIN SYMBOLS1 SYMBOLS2 EXTENDED-LATIN FORMS SYMBOLS3 SYMBOLS4
|
||||
ACCENTED-LATIN GREEK))
|
||||
(RPAQ? DEFAULT-XCCS-CHARSETS '(LATIN JAPANESE-SYMBOLS1 JAPANESE-SYMBOLS2 EXTENDED-LATIN FORMS
|
||||
SYMBOLS1 SYMBOLS2 ACCENTED-LATIN1 GREEK))
|
||||
|
||||
(RPAQ? DEFAULT-XCCS-JAPANESE-CHARSETS '(HIRAGANA KATAKANA JIS))
|
||||
(DECLARE%: DONTEVAL@LOAD DOCOPY
|
||||
|
||||
(MAKE-UNICODE-TRANSLATION-TABLES (READ-UNICODE-MAPPING DEFAULT-XCCS-CHARSETS T)
|
||||
@@ -1005,6 +1033,63 @@
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
(UTF-8.VALIDATE
|
||||
[LAMBDA (STREAM BYTE1) (* ; "Edited 28-Dec-2023 11:57 by rmk")
|
||||
(* ; "Edited 6-Aug-2021 16:02 by rmk:")
|
||||
(* ; "Edited 6-Aug-2020 17:13 by rmk:")
|
||||
|
||||
(* ;; "Returns the codesize if the bytes starting at STREAM's current position form a valid UTF-8 sequence.")
|
||||
|
||||
(* ;; "If BYTE1 is provided, it is interpreted as the just-read header byte with the stream is positioned just after it.")
|
||||
|
||||
(* ;; "Test for smallp because the stream's End-of-file operation may suppress the error--otherwise an error will happen if the streams runs out of necessary bytes.")
|
||||
|
||||
(* ;; "For valid sequences, returns the same value as NUTF8CODEBYTES, but this reads/validates the rest of the bytes. On a non-NILreturn the stream is positioned before the header byte of the next putative code. The stream position is uncertain on a NIL return.")
|
||||
|
||||
(* ;; "")
|
||||
|
||||
(CL:UNLESS BYTE1
|
||||
(SETQ BYTE1 (\BIN STREAM)))
|
||||
(PROG (BYTE2 BYTE3 BYTE4)
|
||||
|
||||
(* ;; "Distinguish on the header byte BYTE1.")
|
||||
|
||||
(CL:WHEN (SMALLP BYTE1)
|
||||
(IF (ILESSP BYTE1 128)
|
||||
THEN (RETURN 1)
|
||||
ELSEIF (IGEQ BYTE1 (LLSH 15 4))
|
||||
THEN (* ; "4 bytes")
|
||||
(SETQ BYTE2 (\BIN STREAM))
|
||||
(CL:WHEN (OR (NOT (SMALLP BYTE2))
|
||||
(ILESSP BYTE2 128))
|
||||
(RETURN))
|
||||
(SETQ BYTE3 (\BIN STREAM))
|
||||
(CL:WHEN (OR (NOT (SMALLP BYTE3))
|
||||
(ILESSP BYTE3 128))
|
||||
(RETURN))
|
||||
(SETQ BYTE4 (\BIN STREAM))
|
||||
(CL:WHEN (OR (NOT (SMALLP BYTE4))
|
||||
(ILESSP BYTE4 128))
|
||||
(RETURN))
|
||||
(RETURN 4)
|
||||
ELSEIF (IGEQ BYTE1 (LLSH 7 5))
|
||||
THEN (* ; "3 bytes")
|
||||
(SETQ BYTE2 (\BIN STREAM))
|
||||
(CL:WHEN (OR (NOT (SMALLP BYTE2))
|
||||
(ILESSP BYTE2 128))
|
||||
(RETURN))
|
||||
(SETQ BYTE3 (\BIN STREAM))
|
||||
(CL:WHEN (OR (NOT (SMALLP BYTE3))
|
||||
(ILESSP BYTE3 128))
|
||||
(RETURN))
|
||||
(RETURN 3)
|
||||
ELSE (* ; " 2 bytes")
|
||||
(SETQ BYTE2 (\BIN STREAM))
|
||||
(CL:WHEN (OR (NOT (SMALLP BYTE2))
|
||||
(ILESSP BYTE2 128))
|
||||
(RETURN NIL))
|
||||
(RETURN 2)))])
|
||||
|
||||
(HEXSTRING
|
||||
[LAMBDA (N WIDTH) (* ; "Edited 23-Jul-2020 08:28 by rmk:")
|
||||
(* ; "Edited 20-Dec-93 17:51 by rmk:")
|
||||
@@ -1068,23 +1153,24 @@
|
||||
ELSE (ERROR "CHARCODE too big for UTF8" CHARCODE])
|
||||
|
||||
(NUTF8CODEBYTES
|
||||
[LAMBDA (N) (* ; "Edited 28-Jun-2022 00:02 by rmk")
|
||||
[LAMBDA (BYTE) (* ; "Edited 8-Jan-2024 10:57 by rmk")
|
||||
(* ; "Edited 28-Jun-2022 00:02 by rmk")
|
||||
(* ; "Edited 10-Aug-2020 12:35 by rmk:")
|
||||
|
||||
(* ;; "Returns the number of bytes needed to encode N in UTF8, ")
|
||||
(* ;; "Returns the number of bytes needed to encode in UTF8 a number headed by BYTE. ")
|
||||
|
||||
(IF (ILESSP N 128)
|
||||
(IF (ILESSP BYTE 128)
|
||||
THEN 1
|
||||
ELSEIF (ILESSP N 2048)
|
||||
ELSEIF (ILESSP BYTE 2048)
|
||||
THEN (* ; "x800")
|
||||
2
|
||||
ELSEIF (ILESSP N 65536)
|
||||
ELSEIF (ILESSP BYTE 65536)
|
||||
THEN (* ; "x10000")
|
||||
3
|
||||
ELSEIF (ILESSP N 2097152)
|
||||
ELSEIF (ILESSP BYTE 2097152)
|
||||
THEN (* ; "x200000")
|
||||
4
|
||||
ELSE (SHOULDNT])
|
||||
ELSE (ERROR "INVALID UTF-8 HEADER BYTE"])
|
||||
|
||||
(NUTF8STRINGBYTES
|
||||
[LAMBDA (STRING RAWFLG) (* ; "Edited 10-Aug-2020 09:06 by rmk:")
|
||||
@@ -1160,6 +1246,44 @@
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
(\UTF8.FETCHCODE
|
||||
[LAMBDA (CODESIZE BUFFER BYTEOFFSET) (* ; "Edited 28-Dec-2023 13:32 by rmk")
|
||||
(* ; "Edited 6-Aug-2021 16:02 by rmk:")
|
||||
(* ; "Edited 6-Aug-2020 17:13 by rmk:")
|
||||
|
||||
(* ;; "Decodes a UTF8 byte sequence of size CODESIZE in BUFFER starting at BYTEOFFSET.")
|
||||
|
||||
(* ;; "The validity of the thesize, buffer, and offset are guaranteed by the caller.")
|
||||
|
||||
(LET ((BYTE1 (\GETBASEBYTE BUFFER BYTEOFFSET))
|
||||
BYTE2 BYTE3 BYTE4)
|
||||
(SELECTQ CODESIZE
|
||||
(2 (SETQ BYTE2 (\UTF8.GETBASEBYTE BUFFER (IPLUS 1 BYTEOFFSET)))
|
||||
(LOGOR (LLSH (LOADBYTE BYTE1 0 5)
|
||||
6)
|
||||
(LOADBYTE BYTE2 0 6)))
|
||||
(3 (SETQ BYTE2 (\UTF8.GETBASEBYTE BUFFER (IPLUS 1 BYTEOFFSET)))
|
||||
(SETQ BYTE3 (\UTF8.GETBASEBYTE BUFFER (IPLUS 2 BYTEOFFSET)))
|
||||
(LOGOR (LLSH (LOADBYTE BYTE1 0 4)
|
||||
12)
|
||||
(LLSH (LOADBYTE BYTE2 0 6)
|
||||
6)
|
||||
(LOADBYTE BYTE3 0 6)))
|
||||
(4 (SETQ BYTE2 (\UTF8.GETBASEBYTE BUFFER (IPLUS 1 BYTEOFFSET)))
|
||||
(SETQ BYTE3 (\UTF8.GETBASEBYTE BUFFER (IPLUS 2 BYTEOFFSET)))
|
||||
(SETQ BYTE4 (\UTF8.GETBASEBYTE BUFFER (IPLUS 3 BYTEOFFSET)))
|
||||
(LOGOR (LLSH (LOADBYTE BYTE1 0 3)
|
||||
18)
|
||||
(LLSH (LOADBYTE BYTE2 0 6)
|
||||
12)
|
||||
(LLSH (LOADBYTE BYTE3 0 6)
|
||||
6)
|
||||
(LOADBYTE BYTE4 0 6)))
|
||||
(1 BYTE1)
|
||||
(SHOULDNT])
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
(SHOWCHARS
|
||||
[LAMBDA (FROMCHAR TOCHAR FONT) (* ; "Edited 1-Aug-2020 09:27 by rmk:")
|
||||
(RESETFORM (DSPFONT (OR FONT '(CLASSIC 12))
|
||||
@@ -1215,15 +1339,16 @@
|
||||
)
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (3717 17808 (UTF8.OUTCHARFN 3727 . 6558) (UTF8.INCCODEFN 6560 . 12050) (UTF8.PEEKCCODEFN
|
||||
12052 . 16826) (\UTF8.BACKCCODEFN 16828 . 17806)) (17809 21590 (UTF16BE.OUTCHARFN 17819 . 18643) (
|
||||
UTF16BE.INCCODEFN 18645 . 19544) (UTF16BE.PEEKCCODEFN 19546 . 20617) (\UTF16BE.BACKCCODEFN 20619 .
|
||||
21588)) (21620 23681 (MAKE-UNICODE-FORMATS 21630 . 23679)) (23778 25084 (UNICODE.UNMAPPED 23788 .
|
||||
25082)) (25085 25621 (XCCS-UTF8-AFTER-OPEN 25095 . 25619)) (26454 26803 (XTOUCODE 26464 . 26632) (
|
||||
UTOXCODE 26634 . 26801)) (26843 42965 (READ-UNICODE-MAPPING-FILENAMES 26853 . 27954) (
|
||||
READ-UNICODE-MAPPING 27956 . 31254) (WRITE-UNICODE-MAPPING 31256 . 35473) (WRITE-UNICODE-INCLUDED
|
||||
35475 . 40197) (WRITE-UNICODE-MAPPING-HEADER 40199 . 41431) (WRITE-UNICODE-MAPPING-FILENAME 41433 .
|
||||
42963)) (46178 54657 (MAKE-UNICODE-TRANSLATION-TABLES 46188 . 54655)) (55074 63100 (HEXSTRING 55084 .
|
||||
56245) (UTF8HEXSTRING 56247 . 58452) (NUTF8CODEBYTES 58454 . 59239) (NUTF8STRINGBYTES 59241 . 59722) (
|
||||
XTOUSTRING 59724 . 62735) (XCCSSTRING 62737 . 63098)) (63101 64570 (SHOWCHARS 63111 . 64568)))))
|
||||
(FILEMAP (NIL (3950 18041 (UTF8.OUTCHARFN 3960 . 6791) (UTF8.INCCODEFN 6793 . 12283) (UTF8.PEEKCCODEFN
|
||||
12285 . 17059) (\UTF8.BACKCCODEFN 17061 . 18039)) (18042 21823 (UTF16BE.OUTCHARFN 18052 . 18876) (
|
||||
UTF16BE.INCCODEFN 18878 . 19777) (UTF16BE.PEEKCCODEFN 19779 . 20850) (\UTF16BE.BACKCCODEFN 20852 .
|
||||
21821)) (21853 24134 (MAKE-UNICODE-FORMATS 21863 . 24132)) (24231 25537 (UNICODE.UNMAPPED 24241 .
|
||||
25535)) (25538 26214 (XCCS-UTF8-AFTER-OPEN 25548 . 26212)) (27670 28019 (XTOUCODE 27680 . 27848) (
|
||||
UTOXCODE 27850 . 28017)) (28059 44757 (READ-UNICODE-MAPPING-FILENAMES 28069 . 30519) (
|
||||
READ-UNICODE-MAPPING 30521 . 33497) (WRITE-UNICODE-MAPPING 33499 . 37249) (WRITE-UNICODE-INCLUDED
|
||||
37251 . 41973) (WRITE-UNICODE-MAPPING-HEADER 41975 . 43223) (WRITE-UNICODE-MAPPING-FILENAME 43225 .
|
||||
44755)) (48071 56550 (MAKE-UNICODE-TRANSLATION-TABLES 48081 . 56548)) (57055 68253 (UTF-8.VALIDATE
|
||||
57065 . 60067) (HEXSTRING 60069 . 61230) (UTF8HEXSTRING 61232 . 63437) (NUTF8CODEBYTES 63439 . 64392)
|
||||
(NUTF8STRINGBYTES 64394 . 64875) (XTOUSTRING 64877 . 67888) (XCCSSTRING 67890 . 68251)) (68254 70058 (
|
||||
\UTF8.FETCHCODE 68264 . 70056)) (70059 71528 (SHOWCHARS 70069 . 71526)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
BIN
library/UNICODE.TEDIT
Normal file
BIN
library/UNICODE.TEDIT
Normal file
Binary file not shown.
@@ -1,98 +0,0 @@
|
||||
This file describes the UNICODE Lisp Library package.
|
||||
|
||||
Contributed by Ron Kaplan, August 2020.
|
||||
|
||||
The UNICODE library package defines external file formats that enable Medley to read and write files where 16 bit character codes are represented as UTF8 byte sequences or big-endian UTF16 byte-pairs. It also provides for character codes to be converted (on reading) from Unicode codes to equivalent codes in the Medley-internal Xerox Character Code Standard (XCCS) and (on writing) from XCCS codes to equivalent Unicode codes.
|
||||
|
||||
Four external formats are defined when the package is loaded:
|
||||
|
||||
:UTF8 codes are represented as UTF8 byte sequences and XCCS/Unicode character
|
||||
conversion takes place.
|
||||
|
||||
:UTF16BE codes are represented as 2-byte pairs, with the high order by appearing
|
||||
first in the file, and characters are converted.
|
||||
|
||||
The two other external formats translate byte sequences into codes, but do not translate the codes. These allow Medley to see and process characters in their native encoding.
|
||||
|
||||
:UTF8-RAW codes are represented as UTF8 byte sequences, but character conversion
|
||||
does not take place.
|
||||
|
||||
:UTF16BE-RAW codes are represented as big-ending 2-byte pairs but there is no
|
||||
conversion.
|
||||
|
||||
These formats all define the end-of-line convention (mostly for writing) for the external files according to the variable EXTERNALEOL (LF, CR, CRLF), with LF the default.
|
||||
|
||||
The external format can be specified as a parameter when a stream is opened:
|
||||
|
||||
(OPENSTREAM 'foo.txt 'INPUT 'OLD '((EXTERNALFORMAT :UTF8)))
|
||||
|
||||
(CL:OPEN 'foo.txt :DIRECTION :INPUT :EXTERNAL-FORMAT :UTF8)
|
||||
|
||||
The function STREAMPROP obtains or changes the external format of an open stream:
|
||||
|
||||
(STREAMPROP stream 'EXTERNALFORMAT) -> :XCCS
|
||||
|
||||
(STREAMPROP stream 'EXTERNALFORMAT :UTF8) -> :XCCS
|
||||
|
||||
In the latter case, the stream's format is changed to :UTF8 and the previous value is returned, in this example it is Medley's historical default format :XCCS.
|
||||
|
||||
Entries can be placed on the variable *DEFAULT-EXTERNALFORMATS* to change the external format that is set by default when a file is opened on a particular device. Loading UNICODE executes
|
||||
|
||||
(PUSH *DEFAULT-EXTERNALFORMATS* '(UNIX :UTF8))
|
||||
|
||||
so that all files opened (by OPENSTREAM, CL:OPEN, etc.) on the UNIX file device will be initialized with :UTF8. Note that the UNIX and DSK file devices reference the same files (although some caution is needed because {UNIX} does not simulate Medley versioning), but the device name in a file name ({UNIX}/Users/... vs. {DSK}/Users/...) selects one or the other. The default setting above applies only to files specified with {UNIX}; a separate default entry for DSK must be established to change its default from :XCCS.
|
||||
|
||||
The user can also specify the external format on a per-stream basis by putting a function on the list STREAM-AFTER-OPEN-FNS. After OPENSTREAM opens a stream and just before it is returned to the calling function, the functions on that list are applied in order to arguments STREAM, ACCESS, PARAMETERS. They can examine and/or change the properties of the stream, in particular, by calling STREAMPROP to change the external format from its device default.
|
||||
|
||||
The XCCS/Unicode mapping tables are defined by the code-mapping files for particular XCCS character sets. These are typically located in the Library sister directory
|
||||
|
||||
../Unicode/Xerox/
|
||||
|
||||
and the variable UNICODEDIRECTORIES is initialized with a globally valid reference to that path. The global reference is constructed by prepending the value of the Unix environment-variable "MEDLEYDIR" to the suffix /Unicode/Xerox/. MEDLEYDIR should be set by the Medley start-up shell script (e.g. /Users/kaplan/local/medley3.5/lispcore/)
|
||||
|
||||
The mapping files have conventional names of the form XCCS-<charsetnum>=<charsetname>.TXT, for example, XCCS-0=LATIN.TXT, XCCS-357=SYMBOLS4.TXT. The translations used by the external formats are read from these files by the function
|
||||
|
||||
(READ-UNICODE-MAPPING FILESPEC NOPRINT NOERROR)
|
||||
|
||||
where FILESPEC can be a list of files, charset octal strings ("0" "357"), or XCCS charset names (LATIN EXTENDED-LATIN). Reading will be silent if NOPRINT, and the process will not abort if an error occurs and NOERROR. The value is a flat list of the mappings for all the character sets, with elements of the form (XCCC-code Unicode-code).
|
||||
|
||||
When UNICODE is loaded the mappings for the character sets specified in the variable DEFAULT-XCCS-CHARSETS are installed. This is initialized to
|
||||
|
||||
(LATIN SYMBOLS1 SYMBOLS2 EXTENDED-LATIN FORMS SYMBOLS3 SYMBOLS4 ACCENTED-LATIN GREEK)
|
||||
|
||||
but DEFAULT-XCCS-CHARSETS can be set to a different collection before UNICODE is loaded.
|
||||
|
||||
The internal translation tables used by the external formats are constructed from a list of correspondence pairs by the function
|
||||
|
||||
(MAKE-UNICODE-TRANSLATION-TABLES MAPPING [FROM-XCCS-VAR][TO-XCCS-VAR])
|
||||
|
||||
This returns a list of two arrays (XCCS-to-Unicode Unicode-to-XCCS)containing the relevant translation information organized for rapid access. If the optional from/to-variables arguments are provide, they are the names of variables whose top-level values will be set to these arrays, for convenience. For the external formats defined above, these variables are *XCCSTOUNICODE* and *UNICODETOXCCS*.
|
||||
|
||||
The macro
|
||||
|
||||
(UNICODE.TRANSLATE CODE TRANSLATION-TABLE)
|
||||
|
||||
is used by the external formats to perform the mappings described by the translation-tables.
|
||||
|
||||
The following utilities are provided for lower-level manipulation of codes and strings
|
||||
|
||||
(XTOUCODE XCCSCODE) -> corresponding Unicode
|
||||
(UTOXCODE UNICODE) -> corresponding XCCS code
|
||||
(NUTF8CODEBYTES N) -> number of bytes in the UTF8 representation of N
|
||||
(NUTF8STRINGBYTES STRING RAWFLG) -> number of UTF8 bytes in the UTF8
|
||||
representation of STRING, translating XCCS to Unicode unless RAWFLG.
|
||||
(XTOUSTRING XCCSSTRING RAWFLG) -> The string of bytes in the UTF8 representation
|
||||
of the characters in XCCSSTRING (= the bytes in its UTF8 file encoding)
|
||||
(HEXSTRING N WIDTH) -> the hex string for N, padded to WIDTH
|
||||
|
||||
|
||||
The UNICODE file also contains a function for writing a mapping file given a list of mapping pairs. The function
|
||||
|
||||
(WRITE-TRANSLATION-TABLE MAPPING [INCLUDEDCHARSETS] [FILE])
|
||||
|
||||
produces one or more mapping files for the mapping-pairs in mapping. If the optional FILE argument is provided, then a single file with that name will be produced and contain all the mappings for all the character sets in MAPPING. If FILE and INCLUDEDCHARSETS are not provided, then all of the mappings will again go to a single file with a composite name XCCS-csn1,csn2,csn3.TXT. Each cs may be a single charset number, or a range of adjacent charset numbers. For example, if the mappings contain entries for characters in charset LATIN, SYMBOLS1, SYMBOLS2, and SYMBOLS3, the file name will be XCCS-0,41-43.TXT.
|
||||
|
||||
If INCLUDEDCHARSETS is provided, it specifies possibly a subset of the mappings in MAPPING for which files should be produced. This provides an implicit subsetting capability.
|
||||
|
||||
Finally, if FILE is not provided and INCLUDEDCHARSETS is T, then a separate file will be produced for each of the character sets, essentially a way of splitting a collection of character-set mappings into separate canonically named files (e.g. XCCS-357=SYMBOLS4.TXT).
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
Binary file not shown.
File diff suppressed because one or more lines are too long
@@ -1,19 +1,18 @@
|
||||
(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
|
||||
(FILECREATED "20-Jul-88 10:15:36" |{MCS:MCS:STANFORD}<LANE>COURIERIMAGESTREAM.;7| 49756
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
changes to%: (VARS COURIERIMAGESTREAMCOMS)
|
||||
(FNS \BITBLT.COURIER \SCALEDBITBLT.COURIER \COURIER.OPENIMAGESTREAM)
|
||||
(FILECREATED " 8-Dec-2023 21:36:09" {WMEDLEY}<lispusers>COURIERIMAGESTREAM.;2 49263
|
||||
|
||||
previous date%: "16-Sep-87 17:41:23" |{MCS:MCS:STANFORD}<LANE>COURIERIMAGESTREAM.;5|)
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (FNS \INITCOURIERIMAGESTREAM)
|
||||
(VARS COURIERIMAGESTREAMCOMS)
|
||||
|
||||
:PREVIOUS-DATE "20-Jul-88 10:15:36" {WMEDLEY}<lispusers>COURIERIMAGESTREAM.;1)
|
||||
|
||||
(* "
|
||||
Copyright (c) 1985, 1986, 1987, 1988 by Xerox Corporation & Stanford University. All rights reserved.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT COURIERIMAGESTREAMCOMS)
|
||||
|
||||
(RPAQQ COURIERIMAGESTREAMCOMS
|
||||
(RPAQQ COURIERIMAGESTREAMCOMS
|
||||
((* * ImageOp Functions)
|
||||
(FNS \BACKCOLOR.COURIER \BITBLT.COURIER \BLTSHADE.COURIER \BOTTOMMARGIN.COURIER
|
||||
\CHARSET.COURIER \CHARWIDTH.COURIER \CHARWIDTHY.COURIER \CLIPPINGREGION.COURIER
|
||||
@@ -28,16 +27,16 @@ Copyright (c) 1985, 1986, 1987, 1988 by Xerox Corporation & Stanford University.
|
||||
\YPOSITION.COURIER \OUTCHAR.COURIER)
|
||||
(* * Courier Server Functions)
|
||||
(FNS \COURIER.BACKCOLOR \COURIER.BITBLT \COURIER.BLTSHADE \COURIER.BOTTOMMARGIN
|
||||
\COURIER.CHARSET \COURIER.CHARWIDTH \COURIER.CHARWIDTHY \COURIER.CLIPPINGREGION
|
||||
\COURIER.CLOSEIMAGESTREAM \COURIER.COLOR \COURIER.DEFAULTSTATE \COURIER.DRAWARC
|
||||
\COURIER.DRAWCIRCLE \COURIER.DRAWCURVE \COURIER.DRAWELLIPSE \COURIER.DRAWLINE
|
||||
\COURIER.DRAWPOINT \COURIER.DRAWPOLYGON \COURIER.FILLCIRCLE \COURIER.FILLPOLYGON
|
||||
\COURIER.FONT \COURIER.FONTTYPE \COURIER.LEFTMARGIN \COURIER.LINEFEED \COURIER.MOVETO
|
||||
\COURIER.NEWPAGE \COURIER.OPERATION \COURIER.OPENIMAGESTREAM \COURIER.OUTCHAR
|
||||
\COURIER.POPSTATE \COURIER.PUSHSTATE \COURIER.RESET \COURIER.RIGHTMARGIN \COURIER.ROTATE
|
||||
\COURIER.SCALE \COURIER.SCALEDBITBLT \COURIER.SCALE2 \COURIER.SPACEFACTOR
|
||||
\COURIER.STRINGWIDTH \COURIER.TERPRI \COURIER.TOPMARGIN \COURIER.TRANSLATE
|
||||
\COURIER.XPOSITION \COURIER.YPOSITION)
|
||||
\COURIER.CHARWIDTH \COURIER.CHARWIDTHY \COURIER.CLIPPINGREGION \COURIER.CLOSEIMAGESTREAM
|
||||
\COURIER.COLOR \COURIER.DEFAULTSTATE \COURIER.DRAWARC \COURIER.DRAWCIRCLE
|
||||
\COURIER.DRAWCURVE \COURIER.DRAWELLIPSE \COURIER.DRAWLINE \COURIER.DRAWPOINT
|
||||
\COURIER.DRAWPOLYGON \COURIER.FILLCIRCLE \COURIER.FILLPOLYGON \COURIER.FONT
|
||||
\COURIER.FONTTYPE \COURIER.LEFTMARGIN \COURIER.LINEFEED \COURIER.MOVETO \COURIER.NEWPAGE
|
||||
\COURIER.OPERATION \COURIER.OPENIMAGESTREAM \COURIER.OUTCHAR \COURIER.POPSTATE
|
||||
\COURIER.PUSHSTATE \COURIER.RESET \COURIER.RIGHTMARGIN \COURIER.ROTATE \COURIER.SCALE
|
||||
\COURIER.SCALEDBITBLT \COURIER.SCALE2 \COURIER.SPACEFACTOR \COURIER.STRINGWIDTH
|
||||
\COURIER.TERPRI \COURIER.TOPMARGIN \COURIER.TRANSLATE \COURIER.XPOSITION
|
||||
\COURIER.YPOSITION)
|
||||
(* * etc.)
|
||||
(FNS \INITCOURIERIMAGESTREAM READSTREAMHANDLE WRITESTREAMHANDLE)
|
||||
(INITVARS \COURIERIMAGEOPS \NULLFDEV IMAGESTREAMALST)
|
||||
@@ -398,11 +397,6 @@ Copyright (c) 1985, 1986, 1987, 1988 by Xerox Corporation & Stanford University.
|
||||
(* ; "Edited 24-Mar-87 20:54 by cdl")
|
||||
`(RETURN ,(IMAGEOP 'IMBOTTOMMARGIN IMAGESTREAM IMAGESTREAM YPOSITION])
|
||||
|
||||
(\COURIER.CHARSET
|
||||
[LAMBDA (COURIERSTREAM PROGRAM PROCEDURE IMAGESTREAM CHARACTERSET)
|
||||
(* ; "Edited 24-Mar-87 20:54 by cdl")
|
||||
`(RETURN ,(IMAGEOP 'IMCHARSET IMAGESTREAM IMAGESTREAM CHARACTERSET])
|
||||
|
||||
(\COURIER.CHARWIDTH
|
||||
[LAMBDA (COURIERSTREAM PROGRAM PROCEDURE IMAGESTREAM CHARCODE)
|
||||
(* ; "Edited 24-Mar-87 20:55 by cdl")
|
||||
@@ -658,7 +652,8 @@ Copyright (c) 1985, 1986, 1987, 1988 by Xerox Corporation & Stanford University.
|
||||
(DEFINEQ
|
||||
|
||||
(\INITCOURIERIMAGESTREAM
|
||||
[LAMBDA NIL (* ; "Edited 3-Sep-87 09:59 by cdl")
|
||||
[LAMBDA NIL (* ; "Edited 8-Dec-2023 21:35 by rmk")
|
||||
(* ; "Edited 3-Sep-87 09:59 by cdl")
|
||||
(SETQ \COURIERIMAGEOPS (create IMAGEOPS
|
||||
IMAGETYPE _ 'COURIER
|
||||
IMCLOSEFN _ (FUNCTION \CLOSEFN.COURIER)
|
||||
@@ -694,7 +689,6 @@ Copyright (c) 1985, 1986, 1987, 1988 by Xerox Corporation & Stanford University.
|
||||
IMCLIPPINGREGION _ (FUNCTION \CLIPPINGREGION.COURIER)
|
||||
IMOPERATION _ (FUNCTION \OPERATION.COURIER)
|
||||
IMSPACEFACTOR _ (FUNCTION \SPACEFACTOR.COURIER)
|
||||
IMCHARSET _ (FUNCTION \CHARSET.COURIER)
|
||||
IMROTATE _ (FUNCTION \ROTATE.COURIER)
|
||||
IMDRAWARC _ (FUNCTION \DRAWARC.COURIER)
|
||||
IMTRANSLATE _ (FUNCTION \TRANSLATE.COURIER)
|
||||
@@ -722,7 +716,7 @@ Copyright (c) 1985, 1986, 1987, 1988 by Xerox Corporation & Stanford University.
|
||||
|
||||
(RPAQ? IMAGESTREAMALST NIL)
|
||||
|
||||
(PUTPROPS STREAMHANDLE COURIERDEF (READSTREAMHANDLE WRITESTREAMHANDLE))
|
||||
(PUTPROPS STREAMHANDLE COURIERDEF (READSTREAMHANDLE WRITESTREAMHANDLE))
|
||||
(DECLARE%: DOEVAL@COMPILE DONTCOPY
|
||||
|
||||
(GLOBALVARS \COURIERIMAGEOPS \NULLFDEV IMAGESTREAMALST)
|
||||
@@ -731,7 +725,7 @@ Copyright (c) 1985, 1986, 1987, 1988 by Xerox Corporation & Stanford University.
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(RECORD COURIERIMAGEDATA (CIS.COURIERSTREAM CIS.IMAGESTREAM CIS.FONT CIS.LOCALFONTS?)
|
||||
CIS.LOCALFONTS? _ T)
|
||||
CIS.LOCALFONTS? _ T)
|
||||
)
|
||||
)
|
||||
|
||||
@@ -973,40 +967,38 @@ Copyright (c) 1985, 1986, 1987, 1988 by Xerox Corporation & Stanford University.
|
||||
(\INITCOURIERIMAGESTREAM)
|
||||
|
||||
(COURIER.START.SERVER)
|
||||
(PUTPROPS COURIERIMAGESTREAM COPYRIGHT ("Xerox Corporation & Stanford University" 1985 1986 1987 1988)
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (3228 21422 (\BACKCOLOR.COURIER 3238 . 3509) (\BITBLT.COURIER 3511 . 4553) (
|
||||
\BLTSHADE.COURIER 4555 . 5235) (\BOTTOMMARGIN.COURIER 5237 . 5518) (\CHARSET.COURIER 5520 . 5794) (
|
||||
\CHARWIDTH.COURIER 5796 . 6200) (\CHARWIDTHY.COURIER 6202 . 6609) (\CLIPPINGREGION.COURIER 6611 . 6893
|
||||
) (\CLOSEFN.COURIER 6895 . 7154) (\COLOR.COURIER 7156 . 7419) (\COURIERIMAGESTREAM.BOUT 7421 . 7695) (
|
||||
\DEFAULTSTATE.COURIER 7697 . 7980) (\DRAWARC.COURIER 7982 . 8399) (\DRAWCIRCLE.COURIER 8401 . 8724) (
|
||||
\DRAWCURVE.COURIER 8726 . 9036) (\DRAWELLIPSE.COURIER 9038 . 9496) (\DRAWLINE.COURIER 9498 . 9887) (
|
||||
\DRAWPOINT.COURIER 9889 . 10205) (\DRAWPOLYGON.COURIER 10207 . 10523) (\FILLCIRCLE.COURIER 10525 .
|
||||
10842) (\FILLPOLYGON.COURIER 10844 . 11128) (\FONT.COURIER 11130 . 11537) (\LEFTMARGIN.COURIER 11539
|
||||
. 11816) (\LINEFEED.COURIER 11818 . 12088) (\MOVETO.COURIER 12090 . 12353) (\NEWPAGE.COURIER 12355 .
|
||||
12616) (\OPENIMAGESTREAM.COURIER 12618 . 15192) (\OPERATION.COURIER 15194 . 15469) (\POPSTATE.COURIER
|
||||
15471 . 15746) (\PUSHSTATE.COURIER 15748 . 16025) (\RESET.COURIER 16027 . 16360) (\RIGHTMARGIN.COURIER
|
||||
16362 . 16641) (\ROTATE.COURIER 16643 . 16923) (\SCALE.COURIER 16925 . 17188) (\SCALEDBITBLT.COURIER
|
||||
17190 . 18470) (\SCALE2.COURIER 18472 . 18747) (\SPACEFACTOR.COURIER 18749 . 19025) (
|
||||
\STRINGWIDTH.COURIER 19027 . 19433) (\TERPRI.COURIER 19435 . 19770) (\TOPMARGIN.COURIER 19772 . 20047)
|
||||
(\TRANSLATE.COURIER 20049 . 20330) (\XPOSITION.COURIER 20332 . 20607) (\YPOSITION.COURIER 20609 .
|
||||
20884) (\OUTCHAR.COURIER 20886 . 21420)) (21460 35552 (\COURIER.BACKCOLOR 21470 . 21730) (
|
||||
\COURIER.BITBLT 21732 . 22252) (\COURIER.BLTSHADE 22254 . 22649) (\COURIER.BOTTOMMARGIN 22651 . 22925)
|
||||
(\COURIER.CHARSET 22927 . 23197) (\COURIER.CHARWIDTH 23199 . 23465) (\COURIER.CHARWIDTHY 23467 .
|
||||
23735) (\COURIER.CLIPPINGREGION 23737 . 24009) (\COURIER.CLOSEIMAGESTREAM 24011 . 24630) (
|
||||
\COURIER.COLOR 24632 . 24884) (\COURIER.DEFAULTSTATE 24886 . 25132) (\COURIER.DRAWARC 25134 . 25508) (
|
||||
\COURIER.DRAWCIRCLE 25510 . 25850) (\COURIER.DRAWCURVE 25852 . 26194) (\COURIER.DRAWELLIPSE 26196 .
|
||||
26666) (\COURIER.DRAWLINE 26668 . 27034) (\COURIER.DRAWPOINT 27036 . 27376) (\COURIER.DRAWPOLYGON
|
||||
27378 . 27726) (\COURIER.FILLCIRCLE 27728 . 28056) (\COURIER.FILLPOLYGON 28058 . 28380) (\COURIER.FONT
|
||||
28382 . 28630) (\COURIER.FONTTYPE 28632 . 28865) (\COURIER.LEFTMARGIN 28867 . 29137) (
|
||||
\COURIER.LINEFEED 29139 . 29399) (\COURIER.MOVETO 29401 . 29691) (\COURIER.NEWPAGE 29693 . 29917) (
|
||||
\COURIER.OPERATION 29919 . 30187) (\COURIER.OPENIMAGESTREAM 30189 . 31050) (\COURIER.OUTCHAR 31052 .
|
||||
31332) (\COURIER.POPSTATE 31334 . 31572) (\COURIER.PUSHSTATE 31574 . 31814) (\COURIER.RESET 31816 .
|
||||
32036) (\COURIER.RIGHTMARGIN 32038 . 32310) (\COURIER.ROTATE 32312 . 32578) (\COURIER.SCALE 32580 .
|
||||
32832) (\COURIER.SCALEDBITBLT 32834 . 33366) (\COURIER.SCALE2 33368 . 33670) (\COURIER.SPACEFACTOR
|
||||
33672 . 33938) (\COURIER.STRINGWIDTH 33940 . 34206) (\COURIER.TERPRI 34208 . 34430) (
|
||||
\COURIER.TOPMARGIN 34432 . 34700) (\COURIER.TRANSLATE 34702 . 35010) (\COURIER.XPOSITION 35012 . 35280
|
||||
) (\COURIER.YPOSITION 35282 . 35550)) (35570 39599 (\INITCOURIERIMAGESTREAM 35580 . 39043) (
|
||||
READSTREAMHANDLE 39045 . 39428) (WRITESTREAMHANDLE 39430 . 39597)))))
|
||||
(FILEMAP (NIL (3073 21267 (\BACKCOLOR.COURIER 3083 . 3354) (\BITBLT.COURIER 3356 . 4398) (
|
||||
\BLTSHADE.COURIER 4400 . 5080) (\BOTTOMMARGIN.COURIER 5082 . 5363) (\CHARSET.COURIER 5365 . 5639) (
|
||||
\CHARWIDTH.COURIER 5641 . 6045) (\CHARWIDTHY.COURIER 6047 . 6454) (\CLIPPINGREGION.COURIER 6456 . 6738
|
||||
) (\CLOSEFN.COURIER 6740 . 6999) (\COLOR.COURIER 7001 . 7264) (\COURIERIMAGESTREAM.BOUT 7266 . 7540) (
|
||||
\DEFAULTSTATE.COURIER 7542 . 7825) (\DRAWARC.COURIER 7827 . 8244) (\DRAWCIRCLE.COURIER 8246 . 8569) (
|
||||
\DRAWCURVE.COURIER 8571 . 8881) (\DRAWELLIPSE.COURIER 8883 . 9341) (\DRAWLINE.COURIER 9343 . 9732) (
|
||||
\DRAWPOINT.COURIER 9734 . 10050) (\DRAWPOLYGON.COURIER 10052 . 10368) (\FILLCIRCLE.COURIER 10370 .
|
||||
10687) (\FILLPOLYGON.COURIER 10689 . 10973) (\FONT.COURIER 10975 . 11382) (\LEFTMARGIN.COURIER 11384
|
||||
. 11661) (\LINEFEED.COURIER 11663 . 11933) (\MOVETO.COURIER 11935 . 12198) (\NEWPAGE.COURIER 12200 .
|
||||
12461) (\OPENIMAGESTREAM.COURIER 12463 . 15037) (\OPERATION.COURIER 15039 . 15314) (\POPSTATE.COURIER
|
||||
15316 . 15591) (\PUSHSTATE.COURIER 15593 . 15870) (\RESET.COURIER 15872 . 16205) (\RIGHTMARGIN.COURIER
|
||||
16207 . 16486) (\ROTATE.COURIER 16488 . 16768) (\SCALE.COURIER 16770 . 17033) (\SCALEDBITBLT.COURIER
|
||||
17035 . 18315) (\SCALE2.COURIER 18317 . 18592) (\SPACEFACTOR.COURIER 18594 . 18870) (
|
||||
\STRINGWIDTH.COURIER 18872 . 19278) (\TERPRI.COURIER 19280 . 19615) (\TOPMARGIN.COURIER 19617 . 19892)
|
||||
(\TRANSLATE.COURIER 19894 . 20175) (\XPOSITION.COURIER 20177 . 20452) (\YPOSITION.COURIER 20454 .
|
||||
20729) (\OUTCHAR.COURIER 20731 . 21265)) (21305 35125 (\COURIER.BACKCOLOR 21315 . 21575) (
|
||||
\COURIER.BITBLT 21577 . 22097) (\COURIER.BLTSHADE 22099 . 22494) (\COURIER.BOTTOMMARGIN 22496 . 22770)
|
||||
(\COURIER.CHARWIDTH 22772 . 23038) (\COURIER.CHARWIDTHY 23040 . 23308) (\COURIER.CLIPPINGREGION 23310
|
||||
. 23582) (\COURIER.CLOSEIMAGESTREAM 23584 . 24203) (\COURIER.COLOR 24205 . 24457) (
|
||||
\COURIER.DEFAULTSTATE 24459 . 24705) (\COURIER.DRAWARC 24707 . 25081) (\COURIER.DRAWCIRCLE 25083 .
|
||||
25423) (\COURIER.DRAWCURVE 25425 . 25767) (\COURIER.DRAWELLIPSE 25769 . 26239) (\COURIER.DRAWLINE
|
||||
26241 . 26607) (\COURIER.DRAWPOINT 26609 . 26949) (\COURIER.DRAWPOLYGON 26951 . 27299) (
|
||||
\COURIER.FILLCIRCLE 27301 . 27629) (\COURIER.FILLPOLYGON 27631 . 27953) (\COURIER.FONT 27955 . 28203)
|
||||
(\COURIER.FONTTYPE 28205 . 28438) (\COURIER.LEFTMARGIN 28440 . 28710) (\COURIER.LINEFEED 28712 . 28972
|
||||
) (\COURIER.MOVETO 28974 . 29264) (\COURIER.NEWPAGE 29266 . 29490) (\COURIER.OPERATION 29492 . 29760)
|
||||
(\COURIER.OPENIMAGESTREAM 29762 . 30623) (\COURIER.OUTCHAR 30625 . 30905) (\COURIER.POPSTATE 30907 .
|
||||
31145) (\COURIER.PUSHSTATE 31147 . 31387) (\COURIER.RESET 31389 . 31609) (\COURIER.RIGHTMARGIN 31611
|
||||
. 31883) (\COURIER.ROTATE 31885 . 32151) (\COURIER.SCALE 32153 . 32405) (\COURIER.SCALEDBITBLT 32407
|
||||
. 32939) (\COURIER.SCALE2 32941 . 33243) (\COURIER.SPACEFACTOR 33245 . 33511) (\COURIER.STRINGWIDTH
|
||||
33513 . 33779) (\COURIER.TERPRI 33781 . 34003) (\COURIER.TOPMARGIN 34005 . 34273) (\COURIER.TRANSLATE
|
||||
34275 . 34583) (\COURIER.XPOSITION 34585 . 34853) (\COURIER.YPOSITION 34855 . 35123)) (35143 39211 (
|
||||
\INITCOURIERIMAGESTREAM 35153 . 38655) (READSTREAMHANDLE 38657 . 39040) (WRITESTREAMHANDLE 39042 .
|
||||
39209)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,54 +1,32 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
(FILECREATED "19-Jul-88 13:36:39" |{MCS:MCS:STANFORD}<LANE>DSPSCALE.;10| 55021
|
||||
|
||||
changes to%: (FNS \TRANSLATE.SCALED CHARWIDTH! CHARWIDTHY! FONTPROP! STRINGWIDTH!
|
||||
INITSCALEDIMAGESTREAM \FILLPOLYGON.SCALED DSPSCALE.DASHING
|
||||
OPENIMAGESTREAM.SCALED \BACKCOLOR.SCALED \BITBLT.SCALED \BLTSHADE.SCALED
|
||||
\BOTTOMMARGIN.SCALED \BOUT.SCALED \CHARSET.SCALED \CHARWIDTH.SCALED
|
||||
\CHARWIDTHY.SCALED \CLIPPINGREGION.SCALED \CLOSEFN.SCALED \COLOR.SCALED
|
||||
\DEFAULTSTATE.SCALED \DRAWARC.SCALED \DRAWCIRCLE.SCALED \DRAWCURVE.SCALED
|
||||
\DRAWELLIPSE.SCALED \DRAWLINE.SCALED \DRAWPOINT.SCALED \DRAWPOLYGON.SCALED
|
||||
\FILLCIRCLE.SCALED \FONT.SCALED \LEFTMARGIN.SCALED \LINEFEED.SCALED
|
||||
\MOVETO.SCALED \NEWPAGE.SCALED \OPERATION.SCALED \POPSTATE.SCALED
|
||||
\PUSHSTATE.SCALED \RESET.SCALED \RIGHTMARGIN.SCALED \ROTATE.SCALED
|
||||
\SCALE.SCALED \SCALEDBITBLT.SCALED \SPACEFACTOR.SCALED \STRINGWIDTH.SCALED
|
||||
\TERPRI.SCALED \TOPMARGIN.SCALED \XPOSITION.SCALED \YPOSITION.SCALED
|
||||
\OUTCHAR.SCALED CENTERPRINTINREGION! CURSORPOSITION! BITBLT! BITMAPBIT!
|
||||
BLTSHADE! DSPBACKUP! DSPBOTTOMMARGIN! DSPCLIPPINGREGION! DRAWBETWEEN!
|
||||
DRAWARC! DRAWCIRCLE! DRAWCURVE! DRAWELLIPSE! DRAWLINE! DRAWPOINT!
|
||||
DRAWPOLYGON! DRAWTO! FILLCIRCLE! FILLPOLYGON! DSPLEFTMARGIN! DSPLINEFEED!
|
||||
GETPOSITION! MOVETO! MOVETOUPPERLEFT! DSPRIGHTMARGIN! DSPSCALE! RELDRAWTO!
|
||||
RELMOVETO! SCALEDBITBLT! STRINGREGION! DSPSPACEFACTOR! DSPTRANSLATE!
|
||||
DSPTOPMARGIN! DSPUNITS! DSPXOFFSET! DSPXPOSITION! DSPYOFFSET! DSPYPOSITION!
|
||||
DSPSCALE.BRUSH DSPSCALE.POINTS DSPSCALE.REGION DSPSCALE.NUMBER
|
||||
DSPSCALE.POSITION DSPSCALE.XPOSITION DSPSCALE.YPOSITION DSPSCALE.WIDTH
|
||||
DSPUNSCALE.REGION DSPUNSCALE.POSITION DSPUNSCALE.NUMBER DSPUNSCALE.CHARACTER
|
||||
)
|
||||
(VARS DSPSCALECOMS)
|
||||
(FILECREATED " 8-Dec-2023 21:32:41" {WMEDLEY}<lispusers>DSPSCALE.;3 52572
|
||||
|
||||
previous date%: "19-Jul-88 10:00:47" |{MCS:MCS:STANFORD}<LANE>DSPSCALE.;6|)
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (FNS INITSCALEDIMAGESTREAM \CHARSET.SCALED)
|
||||
(VARS DSPSCALECOMS)
|
||||
(RECORDS SCALEDIMAGEDATA CONVERT)
|
||||
(MACROS DSPUNSCALE.XPOSITION DSPUNSCALE.YPOSITION)
|
||||
|
||||
:PREVIOUS-DATE "19-Jul-88 13:36:39" {WMEDLEY}<lispusers>DSPSCALE.;1)
|
||||
|
||||
(* "
|
||||
Copyright (c) 1985, 1986, 1987, 1988 by Stanford University. All rights reserved.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT DSPSCALECOMS)
|
||||
|
||||
(RPAQQ DSPSCALECOMS
|
||||
(RPAQQ DSPSCALECOMS
|
||||
((LOCALVARS . T)
|
||||
(* * SCALED ImageStream ImageOp Functions)
|
||||
(FNS INITSCALEDIMAGESTREAM OPENIMAGESTREAM.SCALED)
|
||||
(FNS \BACKCOLOR.SCALED \BITBLT.SCALED \BLTSHADE.SCALED \BOTTOMMARGIN.SCALED \BOUT.SCALED
|
||||
\CHARSET.SCALED \CHARWIDTH.SCALED \CHARWIDTHY.SCALED \CLIPPINGREGION.SCALED
|
||||
\CLOSEFN.SCALED \COLOR.SCALED \DEFAULTSTATE.SCALED \DRAWARC.SCALED \DRAWCIRCLE.SCALED
|
||||
\DRAWCURVE.SCALED \DRAWELLIPSE.SCALED \DRAWLINE.SCALED \DRAWPOINT.SCALED
|
||||
\DRAWPOLYGON.SCALED \FILLCIRCLE.SCALED \FILLPOLYGON.SCALED \FONT.SCALED
|
||||
\LEFTMARGIN.SCALED \LINEFEED.SCALED \MOVETO.SCALED \NEWPAGE.SCALED \OPERATION.SCALED
|
||||
\POPSTATE.SCALED \PUSHSTATE.SCALED \RESET.SCALED \RIGHTMARGIN.SCALED \ROTATE.SCALED
|
||||
\SCALE.SCALED \SCALEDBITBLT.SCALED \SPACEFACTOR.SCALED \STRINGWIDTH.SCALED
|
||||
\TERPRI.SCALED \TOPMARGIN.SCALED \TRANSLATE.SCALED \XPOSITION.SCALED \YPOSITION.SCALED
|
||||
\OUTCHAR.SCALED)
|
||||
\CHARWIDTH.SCALED \CHARWIDTHY.SCALED \CLIPPINGREGION.SCALED \CLOSEFN.SCALED
|
||||
\COLOR.SCALED \DEFAULTSTATE.SCALED \DRAWARC.SCALED \DRAWCIRCLE.SCALED \DRAWCURVE.SCALED
|
||||
\DRAWELLIPSE.SCALED \DRAWLINE.SCALED \DRAWPOINT.SCALED \DRAWPOLYGON.SCALED
|
||||
\FILLCIRCLE.SCALED \FILLPOLYGON.SCALED \FONT.SCALED \LEFTMARGIN.SCALED \LINEFEED.SCALED
|
||||
\MOVETO.SCALED \NEWPAGE.SCALED \OPERATION.SCALED \POPSTATE.SCALED \PUSHSTATE.SCALED
|
||||
\RESET.SCALED \RIGHTMARGIN.SCALED \ROTATE.SCALED \SCALE.SCALED \SCALEDBITBLT.SCALED
|
||||
\SPACEFACTOR.SCALED \STRINGWIDTH.SCALED \TERPRI.SCALED \TOPMARGIN.SCALED
|
||||
\TRANSLATE.SCALED \XPOSITION.SCALED \YPOSITION.SCALED \OUTCHAR.SCALED)
|
||||
(* * Self Scaling DSP* Functions)
|
||||
(FNS CENTERPRINTINREGION! CHARWIDTH! CHARWIDTHY! CURSORPOSITION! BITBLT! BITMAPBIT! BLTSHADE!
|
||||
DSPBACKUP! DSPBOTTOMMARGIN! DSPCLIPPINGREGION! DRAWBETWEEN! DRAWARC! DRAWCIRCLE!
|
||||
@@ -86,11 +64,11 @@ Copyright (c) 1985, 1986, 1987, 1988 by Stanford University. All rights reserve
|
||||
(DEFINEQ
|
||||
|
||||
(INITSCALEDIMAGESTREAM
|
||||
[LAMBDA NIL (* ; "Edited 19-Jul-88 10:59 by cdl")
|
||||
[LAMBDA NIL (* ; "Edited 19-Jul-88 10:59 by cdl")
|
||||
(DECLARE (GLOBALVARS \DISPLAYIMAGEOPS))
|
||||
[if (NULL \NULLFDEV)
|
||||
then (SETQ \NULLFDEV (create FDEV
|
||||
CLOSEFILE _ (FUNCTION NILL]
|
||||
CLOSEFILE _ (FUNCTION NILL]
|
||||
(SETQ \SCALEDIMAGEOPS (create IMAGEOPS
|
||||
IMAGETYPE _ 'SCALED
|
||||
IMCLOSEFN _ (FUNCTION \CLOSEFN.SCALED)
|
||||
@@ -126,7 +104,6 @@ Copyright (c) 1985, 1986, 1987, 1988 by Stanford University. All rights reserve
|
||||
IMDRAWPOLYGON _ (FUNCTION \DRAWPOLYGON.SCALED)
|
||||
IMFILLPOLYGON _ (FUNCTION \FILLPOLYGON.SCALED)
|
||||
IMSCALEDBITBLT _ (FUNCTION \SCALEDBITBLT.SCALED)
|
||||
IMCHARSET _ (FUNCTION \CHARSET.SCALED)
|
||||
IMROTATE _ (FUNCTION \ROTATE.SCALED)
|
||||
IMDRAWARC _ (FUNCTION \DRAWARC.SCALED)
|
||||
IMTRANSLATE _ (FUNCTION \TRANSLATE.SCALED)
|
||||
@@ -208,11 +185,6 @@ Copyright (c) 1985, 1986, 1987, 1988 by Stanford University. All rights reserve
|
||||
(with SCALEDIMAGEDATA (with STREAM STREAM IMAGEDATA)
|
||||
(BOUT IMAGESTREAM BYTE])
|
||||
|
||||
(\CHARSET.SCALED
|
||||
[LAMBDA (STREAM CHARACTERSET) (* cdl "26-Jan-87 08:49")
|
||||
(with SCALEDIMAGEDATA (with STREAM STREAM IMAGEDATA)
|
||||
(IMAGEOP 'IMCHARSET IMAGESTREAM IMAGESTREAM CHARACTERSET])
|
||||
|
||||
(\CHARWIDTH.SCALED
|
||||
[LAMBDA (STREAM CHARCODE) (* cdl "26-Jan-87 09:50")
|
||||
(with SCALEDIMAGEDATA (with STREAM STREAM IMAGEDATA)
|
||||
@@ -975,11 +947,11 @@ Copyright (c) 1985, 1986, 1987, 1988 by Stanford University. All rights reserve
|
||||
)
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
[PUTPROPS DSPUNSCALE.XPOSITION MACRO ((VALUE STREAM)
|
||||
(DSPUNSCALE.NUMBER VALUE STREAM 'X]
|
||||
(PUTPROPS DSPUNSCALE.XPOSITION MACRO ((VALUE STREAM)
|
||||
(DSPUNSCALE.NUMBER VALUE STREAM 'X)))
|
||||
|
||||
[PUTPROPS DSPUNSCALE.YPOSITION MACRO ((VALUE STREAM)
|
||||
(DSPUNSCALE.NUMBER VALUE STREAM 'Y]
|
||||
(PUTPROPS DSPUNSCALE.YPOSITION MACRO ((VALUE STREAM)
|
||||
(DSPUNSCALE.NUMBER VALUE STREAM 'Y)))
|
||||
)
|
||||
(* * etc.)
|
||||
|
||||
@@ -1022,39 +994,38 @@ Copyright (c) 1985, 1986, 1987, 1988 by Stanford University. All rights reserve
|
||||
(MOVD? 'DSPUNITS! 'DSPUNITS)
|
||||
|
||||
(INITSCALEDIMAGESTREAM)
|
||||
(PUTPROPS DSPSCALE COPYRIGHT ("Stanford University" 1985 1986 1987 1988))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (5589 11142 (INITSCALEDIMAGESTREAM 5599 . 9099) (OPENIMAGESTREAM.SCALED 9101 . 11140)) (
|
||||
11143 28693 (\BACKCOLOR.SCALED 11153 . 11396) (\BITBLT.SCALED 11398 . 12265) (\BLTSHADE.SCALED 12267
|
||||
. 13022) (\BOTTOMMARGIN.SCALED 13024 . 13479) (\BOUT.SCALED 13481 . 13690) (\CHARSET.SCALED 13692 .
|
||||
13938) (\CHARWIDTH.SCALED 13940 . 14287) (\CHARWIDTHY.SCALED 14289 . 14638) (\CLIPPINGREGION.SCALED
|
||||
14640 . 15093) (\CLOSEFN.SCALED 15095 . 15356) (\COLOR.SCALED 15358 . 15593) (\DEFAULTSTATE.SCALED
|
||||
15595 . 15850) (\DRAWARC.SCALED 15852 . 16481) (\DRAWCIRCLE.SCALED 16483 . 17072) (\DRAWCURVE.SCALED
|
||||
17074 . 17493) (\DRAWELLIPSE.SCALED 17495 . 18291) (\DRAWLINE.SCALED 18293 . 18940) (\DRAWPOINT.SCALED
|
||||
18942 . 19372) (\DRAWPOLYGON.SCALED 19374 . 19797) (\FILLCIRCLE.SCALED 19799 . 20297) (
|
||||
\FILLPOLYGON.SCALED 20299 . 20639) (\FONT.SCALED 20641 . 20873) (\LEFTMARGIN.SCALED 20875 . 21326) (
|
||||
\LINEFEED.SCALED 21328 . 21769) (\MOVETO.SCALED 21771 . 22097) (\NEWPAGE.SCALED 22099 . 22332) (
|
||||
\OPERATION.SCALED 22334 . 22581) (\POPSTATE.SCALED 22583 . 22830) (\PUSHSTATE.SCALED 22832 . 23081) (
|
||||
\RESET.SCALED 23083 . 23333) (\RIGHTMARGIN.SCALED 23335 . 23788) (\ROTATE.SCALED 23790 . 24042) (
|
||||
\SCALE.SCALED 24044 . 24367) (\SCALEDBITBLT.SCALED 24369 . 25278) (\SPACEFACTOR.SCALED 25280 . 25727)
|
||||
(\STRINGWIDTH.SCALED 25729 . 26084) (\TERPRI.SCALED 26086 . 26338) (\TOPMARGIN.SCALED 26340 . 26789) (
|
||||
\TRANSLATE.SCALED 26791 . 27161) (\XPOSITION.SCALED 27163 . 27612) (\YPOSITION.SCALED 27614 . 28063) (
|
||||
\OUTCHAR.SCALED 28065 . 28691)) (28734 43771 (CENTERPRINTINREGION! 28744 . 29003) (CHARWIDTH! 29005 .
|
||||
29238) (CHARWIDTHY! 29240 . 29475) (CURSORPOSITION! 29477 . 29921) (BITBLT! 29923 . 30533) (BITMAPBIT!
|
||||
30535 . 30764) (BLTSHADE! 30766 . 31298) (DSPBACKUP! 31300 . 31536) (DSPBOTTOMMARGIN! 31538 . 31871)
|
||||
(DSPCLIPPINGREGION! 31873 . 32206) (DRAWBETWEEN! 32208 . 32591) (DRAWARC! 32593 . 33074) (DRAWCIRCLE!
|
||||
33076 . 33451) (DRAWCURVE! 33453 . 33741) (DRAWELLIPSE! 33743 . 34305) (DRAWLINE! 34307 . 34782) (
|
||||
DRAWPOINT! 34784 . 35071) (DRAWPOLYGON! 35073 . 35366) (DRAWTO! 35368 . 35680) (FILLCIRCLE! 35682 .
|
||||
35971) (FILLPOLYGON! 35973 . 36161) (FONTPROP! 36163 . 36501) (DSPLEFTMARGIN! 36503 . 36830) (
|
||||
DSPLINEFEED! 36832 . 37147) (GETPOSITION! 37149 . 37334) (MOVETO! 37336 . 37550) (MOVETOUPPERLEFT!
|
||||
37552 . 37785) (DSPRIGHTMARGIN! 37787 . 38117) (DSPSCALE! 38119 . 38915) (RELDRAWTO! 38917 . 39231) (
|
||||
RELMOVETO! 39233 . 39449) (SCALEDBITBLT! 39451 . 40089) (STRINGREGION! 40091 . 40316) (STRINGWIDTH!
|
||||
40318 . 40560) (DSPSPACEFACTOR! 40562 . 40886) (DSPTRANSLATE! 40888 . 41389) (DSPTOPMARGIN! 41391 .
|
||||
41715) (DSPUNITS! 41717 . 42443) (DSPXOFFSET! 42445 . 42780) (DSPXPOSITION! 42782 . 43106) (
|
||||
DSPYOFFSET! 43108 . 43443) (DSPYPOSITION! 43445 . 43769)) (43812 53676 (DSPSCALE.BRUSH 43822 . 44648)
|
||||
(DSPSCALE.DASHING 44650 . 45198) (DSPSCALE.POINTS 45200 . 46255) (DSPSCALE.REGION 46257 . 46955) (
|
||||
DSPSCALE.NUMBER 46957 . 47912) (DSPSCALE.POSITION 47914 . 48339) (DSPSCALE.XPOSITION 48341 . 48862) (
|
||||
DSPSCALE.YPOSITION 48864 . 49385) (DSPSCALE.WIDTH 49387 . 49607) (DSPUNSCALE.REGION 49609 . 50309) (
|
||||
DSPUNSCALE.POSITION 50311 . 50734) (DSPUNSCALE.NUMBER 50736 . 52070) (DSPUNSCALE.CHARACTER 52072 .
|
||||
53674)))))
|
||||
(FILEMAP (NIL (3514 8995 (INITSCALEDIMAGESTREAM 3524 . 6952) (OPENIMAGESTREAM.SCALED 6954 . 8993)) (
|
||||
8996 26298 (\BACKCOLOR.SCALED 9006 . 9249) (\BITBLT.SCALED 9251 . 10118) (\BLTSHADE.SCALED 10120 .
|
||||
10875) (\BOTTOMMARGIN.SCALED 10877 . 11332) (\BOUT.SCALED 11334 . 11543) (\CHARWIDTH.SCALED 11545 .
|
||||
11892) (\CHARWIDTHY.SCALED 11894 . 12243) (\CLIPPINGREGION.SCALED 12245 . 12698) (\CLOSEFN.SCALED
|
||||
12700 . 12961) (\COLOR.SCALED 12963 . 13198) (\DEFAULTSTATE.SCALED 13200 . 13455) (\DRAWARC.SCALED
|
||||
13457 . 14086) (\DRAWCIRCLE.SCALED 14088 . 14677) (\DRAWCURVE.SCALED 14679 . 15098) (
|
||||
\DRAWELLIPSE.SCALED 15100 . 15896) (\DRAWLINE.SCALED 15898 . 16545) (\DRAWPOINT.SCALED 16547 . 16977)
|
||||
(\DRAWPOLYGON.SCALED 16979 . 17402) (\FILLCIRCLE.SCALED 17404 . 17902) (\FILLPOLYGON.SCALED 17904 .
|
||||
18244) (\FONT.SCALED 18246 . 18478) (\LEFTMARGIN.SCALED 18480 . 18931) (\LINEFEED.SCALED 18933 . 19374
|
||||
) (\MOVETO.SCALED 19376 . 19702) (\NEWPAGE.SCALED 19704 . 19937) (\OPERATION.SCALED 19939 . 20186) (
|
||||
\POPSTATE.SCALED 20188 . 20435) (\PUSHSTATE.SCALED 20437 . 20686) (\RESET.SCALED 20688 . 20938) (
|
||||
\RIGHTMARGIN.SCALED 20940 . 21393) (\ROTATE.SCALED 21395 . 21647) (\SCALE.SCALED 21649 . 21972) (
|
||||
\SCALEDBITBLT.SCALED 21974 . 22883) (\SPACEFACTOR.SCALED 22885 . 23332) (\STRINGWIDTH.SCALED 23334 .
|
||||
23689) (\TERPRI.SCALED 23691 . 23943) (\TOPMARGIN.SCALED 23945 . 24394) (\TRANSLATE.SCALED 24396 .
|
||||
24766) (\XPOSITION.SCALED 24768 . 25217) (\YPOSITION.SCALED 25219 . 25668) (\OUTCHAR.SCALED 25670 .
|
||||
26296)) (26339 41376 (CENTERPRINTINREGION! 26349 . 26608) (CHARWIDTH! 26610 . 26843) (CHARWIDTHY!
|
||||
26845 . 27080) (CURSORPOSITION! 27082 . 27526) (BITBLT! 27528 . 28138) (BITMAPBIT! 28140 . 28369) (
|
||||
BLTSHADE! 28371 . 28903) (DSPBACKUP! 28905 . 29141) (DSPBOTTOMMARGIN! 29143 . 29476) (
|
||||
DSPCLIPPINGREGION! 29478 . 29811) (DRAWBETWEEN! 29813 . 30196) (DRAWARC! 30198 . 30679) (DRAWCIRCLE!
|
||||
30681 . 31056) (DRAWCURVE! 31058 . 31346) (DRAWELLIPSE! 31348 . 31910) (DRAWLINE! 31912 . 32387) (
|
||||
DRAWPOINT! 32389 . 32676) (DRAWPOLYGON! 32678 . 32971) (DRAWTO! 32973 . 33285) (FILLCIRCLE! 33287 .
|
||||
33576) (FILLPOLYGON! 33578 . 33766) (FONTPROP! 33768 . 34106) (DSPLEFTMARGIN! 34108 . 34435) (
|
||||
DSPLINEFEED! 34437 . 34752) (GETPOSITION! 34754 . 34939) (MOVETO! 34941 . 35155) (MOVETOUPPERLEFT!
|
||||
35157 . 35390) (DSPRIGHTMARGIN! 35392 . 35722) (DSPSCALE! 35724 . 36520) (RELDRAWTO! 36522 . 36836) (
|
||||
RELMOVETO! 36838 . 37054) (SCALEDBITBLT! 37056 . 37694) (STRINGREGION! 37696 . 37921) (STRINGWIDTH!
|
||||
37923 . 38165) (DSPSPACEFACTOR! 38167 . 38491) (DSPTRANSLATE! 38493 . 38994) (DSPTOPMARGIN! 38996 .
|
||||
39320) (DSPUNITS! 39322 . 40048) (DSPXOFFSET! 40050 . 40385) (DSPXPOSITION! 40387 . 40711) (
|
||||
DSPYOFFSET! 40713 . 41048) (DSPYPOSITION! 41050 . 41374)) (41417 51281 (DSPSCALE.BRUSH 41427 . 42253)
|
||||
(DSPSCALE.DASHING 42255 . 42803) (DSPSCALE.POINTS 42805 . 43860) (DSPSCALE.REGION 43862 . 44560) (
|
||||
DSPSCALE.NUMBER 44562 . 45517) (DSPSCALE.POSITION 45519 . 45944) (DSPSCALE.XPOSITION 45946 . 46467) (
|
||||
DSPSCALE.YPOSITION 46469 . 46990) (DSPSCALE.WIDTH 46992 . 47212) (DSPUNSCALE.REGION 47214 . 47914) (
|
||||
DSPUNSCALE.POSITION 47916 . 48339) (DSPUNSCALE.NUMBER 48341 . 49675) (DSPUNSCALE.CHARACTER 49677 .
|
||||
51279)))))
|
||||
STOP
|
||||
|
||||
BIN
lispusers/DSPSCALE.LCOM
Normal file
BIN
lispusers/DSPSCALE.LCOM
Normal file
Binary file not shown.
Binary file not shown.
Binary file not shown.
@@ -1,9 +1,19 @@
|
||||
Medley GITFNS
2
|
||||
4
|
||||
1
|
||||
GITFNS
1
|
||||
4
|
||||
By Ron Kaplan
This document was last edited in February 2023.
GITFNS provides a Medley-oriented interface for comparing the files in two different branches of a git repository. This makes it easier to understand what functions or other definitions have changed in a Lisp source file, or what text has changed in a Tedit file. This may be particularly helpful in evaluating the changes in a pull request.
|
||||
Medley GITFNS
|
||||
2
|
||||
|
||||
4
|
||||
|
||||
1
|
||||
|
||||
GITFNS
|
||||
1
|
||||
|
||||
4
|
||||
|
||||
By Ron Kaplan
|
||||
This document was last edited in February 2023.
|
||||
|
||||
GITFNS provides a Medley-oriented interface for comparing the files in two different branches of a git repository. This makes it easier to understand what functions or other definitions have changed in a Lisp source file, or what text has changed in a Tedit file. This may be particularly helpful in evaluating the changes in a pull request.
|
||||
Separately, GITFNS also provides tools and conventions for bridging between git's file-oriented style of development and version control and Medley's residential development style with its own version control conventions. GITFNS allows for intelligent comparisons between Lisp source files, Tedit files, and text files in a local git clone and a local Medley-style working directory, and for migrating files to and from the git clone and the working directory.
|
||||
|
||||
Git projects: Connecting git clones to GITFNS capabilities
|
||||
@@ -41,29 +51,37 @@ GIT-MAKE-PROJECT will also create a pseudohost {Wprojectname} for the user's wor
|
||||
GIT-INIT creates the default set of projects when GITFNS is loaded, as specified in the variable GIT-DEFAULT-PROJECTS, initially containing MEDLEY NOTECARDS LOOPS TEST. GIT-INIT is added to AROUNDEXITFNS so that new pseudohost bindings for the default projects will be created if the sysout or makesys is started on a new machine.
|
||||
|
||||
GIT-DEFAULT-PROJECTS [Variable]
|
||||
Determines the projects that are created (or recreated) by GIT-INIT. This is initialized for the MEDLEY NOTECARDS LOOPS TEST projects, with CLONEPATH=NIL
GITFNS also defines two directory-connecting commands for conveniently connecting to the git and working pseudohosts of a project:
|
||||
Determines the projects that are created (or recreated) by GIT-INIT. This is initialized for the MEDLEY NOTECARDS LOOPS TEST projects, with CLONEPATH=NIL
|
||||
GITFNS also defines two directory-connecting commands for conveniently connecting to the git and working pseudohosts of a project:
|
||||
cdg (projectname) (subdir) [Command]
|
||||
cdw (projectname) (subdir) [Command]
|
||||
For example, cdg notecards library connects to {NOTECARDS}/library/.
|
||||
|
||||
Comparing directories and files in different git branches
|
||||
In its simplest application, GITFNS is just an off-to-the-side add-on to whatever work practices the user has developed with respect to a locally installed git project. Its only advantage is to allow for more interpretable git-branch comparisons, especially for pull-request approval. These comparisons are provided by the prc ("pull request compare") Medley executive command:
|
||||
prc (branch) (DRAFT) (projectname) [Command]
This compares the files in branch against the files in the main branch of the project (origin/master or origin/main). Thus, suppose that a pull request has been issued on github for a particular branch, say branch rmk15 of the default project. Then
prc rmk15
|
||||
prc (branch) (DRAFT) (projectname) [Command]
|
||||
This compares the files in branch against the files in the main branch of the project (origin/master or origin/main). Thus, suppose that a pull request has been issued on github for a particular branch, say branch rmk15 of the default project. Then
|
||||
prc rmk15
|
||||
brings up a lispusers/COMPAREDIRECTORIES browser for the files that currently differ between origin/rmk15 and origin/master. If the selected files are Lisp source files, the Compare item on the file browser menu will show the differences in a lispusers/COMPARESOURCES browser. The differences for other file types will be shown in a lispusers/COMPARETEXT browser.
|
||||
If branch is not specified and the shell command gh is available, then a menu of open pull-request branches will be provided. If gh is not available, the menu will offer all known branches. If the optional DRAFT is provided, then the menu will include draft PR's as well as open ones.
|
||||
If one PR, say rmk15, contains all the commits of another (rmk14), then the menu will indicate this by
|
||||
rmk15 > rmk14
|
||||
Note that the prc comparison is read-only: any comments, approvals, or merges of the branch must be specified using the normal Medley-external git interfaces and commands.
prc is the special case of the more general bbc command ("branch-branch compare") for comparing the files in any two branches:
|
||||
bbc branch1 branch2 (project) [Command]
This compares the files in branch1 and branch2, for example
|
||||
Note that the prc comparison is read-only: any comments, approvals, or merges of the branch must be specified using the normal Medley-external git interfaces and commands.
|
||||
prc is the special case of the more general bbc command ("branch-branch compare") for comparing the files in any two branches:
|
||||
bbc branch1 branch2 (project) [Command]
|
||||
This compares the files in branch1 and branch2, for example
|
||||
bbc rmk15 lmm12 (local)
|
||||
This will compare the files in origin/rmk15 and origin/lmm12 in the GIT-DEFAULT project. branch1 defaults to the origin files of the currently checked out branch, the second defaults to origin/master. If local is non-NIL, then a branch that has neither local/ or origin/ prepended will default to local (e.g. local/rmk15) instead of origin/. Local refers to the files that are currently in the clone directory, which may not be the same as the origin files, depending on the push/pull status.
|
||||
Either of the branches can be specified with an atom LOCAL, REMOTE, or ORIGIN, in which case bbc will offer menus listing the currently existing branches of that type.
|
||||
NOTE: Branch comparison makes use of a git command that has a limit (diff.renameLimit) on the number of files that it can successfully compare. A message will be printed if that limit is exceeded, asking whether a larger value for that limit should be applied globally.
The command cob ("check out branch") checks out a specified branch:
|
||||
NOTE: Branch comparison makes use of a git command that has a limit (diff.renameLimit) on the number of files that it can successfully compare. A message will be printed if that limit is exceeded, asking whether a larger value for that limit should be applied globally.
|
||||
The command cob ("check out branch") checks out a specified branch:
|
||||
cob branch (next-title-string) (project) [Command]
|
||||
This checks out branch of project and then executes git pull. The branch parameter may also be a local branch, T (= the current working branch), or NEW/NEXT (= the next working branch). The current working branch is the branch named <initials>nnn, e.g. rmk15. The initials are the value of INITIALS as used for SEDIT time stamps, and nnn is the largest of the integers of all of the branches beginning with those initials.
|
||||
If branch is NEW or NEXT, then a new initialed branch is created and becomes the user's current branch. Its number is one greater than the largest number of previous initialed branches. If next-title-string is provided, then that string will be appended to the name of the branch, after the initials and next number, and two hyphens. Spaces in next-title-string will also be replaced by hyphens, according to git conventions.
|
||||
If branch is not provided, a menu of locally available branches pops up.
The currently checked out branch is obtained by the b? command:
|
||||
b? (project) [Command]
|
||||
If branch is not provided, a menu of locally available branches pops up.
|
||||
The currently checked out branch is obtained by the b? command:
|
||||
b? (project) [Command]
|
||||
|
||||
Correlating git source control with separate Medley development
|
||||
It is generally unsafe to do Medley development by operating with files in a local clone repository. Medley provides a residential development environment that integrates tightly with the local file system. It is important to have consistent access to the source files of the currently running system, especially for files whose contents have been only partially loaded. A git pull or a branch switch that introduces new versions of some files or removes old files altogether can lead to unpredictable disconnects that are hard to recover from. This is true also because development can go on in the same Medley memory image for days if not weeks, so it is important to have explicit control of any file version changes.
|
||||
GITFNS mitigates the danger by conventions that separate the files in the git clone from the files in the working Medley development directory. The location of the Medley development source tree for a project is given by the WORKINGPATH argument to GIT-MAKE-PROJECT. If WORKINGPATH is T or NIL and there exists a directory >working-projectname> as a sister to the clone, then that is taken to be the WORKINGPATH and thus the prefix for a pseudohost {Wprojectname}.
|
||||
@@ -76,13 +94,12 @@ In addition to the commands for comparing and viewing files, the menu for this b
|
||||
If the master/main branch is the current branch then the menu has no commands to change the clone directory. The browser will show those files that have been updated from a recent merge, and they can individually be copied from the git branch to realign the two source trees with incremented Medley version numbers. If the comparison is with a different branch, say the user's current staging branch, copying files from the working Medley to the git clone or deleting git files will set git up for future commits.
|
||||
Note that the menu item for deleting Medley files will cause all versions to be removed, not just the latest one, to avoid the possibility that an earlier one is revealed. Deletion for Medley files is also accomplished by renaming to a {Wprojectname}<deleted> subdirectory so that they can be recovered if a deletion is in error. Files in the git-clone are removed from the file system immediately, since git provides its own recovery mechanism for those files.
|
||||
GITFNS does not (yet?) include functions for commits, pushes, or merge for updating the remote repository. Those have to be done outside of Medley through the usual github interfaces, as guided by the information provided by the comparisons.
|
||||
| ||||