github.com/Interlisp.medley
1
0
Fork 0
mirror of synced 2026-03-04 02:36:38 +00:00
Code Issues Projects Releases Wiki Activity

Inspectcode scrolls, has the correct window title (#2222)

Browse Source 
* Inspectcode scrolls, has the correct window title

* Add promptwindo so M-f search strings are locally visible

* Fix FILETYPE for LLDISPLAY

* MEDLEYFONTFORMAT More efficient store and read of numeric Interlisp arrays
This commit is contained in:
rmkaplan
2025-07-30 15:42:20 -07:00
committed by GitHub
parent 10de55af05
commit bc7269e3c4
9 changed files with 1213 additions and 207 deletions
Download Patch File Download Diff File Expand all files Collapse all files

76
library/tedit/TEDIT-WINDOW
View File

@@ -1,12 +1,12 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "30-May-2025 12:54:56" {WMEDLEY}<library>TEDIT>TEDIT-WINDOW.;860 229476
(FILECREATED "21-Jul-2025 11:55:26" {WMEDLEY}<library>TEDIT>TEDIT-WINDOW.;861 229641
:EDIT-BY rmk
:CHANGES-TO (FNS TEDIT.DEACTIVATE.WINDOW)
:CHANGES-TO (FNS \TEDIT.WINDOW.CREATE)
:PREVIOUS-DATE "29-May-2025 15:02:25" {WMEDLEY}<library>TEDIT>TEDIT-WINDOW.;858)
:PREVIOUS-DATE "30-May-2025 12:54:56" {WMEDLEY}<library>TEDIT>TEDIT-WINDOW.;860)
(PRETTYCOMPRINT TEDIT-WINDOWCOMS)
@@ -354,7 +354,8 @@
(DEFINEQ
(\TEDIT.WINDOW.CREATE
[LAMBDA (WINDOW TSTREAM PROPS) (* ; "Edited 9-May-2025 12:11 by rmk")
[LAMBDA (WINDOW TSTREAM PROPS) (* ; "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")
@@ -392,7 +393,8 @@
(TEDIT.KILL WINDOW)
(\TEDIT.CLOSESPLITS (fetch (TEXTWINDOW WTEXTSTREAM) of WINDOW)
T))
(SETQ TITLE (LISTGET PROPS 'TITLE)))
[SETQ TITLE (OR (LISTGET PROPS 'TITLE)
(WINDOWPROP WINDOW 'TITLE])
(SETQ REGIONTYPE (OR (GETTEXTPROP TEXTOBJ 'REGION-TYPE)
(AND (LITATOM WINDOW)
WINDOW)))
@@ -3627,36 +3629,36 @@
(RPAQ? TEDIT.TITLED.ICON.TEMPLATE (create TITLEDICON ICON _ TEDITICON MASK _ TEDITMASK TITLEREG _
TEDIT.ICON.TITLE.REGION))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (17103 17999 (TEDIT.DEFER.UPDATES 17113 . 17997)) (18000 43777 (\TEDIT.WINDOW.CREATE
18010 . 25172) (\TEDIT.WINDOW.GETREGION 25174 . 28664) (\TEDIT.WINDOW.SETUP 28666 . 32996) (
\TEDIT.MINIMAL.WINDOW.SETUP 32998 . 40409) (\TEDIT.CLEARPANE 40411 . 41128) (\TEDIT.FILL.PANES 41130
. 43775)) (43778 67751 (\TEDIT.CURSORMOVEDFN 43788 . 49398) (\TEDIT.CURSOROUTFN 49400 . 50088) (
\TEDIT.ACTIVE.WINDOWP 50090 . 51160) (\TEDIT.EXPANDFN 51162 . 51725) (\TEDIT.MAINW 51727 . 53007) (
\TEDIT.MAINSTREAM 53009 . 53343) (\TEDIT.PRIMARYPANE 53345 . 54115) (\TEDIT.PANELIST 54117 . 54613) (
\TEDIT.NEWREGIONFN 54615 . 57131) (\TEDIT.SET.WINDOW.EXTENT 57133 . 62387) (\TEDIT.SHRINK.ICONCREATE
62389 . 65122) (\TEDIT.SHRINKFN 65124 . 65533) (\TEDIT.PANEREGION 65535 . 67749)) (67783 100829 (
\TEDIT.BUTTONEVENTFN 67793 . 80766) (\TEDIT.BUTTONEVENTFN.DOOPERATION 80768 . 88031) (
\TEDIT.BUTTONEVENTFN.GETOPERATION 88033 . 89875) (\TEDIT.BUTTONEVENTFN.CURSEL.INIT 89877 . 93547) (
\TEDIT.BUTTONEVENTFN.INACTIVE 93549 . 95979) (\TEDIT.BUTTONEVENTFN.INTITLE 95981 . 97816) (
\TEDIT.COPYINSERTFN 97818 . 98950) (\TEDIT.FOREIGN.COPY 98952 . 100827)) (100830 118072 (
\TEDIT.PANE.SPLIT 100840 . 104788) (\TEDIT.SPLITW 104790 . 112528) (\TEDIT.UNSPLITW 112530 . 116729) (
\TEDIT.LINKPANES 116731 . 117494) (\TEDIT.UNLINKPANE 117496 . 118070)) (119506 120397 (TEDITWINDOWP
119516 . 120395)) (120434 123537 (TEDIT.GETINPUT 120444 . 122887) (\TEDIT.MAKEFILENAME 122889 . 123535
)) (123586 131213 (TEDIT.PROMPTWINDOW 123596 . 123910) (TEDIT.PROMPTPRINT 123912 . 126539) (
TEDIT.PROMPTCLEAR 126541 . 128260) (TEDIT.PROMPTFLASH 128262 . 129520) (\TEDIT.PROMPT.PAGEFULLFN
129522 . 131211)) (131451 141855 (\TEDIT.FILENAME 131461 . 132233) (\TEDIT.DEFAULT.TITLE 132235 .
134614) (\TEDIT.WINDOW.TITLE 134616 . 136785) (\TEDIT.LIKELY.FILENAME 136787 . 139337) (
\TEDIT.UPDATE.TITLE 139339 . 141853)) (141898 154382 (TEDIT.DEACTIVATE.WINDOW 141908 . 147481) (
\TEDIT.RESHAPEFN 147483 . 149568) (\TEDIT.REPAINTFN 149570 . 149794) (\TEDIT.CLOSESPLITS 149796 .
152241) (\TEDIT.CLOSEPANE 152243 . 154380)) (154383 197182 (\TEDIT.SCROLLFN 154393 . 156624) (
\TEDIT.SCROLLCH.TOP 156626 . 158737) (\TEDIT.SCROLLCH.BOTTOM 158739 . 163069) (\TEDIT.SCROLLUP 163071
. 168797) (\TEDIT.TOPLINE.YTOP 168799 . 170468) (\TEDIT.SCROLLDOWN 170470 . 177509) (
\TEDIT.SCROLL.CARET 177511 . 180349) (\TEDIT.VISIBLECARETP 180351 . 182645) (\TEDIT.VISIBLECHARP
182647 . 183738) (\TEDIT.BITMAPLINES 183740 . 187660) (\TEDIT.SETPANE.TOPLINE 187662 . 188274) (
\TEDIT.SHIFTLINES 188276 . 197180)) (197183 208052 (\TEDIT.ONSCREEN? 197193 . 201744) (
\TEDIT.ONSCREEN.REGION 201746 . 205397) (\TEDIT.AFTERMOVEFN 205399 . 206296) (OFFSCREENP 206298 .
208050)) (208094 210908 (\TEDIT.PROCIDLEFN 208104 . 209764) (\TEDIT.PROCENTRYFN 209766 . 210211) (
\TEDIT.PROCEXITFN 210213 . 210906)) (210987 224212 (\TEDIT.DOWNCARET 210997 . 211790) (
\TEDIT.FLASHCARET 211792 . 213903) (\TEDIT.UPCARET 213905 . 215009) (TEDIT.NORMALIZECARET 215011 .
218229) (\TEDIT.SETCARET 218231 . 223582) (\TEDIT.CARET 223584 . 224210)))))
(FILEMAP (NIL (17100 17996 (TEDIT.DEFER.UPDATES 17110 . 17994)) (17997 43942 (\TEDIT.WINDOW.CREATE
18007 . 25337) (\TEDIT.WINDOW.GETREGION 25339 . 28829) (\TEDIT.WINDOW.SETUP 28831 . 33161) (
\TEDIT.MINIMAL.WINDOW.SETUP 33163 . 40574) (\TEDIT.CLEARPANE 40576 . 41293) (\TEDIT.FILL.PANES 41295
. 43940)) (43943 67916 (\TEDIT.CURSORMOVEDFN 43953 . 49563) (\TEDIT.CURSOROUTFN 49565 . 50253) (
\TEDIT.ACTIVE.WINDOWP 50255 . 51325) (\TEDIT.EXPANDFN 51327 . 51890) (\TEDIT.MAINW 51892 . 53172) (
\TEDIT.MAINSTREAM 53174 . 53508) (\TEDIT.PRIMARYPANE 53510 . 54280) (\TEDIT.PANELIST 54282 . 54778) (
\TEDIT.NEWREGIONFN 54780 . 57296) (\TEDIT.SET.WINDOW.EXTENT 57298 . 62552) (\TEDIT.SHRINK.ICONCREATE
62554 . 65287) (\TEDIT.SHRINKFN 65289 . 65698) (\TEDIT.PANEREGION 65700 . 67914)) (67948 100994 (
\TEDIT.BUTTONEVENTFN 67958 . 80931) (\TEDIT.BUTTONEVENTFN.DOOPERATION 80933 . 88196) (
\TEDIT.BUTTONEVENTFN.GETOPERATION 88198 . 90040) (\TEDIT.BUTTONEVENTFN.CURSEL.INIT 90042 . 93712) (
\TEDIT.BUTTONEVENTFN.INACTIVE 93714 . 96144) (\TEDIT.BUTTONEVENTFN.INTITLE 96146 . 97981) (
\TEDIT.COPYINSERTFN 97983 . 99115) (\TEDIT.FOREIGN.COPY 99117 . 100992)) (100995 118237 (
\TEDIT.PANE.SPLIT 101005 . 104953) (\TEDIT.SPLITW 104955 . 112693) (\TEDIT.UNSPLITW 112695 . 116894) (
\TEDIT.LINKPANES 116896 . 117659) (\TEDIT.UNLINKPANE 117661 . 118235)) (119671 120562 (TEDITWINDOWP
119681 . 120560)) (120599 123702 (TEDIT.GETINPUT 120609 . 123052) (\TEDIT.MAKEFILENAME 123054 . 123700
)) (123751 131378 (TEDIT.PROMPTWINDOW 123761 . 124075) (TEDIT.PROMPTPRINT 124077 . 126704) (
TEDIT.PROMPTCLEAR 126706 . 128425) (TEDIT.PROMPTFLASH 128427 . 129685) (\TEDIT.PROMPT.PAGEFULLFN
129687 . 131376)) (131616 142020 (\TEDIT.FILENAME 131626 . 132398) (\TEDIT.DEFAULT.TITLE 132400 .
134779) (\TEDIT.WINDOW.TITLE 134781 . 136950) (\TEDIT.LIKELY.FILENAME 136952 . 139502) (
\TEDIT.UPDATE.TITLE 139504 . 142018)) (142063 154547 (TEDIT.DEACTIVATE.WINDOW 142073 . 147646) (
\TEDIT.RESHAPEFN 147648 . 149733) (\TEDIT.REPAINTFN 149735 . 149959) (\TEDIT.CLOSESPLITS 149961 .
152406) (\TEDIT.CLOSEPANE 152408 . 154545)) (154548 197347 (\TEDIT.SCROLLFN 154558 . 156789) (
\TEDIT.SCROLLCH.TOP 156791 . 158902) (\TEDIT.SCROLLCH.BOTTOM 158904 . 163234) (\TEDIT.SCROLLUP 163236
. 168962) (\TEDIT.TOPLINE.YTOP 168964 . 170633) (\TEDIT.SCROLLDOWN 170635 . 177674) (
\TEDIT.SCROLL.CARET 177676 . 180514) (\TEDIT.VISIBLECARETP 180516 . 182810) (\TEDIT.VISIBLECHARP
182812 . 183903) (\TEDIT.BITMAPLINES 183905 . 187825) (\TEDIT.SETPANE.TOPLINE 187827 . 188439) (
\TEDIT.SHIFTLINES 188441 . 197345)) (197348 208217 (\TEDIT.ONSCREEN? 197358 . 201909) (
\TEDIT.ONSCREEN.REGION 201911 . 205562) (\TEDIT.AFTERMOVEFN 205564 . 206461) (OFFSCREENP 206463 .
208215)) (208259 211073 (\TEDIT.PROCIDLEFN 208269 . 209929) (\TEDIT.PROCENTRYFN 209931 . 210376) (
\TEDIT.PROCEXITFN 210378 . 211071)) (211152 224377 (\TEDIT.DOWNCARET 211162 . 211955) (
\TEDIT.FLASHCARET 211957 . 214068) (\TEDIT.UPCARET 214070 . 215174) (TEDIT.NORMALIZECARET 215176 .
218394) (\TEDIT.SETCARET 218396 . 223747) (\TEDIT.CARET 223749 . 224375)))))
STOP

BIN
library/tedit/TEDIT-WINDOW.LCOM
View File

Binary file not shown.

BIN
lispusers/tmax/TMAX.TOC
View File

Binary file not shown.

118
sources/INSPECT
View File

@@ -1,13 +1,12 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "16-Jul-2024 18:28:42" {WMEDLEY}<sources>INSPECT.;33 129220
(FILECREATED "21-Jul-2025 16:55:18" {WMEDLEY}<sources>INSPECT.;36 129584
:EDIT-BY rmk
:CHANGES-TO (FNS IMAGEOBJ\PROPFETCHFN IMAGEOBJ\PROPSTOREFN)
(VARS INSPECTCOMS)
:CHANGES-TO (FNS \TEDIT.INSPECTCODE)
:PREVIOUS-DATE " 4-Jul-2024 12:16:52" {WMEDLEY}<sources>INSPECT.;31)
:PREVIOUS-DATE "21-Jul-2025 11:55:38" {WMEDLEY}<sources>INSPECT.;35)
(PRETTYCOMPRINT INSPECTCOMS)
@@ -1802,24 +1801,29 @@
(\INSPECT/CODE/RESHAPEFN WINDOW])
(\TEDIT.INSPECTCODE
[LAMBDA (FN WHERE LVFLG RADIX PC CODEPRINTER) (* ; "Edited 11-Oct-2021 14:04 by rmk:")
[LAMBDA (FN WHERE LVFLG RADIX PC CODEPRINTER) (* ; "Edited 21-Jul-2025 16:54 by rmk")
(* ; "Edited 11-Oct-2021 14:04 by rmk:")
(PROG ((STREAM (OPENSTREAM '{NODIRCORE} 'BOTH))
WINDOW SEL)
(APPLY* (OR CODEPRINTER (FUNCTION PRINTCODE))
FN LVFLG RADIX STREAM NIL PC)
[SETQ STREAM (OPENTEXTSTREAM STREAM [SETQ WINDOW (DECODE.WINDOW.ARG
WHERE 400 280
(COND
((OR (LITATOM FN)
(NOT (CCODEP FN)))
(CONCAT "Code for " FN))
(T (CONCAT (COND
(PC "Code for frame ")
(T "CCODEP named "))
(fetch (COMPILED-CLOSURE
FRAMENAME)
of FN]
NIL NIL `(READONLY T PROMPTWINDOW DON'T FONT ,DEFAULTFONT]
[SETQ STREAM (TEDIT STREAM [SETQ WINDOW (DECODE.WINDOW.ARG
WHERE 400 280 (COND
((OR (LITATOM FN)
(NOT (CCODEP FN)))
(CONCAT "Code for " FN))
(T (CONCAT (COND
(PC
"Code for frame "
)
(T "CCODEP named ")
)
(fetch (
COMPILED-CLOSURE
FRAMENAME)
of FN]
NIL
`(READONLY T FONT ,DEFAULTFONT]
(COND
((AND PC (SETQ SEL (TEDIT.FIND STREAM "----------" 1)))
(* ; "Highlight location of PC")
@@ -2311,43 +2315,43 @@
("As Character array" '(8 \INSPECT.FETCH.CHAR \INSPECT.STORE.CHAR))
("As Fat Character array" '(16 \INSPECT.FETCH.FATCHAR \INSPECT.STORE.FATCHAR])
(DECLARE%: DONTCOPY
(FILEMAP (NIL (7776 46129 (INSPECTW.CREATE 7786 . 13081) (INSPECTW.REPAINTFN 13083 . 18619) (
INSPECTW.REDISPLAY 18621 . 27493) (\INSPECTW.VALUE.MARGIN 27495 . 27898) (INSPECTW.REPLACE 27900 .
28608) (INSPECTW.SELECTITEM 28610 . 29600) (\INSPECTW.REDISPLAYPROP 29602 . 32032) (INSPECTW.FETCH
32034 . 32457) (INSPECTW.PROPERTIES 32459 . 33100) (DECODE.WINDOW.ARG 33102 . 34830) (
DEFAULT.INSPECTW.PROPCOMMANDFN 34832 . 36860) (DEFAULT.INSPECTW.VALUECOMMANDFN 36862 . 38278) (
DEFAULT.INSPECTW.TITLECOMMANDFN 38280 . 41729) (\SELITEM.FROM.PROPERTY 41731 . 42173) (
\INSPECT.COMPUTE.TITLE 42175 . 43459) (LEVELEDFORM 43461 . 44180) (MAKEWITHINREGION 44182 . 46127)) (
46130 63435 (ITEMW.REPAINTFN 46140 . 47360) (\ITEM.WINDOW.BUTTON.HANDLER 47362 . 47781) (
\ITEM.WINDOW.SELECTION.HANDLER 47783 . 50450) (\INSPECTW.COMMAND.HANDLER 50452 . 54453) (
ITEM.WINDOW.SET.STACK.ARG 54455 . 56659) (REPLACESTKARG 56661 . 57760) (IN/ITEM? 57762 . 58644) (
\ITEMW.DESELECTITEM 58646 . 58910) (\ITEMW.SELECTITEM 58912 . 59174) (\ITEMW.CLEARSELECTION 59176 .
59531) (\ITEMW.FLIPITEM 59533 . 60006) (PRINTANDBOX 60008 . 62517) (PRINTATBOX 62519 . 63036) (
ITEMOFPROPERTYVALUE 63038 . 63433)) (63436 67177 (\ITEM.WINDOW.COPY.HANDLER 63446 . 65303) (
\ITEMW.FLIPCOPY 65305 . 65764) (BKSYSBUF.GENERAL 65766 . 67175)) (67569 92484 (INSPECT 67579 . 72109)
(\APPLYINSPECTMACRO 72111 . 73172) (INSPECT/BITMAP 73174 . 74326) (INSPECT/DATATYPE 74328 . 77842) (
INSPECTABLEFIELDNAMES 77844 . 79177) (REMOVEDUPS 79179 . 79384) (INSPECT/ARRAY 79386 . 80451) (
INSPECT/TOP/LEVEL/LIST 80453 . 81570) (INSPECT/PROPLIST 81572 . 82660) (NONSYSPROPNAMES 82662 . 82958)
(INSPECT/LISTP 82960 . 83399) (ALISTP 83401 . 83610) (PROPLISTP 83612 . 84252) (INSPECT/ALIST 84254
. 84730) (ASSOCGET 84732 . 84943) (/ASSOCPUT 84945 . 85210) (INSPECT/PLIST 85212 . 85696) (
INSPECT/TYPERECORD 85698 . 86055) (INSPECT/AS/RECORD 86057 . 87294) (SELECT.LIST.INSPECTOR 87296 .
89347) (STANDARDEDITE 89349 . 89632) (NTHTOPLEVELELT 89634 . 89950) (SETNTHTOPLEVELELT 89952 . 90712)
(DEDITE 90714 . 90921) (FINDRECDECL 90923 . 91506) (FINDSYSRECDECL 91508 . 91909) (
MAKE-INSPECTOR-PROFILE 91911 . 92296) (CONFIRM-SET 92298 . 92482)) (94308 102522 (INSPECT/ATOM 94318
. 98423) (SELECT.ATOM.ASPECT 98425 . 99569) (INSPECT/AS/FUNCTION 99571 . 101857) (SELECT.FNS.EDITOR
101859 . 102520)) (102563 107988 (INSPECTCODE 102573 . 103725) (\TEDIT.INSPECTCODE 103727 . 105705) (
\INSPECT/CODE/RESHAPEFN 105707 . 107246) (\INSPECT/CODE/REPAINTFN 107248 . 107986)) (108026 109632 (
INSPECT/HARRAYP 108036 . 108784) (HARRAYKEYS 108786 . 109165) (INSPECTW.GETHASH 109167 . 109394) (
INSPECTW.PUTHASH 109396 . 109630)) (109681 115890 (RDTBL\NONOTHERCODES 109691 . 110711) (GETSYNTAXPROP
110713 . 112211) (SETSYNTAXPROP 112213 . 113940) (GETTTBLPROP 113942 . 114860) (SETTTBLPROP 114862 .
115888)) (116395 117845 (WINDOW\INSPECTPROPS 116405 . 117260) (WINDOW\PROPFETCHFN 117262 . 117616) (
WINDOW\PROPSTOREFN 117618 . 117843)) (117994 120023 (IMAGEOBJ\INSPECTPROPS 118004 . 119070) (
IMAGEOBJ\PROPFETCHFN 119072 . 119602) (IMAGEOBJ\PROPSTOREFN 119604 . 120021)) (120160 128802 (
INSPECT/AS/BLOCKRECORD 120170 . 121170) (INSPECT/TYPELESS 121172 . 122563) (LIST-ALL-BLOCKRECORDS
122565 . 122840) (INSPECT/HUNK 122842 . 125445) (\INSPECT.DATATYPE.RAW.FETCH 125447 . 125773) (
\INSPECT.FETCH.8 125775 . 125924) (\INSPECT.FETCH.32 125926 . 126097) (\INSPECT.FETCH.CHAR 126099 .
126262) (\INSPECT.FETCH.FATCHAR 126264 . 126426) (\INSPECT.FETCH.PTR 126428 . 126599) (
\INSPECT.STORE.8 126601 . 126907) (\INSPECT.STORE.16 126909 . 127209) (\INSPECT.STORE.32 127211 .
127646) (\INSPECT.STORE.CHAR 127648 . 127974) (\INSPECT.STORE.FATCHAR 127976 . 128298) (
\INSPECT.STORE.PTR 128300 . 128647) (INSPECT/MAKE/CCODEP 128649 . 128800)))))
(FILEMAP (NIL (7716 46069 (INSPECTW.CREATE 7726 . 13021) (INSPECTW.REPAINTFN 13023 . 18559) (
INSPECTW.REDISPLAY 18561 . 27433) (\INSPECTW.VALUE.MARGIN 27435 . 27838) (INSPECTW.REPLACE 27840 .
28548) (INSPECTW.SELECTITEM 28550 . 29540) (\INSPECTW.REDISPLAYPROP 29542 . 31972) (INSPECTW.FETCH
31974 . 32397) (INSPECTW.PROPERTIES 32399 . 33040) (DECODE.WINDOW.ARG 33042 . 34770) (
DEFAULT.INSPECTW.PROPCOMMANDFN 34772 . 36800) (DEFAULT.INSPECTW.VALUECOMMANDFN 36802 . 38218) (
DEFAULT.INSPECTW.TITLECOMMANDFN 38220 . 41669) (\SELITEM.FROM.PROPERTY 41671 . 42113) (
\INSPECT.COMPUTE.TITLE 42115 . 43399) (LEVELEDFORM 43401 . 44120) (MAKEWITHINREGION 44122 . 46067)) (
46070 63375 (ITEMW.REPAINTFN 46080 . 47300) (\ITEM.WINDOW.BUTTON.HANDLER 47302 . 47721) (
\ITEM.WINDOW.SELECTION.HANDLER 47723 . 50390) (\INSPECTW.COMMAND.HANDLER 50392 . 54393) (
ITEM.WINDOW.SET.STACK.ARG 54395 . 56599) (REPLACESTKARG 56601 . 57700) (IN/ITEM? 57702 . 58584) (
\ITEMW.DESELECTITEM 58586 . 58850) (\ITEMW.SELECTITEM 58852 . 59114) (\ITEMW.CLEARSELECTION 59116 .
59471) (\ITEMW.FLIPITEM 59473 . 59946) (PRINTANDBOX 59948 . 62457) (PRINTATBOX 62459 . 62976) (
ITEMOFPROPERTYVALUE 62978 . 63373)) (63376 67117 (\ITEM.WINDOW.COPY.HANDLER 63386 . 65243) (
\ITEMW.FLIPCOPY 65245 . 65704) (BKSYSBUF.GENERAL 65706 . 67115)) (67509 92424 (INSPECT 67519 . 72049)
(\APPLYINSPECTMACRO 72051 . 73112) (INSPECT/BITMAP 73114 . 74266) (INSPECT/DATATYPE 74268 . 77782) (
INSPECTABLEFIELDNAMES 77784 . 79117) (REMOVEDUPS 79119 . 79324) (INSPECT/ARRAY 79326 . 80391) (
INSPECT/TOP/LEVEL/LIST 80393 . 81510) (INSPECT/PROPLIST 81512 . 82600) (NONSYSPROPNAMES 82602 . 82898)
(INSPECT/LISTP 82900 . 83339) (ALISTP 83341 . 83550) (PROPLISTP 83552 . 84192) (INSPECT/ALIST 84194
. 84670) (ASSOCGET 84672 . 84883) (/ASSOCPUT 84885 . 85150) (INSPECT/PLIST 85152 . 85636) (
INSPECT/TYPERECORD 85638 . 85995) (INSPECT/AS/RECORD 85997 . 87234) (SELECT.LIST.INSPECTOR 87236 .
89287) (STANDARDEDITE 89289 . 89572) (NTHTOPLEVELELT 89574 . 89890) (SETNTHTOPLEVELELT 89892 . 90652)
(DEDITE 90654 . 90861) (FINDRECDECL 90863 . 91446) (FINDSYSRECDECL 91448 . 91849) (
MAKE-INSPECTOR-PROFILE 91851 . 92236) (CONFIRM-SET 92238 . 92422)) (94248 102462 (INSPECT/ATOM 94258
. 98363) (SELECT.ATOM.ASPECT 98365 . 99509) (INSPECT/AS/FUNCTION 99511 . 101797) (SELECT.FNS.EDITOR
101799 . 102460)) (102503 108352 (INSPECTCODE 102513 . 103665) (\TEDIT.INSPECTCODE 103667 . 106069) (
\INSPECT/CODE/RESHAPEFN 106071 . 107610) (\INSPECT/CODE/REPAINTFN 107612 . 108350)) (108390 109996 (
INSPECT/HARRAYP 108400 . 109148) (HARRAYKEYS 109150 . 109529) (INSPECTW.GETHASH 109531 . 109758) (
INSPECTW.PUTHASH 109760 . 109994)) (110045 116254 (RDTBL\NONOTHERCODES 110055 . 111075) (GETSYNTAXPROP
111077 . 112575) (SETSYNTAXPROP 112577 . 114304) (GETTTBLPROP 114306 . 115224) (SETTTBLPROP 115226 .
116252)) (116759 118209 (WINDOW\INSPECTPROPS 116769 . 117624) (WINDOW\PROPFETCHFN 117626 . 117980) (
WINDOW\PROPSTOREFN 117982 . 118207)) (118358 120387 (IMAGEOBJ\INSPECTPROPS 118368 . 119434) (
IMAGEOBJ\PROPFETCHFN 119436 . 119966) (IMAGEOBJ\PROPSTOREFN 119968 . 120385)) (120524 129166 (
INSPECT/AS/BLOCKRECORD 120534 . 121534) (INSPECT/TYPELESS 121536 . 122927) (LIST-ALL-BLOCKRECORDS
122929 . 123204) (INSPECT/HUNK 123206 . 125809) (\INSPECT.DATATYPE.RAW.FETCH 125811 . 126137) (
\INSPECT.FETCH.8 126139 . 126288) (\INSPECT.FETCH.32 126290 . 126461) (\INSPECT.FETCH.CHAR 126463 .
126626) (\INSPECT.FETCH.FATCHAR 126628 . 126790) (\INSPECT.FETCH.PTR 126792 . 126963) (
\INSPECT.STORE.8 126965 . 127271) (\INSPECT.STORE.16 127273 . 127573) (\INSPECT.STORE.32 127575 .
128010) (\INSPECT.STORE.CHAR 128012 . 128338) (\INSPECT.STORE.FATCHAR 128340 . 128662) (
\INSPECT.STORE.PTR 128664 . 129011) (INSPECT/MAKE/CCODEP 129013 . 129164)))))
STOP

BIN
sources/INSPECT.LCOM
View File

Binary file not shown.

178
sources/LLDISPLAY
View File

@@ -1,12 +1,14 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "31-Jul-2023 14:50:58" {WMEDLEY}<sources>LLDISPLAY.;19 270570
(FILECREATED "27-Jul-2025 20:25:24" 
{DSK}<Users>kaplan>Local>medley3.5>working-medley>sources>LLDISPLAY.;25 272767
:EDIT-BY rmk
:CHANGES-TO (FNS BITMAPEQUAL)
:CHANGES-TO (VARS LLDISPLAYCOMS)
:PREVIOUS-DATE "31-Jul-2023 14:45:32" {WMEDLEY}<sources>LLDISPLAY.;18)
:PREVIOUS-DATE "14-Jul-2025 22:06:59"
{DSK}<Users>kaplan>Local>medley3.5>working-medley>sources>LLDISPLAY.;23)
(PRETTYCOMPRINT LLDISPLAYCOMS)
@@ -30,9 +32,10 @@
[COMS (* ; "bitmap functions.")
(FNS BITBLT BLTSHADE \BITBLTSUB \GETPILOTBBTSCRATCHBM BITMAPCOPY BITMAPCREATE BITMAPBIT
BITMAPEQUAL BLTCHAR \BLTCHAR \MEDW.BLTCHAR \CHANGECHARSET.DISPLAY \INDICATESTRING
\SLOWBLTCHAR TEXTUREP INVERT.TEXTURE INVERT.TEXTURE.BITMAP BITMAPWIDTH READBITMAP
\INSUREBITSPERPIXEL MAXIMUMCOLOR OPPOSITECOLOR MAXIMUMSHADE OPPOSITESHADE
\MEDW.BITBLT)
\SLOWBLTCHAR TEXTUREP INVERT.TEXTURE INVERT.TEXTURE.BITMAP BITMAPWIDTH
BITMAPHEIGHT READBITMAP \INSUREBITSPERPIXEL MAXIMUMCOLOR OPPOSITECOLOR
MAXIMUMSHADE OPPOSITESHADE \MEDW.BITBLT)
(FNS \READBINARYBITMAP \PRINTBINARYBITMAP)
(FUNCTIONS FINISH-READING-BITMAP)
(CONSTANTS (MINIMUMCOLOR 0)
(MINIMUMSHADE 0))
@@ -1361,6 +1364,18 @@
(WINDOWPROP BITMAP 'WIDTH))
(T (\ILLEGAL.ARG BITMAP])
(BITMAPHEIGHT
[LAMBDA (BITMAP) (* kbr%: " 8-Jul-85 16:01")
(* ;; "returns the height in pixels of a bitmap.")
(COND
((type? BITMAP BITMAP)
(fetch (BITMAP BITMAPHEIGHT) of BITMAP))
((type? WINDOW BITMAP)
(WINDOWPROP BITMAP 'HEIGHT))
(T (\ILLEGAL.ARG BITMAP])
(READBITMAP
[LAMBDA (FILE) (* ; "Edited 8-Aug-2021 00:18 by rmk:")
@@ -1501,6 +1516,44 @@
(T (SHOULDNT "Invalid argument to \XW.BIBLT")))
T])
)
(DEFINEQ
(\READBINARYBITMAP
[LAMBDA (STREAM) (* rrb "23-Jul-84 15:17")
(* * reads a bitmap printed on STREAM by \PRINTBINARYBITMAP.)
(SETQ STREAM (GETSTREAM STREAM 'INPUT))
(PROG ((BMW (\WIN STREAM))
(BMH (\WIN STREAM))
(BPP (\WIN STREAM))
BITMAP)
(SETQ BITMAP (BITMAPCREATE BMW BMH BPP))
(\BINS STREAM (fetch (BITMAP BITMAPBASE) of BITMAP)
0
(ITIMES (fetch (BITMAP BITMAPRASTERWIDTH) of BITMAP)
BMH BYTESPERWORD))
(RETURN BITMAP])
(\PRINTBINARYBITMAP
[LAMBDA (BITMAP STREAM) (* rrb "23-Jul-84 15:16")
(* * prints the representation of a bitmap onto STREAM in a form that can be read
 back by \READBINARYBITMAP.)
(PROG ((STREAM (GETSTREAM STREAM 'OUTPUT))
BMH)
(OR (BITMAPP BITMAP)
(\ILLEGAL.ARG BITMAP))
(\WOUT STREAM (BITMAPWIDTH BITMAP))
(\WOUT STREAM (SETQ BMH (BITMAPHEIGHT BITMAP)))
(\WOUT STREAM (BITSPERPIXEL BITMAP))
(\BOUTS STREAM (fetch (BITMAP BITMAPBASE) of BITMAP)
0
(ITIMES (fetch (BITMAP BITMAPRASTERWIDTH) of BITMAP)
BMH BYTESPERWORD))
(RETURN BITMAP])
)
(CL:DEFUN FINISH-READING-BITMAP (STREAM)
@@ -3249,34 +3302,33 @@
(\INVALIDATEDISPLAYCACHE DD))])])
(\DSPFONT.DISPLAY
[LAMBDA (DISPLAYSTREAM FONT) (* ; "Edited 11-Nov-87 15:36 by FS")
[LAMBDA (DISPLAYSTREAM FONT) (* ; "Edited 14-Jul-2025 22:06 by rmk")
(* ; "Edited 11-Nov-87 15:36 by FS")
(* ;; "sets the font that a display stream uses to print characters. DISPLAYSTREAM is guaranteed to be a stream of type display")
(PROG (XFONT OLDFONT DD)
(SETQ DD (fetch (STREAM IMAGEDATA) of DISPLAYSTREAM))
(* ;
 "save old value to return, smash new value and update the bitchar portion of the record.")
 "save old value to return, smash new value and update the bitchar portion of the record.")
(RETURN (PROG1 (SETQ OLDFONT (fetch (\DISPLAYDATA DDFONT) of DD))
[COND
(FONT
(* ;; "Either FONT is coerceable to a font, or its a proplist of ways to change the current font (see IRM), otherwise an error.")
(SETQ XFONT (OR (\COERCEFONTDESC FONT DISPLAYSTREAM T)
(FONTCOPY (ffetch (\DISPLAYDATA DDFONT)
of DD)
(SETQ XFONT (OR (FONTCREATE FONT NIL NIL NIL DISPLAYSTREAM T)
(FONTCOPY (ffetch (\DISPLAYDATA DDFONT) of DD)
(CONS 'NOERROR (CONS T FONT)))
(ERROR "FONT NOT FOUND OR ILLEGAL FONTCOPY PARAMETER")
)) (* ;
 "updating font information is fairly expensive operation. Don't bother unless font has changed.")
 "updating font information is fairly expensive operation. Don't bother unless font has changed.")
(OR (EQ XFONT OLDFONT)
(UNINTERRUPTABLY
(freplace (\DISPLAYDATA DDFONT) of DD with XFONT)
(freplace (\DISPLAYDATA DDLINEFEED) of DD
with (IMINUS (fetch (FONTDESCRIPTOR \SFHeight)
of XFONT)))
with (IMINUS (fetch (FONTDESCRIPTOR \SFHeight) of XFONT)))
(* ;
 "This will be difference when spacefactor is implemented for the display. ")
 "This will be difference when spacefactor is implemented for the display. ")
(freplace (\DISPLAYDATA DDSPACEWIDTH) of DD
with (\FGETCHARWIDTH XFONT (CHARCODE SPACE)))
(\SFFixFont DISPLAYSTREAM DD))])])
@@ -4541,14 +4593,17 @@
(DEFINEQ
(INITIALIZEDISPLAYSTREAMS
[LAMBDA NIL (* lmm " 7-Jan-86 16:51")
[LAMBDA NIL (* ; "Edited 6-Jul-2025 12:57 by rmk")
(* lmm " 7-Jan-86 16:51")
(SETQ WHOLEDISPLAY (create REGION))
(SETQ \SYSPILOTBBT (create PILOTBBT)) (* ; "For BITBLT")
(SETQ \SYSBBTEXTURE (BITMAPCREATE 16 16)) (* ;
 "For texture handling in \BITBLTSUB")
(SETQ \SYSPILOTBBT (create PILOTBBT)) (* ; "For BITBLT")
(SETQ \SYSBBTEXTURE (BITMAPCREATE 16 16)) (* ;
 "For texture handling in \BITBLTSUB")
(* ;
 "A guaranteed display font is initialized here after pup, font, and bitmap code has been loaded.")
(SETQ \GUARANTEEDDISPLAYFONT (FONTCREATE 'GACHA 10 NIL NIL 'DISPLAY))
 "A guaranteed display font is initialized here after pup, font, and bitmap code has been loaded.")
(SETQ \GUARANTEEDDISPLAYFONT (FONTCREATE 'GACHA 10 '(MEDIUM REGULAR REGULAR)
NIL
'DISPLAY))
(SETQ DEFAULTFONT (FONTCLASS 'DEFAULTFONT (LIST 1 \GUARANTEEDDISPLAYFONT])
)
(DECLARE%: DOCOPY DONTEVAL@LOAD
@@ -4563,7 +4618,7 @@
(DISPLAYSTREAMINIT 1000)
)
(PUTPROPS LLDISPLAY FILETYPE COMPILE-FILE)
(PUTPROPS LLDISPLAY FILETYPE :FAKE-COMPILE-FILE)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
@@ -4573,43 +4628,44 @@
(ADDTOVAR LAMA )
)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (20459 23127 (\FBITMAPBIT 20469 . 20929) (\FBITMAPBIT.UFN 20931 . 21950) (
\NEWPAGE.DISPLAY 21952 . 22087) (INITBITMASKS 22089 . 23125)) (25052 25561 (\CreateCursorBitMap 25062
. 25559)) (25678 86230 (BITBLT 25688 . 36078) (BLTSHADE 36080 . 36858) (\BITBLTSUB 36860 . 46995) (
\GETPILOTBBTSCRATCHBM 46997 . 47612) (BITMAPCOPY 47614 . 48190) (BITMAPCREATE 48192 . 49752) (
BITMAPBIT 49754 . 58141) (BITMAPEQUAL 58143 . 59605) (BLTCHAR 59607 . 60223) (\BLTCHAR 60225 . 60727)
(\MEDW.BLTCHAR 60729 . 65607) (\CHANGECHARSET.DISPLAY 65609 . 68567) (\INDICATESTRING 68569 . 69765) (
\SLOWBLTCHAR 69767 . 76863) (TEXTUREP 76865 . 77135) (INVERT.TEXTURE 77137 . 77411) (
INVERT.TEXTURE.BITMAP 77413 . 78948) (BITMAPWIDTH 78950 . 79322) (READBITMAP 79324 . 81834) (
\INSUREBITSPERPIXEL 81836 . 82131) (MAXIMUMCOLOR 82133 . 82274) (OPPOSITECOLOR 82276 . 82455) (
MAXIMUMSHADE 82457 . 82668) (OPPOSITESHADE 82670 . 82849) (\MEDW.BITBLT 82851 . 86228)) (86232 91418 (
FINISH-READING-BITMAP 86232 . 91418)) (92540 93021 (BITMAPBIT.EXPANDER 92550 . 93019)) (93022 141556 (
\BITBLT.DISPLAY 93032 . 116271) (\BITBLT.BITMAP 116273 . 125372) (\BITBLT.MERGE 125374 . 127627) (
\BLTSHADE.DISPLAY 127629 . 134729) (\BLTSHADE.BITMAP 134731 . 141554)) (141557 150877 (
\BITBLT.BITMAP.SLOW 141567 . 150875)) (150878 167259 (\PUNT.BLTSHADE.BITMAP 150888 . 157984) (
\PUNT.BITBLT.BITMAP 157986 . 167257)) (167260 170700 (\SCALEDBITBLT.DISPLAY 167270 . 168903) (
\BACKCOLOR.DISPLAY 168905 . 170698)) (174555 176828 (DISPLAYSTREAMP 174565 . 175173) (DSPSOURCETYPE
175175 . 176184) (DSPXOFFSET 176186 . 176505) (DSPYOFFSET 176507 . 176826)) (176829 191024 (
DSPDESTINATION 176839 . 179942) (DSPTEXTURE 179944 . 180106) (\DISPLAYSTREAMINCRXPOSITION 180108 .
180395) (\SFFixDestination 180397 . 181575) (\SFFixClippingRegion 181577 . 183749) (\SFFixFont 183751
. 184801) (\SFFIXLINELENGTH 184803 . 186299) (\UPDATE-SYNONYM-STREAM-LINELENGTH-FIELD 186301 . 188114
) (\SFFixY 188116 . 191022)) (191025 194872 (\SIMPLE.DSPCREATE 191035 . 191585) (\COMMON.DSPCREATE
191587 . 194870)) (194973 197167 (\MEDW.XOFFSET 194983 . 196124) (\MEDW.YOFFSET 196126 . 197165)) (
197168 205094 (\DSPCLIPPINGREGION.DISPLAY 197178 . 197924) (\DSPFONT.DISPLAY 197926 . 200296) (
\DISPLAY.PILOTBITBLT 200298 . 200447) (\DSPLINEFEED.DISPLAY 200449 . 201020) (\DSPLEFTMARGIN.DISPLAY
201022 . 201753) (\DSPOPERATION.DISPLAY 201755 . 202779) (\DSPRIGHTMARGIN.DISPLAY 202781 . 203626) (
\DSPXPOSITION.DISPLAY 203628 . 204485) (\DSPYPOSITION.DISPLAY 204487 . 205092)) (209282 214318 (
TTYDISPLAYSTREAM 209292 . 214316)) (214621 215651 (DSPSCROLL 214631 . 215331) (PAGEHEIGHT 215333 .
215649)) (215696 218718 (\DSPRESET.DISPLAY 215706 . 218716)) (218754 219277 (\MAYBE-DRIBBLE-CHAR
218754 . 219277)) (219278 239916 (\DSPPRINTCHAR 219288 . 227126) (\DSPPRINTCR/LF 227128 . 239914)) (
239917 240509 (\TTYBACKGROUND 239927 . 240507)) (240510 243797 (DSPBACKUP 240520 . 243795)) (243981
244237 (COLORDISPLAYP 243991 . 244235)) (244238 246309 (DISPLAYBEFOREEXIT 244248 . 245074) (
DISPLAYAFTERENTRY 245076 . 246307)) (246681 251213 (\DSPCLIPTRANSFORMX 246691 . 247280) (
\DSPCLIPTRANSFORMY 247282 . 248007) (\DSPTRANSFORMREGION 248009 . 248541) (\DSPUNTRANSFORMY 248543 .
248803) (\DSPUNTRANSFORMX 248805 . 249065) (\OFFSETCLIPPINGREGION 249067 . 251211)) (252527 255114 (
UPDATESCREENDIMENSIONS 252537 . 253166) (\CreateScreenBitMap 253168 . 255112)) (255673 268832 (
\CoerceToDisplayDevice 255683 . 256096) (\CREATEDISPLAY 256098 . 257938) (DISPLAYSTREAMINIT 257940 .
261084) (\STARTDISPLAY 261086 . 263997) (\MOVE.WINDOWS.ONTO.SCREEN 263999 . 266191) (
\UPDATE.PBT.RASTERWIDTHS 266193 . 267975) (\STOPDISPLAY 267977 . 268469) (\DEFINEDISPLAYINFO 268471 .
268830)) (269440 270201 (INITIALIZEDISPLAYSTREAMS 269450 . 270199)))))
(FILEMAP (NIL (20615 23283 (\FBITMAPBIT 20625 . 21085) (\FBITMAPBIT.UFN 21087 . 22106) (
\NEWPAGE.DISPLAY 22108 . 22243) (INITBITMASKS 22245 . 23281)) (25208 25717 (\CreateCursorBitMap 25218
. 25715)) (25834 86764 (BITBLT 25844 . 36234) (BLTSHADE 36236 . 37014) (\BITBLTSUB 37016 . 47151) (
\GETPILOTBBTSCRATCHBM 47153 . 47768) (BITMAPCOPY 47770 . 48346) (BITMAPCREATE 48348 . 49908) (
BITMAPBIT 49910 . 58297) (BITMAPEQUAL 58299 . 59761) (BLTCHAR 59763 . 60379) (\BLTCHAR 60381 . 60883)
(\MEDW.BLTCHAR 60885 . 65763) (\CHANGECHARSET.DISPLAY 65765 . 68723) (\INDICATESTRING 68725 . 69921) (
\SLOWBLTCHAR 69923 . 77019) (TEXTUREP 77021 . 77291) (INVERT.TEXTURE 77293 . 77567) (
INVERT.TEXTURE.BITMAP 77569 . 79104) (BITMAPWIDTH 79106 . 79478) (BITMAPHEIGHT 79480 . 79856) (
READBITMAP 79858 . 82368) (\INSUREBITSPERPIXEL 82370 . 82665) (MAXIMUMCOLOR 82667 . 82808) (
OPPOSITECOLOR 82810 . 82989) (MAXIMUMSHADE 82991 . 83202) (OPPOSITESHADE 83204 . 83383) (\MEDW.BITBLT
83385 . 86762)) (86765 88194 (\READBINARYBITMAP 86775 . 87413) (\PRINTBINARYBITMAP 87415 . 88192)) (
88196 93382 (FINISH-READING-BITMAP 88196 . 93382)) (94504 94985 (BITMAPBIT.EXPANDER 94514 . 94983)) (
94986 143520 (\BITBLT.DISPLAY 94996 . 118235) (\BITBLT.BITMAP 118237 . 127336) (\BITBLT.MERGE 127338
. 129591) (\BLTSHADE.DISPLAY 129593 . 136693) (\BLTSHADE.BITMAP 136695 . 143518)) (143521 152841 (
\BITBLT.BITMAP.SLOW 143531 . 152839)) (152842 169223 (\PUNT.BLTSHADE.BITMAP 152852 . 159948) (
\PUNT.BITBLT.BITMAP 159950 . 169221)) (169224 172664 (\SCALEDBITBLT.DISPLAY 169234 . 170867) (
\BACKCOLOR.DISPLAY 170869 . 172662)) (176519 178792 (DISPLAYSTREAMP 176529 . 177137) (DSPSOURCETYPE
177139 . 178148) (DSPXOFFSET 178150 . 178469) (DSPYOFFSET 178471 . 178790)) (178793 192988 (
DSPDESTINATION 178803 . 181906) (DSPTEXTURE 181908 . 182070) (\DISPLAYSTREAMINCRXPOSITION 182072 .
182359) (\SFFixDestination 182361 . 183539) (\SFFixClippingRegion 183541 . 185713) (\SFFixFont 185715
. 186765) (\SFFIXLINELENGTH 186767 . 188263) (\UPDATE-SYNONYM-STREAM-LINELENGTH-FIELD 188265 . 190078
) (\SFFixY 190080 . 192986)) (192989 196836 (\SIMPLE.DSPCREATE 192999 . 193549) (\COMMON.DSPCREATE
193551 . 196834)) (196937 199131 (\MEDW.XOFFSET 196947 . 198088) (\MEDW.YOFFSET 198090 . 199129)) (
199132 207062 (\DSPCLIPPINGREGION.DISPLAY 199142 . 199888) (\DSPFONT.DISPLAY 199890 . 202264) (
\DISPLAY.PILOTBITBLT 202266 . 202415) (\DSPLINEFEED.DISPLAY 202417 . 202988) (\DSPLEFTMARGIN.DISPLAY
202990 . 203721) (\DSPOPERATION.DISPLAY 203723 . 204747) (\DSPRIGHTMARGIN.DISPLAY 204749 . 205594) (
\DSPXPOSITION.DISPLAY 205596 . 206453) (\DSPYPOSITION.DISPLAY 206455 . 207060)) (211250 216286 (
TTYDISPLAYSTREAM 211260 . 216284)) (216589 217619 (DSPSCROLL 216599 . 217299) (PAGEHEIGHT 217301 .
217617)) (217664 220686 (\DSPRESET.DISPLAY 217674 . 220684)) (220722 221245 (\MAYBE-DRIBBLE-CHAR
220722 . 221245)) (221246 241884 (\DSPPRINTCHAR 221256 . 229094) (\DSPPRINTCR/LF 229096 . 241882)) (
241885 242477 (\TTYBACKGROUND 241895 . 242475)) (242478 245765 (DSPBACKUP 242488 . 245763)) (245949
246205 (COLORDISPLAYP 245959 . 246203)) (246206 248277 (DISPLAYBEFOREEXIT 246216 . 247042) (
DISPLAYAFTERENTRY 247044 . 248275)) (248649 253181 (\DSPCLIPTRANSFORMX 248659 . 249248) (
\DSPCLIPTRANSFORMY 249250 . 249975) (\DSPTRANSFORMREGION 249977 . 250509) (\DSPUNTRANSFORMY 250511 .
250771) (\DSPUNTRANSFORMX 250773 . 251033) (\OFFSETCLIPPINGREGION 251035 . 253179)) (254495 257082 (
UPDATESCREENDIMENSIONS 254505 . 255134) (\CreateScreenBitMap 255136 . 257080)) (257641 270800 (
\CoerceToDisplayDevice 257651 . 258064) (\CREATEDISPLAY 258066 . 259906) (DISPLAYSTREAMINIT 259908 .
263052) (\STARTDISPLAY 263054 . 265965) (\MOVE.WINDOWS.ONTO.SCREEN 265967 . 268159) (
\UPDATE.PBT.RASTERWIDTHS 268161 . 269943) (\STOPDISPLAY 269945 . 270437) (\DEFINEDISPLAYINFO 270439 .
270798)) (271408 272392 (INITIALIZEDISPLAYSTREAMS 271418 . 272390)))))
STOP

134
sources/LLDISPLAY.LCOM
View File

@@ -1,9 +1,12 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "31-Jul-2023 14:50:58" ("compiled on " {WMEDLEY}<sources>LLDISPLAY.;19)
"31-Jul-2023 14:48:17" "COMPILE-FILEd" in "FULL 31-Jul-2023 ..." dated "31-Jul-2023 14:48:24")
(FILECREATED "31-Jul-2023 14:50:58" {WMEDLEY}<sources>LLDISPLAY.;19 270570 :EDIT-BY rmk :CHANGES-TO (
FNS BITMAPEQUAL) :PREVIOUS-DATE "31-Jul-2023 14:45:32" {WMEDLEY}<sources>LLDISPLAY.;18)
(FILECREATED "27-Jul-2025 20:25:50" ("compiled on "
{DSK}<Users>kaplan>Local>medley3.5>working-medley>sources>LLDISPLAY.;25) "27-Jul-2025 13:59:31"
"COMPILE-FILEd" in "FULL 27-Jul-2025 ..." dated "27-Jul-2025 13:59:38")
(FILECREATED "27-Jul-2025 20:25:24"
{DSK}<Users>kaplan>Local>medley3.5>working-medley>sources>LLDISPLAY.;25 272767 :EDIT-BY rmk
:CHANGES-TO (VARS LLDISPLAYCOMS) :PREVIOUS-DATE "14-Jul-2025 22:06:59"
{DSK}<Users>kaplan>Local>medley3.5>working-medley>sources>LLDISPLAY.;23)
(RPAQQ LLDISPLAYCOMS ((DECLARE%: DONTCOPY (EXPORT (RECORDS PILOTBBT \DISPLAYDATA DISPLAYSTATE
DISPLAYINFO) (MACROS \GETDISPLAYDATA))) (* ;
"User-visible records are on ADISPLAY --- must be init'ed here") (INITRECORDS BITMAP PILOTBBT REGION
@@ -14,12 +17,13 @@ WORDMASK 65535)))) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (INITBITMASKS)))) (COMS (*
\CreateCursorBitMap) (DECLARE%: DONTEVAL@LOAD DOCOPY (VARS (CursorBitMap (\CreateCursorBitMap))))) (
COMS (* ; "bitmap functions.") (FNS BITBLT BLTSHADE \BITBLTSUB \GETPILOTBBTSCRATCHBM BITMAPCOPY
BITMAPCREATE BITMAPBIT BITMAPEQUAL BLTCHAR \BLTCHAR \MEDW.BLTCHAR \CHANGECHARSET.DISPLAY
\INDICATESTRING \SLOWBLTCHAR TEXTUREP INVERT.TEXTURE INVERT.TEXTURE.BITMAP BITMAPWIDTH READBITMAP
\INSUREBITSPERPIXEL MAXIMUMCOLOR OPPOSITECOLOR MAXIMUMSHADE OPPOSITESHADE \MEDW.BITBLT) (FUNCTIONS
FINISH-READING-BITMAP) (CONSTANTS (MINIMUMCOLOR 0) (MINIMUMSHADE 0)) (P (MOVD (QUOTE BITMAPBIT) (QUOTE
\BITMAPBIT))) (DECLARE%: DONTCOPY (EXPORT (MACROS \INVALIDATEDISPLAYCACHE))) (OPTIMIZERS BITMAPBIT
BITMAPP) (FNS BITMAPBIT.EXPANDER) (FNS \BITBLT.DISPLAY \BITBLT.BITMAP \BITBLT.MERGE \BLTSHADE.DISPLAY
\BLTSHADE.BITMAP) (FNS (* ;; "For SunLoadup") \BITBLT.BITMAP.SLOW) (FNS (* ;;
\INDICATESTRING \SLOWBLTCHAR TEXTUREP INVERT.TEXTURE INVERT.TEXTURE.BITMAP BITMAPWIDTH BITMAPHEIGHT
READBITMAP \INSUREBITSPERPIXEL MAXIMUMCOLOR OPPOSITECOLOR MAXIMUMSHADE OPPOSITESHADE \MEDW.BITBLT) (
FNS \READBINARYBITMAP \PRINTBINARYBITMAP) (FUNCTIONS FINISH-READING-BITMAP) (CONSTANTS (MINIMUMCOLOR 0
) (MINIMUMSHADE 0)) (P (MOVD (QUOTE BITMAPBIT) (QUOTE \BITMAPBIT))) (DECLARE%: DONTCOPY (EXPORT (
MACROS \INVALIDATEDISPLAYCACHE))) (OPTIMIZERS BITMAPBIT BITMAPP) (FNS BITMAPBIT.EXPANDER) (FNS
\BITBLT.DISPLAY \BITBLT.BITMAP \BITBLT.MERGE \BLTSHADE.DISPLAY \BLTSHADE.BITMAP) (FNS (* ;;
"For SunLoadup") \BITBLT.BITMAP.SLOW) (FNS (* ;;
" punt case for C funcs.bitblt_bitmap,bitshade.bitmap") \PUNT.BLTSHADE.BITMAP \PUNT.BITBLT.BITMAP) (
FNS (* ;; "from SUMEX-AIM") \SCALEDBITBLT.DISPLAY \BACKCOLOR.DISPLAY) (DECLARE%: DONTCOPY (CONSTANTS (
\DisplayWordAlign 16) (\MaxBitMapWidth 65535) (\MaxBitMapHeight 65535) (\MaxBitMapWords 131066)) (
@@ -192,7 +196,7 @@ BLTCHAR :D8
(42 \DISPLAYDATA 35 STREAM 24 OUTPUT)
()
\BLTCHAR :D8
(P 0 A0229 I 2 DISPLAYDATA I 1 DISPLAYSTREAM I 0 CHARCODE) (Agh bÉ.ÉZ@ABlH(11 \GETSTREAM)
(P 0 A0169 I 2 DISPLAYDATA I 1 DISPLAYSTREAM I 0 CHARCODE) (Agh bÉ.ÉZ@ABlH(11 \GETSTREAM)
(25 IMAGEOPS 18 STREAM 5 OUTPUT)
()
\MEDW.BLTCHAR :D8
@@ -205,10 +209,11 @@ BLTCHAR :D8
(256 \EM.DISPINTERRUPT 191 \TOPWDS 175 \EM.DISPINTERRUPT 167 \EM.DISPINTERRUPT 132 PILOTBBT)
()
\CHANGECHARSET.DISPLAY :D8
(P 4 \INTERRUPTABLE P 2 BM P 1 CSINFO P 0 PBT I 1 CHARSET I 0 DISPLAYDATA) Š@É*@É ÉAàÐɵ A@É h "@IÉ¿@IÉ¿@IÉ0¿@A>¿IɺHJÈàààànÿÿåÍ¿@È'IÈ
ð—@È@IÈ ð©@I
¿°#JÉJÈ@ÉBÚлHKÒÍ¿HKÓÍh(98 \SFFixY 24 \CREATECHARSET)
(130 PILOTBBT 119 PILOTBBT)
(P 7 \INTERRUPTABLE P 5 BM P 4 CSINFO P 3 PBT I 1 CHARSET I 0 DISPLAYDATA) œ@É*@É ÉAàÐɵ@É ÉAàA@É
HIÐJ¿J"@LÉ¿@LÉ¿@LÉ0¿@A>¿LɽKMÈàààànÿÿåÍ¿@È'LÈ
ð—@È@LÈ ð©@L
¿°#MÉMÈ@ÉBÚоKNÒÍ¿KNÓÍh(116 \SFFixY 30 \CREATECHARSET)
(148 PILOTBBT 137 PILOTBBT)
()
\INDICATESTRINGA0001 :D8
(NAME SI::*UNWIND-PROTECT* I 0 SI::*CLEANUP-FORMS* F 0 SI::*RESETFORMS* F 1 CHARCODE) Hgd gi
@@ -220,17 +225,18 @@ BLTCHAR :D8
(75 ^ 52 %# 16 SI::RESETUNWIND)
( 81 "" 58 "")
\SLOWBLTCHAR :D8
(P 16 CSINFO P 15 HEIGHTMOVED P 14 YPOS P 13 SOFTCURSORUP P 12 DISPINTERRUPT P 11 SOURCEBIT P 10 WIDTH P 9 DESTBIT P 8 PILOTBBT P 7 CURX P 6 RIGHT P 5 LEFT P 4 NEWX P 2 DD P 1 CHAR8CODE P 0 ROTATION I 1 DISPLAYSTREAM I 0 CHARCODE F 17 \SOFTCURSORP F 18 \SOFTCURSORUPP F 19 \CURSORDESTINATION F 20 \SCREENBITMAPS) K@@lÿåYAÉ0ZdÉ È Xdjð¢±~€ JÉ_JÉIÐÈØ\JÉñ²l A
¿JÉ_JÉIÐÈؼJL¿OJÉØ_¿JÈ"dOñ¢¿O½JÈ#LJÉØ»dKñ‘¿K¾JÉ*_¿NMñ¢± OÈ jð’±M_¿NMÙ_¿JÉIÐÈMØOÙ_¿JÉÈdkð³adlð²¿Oàà_¿Oàà_¿Oàà_°Ddlð²¿Oààà_¿Oààà_¿Oààà_°$lð²lOÚ_¿lOÚ_¿lOÚ_„¿ W"²-W$´ hA
W&ð_²`È_¿`jÍ¿¿A`ð³hA
W(–A ¿OOÍ¿OOÍ¿OOÍ¿Ojv¿OŸ¿`OÍ¿±·0JÉ_¿JÉIÐÈ_¿JÉ É@ãàÐɵ @ãJÉ h _ ¿HdlZð²;¿AOOØ
(P 16 CSINFO P 15 HEIGHTMOVED P 14 YPOS P 13 SOFTCURSORUP P 12 DISPINTERRUPT P 11 SOURCEBIT P 10 WIDTH P 9 DESTBIT P 8 PILOTBBT P 7 CURX P 6 RIGHT P 5 LEFT P 4 NEWX P 2 DD P 1 CHAR8CODE P 0 ROTATION I 1 DISPLAYSTREAM I 0 CHARCODE F 20 \SOFTCURSORP F 21 \SOFTCURSORUPP F 22 \CURSORDESTINATION F 23 \SCREENBITMAPS) b@@lÿåYAÉ0ZdÉ È Xdjð¢±~€ JÉ_JÉIÐÈØ\JÉñ²l A
¿JÉ_JÉIÐÈؼJL¿OJÉØ_¿JÈ"dOñ¢¿O½JÈ#LJÉØ»dKñ‘¿K¾JÉ*_¿NMñ¢± OÈ jð’±M_¿NMÙ_¿JÉIÐÈMØOÙ_¿JÉÈdkð³adlð²¿Oàà_¿Oàà_¿Oàà_°Ddlð²¿Oààà_¿Oààà_¿Oààà_°$lð²lOÚ_¿lOÚ_¿lOÚ_„¿ W(²-W*´ hA
W,ð_²`È_¿`jÍ¿¿A`ð³hA
W.–A ¿OOÍ¿OOÍ¿OOÍ¿Ojv¿OŸ¿`OÍ¿±Î0JÉ_¿JÉIÐÈ_¿JÉ É@ãàÐɵ$JÉ É@ãà@ãJÉ
O"O$ÐO&¿O&_ ¿HdlZð²;¿AOOØ
¿O ÉjJÉIÐÈAJÉO È
ÙkØOO È
O È ØO °Hnð²8AOOÙ
¿O ÉjJÉIÐÈAJÉO È ÙJÉO È
O È ØO ‰o h(583 ERROR 572 BKBITBLT 530 \DSPYPOSITION.DISPLAY 511 BKBITBLT 468 \DSPYPOSITION.DISPLAY 446 \CREATECHARSET 387 \SOFTCURSORUPCURRENT 352 \TOTOPWDS 342 DSPDESTINATION 325 \SOFTCURSORDOWN 294 DSPDESTINATION 275 SHOULDNT 55 \DSPPRINTCR/LF)
O È ØO ‰o h(606 ERROR 595 BKBITBLT 553 \DSPYPOSITION.DISPLAY 534 BKBITBLT 491 \DSPYPOSITION.DISPLAY 453 \CREATECHARSET 387 \SOFTCURSORUPCURRENT 352 \TOTOPWDS 342 DSPDESTINATION 325 \SOFTCURSORDOWN 294 DSPDESTINATION 275 SHOULDNT 55 \DSPPRINTCR/LF)
(393 \EM.DISPINTERRUPT 332 \TOPWDS 316 \EM.DISPINTERRUPT 306 \EM.DISPINTERRUPT 111 \DISPLAYDATA 83 \DISPLAYDATA)
( 578 "Not implemented to rotate by other than 0, 90 or 270")
( 601 "Not implemented to rotate by other than 0, 90 or 270")
TEXTUREP :D8
(I 0 OBJECT) @d3 ³ô@Èkð´@NIL
(18 BITMAP 10 BITMAP)
@@ -250,6 +256,11 @@ BITMAPWIDTH :D8
@ (35 \ILLEGAL.ARG 28 GETWINDOWPROP)
(23 WIDTH 16 WINDOW 5 BITMAP)
()
BITMAPHEIGHT :D8
(I 0 BITMAP) +@Ø@È@Û@g
@ (40 \ILLEGAL.ARG 33 GETWINDOWPROP)
(28 HEIGHT 21 WINDOW 12 BITMAP 5 BITMAP)
()
READBITMAP :D8
(P 6 BITSPERPIXEL P 5 W P 4 BM P 3 BASE P 2 STRM P 1 HEIGHT P 0 WIDTH I 0 FILE) @ @ gðªo ¿@ @ @g
CJ dgð§dgð’¿k†¿@ ^HÚlØââââ½HIN \É»Ij𒱊J gð²jIdjñ²tJ ¿J l"ð²QMdjñ²@KjJ l@ÙààààJ l@ÙäÇ¿KkJ l@ÙààààJ l@ÙäÇ¿KkлkÙ°¿¿J l"ð¬¿o hkÙ°‹¿J ¿J l)ð²ßL(270 \INCCODE 263 SKIPSEPRS 250 ERROR 235 \INCCODE 214 \INCCODE 201 \INCCODE 187 \INCCODE 174 \INCCODE 155 \INCCODE 148 SKIPSEPRS 128 SKIPSEPRS 106 BITMAPCREATE 87 RATOM 61 SKIPSEPRS 52 GETSTREAM 41 RATOM 35 RATOM 28 ERROR 11 READC 5 SKIPSEPRS)
@@ -278,7 +289,7 @@ OPPOSITESHADE :D8
NIL
()
\MEDW.BITBLT :D8
(P 9 A0232 P 8 A0231 P 7 SOURCEBOTTOMTRANSFORMED P 6 SOURCELEFTTRANSFORMED P 3 SRCWIN P 2 A0230 P 1 DD P 0 DSTWIN I 11 CLIPPINGREGION I 10 TEXTURE I 9 OPERATION I 8 SOURCETYPE I 7 HEIGHT I 6 WIDTH I 5 DESTINATIONBOTTOM I 4 DESTINATIONLEFT I 3 DESTINATION I 2 SOURCEBOTTOM I 1 SOURCELEFT I 0 SOURCE F 10 \SCREENBITMAPS) 
(P 9 A0172 P 8 A0171 P 7 SOURCEBOTTOMTRANSFORMED P 6 SOURCELEFTTRANSFORMED P 3 SRCWIN P 2 A0170 P 1 DD P 0 DSTWIN I 11 CLIPPINGREGION I 10 TEXTURE I 9 OPERATION I 8 SOURCETYPE I 7 HEIGHT I 6 WIDTH I 5 DESTINATIONBOTTOM I 4 DESTINATIONLEFT I 3 DESTINATION I 2 SOURCEBOTTOM I 1 SOURCELEFT I 0 SOURCE F 10 \SCREENBITMAPS) 
 @ ³C ªo ¿@òZ@²WCi
Cgh É0HÉ2ÉHºHÉ2@ABCDEFGGGGGABlJ±–Cô‚±¯C´‚±¨@i
!@gh É0AIÉصABIÉصBKÉ2ÉJ_¿KÉ2IÉNOCDEFGGGGGNIÈ"¼dLñ¡¿LOIÈ$½dMñ¡¿MlO±Þ@
@@ -288,6 +299,25 @@ NIL
W–@ ¿KÉ2ÉL KÉ2IÉNOCDEFGGGGGNIÈ"¼dLñ¡¿LOIÈ$½dMñ¡¿MlO‰o i(524 SHOULDNT 418 \TOTOPWDS 408 DSPDESTINATION 345 \GETSTREAM 330 WFROMDS 318 DSPDESTINATION 311 DSPDESTINATION 162 \GETSTREAM 147 WFROMDS 55 \GETSTREAM 43 WFROMDS 24 SHOULDNT 13 IMAGESTREAMP 5 IMAGESTREAMP)
(494 \DISPLAYDATA 477 \DISPLAYDATA 451 \DISPLAYDATA 443 WINDOW 432 SCREEN 425 WINDOW 398 \TOPWDS 383 \DISPLAYDATA 367 \DISPLAYDATA 357 \DISPLAYDATA 350 STREAM 339 OUTPUT 284 \DISPLAYDATA 267 \DISPLAYDATA 241 \DISPLAYDATA 233 WINDOW 222 SCREEN 215 WINDOW 200 \DISPLAYDATA 184 \DISPLAYDATA 174 \DISPLAYDATA 167 STREAM 156 OUTPUT 127 BITMAP 92 WINDOW 83 SCREEN 76 WINDOW 67 \DISPLAYDATA 60 STREAM 49 OUTPUT 31 BITMAP)
( 519 "Invalid argument to \XW.BIBLT" 19 "Neither SOURCE nor DESTINATION is an imagestream.")
\READBINARYBITMAP :D8
(P 3 BITMAP P 2 BPP P 1 BMH P 0 BMW I 0 STREAM) `@g
bd á@ Ø@ á@ Ø@ á@ Ø#HIJ [@KÉKÈIÚlÚMÉ
É>¼MNjOlLK(41 BITMAPCREATE 10 GETSTREAM)
(80 FDEV 73 STREAM 57 BITMAP 49 BITMAP 5 INPUT)
()
\PRINTBINARYBITMAP :D8
(P 1 BMH P 0 STREAM I 1 STREAM I 0 BITMAP) ­ Ag
q@Ñ@¦@ ¿H@ »ZKã
¿JKlÿå
¿H@ ¹\Iã
¿LIlÿå
¿H@ ¾]Nã
¿MNlÿå
¿H@É@ÈIÚlÚ
OÉ
É@_¿OOjOlO@(112 \BOUT 101 \BOUT 92 BITSPERPIXEL 84 \BOUT 73 \BOUT 64 BITMAPHEIGHT 56 \BOUT 45 \BOUT 36 BITMAPWIDTH 28 \ILLEGAL.ARG 10 GETSTREAM)
(152 FDEV 145 STREAM 128 BITMAP 120 BITMAP 19 BITMAP 5 OUTPUT)
()
FINISH-READING-BITMAP :D8
(L (0 STREAM) F 29 *READ-SUPPRESS*) (@ ñ Hd²µoH
¿°íYºI[¼K]µLk¾M_¿J3 šL3 –N3 ’O›oH
@@ -425,11 +455,11 @@ Q
(145 ERASE 138 INVERT 121 INVERT 110 PAINT 99 ERASE 86 \DISPLAYDATA 77 \DISPLAYDATA 53 INVERT 43 INPUT 32 \DISPLAYDATA 23 \DISPLAYDATA 16 STREAM 5 OUTPUT)
()
DSPXOFFSET :D8
(P 0 A0244 I 1 DISPLAYSTREAM I 0 XOFFSET) 'Agh bÉ.É\@AlH(11 \GETSTREAM)
(P 0 A0186 I 1 DISPLAYSTREAM I 0 XOFFSET) 'Agh bÉ.É\@AlH(11 \GETSTREAM)
(25 IMAGEOPS 18 STREAM 5 OUTPUT)
()
DSPYOFFSET :D8
(P 0 A0245 I 1 DISPLAYSTREAM I 0 YOFFSET) 'Agh bÉ.É^@AlH(11 \GETSTREAM)
(P 0 A0187 I 1 DISPLAYSTREAM I 0 YOFFSET) 'Agh bÉ.É^@AlH(11 \GETSTREAM)
(25 IMAGEOPS 18 STREAM 5 OUTPUT)
()
DSPDESTINATION :D8
@@ -514,13 +544,13 @@ A
(23 \DISPLAYDATA 16 STREAM 5 OUTPUT)
( 63 " is not a REGION.")
\DSPFONT.DISPLAY :D8
(P 3 \INTERRUPTABLE P 2 DD P 1 OLDFONT P 0 XFONT I 1 FONT I 0 DISPLAYSTREAM) {0@É0ZdÉ YA²cA@i µJÉ giA
µ o XIð³7JH ¿JjHÈ
Ù¿JHÉɵ
jHh ÉÈ ÍA¿@J
(119 \SFFixFont 105 \CREATECHARSET 62 ERROR 50 FONTCOPY 31 \COERCEFONTDESC)
(83 FONTDESCRIPTOR 41 NOERROR 17 \DISPLAYDATA 8 STREAM)
( 57 "FONT NOT FOUND OR ILLEGAL FONTCOPY PARAMETER")
(P 4 \INTERRUPTABLE P 2 DD P 1 OLDFONT P 0 XFONT I 1 FONT I 0 DISPLAYSTREAM) †@@É0ZdÉ YA²nAhdd@i µJÉ giA
µ o XIð³>JH ¿JjHÈ
Ù¿JHÉɵHÉjH
[¿KÉÈ ÍA¿@J
(130 \SFFixFont 111 \CREATECHARSET 66 ERROR 54 FONTCOPY 35 FONTCREATE)
(87 FONTDESCRIPTOR 45 NOERROR 17 \DISPLAYDATA 8 STREAM)
( 61 "FONT NOT FOUND OR ILLEGAL FONTCOPY PARAMETER")
\DISPLAY.PILOTBITBLT :D8
(I 1 N I 0 PILOTBBT) @AvNIL
NIL
@@ -594,7 +624,7 @@ NIL
hI
I
HÉ
ZHÉ [dÈ\KÈ djð²%¿@HÉ
ZHÉ [d È\KÈ djð²%¿@HÉ
¿@JJØmÿØLÙkØ
°UdlZð²¿@JLØ
¿@J
@@ -602,8 +632,8 @@ ZH
¿@JJØmÿØ
‰o ¿hdd@JJJJggHÉ6 @i
Md²" É.]d² @ð´Mo
h(297 PROCESS.EVAL 282 PROCESS.TTY 271 \INSUREWINDOW 259 WFROMDS 252 BKBITBLT 214 ERROR 203 \DSPYPOSITION.DISPLAY 184 \DSPXPOSITION.DISPLAY 158 \DSPYPOSITION.DISPLAY 148 \DSPXPOSITION.DISPLAY 129 \DSPYPOSITION.DISPLAY 106 \DSPXPOSITION.DISPLAY 61 WYOFFSET 55 WYOFFSET 48 WXOFFSET 42 WXOFFSET 32 WFROMDS 11 \GETSTREAM)
(243 REPLACE 238 TEXTURE 89 FONTDESCRIPTOR 80 FONTDESCRIPTOR 71 \DISPLAYDATA 25 \DISPLAYDATA 18 STREAM 5 OUTPUT)
h(297 PROCESS.EVAL 282 PROCESS.TTY 271 \INSUREWINDOW 259 WFROMDS 252 BKBITBLT 214 ERROR 203 \DSPYPOSITION.DISPLAY 184 \DSPXPOSITION.DISPLAY 158 \DSPYPOSITION.DISPLAY 148 \DSPXPOSITION.DISPLAY 129 \DSPYPOSITION.DISPLAY 106 \DSPXPOSITION.DISPLAY 80 FONTCREATE 61 WYOFFSET 55 WYOFFSET 48 WXOFFSET 42 WXOFFSET 32 WFROMDS 11 \GETSTREAM)
(243 REPLACE 238 TEXTURE 89 FONTDESCRIPTOR 71 \DISPLAYDATA 25 \DISPLAYDATA 18 STREAM 5 OUTPUT)
( 292 (SETQ \CURRENTDISPLAYLINE 0) 209 "only supported rotations are 0, 90 and 270")
(RPAQ? *DRIBBLE-OUTPUT* NIL)
expand-\MAYBE-DRIBBLE-CHAR :D8
@@ -655,14 +685,14 @@ expand-\MAYBE-DRIBBLE-CHAR :D8
DSPBACKUP :D8
(P 4 XPOS P 3 BLTWIDTH P 2 ROTATION P 1 FONT P 0 DD I 1 DISPLAYSTREAM I 0 WIDTH) fA ³Ag
b ¢±Agh bÉ0q@HÉ\HÉÙ½dMñ‘¿M[HÉ YHɘIÈ €jZKjñ´‚±Ä`–A ¿Jdjð²0¿LKÙA
¿hjdAHÉHÉIÈ ÙKIÈ
°qlZð²0hjdAHÉIÈÙHHÉjKÙÔ^¿N°5Jnð²GhjdAHÉIÈ ÙHHÉKÔ_¿OIÈ
¿hjdAHÉHÉI È ÙKI È
°qlZð²0hjdAHÉI ÈÙHHÉjKÙÔ^¿N°5Jnð²GhjdAHÉI È ÙHHÉKÔ_¿OI È
Kgg
i@Mjñ²#Al
¿Al
¿Al
¾MkÙ]°ÝN(347 BOUT 338 BOUT 329 BOUT 310 BKBITBLT 147 DSPXPOSITION 130 \CARET.DOWN 41 \GETSTREAM 25 DISPLAYSTREAMP 18 GETSTREAM 5 DISPLAYSTREAMP)
(304 REPLACE 299 TEXTURE 291 FONTDESCRIPTOR 274 \DISPLAYDATA 268 \DISPLAYDATA 259 FONTDESCRIPTOR 251 \DISPLAYDATA 221 \DISPLAYDATA 215 \DISPLAYDATA 206 FONTDESCRIPTOR 198 \DISPLAYDATA 179 FONTDESCRIPTOR 169 FONTDESCRIPTOR 158 \DISPLAYDATA 123 \CARET.UP 104 FONTDESCRIPTOR 95 \DISPLAYDATA 86 \DISPLAYDATA 65 \DISPLAYDATA 55 \DISPLAYDATA 48 STREAM 35 OUTPUT 13 OUTPUT)
¾MkÙ]°ÝN(347 BOUT 338 BOUT 329 BOUT 310 BKBITBLT 291 FONTCREATE 259 FONTCREATE 206 FONTCREATE 179 FONTCREATE 169 FONTCREATE 147 DSPXPOSITION 130 \CARET.DOWN 41 \GETSTREAM 25 DISPLAYSTREAMP 18 GETSTREAM 5 DISPLAYSTREAMP)
(304 REPLACE 299 TEXTURE 274 \DISPLAYDATA 268 \DISPLAYDATA 251 \DISPLAYDATA 221 \DISPLAYDATA 215 \DISPLAYDATA 198 \DISPLAYDATA 158 \DISPLAYDATA 123 \CARET.UP 104 FONTDESCRIPTOR 95 \DISPLAYDATA 86 \DISPLAYDATA 65 \DISPLAYDATA 55 \DISPLAYDATA 48 STREAM 35 OUTPUT 13 OUTPUT)
()
(RPAQ? \CARET.UP)
(RPAQQ BELLCNT 2)
@@ -749,22 +779,22 @@ NIL
()
DISPLAYSTREAMINIT :D8
(P 2 TTYFONTHEIGHT P 1 TTYHEIGHT P 0 TTYFONT I 0 N F 3 TtyDisplayStream) «chS
!HÈ
!H È
Z`S
S `@3µLdJÚ¹`IÙS
¿HÈ S
¿H È S
¿jS
¿jd`IhS
¿`S
¿JÚ`ñš`JÛlÙ€@°<>(139 DSPRIGHTMARGIN 127 DSPCLIPPINGREGION 107 DSPXOFFSET 99 DSPYPOSITION 84 DSPYOFFSET 57 TERMINAL-OUTPUT 41 DSPDESTINATION 18 DSPFONT 9 DSPCREATE 4 \STARTDISPLAY)
(167 \LastTTYLines 155 SCREENHEIGHT 148 SCREENHEIGHT 133 SCREENWIDTH 115 SCREENWIDTH 91 FONTDESCRIPTOR 76 SCREENHEIGHT 62 \LastTTYLines 52 \TopLevelTtyWindow 47 \DEFAULTTTYDISPLAYSTREAM 35 ScreenBitMap 27 FONTDESCRIPTOR)
¿JÚ`ñš`JÛlÙ€@°<>(139 DSPRIGHTMARGIN 127 DSPCLIPPINGREGION 107 DSPXOFFSET 99 DSPYPOSITION 91 FONTCREATE 84 DSPYOFFSET 57 TERMINAL-OUTPUT 41 DSPDESTINATION 27 FONTCREATE 18 DSPFONT 9 DSPCREATE 4 \STARTDISPLAY)
(167 \LastTTYLines 155 SCREENHEIGHT 148 SCREENHEIGHT 133 SCREENWIDTH 115 SCREENWIDTH 76 SCREENHEIGHT 62 \LastTTYLines 52 \TopLevelTtyWindow 47 \DEFAULTTTYDISPLAYSTREAM 35 ScreenBitMap)
()
\STARTDISPLAY :D8
(P 2 \INTERRUPTABLE P 1 W P 0 OLDWINDOWS F 3 \MAINSCREEN F 4 \WINDOWWORLD F 5 \CURSORDESTINATION F 6 WINDOWBACKGROUNDSHADE F 7 \CURSORDESTWIDTH F 8 \CURSORDESTHEIGHT F 9 \CURSORDESTRASTERWIDTH) <``ðœ``ð³AT²> ¸``ó«``ó–H ¿HŒdI µò``
(P 2 \INTERRUPTABLE P 1 W P 0 OLDWINDOWS F 3 \MAINSCREEN F 4 \WINDOWWORLD F 5 \CURSORDESTINATION F 6 \CURSORDESTRASTERWIDTH F 7 \CURSORDESTWIDTH F 8 \CURSORDESTHEIGHT) @``ðœ``ð³AT²> ¸``ó«``ó–H ¿HŒdI µò``
É`È
¿ijd``hSµ7`c
`c`c`ÈcH²LV ¿H °:`¿S`¿S`¿°¢dI µò``h(287 \OPENW1 231 REVERSE 224 CHANGEBACKGROUND 142 SHOWDISPLAY 113 \CreateScreenBitMap 90 \CLOSEW1 76 \MOVE.WINDOWS.ONTO.SCREEN 45 REVERSE 40 OPENWINDOWS 7 UPDATESCREENDIMENSIONS)
(312 \OLDSCREENWIDTH 307 SCREENWIDTH 302 \OLDSCREENHEIGHT 297 SCREENHEIGHT 271 SCREENHEIGHT 266 SCREEN 257 SCREENWIDTH 252 SCREEN 243 ScreenBitMap 238 SCREEN 211 BITMAP 206 ScreenBitMap 199 SCREENHEIGHT 192 SCREENWIDTH 185 ScreenBitMap 177 WHOLESCREEN 172 WHOLEDISPLAY 162 SCREENHEIGHT 157 SCREENWIDTH 149 \DisplayStarted 135 BITMAP 130 ScreenBitMap 123 BITMAP 118 ScreenBitMap 108 SCREENHEIGHT 103 SCREENWIDTH 68 SCREENHEIGHT 63 \OLDSCREENHEIGHT 56 SCREENWIDTH 51 \OLDSCREENWIDTH 29 \OLDSCREENHEIGHT 24 SCREENHEIGHT 17 \OLDSCREENWIDTH 12 SCREENWIDTH)
¿ijd``hSµ;`c
`c`c`Èc H²P` ¿H °:`¿S`¿S`¿°ždI µò``h(291 \OPENW1 235 REVERSE 228 CHANGEBACKGROUND 142 SHOWDISPLAY 113 \CreateScreenBitMap 90 \CLOSEW1 76 \MOVE.WINDOWS.ONTO.SCREEN 45 REVERSE 40 OPENWINDOWS 7 UPDATESCREENDIMENSIONS)
(316 \OLDSCREENWIDTH 311 SCREENWIDTH 306 \OLDSCREENHEIGHT 301 SCREENHEIGHT 275 SCREENHEIGHT 270 SCREEN 261 SCREENWIDTH 256 SCREEN 247 ScreenBitMap 242 SCREEN 223 WINDOWBACKGROUNDSHADE 211 BITMAP 206 ScreenBitMap 199 SCREENHEIGHT 192 SCREENWIDTH 185 ScreenBitMap 177 WHOLESCREEN 172 WHOLEDISPLAY 162 SCREENHEIGHT 157 SCREENWIDTH 149 \DisplayStarted 135 BITMAP 130 ScreenBitMap 123 BITMAP 118 ScreenBitMap 108 SCREENHEIGHT 103 SCREENWIDTH 68 SCREENHEIGHT 63 \OLDSCREENHEIGHT 56 SCREENWIDTH 51 \OLDSCREENWIDTH 29 \OLDSCREENHEIGHT 24 SCREENHEIGHT 17 \OLDSCREENWIDTH 12 SCREENWIDTH)
()
\MOVE.WINDOWS.ONTO.SCREEN :D8
(P 4 REG P 3 YFACTOR P 2 XFACTOR P 1 W I 0 WINDOWS) Ú@Hµ+h´&```ëZ``ë[@HµAhYÉLLØmÿØ`óµLLØmÿØ`ó•Iµ¥i°¢HX°™Yd ð²\Ii
@@ -785,15 +815,15 @@ NIL
(PUTPROPS DISPLAYSTARTEDP MACRO (NIL \DisplayStarted))
(ADDTOVAR GLOBALVARS WHOLESCREEN)
INITIALIZEDISPLAYSTREAMS :D8
(F 0 \GUARANTEEDDISPLAYFONT F 1 DEFAULTFONT) Uodnÿdh`ld
(F 0 \GUARANTEEDDISPLAYFONT F 1 DEFAULTFONT) Yodnÿdh`ld
gl
hdg cgkPh
c(80 FONTCLASS 63 FONTCREATE 38 BITMAPCREATE)
(70 DEFAULTFONT 57 DISPLAY 48 GACHA 43 \SYSBBTEXTURE 30 \SYSPILOTBBT 24 |PILOTBBTTYPE#| 19 WHOLEDISPLAY)
( 4 -16383)
ohg cgkPh
c(84 FONTCLASS 67 FONTCREATE 38 BITMAPCREATE)
(74 DEFAULTFONT 61 DISPLAY 48 GACHA 43 \SYSBBTEXTURE 30 \SYSPILOTBBT 24 |PILOTBBTTYPE#| 19 WHOLEDISPLAY)
( 55 (MEDIUM REGULAR REGULAR) 4 -16383)
(RPAQQ \DisplayStarted NIL)
(RPAQQ \LastTTYLines 12)
(INITIALIZEDISPLAYSTREAMS)
(DISPLAYSTREAMINIT 1000)
(PUTPROPS LLDISPLAY FILETYPE COMPILE-FILE)
(PUTPROPS LLDISPLAY FILETYPE :FAKE-COMPILE-FILE)
NIL

914
sources/MEDLEYFONTFORMAT Normal file
View File

@@ -0,0 +1,914 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "27-Jul-2025 22:22:23" {WMEDLEY}<sources>MEDLEYFONTFORMAT.;218 57699
:EDIT-BY rmk
:CHANGES-TO (FNS MEDLEYFONT.READ.ITEM)
:PREVIOUS-DATE "24-Jul-2025 22:07:35" {WMEDLEY}<sources>MEDLEYFONTFORMAT.;217)
(PRETTYCOMPRINT MEDLEYFONTFORMATCOMS)
(RPAQQ MEDLEYFONTFORMATCOMS
[
(* ;; "Eventually, MEDLEYFONT should be a package")
(* ;; "Main public entries")
(FNS MEDLEYFONT.WRITE.FONT MEDLEYFONT.GETCHARSET MEDLEYFONT.CHARSET? MEDLEYFONT.GETFILEPROP
MEDLEYFONT.FILEP)
(* ;; "Reading")
(FNS MEDLEYFONT.READ.FONT MEDLEYFONT.READ.CHARSET MEDLEYFONT.READ.ITEM MEDLEYFONT.PEEK.ITEM
MEDLEYFONT.READ.FONTPROPS MEDLEYFONT.READ.VERIFIEDFONT)
(* ;; "Writing")
(FNS MEDLEYFONT.WRITE.CHARSET MEDLEYFONT.WRITE.ITEM MEDLEYFONT.WRITE.FONTPROPS
MEDLEYFONT.WRITE.HEADER)
(FNS MEDLEYFONT.FILENAME)
(ADDVARS (DISPLAYFONTEXTENSIONS MEDLEYDISPLAYFONT)
(DISPLAYCHARSETFNS (MEDLEYFONT MEDLEYFONT.FILEP MEDLEYFONT.GETCHARSET))
(INTERPRESSFONTEXTENSIONS MEDLEYINTERPRESSFONT))
(DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (PRINTDATA 0)
(SMALLPDATA 1)
(BITMAPDATA 2)
(WORDBLOCKDATA 3)
(CLARRAYDATA 4)
(FIXPDATA 5)
(ILPOINTERARRAY 6)
(ILNUMBERARRAY 11)
(HPRINTDATA 7)
(ALISTDATA 8)
(PLISTDATA 9)
(LISTDATA 10])
(* ;; "Eventually, MEDLEYFONT should be a package")
(* ;; "Main public entries")
(DEFINEQ
(MEDLEYFONT.WRITE.FONT
[LAMBDA (FONT FILE CHARSETNOS OTHERFONTPROPS NOINDIRECTS) (* ; "Edited 15-Jul-2025 16:43 by rmk")
(* ; "Edited 9-Jul-2025 09:32 by rmk")
(* ; "Edited 19-Jun-2025 10:59 by rmk")
(* ; "Edited 9-Jun-2025 12:17 by rmk")
(* ; "Edited 25-May-2025 20:48 by rmk")
(* ; "Edited 23-May-2025 14:59 by rmk")
(* ; "Edited 22-May-2025 09:58 by rmk")
(* ; "Edited 16-May-2025 20:17 by rmk")
(* ; "Edited 14-May-2025 17:45 by rmk")
(SETQ FONT (FONTCREATE FONT))
(CL:UNLESS FILE
(SETQ FILE (MEDLEYFONT.FILENAME FONT CHARSETNOS)))
(SETQ CHARSETNOS (SORT (MKLIST CHARSETNOS)))
(CL:WITH-OPEN-FILE (STREAM FILE :DIRECTION :OUTPUT :IF-EXISTS :NEW-VERSION)
(MEDLEYFONT.WRITE.HEADER STREAM OTHERFONTPROPS)
(LET ((CHARSETLOCS (CL:MAKE-ARRAY 256 :INITIAL-ELEMENT 0))
(FONTCHARENCODING (FONTPROP FONT 'CHARENCODING))
(*READTABLE* (FIND-READTABLE "INTERLISP"))
CSVECTORPTRLOC CSVECTORLOC FILECHARSETS)
(* ;; "Figure out the actual non empty/sluggish charsets that will be wrtitten.")
(SETQ FILECHARSETS (for CSNO CSINFO from 0 to \MAXCHARSET
when (OR (NULL CHARSETNOS)
(MEMB CSNO CHARSETNOS))
when (SETQ CSINFO (\XGETCHARSETINFO FONT CSNO))
unless (fetch (CHARSETINFO CSSLUGP) of CSINFO) collect CSNO))
(CL:UNLESS FILECHARSETS (ERROR "No character sets to write" FONT))
(* ;; "Right after the header, leave 4 bytes for the pointer to the charset dispatch vector. If writing a single charset, we store the negative of the byte location so we can still easily skip the font properties without writing the whole vector. The byte in front of the single charset holds its number.")
(* ;; "")
(SETQ CSVECTORPTRLOC (GETFILEPTR STREAM)) (* ;
 "Ptr is before fontproperties, vector is after")
(\FIXPOUT STREAM 0)
(MEDLEYFONT.WRITE.FONTPROPS STREAM FONT)
(if (CDR FILECHARSETS)
then (PRINTOUT STREAM "CHARSET LOCATIONS" T)
(* ;
 "Allocate the vector space if multiple")
(SETQ CSVECTORLOC (GETFILEPTR STREAM))
(for I from 0 to \MAXCHARSET do (\FIXPOUT STREAM 0))
(TERPRI STREAM)
(for CSNO in FILECHARSETS do
(* ;;
 "LOC remains zero for missing charsets, slug properties are determined by font-level properties.")
(CL:SETF (CL:SVREF CHARSETLOCS CSNO)
(GETFILEPTR STREAM))
(MEDLEYFONT.WRITE.CHARSET FONT CSNO STREAM
NOINDIRECTS))
(SETFILEPTR STREAM CSVECTORLOC)
(for CSNO from 0 to \MAXCHARSET do (\FIXPOUT STREAM (CL:SVREF CHARSETLOCS
CSNO)))
else
(* ;; "Only one. The %"vector%" is the charset byte immediately before the charset, the sign bit tells the tale.")
(SETQ CSVECTORLOC (IMINUS (GETFILEPTR STREAM)))
(BOUT STREAM (CAR FILECHARSETS))
(MEDLEYFONT.WRITE.CHARSET FONT (CAR FILECHARSETS)
STREAM NOINDIRECTS))
(SETFILEPTR STREAM CSVECTORPTRLOC)
(\FIXPOUT STREAM CSVECTORLOC) (* ;
 "Pointer to the charset dispatch vector--or negative of actual location for a singleton")
(FULLNAME STREAM])
(MEDLEYFONT.GETCHARSET
[LAMBDA (STREAM CHARSET) (* ; "Edited 15-Jul-2025 17:09 by rmk")
(* ; "Edited 9-Jul-2025 15:45 by rmk")
(* ; "Edited 14-May-2025 17:46 by rmk")
(* ;; "If open, assume its a medleyfont stream, that the initial Me etc. has been checked, and we are positioned after the header information")
(CL:UNLESS (<= 0 CHARSET \MAXCHARSET)
(\ILLEGAL.ARG CHARSET))
(RESETLST
(CL:UNLESS (\GETSTREAM STREAM 'INPUT T)
[RESETSAVE (SETQ STREAM (OPENSTREAM STREAM 'INPUT))
`(PROGN (CLOSEF? OLDVALUE]
(CL:UNLESS (MEDLEYFONT.FILEP STREAM) (* ;
 "Checks and positions, if reopening.")
(ERROR "NOT A MEDLEYFONT FILE" (FULLNAME STREAM))))
(LET ((CSVECTORLOC (\FIXPIN STREAM))
CSLOC)
(* ;; "We know now that this file has information about the requested charset, including NIL entries for empty/slugglish ones in the middle of populated ones. A file that would have contain a single empty/sluggish charset cannot be created--the caller would recognize the case of a missing file and provide either NIL or a slug-vector.")
(CL:WHEN (if (ILESSP CSVECTORLOC 0)
then
(* ;; "File contains only one charset. Is it the one we want? If the intended charset is empty/sluggish, the file would not have been constructed and we wouldn't be here.")
(SETFILEPTR STREAM (IMINUS CSVECTORLOC))
(EQ CHARSET (BIN STREAM))
else
(* ;; "The vector-entry points to the one we want. Is it there?")
(SETFILEPTR STREAM (IPLUS CSVECTORLOC (UNFOLD CHARSET BYTESPERCELL)))
(CL:UNLESS (EQ 0 (SETQ CSLOC (\FIXPIN STREAM)))
(SETFILEPTR STREAM CSLOC)))
(MEDLEYFONT.READ.CHARSET STREAM CHARSET))))])
(MEDLEYFONT.CHARSET?
[LAMBDA (FILE CHARSET) (* ; "Edited 15-Jul-2025 15:21 by rmk")
(* ; "Edited 25-May-2025 20:53 by rmk")
(* ; "Edited 21-May-2025 11:35 by rmk")
(* ; "Edited 17-May-2025 11:29 by rmk")
(* ; "Edited 14-May-2025 17:46 by rmk")
(* ;; "If CHARSET, returns CHARSET if FILE contains a non-slug entry for CHARSET. If not CHARSET, returns the list of non-slug charsets in FILE.")
(CL:WITH-OPEN-FILE (STREAM FILE :DIRECTION :INPUT)
(CL:UNLESS (MEDLEYFONT.FILEP STREAM)
(ERROR "Not a MEDLEYFONT file" FILE))
(LET ((CSVECTORLOC (\FIXPIN STREAM)))
(CL:WHEN (if (ILESSP CSVECTORLOC 0)
then
(* ;; "File contains only one charse, is it the one we want? ")
(SETFILEPTR STREAM (IMINUS CSVECTORLOC))
(EQ CHARSET (BIN STREAM))
else (SETFILEPTR STREAM (IPLUS CSVECTORLOC (UNFOLD CHARSET BYTESPERCELL)))
(NEQ 0 (\FIXPIN STREAM)))
CHARSET])
(MEDLEYFONT.GETFILEPROP
[LAMBDA (FILE PROP) (* ; "Edited 15-Jul-2025 20:21 by rmk")
(* ; "Edited 10-Jul-2025 17:50 by rmk")
(* ; "Edited 25-May-2025 20:53 by rmk")
(* ; "Edited 21-May-2025 11:36 by rmk")
(* ; "Edited 17-May-2025 19:07 by rmk")
(* ; "Edited 14-May-2025 17:46 by rmk")
(CL:UNLESS (OR (LITATOM FILE)
(STRINGP FILE))
[SETQ FILE (CAR (APPLY (FUNCTION FONTFILES)
(FONTPROP (FONTCREATE FILE)
'SPEC])
(CL:WITH-OPEN-FILE (STREAM FILE :DIRECTION :INPUT)
(LET (HEADERPROPS CSVECTORLOC)
(CL:UNLESS (SETQ HEADERPROPS (MEDLEYFONT.FILEP STREAM))
(ERROR "Not a MEDLEYFONT file" (FULLNAME STREAM)))
(SETQ CSVECTORLOC (\FIXPIN STREAM))
(SELECTQ PROP
(OTHERPROPS (CDDR HEADERPROPS))
(DATE (CADR HEADERPROPS))
(FONTPROPS (MEDLEYFONT.READ.FONTPROPS STREAM))
(CHARSETS (if (ILESSP CSVECTORLOC 0)
then
(* ;; "File contains only one charset ")
(SETFILEPTR STREAM (IMINUS CSVECTORLOC))
(CONS (BIN STREAM))
else (SETFILEPTR STREAM CSVECTORLOC)
(for CS from 0 to \MAXCHARSET unless (EQ 0 (\FIXPIN STREAM))
collect CS)))
(ERROR "Unknown MEDLEYFONT property"])
(MEDLEYFONT.FILEP
[LAMBDA (FILE) (* ; "Edited 6-Jul-2025 11:44 by rmk")
(* ; "Edited 10-Jun-2025 18:19 by rmk")
(* ; "Edited 8-Jun-2025 22:55 by rmk")
(* ; "Edited 25-May-2025 20:54 by rmk")
(* ; "Edited 21-May-2025 11:37 by rmk")
(* ; "Edited 16-May-2025 21:58 by rmk")
(* ; "Edited 14-May-2025 17:00 by rmk")
(* ;; "Me in first 2 bytes distinguishes MEDLEYFONT format from others. This may be called after the first 2 bytes have been read to verify the %"Me%", if not we skip over it here.")
(* ;; "For a valid file, returns (fullname date)")
(* ;; "If FILE is an open stream, it is left open. Otherwise it is opened and closed.")
(RESETLST
[LET (STREAM VERSION DATE)
[if (\GETSTREAM FILE 'INPUT T)
then (SETQ STREAM FILE)
else (RESETSAVE (SETQ STREAM (OPENSTREAM FILE 'INPUT))
`(PROGN (CLOSEF? OLDVALUE]
(CL:UNLESS (ZEROP (GETFILEPTR STREAM))
(SETFILEPTR STREAM 0))
(CL:WHEN (for C in (CONSTANT (CHCON "Medley font")) always (EQ C (READCCODE STREAM)))
[CAR (NLSETQ [CL:WHEN (EQ 0 (SETQ VERSION (MEDLEYFONT.READ.ITEM STREAM 'VERSION]
`(,(FULLNAME STREAM)
,(MEDLEYFONT.READ.ITEM STREAM 'DATE)
,VERSION
,@(MEDLEYFONT.READ.ITEM STREAM 'OTHERFONTPROPS])])])
)
(* ;; "Reading")
(DEFINEQ
(MEDLEYFONT.READ.FONT
[LAMBDA (FILE CHARSETNOS FONT) (* ; "Edited 15-Jul-2025 20:20 by rmk")
(* ; "Edited 9-Jul-2025 00:06 by rmk")
(* ; "Edited 6-Jul-2025 11:45 by rmk")
(CL:UNLESS FILE (SETQ FILE FONT))
(CL:WHEN (OR (type? FONTDESCRIPTOR FILE)
(LISTP FILE))
(SETQ FILE (MEDLEYFONT.FILENAME FILE)))
(SETQ CHARSETNOS (SORT (MKLIST CHARSETNOS)))
(CL:WITH-OPEN-FILE (STREAM FILE :DIRECTION :INPUT)
(CL:UNLESS (MEDLEYFONT.FILEP STREAM)
(ERROR "NOT A MEDLEYFONT FILE" (FULLNAME STREAM)))
(LET ((*READTABLE* (FIND-READTABLE "INTERLISP"))
FONTCHARSETVECTOR CSVECTORLOC NOTFOUND SINGLECS)
(SETQ CSVECTORLOC (\FIXPIN STREAM)) (* ;
 "Byte location of the charset dispatch vector")
(* ;; "We know now that this file has information about all requested charsets, including NIL entries for empty/slugglish ones in the middle of populated ones. A file that would have contain a single empty/sluggish charset cannot be created--the caller would recognize the case of a missing file and provide either NIL or a slug-vector.")
(SETQ FONT (MEDLEYFONT.READ.VERIFIEDFONT STREAM FONT))
(SETQ FONTCHARSETVECTOR (fetch (FONTDESCRIPTOR FONTCHARSETVECTOR) of FONT))
(CL:UNLESS (EQ CSVECTORLOC 0) (* ; "Not empty")
[if (ILESSP CSVECTORLOC 0)
then
(* ;;
 "File contains only one charset and it's the one we want. Its CHARSET number is in the first byte.")
(* ;; "If the intended charset is empty/sluggish, the file would not have been constructed and we wouldn't be here.")
(SETFILEPTR STREAM (IMINUS CSVECTORLOC))
(SETQ SINGLECS (BIN STREAM))
(CL:WHEN CHARSETNOS
(CL:UNLESS (AND (EQ SINGLECS (CAR CHARSETNOS))
(NULL (CDR CHARSETNOS)))
(ERROR (CONCAT FILE
" does not contain information for charsets ÿ4ÿ"
(REMOVE SINGLECS CHARSETNOS)))))
(\SETCHARSETINFO FONTCHARSETVECTOR SINGLECS (MEDLEYFONT.READ.CHARSET
STREAM SINGLECS))
else
(* ;;
 "Gather all of the CSLOCS before reading, so that we always move forward")
(for CSNO CSLOC
in (OR CHARSETNOS (for I from 0 to \MAXCHARSET collect I))
eachtime (SETFILEPTR STREAM (IPLUS CSVECTORLOC (UNFOLD CSNO
BYTESPERCELL)))
(SETQ CSLOC (\FIXPIN STREAM))
(CL:WHEN (ZEROP CSLOC)
(push NOTFOUND CSNO)) unless (ZEROP CSLOC)
collect (CONS CSNO CSLOC)
finally (CL:WHEN (AND CHARSETNOS NOTFOUND)
(ERROR FILE (CONCAT
" does not contain information for charsets "
(DREVERSE NOTFOUND))))
(for X CS in $$VAL do (SETQ CSNO (CAR X))
(SETFILEPTR STREAM (CDR X))
(\SETCHARSETINFO FONTCHARSETVECTOR CSNO
(MEDLEYFONT.READ.CHARSET STREAM CSNO
])
FONT])
(MEDLEYFONT.READ.CHARSET
[LAMBDA (STREAM CHARSET) (* ; "Edited 15-Jul-2025 11:27 by rmk")
(* ; "Edited 9-Jul-2025 19:33 by rmk")
(* ; "Edited 6-Jul-2025 10:11 by rmk")
(* ; "Edited 25-May-2025 20:54 by rmk")
(* ; "Edited 23-May-2025 11:01 by rmk")
(* ; "Edited 21-May-2025 16:25 by rmk")
(* ; "Edited 16-May-2025 20:19 by rmk")
(* ; "Edited 14-May-2025 10:43 by rmk")
(* ; "Edited 12-May-2025 07:55 by rmk")
(MEDLEYFONT.READ.ITEM STREAM 'CHARSETSTRING) (* ;
 "Throwaway for looking with text editor")
(LET (CSNO INDIRECT)
(CL:UNLESS [EQ CHARSET (SETQ CSNO (MEDLEYFONT.READ.ITEM STREAM 'CHARSET]
(ERROR "Charset mismatch" (LIST CHARSET CSNO)))
(if [EQ 'INDIRECTCHARSET (CAR (SETQ INDIRECT (MEDLEYFONT.PEEK.ITEM STREAM]
then (* ;
 "Read a complete charset from another file (e.g. shared Kanji)")
(MEDLEYFONT.READ.ITEM STREAM 'INDIRECTCHARSET)
(APPLY (FUNCTION \READCHARSET)
(CADR INDIRECT))
else (bind PAIR LABEL ITEM (CSINFO _ (create CHARSETINFO
WIDTHS _ NIL
OFFSETS _ NIL)) eachtime (SETQ PAIR
(
 MEDLEYFONT.READ.ITEM
STREAM))
(SETQ LABEL (CAR PAIR))
(SETQ ITEM (CADR PAIR))
until (EQ LABEL 'STOP) do (SELECTQ LABEL
(WIDTHS (replace (CHARSETINFO WIDTHS) of CSINFO
with ITEM))
(OFFSETS (replace (CHARSETINFO OFFSETS) of CSINFO
with ITEM))
(IMAGEWIDTHS (replace (CHARSETINFO IMAGEWIDTHS)
of CSINFO with ITEM))
(YWIDTHS (replace (CHARSETINFO YWIDTHS) of CSINFO
with ITEM))
(ASCENT (replace (CHARSETINFO CHARSETASCENT)
of CSINFO with ITEM))
(DESCENT (replace (CHARSETINFO CHARSETDESCENT)
of CSINFO with ITEM))
(LEFTKERN (replace (CHARSETINFO LEFTKERN)
of CSINFO with ITEM))
(BITMAP (replace (CHARSETINFO CHARSETBITMAP)
of CSINFO with ITEM))
(CSINFOPROPS (replace (CHARSETINFO CSINFOPROPS)
of CSINFO with ITEM))
(CSCOMPLETEP (replace (CHARSETINFO CSCOMPLETEP)
of CSINFO with ITEM))
(HELP "Unrecognized charsetinfo label'" LABEL))
finally (CL:UNLESS (fetch (CHARSETINFO IMAGEWIDTHS) of CSINFO)
(replace (CHARSETINFO IMAGEWIDTHS) of CSINFO
with (fetch (CHARSETINFO WIDTHS) of CSINFO)))
(RETURN CSINFO])
(MEDLEYFONT.READ.ITEM
[LAMBDA (STREAM LABEL?) (* ; "Edited 27-Jul-2025 22:22 by rmk")
(* ; "Edited 24-Jul-2025 22:07 by rmk")
(* ; "Edited 14-Jul-2025 15:47 by rmk")
(* ;; "Reads and returns the (label data) that starts at the current position in STREAM according to its storage type. If LABEL? is provided, error if the data read does not have that label. ")
(LET
[(ITEM (GETSTREAMPROP STREAM 'MEDLEYFONT.PEEKEDITEM]
(if ITEM
then (PUTSTREAMPROP STREAM 'MEDLEYFONT.PEEKEDITEM NIL)
else (LET ((*READTABLE* (FIND-READTABLE 'INTERLISP))
(*PACKAGE* (CL:FIND-PACKAGE 'INTERLISP))
LABEL NELTS)
(SETQ LABEL (RATOM STREAM))
(READCCODE STREAM)
[SETQ ITEM
(LIST LABEL (SELECTC (BIN STREAM)
(SMALLPDATA (\WIN STREAM))
(FIXPDATA (\FIXPIN STREAM))
(PRINTDATA (READ STREAM))
(ALISTDATA (bind X until [EQ 'STOP (CAR (SETQ X (
 MEDLEYFONT.READ.ITEM
STREAM]
collect (CONS (CAR X)
(CADR X))))
(PLISTDATA (bind X until [EQ 'STOP (CAR (SETQ X (
 MEDLEYFONT.READ.ITEM
STREAM]
join X))
(LISTDATA (bind ELT until [EQ 'STOP (CAR (SETQ ELT (
 MEDLEYFONT.READ.ITEM
STREAM]
collect (CADR ELT)
finally (CL:WHEN (CADR ELT)
(NCONC $$VAL ELT))))
(BITMAPDATA (\READBINARYBITMAP STREAM))
(CLARRAYDATA (LET [[ARRAY (CL:MAKE-ARRAY (READ STREAM)
:ELEMENT-TYPE
(MEDLEYFONT.READ.ITEM STREAM
'ELEMENT-TYPE]
(ALLFIXED (EQ 1 (BIN STREAM]
(for I from 0 to (\FIXPIN STREAM)
do [CL:SETF (XCL:ROW-MAJOR-AREF ARRAY I)
(CL:IF ALLFIXED
(\FIXPIN STREAM)
(CADR (MEDLEYFONT.READ.ITEM
STREAM)))]
finally (RETURN ARRAY))))
(ILPOINTERARRAY
(LET [(NELTS (\FIXPIN STREAM))
(ORIG (BIN STREAM))
(ALLFIXED (EQ 1 (BIN STREAM]
(for I (ARRAY _ (ARRAY NELTS NIL NIL ORIG)) from ORIG
to (CL:IF (EQ ORIG 1)
NELTS
(SUB1 NELTS))
do (SETA ARRAY I (CL:IF ALLFIXED
(\FIXPIN STREAM)
(MEDLEYFONT.READ.ITEM STREAM I)))
finally (RETURN ARRAY))))
(ILNUMBERARRAY (LET ((NELTS (\FIXPIN STREAM))
(ORIG (BIN STREAM)))
(AIN (ARRAY NELTS (MEDLEYFONT.READ.ITEM
STREAM
'ARRAYTYP)
NIL ORIG)
ORIG NELTS STREAM)))
(WORDBLOCKDATA (LET* [(NWORDS (\FIXPIN STREAM))
(BLOCK (\ALLOCBLOCK (FOLDHI NWORDS
WORDSPERCELL]
(\BINS STREAM BLOCK 0 (UNFOLD NWORDS
BYTESPERWORD))
BLOCK))
(HPRINTDATA (HREAD STREAM))
(SHOULDNT "UNKNOWN MEDLEYFONT DATA TYPE"]
(* ; "Skip the EOL")
(READCCODE STREAM)))
(CL:WHEN (AND LABEL? (NEQ LABEL? (CAR ITEM)))
(ERROR (CONCAT LABEL? " item not found")
ITEM))
(CL:IF LABEL?
(CADR ITEM)
ITEM)])
(MEDLEYFONT.PEEK.ITEM
[LAMBDA (STREAM LABEL?) (* ; "Edited 6-Jul-2025 14:10 by rmk")
(* ;; "If previously peeked and not read, returns that item. Otherwise calls the reader to get the new item. We always record the (LABEL DATA pair)")
(LET [(PEEKEDITEM (GETSTREAMPROP STREAM 'MEDLEYFONT.PEEKEDITEM]
(CL:UNLESS PEEKEDITEM
(PUTSTREAMPROP STREAM 'MEDLEYFONT.PEEKEDITEM (SETQ PEEKEDITEM (MEDLEYFONT.READ.ITEM
STREAM))))
(CL:WHEN (AND LABEL? (NEQ LABEL? (CAR PEEKEDITEM)))
(ERROR (CONCAT "Peeked " (CAR PEEKEDITEM)
" instead of " LABEL?)
PEEKEDITEM))
(CL:IF LABEL?
(CADR PEEKEDITEM)
PEEKEDITEM)])
(MEDLEYFONT.READ.FONTPROPS
[LAMBDA (STREAM) (* ; "Edited 25-May-2025 20:55 by rmk")
(* ; "Edited 16-May-2025 21:58 by rmk")
(* ; "Edited 14-May-2025 09:11 by rmk")
(bind PAIR until [EQ 'STOP (CAR (SETQ PAIR (MEDLEYFONT.READ.ITEM STREAM] collect PAIR])
(MEDLEYFONT.READ.VERIFIEDFONT
[LAMBDA (STREAM FONT) (* ; "Edited 10-Jun-2025 20:57 by rmk")
(* ; "Edited 21-May-2025 22:55 by rmk")
(* ; "Edited 19-May-2025 17:42 by rmk")
(* ; "Edited 16-May-2025 10:28 by rmk")
(LET ((FONTPROPS (MEDLEYFONT.READ.FONTPROPS STREAM)))
[if FONT
then (* ; "compare/verify")
(for P in FONTPROPS unless (EQUAL (CADR P)
(RECORDACCESS (CAR P)
FONT NIL 'FETCH))
do (ERROR "Mismatching font property" P))
else (SETQ FONT (create FONTDESCRIPTOR)) (* ; "Construct")
(for P VAL in FONTPROPS do (SETQ VAL (CADR P))
(SELECTQ (CAR P)
(FONTDEVICE (replace (FONTDESCRIPTOR FONTDEVICE)
of FONT with VAL))
(FONTCOMPLETEP (replace (FONTDESCRIPTOR FONTCOMPLETEP)
of FONT with VAL))
(FONTFAMILY (replace (FONTDESCRIPTOR FONTFAMILY)
of FONT with VAL))
(FONTSIZE (replace (FONTDESCRIPTOR FONTSIZE)
of FONT with VAL))
(FONTFACE (replace (FONTDESCRIPTOR FONTFACE)
of FONT with VAL))
(\SFAscent (replace (FONTDESCRIPTOR \SFAscent)
of FONT with VAL))
(\SFDescent (replace (FONTDESCRIPTOR \SFDescent)
of FONT with VAL))
(\SFHeight (replace (FONTDESCRIPTOR \SFHeight)
of FONT with VAL))
(ROTATION (replace (FONTDESCRIPTOR ROTATION)
of FONT with VAL))
(FONTDEVICESPEC
(replace (FONTDESCRIPTOR FONTDEVICESPEC)
of FONT with VAL))
(OTHERDEVICEFONTPROPS
(replace (FONTDESCRIPTOR OTHERDEVICEFONTPROPS)
of FONT with VAL))
(FONTSCALE (replace (FONTDESCRIPTOR FONTSCALE)
of FONT with VAL))
(\SFFACECODE (replace (FONTDESCRIPTOR \SFFACECODE)
of FONT with VAL))
(FONTAVGCHARWIDTH
(replace (FONTDESCRIPTOR FONTAVGCHARWIDTH)
of FONT with VAL))
(FONTCHARENCODING
(replace (FONTDESCRIPTOR FONTCHARENCODING)
of FONT with VAL))
(FONTCHARSETVECTOR
(replace (FONTDESCRIPTOR FONTCHARSETVECTOR)
of FONT with VAL))
(FONTHASLEFTKERNS
(replace (FONTDESCRIPTOR FONTHASLEFTKERNS)
of FONT with VAL))
(FONTEXTRAFIELD2
(replace (FONTDESCRIPTOR FONTEXTRAFIELD2)
of FONT with VAL))
(HELP "UNKNOWN FONTDESCRIPTOR PROPERTY: P"]
FONT])
)
(* ;; "Writing")
(DEFINEQ
(MEDLEYFONT.WRITE.CHARSET
[LAMBDA (FONT CHARSET STREAM NOINDIRECTS) (* ; "Edited 9-Jul-2025 19:14 by rmk")
(* ; "Edited 25-May-2025 20:49 by rmk")
(* ; "Edited 22-May-2025 09:58 by rmk")
(* ; "Edited 16-May-2025 20:18 by rmk")
(* ; "Edited 13-May-2025 23:26 by rmk")
(* ;; "This outputs the characterset info for CHARSET in FONT.")
(LET ((CSINFO (\INSURECHARSETINFO CHARSET FONT))
CSCHARENCODING)
(MEDLEYFONT.WRITE.ITEM STREAM 'CHARSETSTRING (MKSTRING CHARSET))
(* ; "For human file-scan")
(MEDLEYFONT.WRITE.ITEM STREAM 'CHARSET CHARSET)
(CL:UNLESS (OR (NULL CSINFO)
(fetch (CHARSETINFO CSSLUGP) of CSINFO))
(* ;
 "Slug info is determined by FONT properties")
(* ;; "Copy the fonts charencoding down to each charset info so that it is available when the charsetinfo is read. The fontdescriptor isn't available at that point and coercion could lead to fonts of different encodings. At least this would make it possible to fix things up.")
(if (CL:UNLESS NOINDIRECTS (INDIRECTCHARSETP CSINFO FONT CHARSET))
then
(* ;;
 "This charset is is taken entirely from on another file, no need to copy it to this file.")
(MEDLEYFONT.WRITE.ITEM STREAM 'INDIRECTCHARSET (GETMULTI (fetch (CHARSETINFO
CSINFOPROPS)
of CSINFO)
'SOURCE)
NIL
'PRINT)
else (MEDLEYFONT.WRITE.ITEM STREAM 'CSINFOPROPS (fetch (CHARSETINFO CSINFOPROPS)
of CSINFO)
NIL
'ALIST)
(MEDLEYFONT.WRITE.ITEM STREAM 'WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO))
(CL:UNLESS [OR (EQ (fetch (CHARSETINFO IMAGEWIDTHS) of CSINFO)
(fetch (CHARSETINFO WIDTHS) of CSINFO))
(for I (W _ (fetch (CHARSETINFO WIDTHS) of CSINFO))
(IM _ (fetch (CHARSETINFO IMAGEWIDTHS) of CSINFO))
from 0 to (SUB1 (IPLUS \MAXTHINCHAR 3))
always (EQ (\GETBASE W I)
(\GETBASE IM I]
(MEDLEYFONT.WRITE.ITEM STREAM 'IMAGEWIDTHS (fetch (CHARSETINFO IMAGEWIDTHS)
of CSINFO)))
(MEDLEYFONT.WRITE.ITEM STREAM 'OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO))
(MEDLEYFONT.WRITE.ITEM STREAM 'YWIDTHS (fetch (CHARSETINFO YWIDTHS) of CSINFO))
(MEDLEYFONT.WRITE.ITEM STREAM 'ASCENT (fetch (CHARSETINFO CHARSETASCENT)
of CSINFO))
(MEDLEYFONT.WRITE.ITEM STREAM 'DESCENT (fetch (CHARSETINFO CHARSETDESCENT)
of CSINFO))
(MEDLEYFONT.WRITE.ITEM STREAM 'LEFTKERN (fetch (CHARSETINFO LEFTKERN)
of CSINFO))
(MEDLEYFONT.WRITE.ITEM STREAM 'BITMAP (fetch (CHARSETINFO CHARSETBITMAP)
of CSINFO))
(MEDLEYFONT.WRITE.ITEM STREAM 'CSCOMPLETEP (fetch (CHARSETINFO CSCOMPLETEP)
of CSINFO))
(MEDLEYFONT.WRITE.ITEM STREAM 'STOP T)))])
(MEDLEYFONT.WRITE.ITEM
[LAMBDA (STREAM LABEL ITEM EVENIFNIL TYPE BLOCKNELTS) (* ; "Edited 24-Jul-2025 22:07 by rmk")
(* ; "Edited 15-Jul-2025 11:06 by rmk")
(* ; "Edited 8-Jul-2025 23:03 by rmk")
(* ; "Edited 20-Jun-2025 11:10 by rmk")
(* ; "Edited 8-Jun-2025 21:14 by rmk")
(* ; "Edited 25-May-2025 20:48 by rmk")
(* ; "Edited 23-May-2025 10:58 by rmk")
(* ; "Edited 22-May-2025 10:31 by rmk")
(* ; "Edited 17-May-2025 10:10 by rmk")
(* ; "Edited 14-May-2025 00:07 by rmk")
(* ;; "Writes ITEM preceded by LABEL. BLOCKNELTS overrides the default for array blocks, because of the uncertainty/complexity in determining arrayblock length.")
(LET [(*READTABLE* (FIND-READTABLE 'INTERLISP))
(*PACKAGE* (CL:FIND-PACKAGE 'INTERLISP]
(CL:WHEN (OR ITEM EVENIFNIL)
(PRIN2 LABEL STREAM)
(PRIN1 " " STREAM)
(SELECTQ (OR TYPE (TYPENAME ITEM))
(SMALLP (BOUT STREAM SMALLPDATA)
(\WOUT STREAM ITEM))
(FIXP (* ; "Must come after SMALLP")
(BOUT STREAM FIXPDATA)
(\FIXPOUT STREAM ITEM))
((LITATOM STRINGP PRINT)
(BOUT STREAM PRINTDATA) (* ;
 "A printable Lisp object, even some lists (below)")
(PRIN2 ITEM STREAM))
(LISTP [if (for TAIL on ITEM always (ATOM (CAR TAIL))
finally
(* ;; "Check the final CDR.")
(CL:UNLESS (ATOM TAIL)
(RETURN NIL)))
then (BOUT STREAM PRINTDATA) (* ; "More compact for simple lists.")
(PRIN2 ITEM STREAM)
else (BOUT STREAM LISTDATA)
(for TAIL on ITEM as I from 1 do (MEDLEYFONT.WRITE.ITEM STREAM I
(CAR TAIL)
T)
(CL:UNLESS (LISTP (CDR TAIL))
(MEDLEYFONT.WRITE.ITEM
STREAM
'STOP
(CDR TAIL)
T)
(RETURN))])
(ALIST
(* ;;
 " This could be done as LISTDATA, but this way it uses the alist keys as labels.")
(BOUT STREAM ALISTDATA)
(for X KEY in ITEM do (SETQ KEY (CAR X))
(CL:UNLESS (OR (LITATOM KEY)
(SMALLP KEY))
(ERROR "NOT AN ALIST" ITEM))
(MEDLEYFONT.WRITE.ITEM STREAM KEY (CDR X)
EVENIFNIL))
(MEDLEYFONT.WRITE.ITEM STREAM 'STOP T))
(PLIST (BOUT STREAM PLISTDATA)
(for DTAIL KEY on ITEM by (CDDR DTAIL)
do (SETQ KEY (CAR DTAIL))
(CL:UNLESS (OR (LITATOM KEY)
(SMALLP KEY))
(ERROR "NOT A PLIST" ITEM))
(MEDLEYFONT.WRITE.ITEM STREAM KEY (CADR DTAIL)
EVENIFNIL))
(MEDLEYFONT.WRITE.ITEM STREAM 'STOP T))
(BITMAP (BOUT STREAM BITMAPDATA)
(\PRINTBINARYBITMAP ITEM STREAM))
((ONED-ARRAY TWOD-ARRAY GENERAL-ARRAY) (* ;
 "Note: can't be used in MAKEINIT fonts")
(BOUT STREAM CLARRAYDATA)
(PRIN2 (CL:ARRAY-DIMENSIONS ITEM)
STREAM) (* ; "A list, READ's OK")
(MEDLEYFONT.WRITE.ITEM STREAM 'ELEMENT-TYPE (CL:ARRAY-ELEMENT-TYPE ITEM))
(for I ALLFIXED ELT from 0 to (SUB1 (CL:ARRAY-TOTAL-SIZE ITEM))
first [SETQ ALLFIXED (for I from 0 to (SUB1 (CL:ARRAY-TOTAL-SIZE ITEM))
always (FIXP (XCL:ROW-MAJOR-AREF ITEM I]
(BOUT STREAM (CL:IF ALLFIXED
1
0))
(\FIXPOUT STREAM (SUB1 (CL:ARRAY-TOTAL-SIZE ITEM)))
do (SETQ ELT (XCL:ROW-MAJOR-AREF ITEM I))
(CL:IF ALLFIXED
(\FIXPOUT STREAM ELT)
(MEDLEYFONT.WRITE.ITEM STREAM I ELT T))))
(ARRAYP (if (EQ 'POINTER (ARRAYTYP ITEM))
then (BOUT STREAM ILPOINTERARRAY)
(\FIXPOUT STREAM (ARRAYSIZE ITEM))
(BOUT STREAM (ARRAYORIG ITEM))
(for I ALLFIXED from (ARRAYORIG ITEM)
to (IPLUS (ARRAYORIG ITEM)
(SUB1 (ARRAYSIZE ITEM)))
first [SETQ ALLFIXED (for I from (ARRAYORIG ITEM)
to (IPLUS (ARRAYORIG ITEM)
(SUB1 (ARRAYSIZE ITEM)))
always (FIXP (ELT ITEM I]
(BOUT STREAM (CL:IF ALLFIXED
1
0))
do
(* ;; "Don't need to do the item recursion if all integers")
(CL:IF ALLFIXED
(\FIXPOUT STREAM (ELT ITEM I))
(MEDLEYFONT.WRITE.ITEM STREAM I (ELT ITEM I)
T)))
else (BOUT STREAM ILNUMBERARRAY)
(\FIXPOUT STREAM (ARRAYSIZE ITEM))
(BOUT STREAM (ARRAYORIG ITEM))
(MEDLEYFONT.WRITE.ITEM STREAM 'ARRAYTYP (ARRAYTYP ITEM))
(AOUT ITEM (ARRAYORIG ITEM)
(ARRAYSIZE ITEM)
STREAM)))
(if (\BLOCKDATAP ITEM)
then
(* ;; "This assumes word-element blocks. We can distinguish pointer blocks (from the DTD, see BLOCKEQUALP), caller would have to tell us (a different TYPE?) whether we are looking at full integer or word blocks--how to interpret NELTS")
(BOUT STREAM WORDBLOCKDATA)
(CL:UNLESS BLOCKNELTS (* ; "Why 3 ?")
(SETQ BLOCKNELTS (IPLUS \MAXTHINCHAR 3)))
(\FIXPOUT STREAM BLOCKNELTS)
(\BOUTS STREAM ITEM 0 (UNFOLD BLOCKNELTS BYTESPERWORD))
else (BOUT STREAM HPRINTDATA) (* ; "A datatype?")
(HPRINT ITEM STREAM T T)))
(* ;; "Terpri to make sure ratom is OK, also looks better")
(TERPRI STREAM))])
(MEDLEYFONT.WRITE.FONTPROPS
[LAMBDA (STREAM FONT) (* ; "Edited 10-Jun-2025 20:50 by rmk")
(* ; "Edited 25-May-2025 20:50 by rmk")
(* ; "Edited 22-May-2025 10:31 by rmk")
(* ; "Edited 19-May-2025 10:42 by rmk")
(* ; "Edited 14-May-2025 17:26 by rmk")
(* ;; "RECORDFIELDACCESS would be more succinct but would depend on runtime availability of the record. If the record changes, this and the reader have to be updated.")
(* ;; "HPRINT would be obvious, but it would get charsetvector etc.")
(* ;; "Exclude FONTCHARSETVECTOR and \SFFACECODE")
(* ;; "Write even NIL values for default overerides")
(MEDLEYFONT.WRITE.ITEM STREAM 'FONTDEVICE (fetch (FONTDESCRIPTOR FONTDEVICE) of FONT)
T)
(MEDLEYFONT.WRITE.ITEM STREAM 'FONTCOMPLETEP (fetch (FONTDESCRIPTOR FONTCOMPLETEP) of FONT)
T)
(MEDLEYFONT.WRITE.ITEM STREAM 'FONTFAMILY (fetch (FONTDESCRIPTOR FONTFAMILY) of FONT)
T)
(MEDLEYFONT.WRITE.ITEM STREAM 'FONTSIZE (fetch (FONTDESCRIPTOR FONTSIZE) of FONT)
T)
(MEDLEYFONT.WRITE.ITEM STREAM 'FONTFACE (fetch (FONTDESCRIPTOR FONTFACE) of FONT)
T)
(MEDLEYFONT.WRITE.ITEM STREAM '\SFAscent (fetch (FONTDESCRIPTOR \SFAscent) of FONT)
T)
(MEDLEYFONT.WRITE.ITEM STREAM '\SFDescent (fetch (FONTDESCRIPTOR \SFDescent) of FONT)
T)
(MEDLEYFONT.WRITE.ITEM STREAM '\SFHeight (fetch (FONTDESCRIPTOR \SFHeight) of FONT)
T)
(MEDLEYFONT.WRITE.ITEM STREAM 'ROTATION (fetch (FONTDESCRIPTOR ROTATION) of FONT)
T)
(MEDLEYFONT.WRITE.ITEM STREAM 'FONTDEVICESPEC (fetch (FONTDESCRIPTOR FONTDEVICESPEC) of FONT)
T)
(MEDLEYFONT.WRITE.ITEM STREAM 'OTHERDEVICEFONTPROPS (fetch (FONTDESCRIPTOR OTHERDEVICEFONTPROPS)
of FONT)
T)
(MEDLEYFONT.WRITE.ITEM STREAM 'FONTSCALE (fetch (FONTDESCRIPTOR FONTSCALE) of FONT)
T)
(MEDLEYFONT.WRITE.ITEM STREAM 'FONTAVGCHARWIDTH (fetch (FONTDESCRIPTOR FONTAVGCHARWIDTH)
of FONT)
T)
(MEDLEYFONT.WRITE.ITEM STREAM 'FONTCHARENCODING (fetch (FONTDESCRIPTOR FONTCHARENCODING)
of FONT)
T)
(MEDLEYFONT.WRITE.ITEM STREAM 'FONTHASLEFTKERNS (fetch (FONTDESCRIPTOR FONTHASLEFTKERNS)
of FONT)
T)
(MEDLEYFONT.WRITE.ITEM STREAM 'FONTEXTRAFIELD2 (fetch (FONTDESCRIPTOR FONTEXTRAFIELD2)
of FONT)
T)
(MEDLEYFONT.WRITE.ITEM STREAM 'STOP T])
(MEDLEYFONT.WRITE.HEADER
[LAMBDA (STREAM OTHERFONTPROPS) (* ; "Edited 25-May-2025 20:51 by rmk")
(* ; "Edited 16-May-2025 20:20 by rmk")
(* ; "Edited 14-May-2025 17:01 by rmk")
(* ;; "Me in first 2 bytes distinguishes MEDLEYFONT format from others")
(PRINTOUT STREAM "Medley font" T)
(MEDLEYFONT.WRITE.ITEM STREAM 'VERSION 0)
(MEDLEYFONT.WRITE.ITEM STREAM 'DATE (DATE))
(MEDLEYFONT.WRITE.ITEM STREAM 'OTHERFONTPROPS OTHERFONTPROPS T])
)
(DEFINEQ
(MEDLEYFONT.FILENAME
[LAMBDA (FONT CHARSET EXTENSION FILE) (* ; "Edited 10-Jun-2025 11:02 by rmk")
(* ; "Edited 25-May-2025 21:25 by rmk")
(* ; "Edited 19-May-2025 17:42 by rmk")
(* ; "Edited 16-May-2025 14:09 by rmk")
(* ;; "If EXTENSION and FILE are NIL, puts the file in the MEDLEYDIR fonts/medley[device]fonts/ directory with extension MEDLEY[device]FONT. If CHARSET, goes in the CHARSET subdirectory.")
(CL:WHEN (AND (LISTP CHARSET)
(NULL (CDR CHARSET)))
(SETQ CHARSET (CAR CHARSET))) (* ; "Edited 14-May-2025 12:02 by rmk")
(LET (FAMILY SIZE FACE DEVICE FILENAME)
[if (LISTP FONT)
then (SETQ FAMILY (CAR FONT))
(SETQ SIZE (CADR FONT))
(SETQ FACE (OR (CADDR FONT)
'MRR))
(SETQ DEVICE (OR (CADDDR FONT)
'DISPLAY))
elseif (type? FONTDESCRIPTOR FONT)
then (SETQ FAMILY (FONTPROP FONT 'FAMILY))
(SETQ SIZE (FONTPROP FONT 'SIZE))
(SETQ FACE (FONTPROP FONT 'FACE))
(SETQ DEVICE (FONTPROP FONT 'DEVICE]
(CL:WHEN (LISTP FACE)
(SETQ FACE (CONCAT (NTHCHAR (CAR FACE)
1)
(NTHCHAR (CADR FACE)
1)
(NTHCHAR (CADDR FACE)
1))))
(CL:UNLESS EXTENSION
(SETQ EXTENSION (CONCAT "MEDLEY" (U-CASE DEVICE)
"FONT"))
(CL:UNLESS FILE
[SETQ FILE (PSEUDOFILENAME (MEDLEYDIR (CONCAT "fonts/" (L-CASE EXTENSION)
"s"]))
(SETQ FILENAME (PACK* FAMILY (CL:IF (ILEQ SIZE 9)
"0"
"")
SIZE "-" FACE (CL:IF (SMALLP CHARSET)
(CONCAT "-C" (OCTALSTRING CHARSET))
"")
"." EXTENSION))
(PACKFILENAME 'BODY FILE 'BODY FILENAME])
)
(ADDTOVAR DISPLAYFONTEXTENSIONS MEDLEYDISPLAYFONT)
(ADDTOVAR DISPLAYCHARSETFNS (MEDLEYFONT MEDLEYFONT.FILEP MEDLEYFONT.GETCHARSET))
(ADDTOVAR INTERPRESSFONTEXTENSIONS MEDLEYINTERPRESSFONT)
(DECLARE%: EVAL@COMPILE DONTCOPY
(DECLARE%: EVAL@COMPILE
(RPAQQ PRINTDATA 0)
(RPAQQ SMALLPDATA 1)
(RPAQQ BITMAPDATA 2)
(RPAQQ WORDBLOCKDATA 3)
(RPAQQ CLARRAYDATA 4)
(RPAQQ FIXPDATA 5)
(RPAQQ ILPOINTERARRAY 6)
(RPAQQ ILNUMBERARRAY 11)
(RPAQQ HPRINTDATA 7)
(RPAQQ ALISTDATA 8)
(RPAQQ PLISTDATA 9)
(RPAQQ LISTDATA 10)
(CONSTANTS (PRINTDATA 0)
(SMALLPDATA 1)
(BITMAPDATA 2)
(WORDBLOCKDATA 3)
(CLARRAYDATA 4)
(FIXPDATA 5)
(ILPOINTERARRAY 6)
(ILNUMBERARRAY 11)
(HPRINTDATA 7)
(ALISTDATA 8)
(PLISTDATA 9)
(LISTDATA 10))
)
)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (2127 14772 (MEDLEYFONT.WRITE.FONT 2137 . 6995) (MEDLEYFONT.GETCHARSET 6997 . 9296) (
MEDLEYFONT.CHARSET? 9298 . 10767) (MEDLEYFONT.GETFILEPROP 10769 . 12804) (MEDLEYFONT.FILEP 12806 .
14770)) (14798 36689 (MEDLEYFONT.READ.FONT 14808 . 19241) (MEDLEYFONT.READ.CHARSET 19243 . 24137) (
MEDLEYFONT.READ.ITEM 24139 . 30288) (MEDLEYFONT.PEEK.ITEM 30290 . 31152) (MEDLEYFONT.READ.FONTPROPS
31154 . 31619) (MEDLEYFONT.READ.VERIFIEDFONT 31621 . 36687)) (36715 54244 (MEDLEYFONT.WRITE.CHARSET
36725 . 41330) (MEDLEYFONT.WRITE.ITEM 41332 . 50385) (MEDLEYFONT.WRITE.FONTPROPS 50387 . 53589) (
MEDLEYFONT.WRITE.HEADER 53591 . 54242)) (54245 56814 (MEDLEYFONT.FILENAME 54255 . 56812)))))
STOP

BIN
sources/MEDLEYFONTFORMAT.LCOM Normal file
View File

Binary file not shown.