github.com/Interlisp.medley
1
0
Fork 0
mirror of synced 2026-04-19 01:37:23 +00:00
Code Issues Projects Releases Wiki Activity

EDITFONT uses FONTFACE subfunction

Browse Source
This commit is contained in:
rmkaplan
2025-09-11 23:52:37 -07:00
parent 3b0b847812
commit 00a8f0eba3
2 changed files with 23 additions and 19 deletions
Download Patch File Download Diff File Expand all files Collapse all files

42
lispusers/EDITFONT
View File

@@ -1,12 +1,12 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "29-Aug-2025 22:34:31" {WMEDLEY}<lispusers>EDITFONT.;33 24939 (FILECREATED " 4-Sep-2025 10:30:31" {WMEDLEY}<lispusers>EDITFONT.;35 25299
:EDIT-BY rmk :EDIT-BY rmk
:CHANGES-TO (FNS EDITFONT EF.EDITBM EF.CHARITEMS EF.SAVE) :CHANGES-TO (FNS EDITFONT)
:PREVIOUS-DATE "27-Aug-2025 22:50:51" {WMEDLEY}<lispusers>EDITFONT.;30) :PREVIOUS-DATE " 2-Sep-2025 23:03:37" {WMEDLEY}<lispusers>EDITFONT.;34)
(PRETTYCOMPRINT EDITFONTCOMS) (PRETTYCOMPRINT EDITFONTCOMS)
@@ -179,15 +179,16 @@
(REDISPLAYW (WFROMMENU MENU]) (REDISPLAYW (WFROMMENU MENU])
(EF.DELETE (EF.DELETE
[LAMBDA (CHARITEM MENU) (* ; "Edited 4-Aug-2025 13:14 by rmk") [LAMBDA (CHARITEM MENU) (* ; "Edited 2-Sep-2025 23:03 by rmk")
(* ; "Edited 4-Aug-2025 13:14 by rmk")
(* kbr%: "15-Dec-84 15:20") (* kbr%: "15-Dec-84 15:20")
(* ; (* ;
 "Turn CHARITEM into a slug charitem.")  "Turn CHARITEM into a slug charitem.")
(LET ((WINDOW (WFROMMENU MENU)) (LET ((WINDOW (WFROMMENU MENU))
SLUGBITMAP) SLUGBITMAP)
[SETQ SLUGBITMAP (\GETCHARBITMAP.CSINFO SLUGCHARINDEX (\XGETCHARSETINFO (WINDOWPROP [SETQ SLUGBITMAP (\GETCHARBITMAP.CSINFO SLUGCHARINDEX (\GETCHARSETINFO (WINDOWPROP
WINDOW WINDOW
'FONT) 'FONT)
(WINDOWPROP WINDOW 'CHARSET] (WINDOWPROP WINDOW 'CHARSET]
(UNINTERRUPTABLY (UNINTERRUPTABLY
(replace (CHARITEM BITMAP) of CHARITEM with SLUGBITMAP) (replace (CHARITEM BITMAP) of CHARITEM with SLUGBITMAP)
@@ -233,7 +234,8 @@
(T (LISPERROR "ILLEGAL ARG" BITMAP]) (T (LISPERROR "ILLEGAL ARG" BITMAP])
(EF.SAVE (EF.SAVE
[LAMBDA (WINDOW) (* ; "Edited 29-Aug-2025 11:35 by rmk") [LAMBDA (WINDOW) (* ; "Edited 2-Sep-2025 23:03 by rmk")
(* ; "Edited 29-Aug-2025 11:35 by rmk")
(* ; "Edited 4-Aug-2025 09:22 by rmk") (* ; "Edited 4-Aug-2025 09:22 by rmk")
(* ; "Edited 2-Aug-2025 08:47 by rmk") (* ; "Edited 2-Aug-2025 08:47 by rmk")
(* kbr%: "21-Oct-85 15:39") (* kbr%: "21-Oct-85 15:39")
@@ -255,12 +257,12 @@
(* ;; "We'll install the slugbm at the end, include its dimensions") (* ;; "We'll install the slugbm at the end, include its dimensions")
(SETQ SLUGBM (\GETCHARBITMAP.CSINFO SLUGCHARINDEX (\XGETCHARSETINFO FONT CHARSET))) (SETQ SLUGBM (\GETCHARBITMAP.CSINFO SLUGCHARINDEX (\GETCHARSETINFO FONT CHARSET)))
(SETQ SLUGWIDTH (fetch (BITMAP BITMAPWIDTH) of SLUGBM)) (SETQ SLUGWIDTH (fetch (BITMAP BITMAPWIDTH) of SLUGBM))
(add CBWIDTH SLUGWIDTH) (add CBWIDTH SLUGWIDTH)
(SETQ CBHEIGHT (IMAX CBHEIGHT (fetch (BITMAP BITMAPHEIGHT) of SLUGBM))) (SETQ CBHEIGHT (IMAX CBHEIGHT (fetch (BITMAP BITMAPHEIGHT) of SLUGBM)))
(SETQ CB (BITMAPCREATE CBWIDTH CBHEIGHT)) (SETQ CB (BITMAPCREATE CBWIDTH CBHEIGHT))
(SETQ CSINFO (create CHARSETINFO copying (\XGETCHARSETINFO FONT CHARSET) (SETQ CSINFO (create CHARSETINFO copying (\GETCHARSETINFO FONT CHARSET)
CHARSETBITMAP _ CB)) CHARSETBITMAP _ CB))
(SETQ OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO)) (SETQ OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO))
(SETQ WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO))(* ; "Store new info in allocations") (SETQ WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO))(* ; "Store new info in allocations")
@@ -325,6 +327,7 @@
(BLANKCHARSETCREATE (BLANKCHARSETCREATE
[LAMBDA (FAMILY SIZE FACE CHARSET FIRSTCHAR LASTCHAR ASCENT DESCENT WIDTH) [LAMBDA (FAMILY SIZE FACE CHARSET FIRSTCHAR LASTCHAR ASCENT DESCENT WIDTH)
(* ; "Edited 2-Sep-2025 23:03 by rmk")
(* ; "Edited 4-Aug-2025 13:29 by rmk") (* ; "Edited 4-Aug-2025 13:29 by rmk")
(* mjs "27-Mar-85 14:48") (* mjs "27-Mar-85 14:48")
(* ; "Edited 3-Aug-2025 17:53 by rmk") (* ; "Edited 3-Aug-2025 17:53 by rmk")
@@ -343,7 +346,7 @@
(PROG (ROTATION DEVICE FONT CSINFO SLUGWIDTH OFFSETS WIDTHS SLUGOFFSET CB CBWIDTH CBHEIGHT) (PROG (ROTATION DEVICE FONT CSINFO SLUGWIDTH OFFSETS WIDTHS SLUGOFFSET CB CBWIDTH CBHEIGHT)
(SETQ FONT (\FONT.CHECKARGS FAMILY SIZE FACE 0 'DISPLAY CHARSET)) (SETQ FONT (\FONT.CHECKARGS FAMILY SIZE FACE 0 'DISPLAY CHARSET))
[if (type? FONTDESCRIPTOR FONT) [if (type? FONTDESCRIPTOR FONT)
then (CL:WHEN (SETQ CSINFO (\XGETCHARSETINFO FONT CHARSET)) then (CL:WHEN (SETQ CSINFO (\GETCHARSETINFO FONT CHARSET))
(RETURN FONT)) (RETURN FONT))
else (SPREADFONTSPEC FONT) else (SPREADFONTSPEC FONT)
(SETQ FONT (SETQ FONT
@@ -418,7 +421,8 @@
(RETURN FONT]) (RETURN FONT])
(EDITFONT (EDITFONT
[LAMBDA (FONT CHARSET) (* ; "Edited 29-Aug-2025 22:34 by rmk") [LAMBDA (FONT CHARSET) (* ; "Edited 4-Sep-2025 09:27 by rmk")
(* ; "Edited 29-Aug-2025 22:34 by rmk")
(* ; "Edited 17-Aug-2025 12:03 by rmk") (* ; "Edited 17-Aug-2025 12:03 by rmk")
(* ; "Edited 3-Aug-2025 23:25 by rmk") (* ; "Edited 3-Aug-2025 23:25 by rmk")
(* ; "Edited 2-Aug-2025 10:11 by rmk") (* ; "Edited 2-Aug-2025 10:11 by rmk")
@@ -440,7 +444,7 @@
" " " "
(FONTPROP FONT 'SIZE) (FONTPROP FONT 'SIZE)
" " " "
(PACKC (for ATOM in (FONTPROP FONT 'FACE) collect (CHCON1 ATOM))) (FONTFACETOATOM (FONTPROP FONT 'FACE))
" " " "
(OCTALSTRING CHARSET))) (OCTALSTRING CHARSET)))
(PUTMENUPROP MENU 'EDITFONTTITLE TITLE) (PUTMENUPROP MENU 'EDITFONTTITLE TITLE)
@@ -477,10 +481,10 @@
(EF.INIT) (EF.INIT)
(DECLARE%: DONTCOPY (DECLARE%: DONTCOPY
(FILEMAP (NIL (1141 16132 (EF.INIT 1151 . 1785) (EF.PROMPT 1787 . 2369) (EF.MESSAGE 2371 . 2583) ( (FILEMAP (NIL (1110 16314 (EF.INIT 1120 . 1754) (EF.PROMPT 1756 . 2338) (EF.MESSAGE 2340 . 2552) (
EF.CLOSEFN 2585 . 3112) (EF.CHARITEMS 3114 . 4436) (EF.BUTTONEVENTFN 4438 . 4850) (EF.WHENSELECTEDFN EF.CLOSEFN 2554 . 3081) (EF.CHARITEMS 3083 . 4405) (EF.BUTTONEVENTFN 4407 . 4819) (EF.WHENSELECTEDFN
4852 . 5256) (EF.EDITBM 5258 . 6752) (EF.MIDDLEBUTTONFN 6754 . 6999) (EF.CHANGESIZE 7001 . 8330) ( 4821 . 5225) (EF.EDITBM 5227 . 6721) (EF.MIDDLEBUTTONFN 6723 . 6968) (EF.CHANGESIZE 6970 . 8299) (
EF.DELETE 8332 . 9407) (EF.ENTER 9409 . 10350) (EF.REPLACE 10352 . 11325) (EF.SAVE 11327 . 15424) ( EF.DELETE 8301 . 9482) (EF.ENTER 9484 . 10425) (EF.REPLACE 10427 . 11400) (EF.SAVE 11402 . 15606) (
COPYFONT 15426 . 15701) (READSTRIKEFONTFILE 15703 . 16130)) (16133 24751 (BLANKCHARSETCREATE 16143 . COPYFONT 15608 . 15883) (READSTRIKEFONTFILE 15885 . 16312)) (16315 25111 (BLANKCHARSETCREATE 16325 .
22120) (EDITFONT 22122 . 24749))))) 22410) (EDITFONT 22412 . 25109)))))
STOP STOP

BIN
lispusers/EDITFONT.LCOM
View File

Binary file not shown.