Compare commits
3 Commits
HDJ-BROKEN
...
rmk172--Cl
| Author | SHA1 | Date | |
|---|---|---|---|
|
0aef7f4e51 | ||
|
6504bfde6b | ||
|
|
96b131ee2c |
@@ -1,187 +0,0 @@
|
||||
(DEFINE-FILE-INFO :PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10)
|
||||
|
||||
(FILECREATED "14-Apr-2026 12:14:44" {PROJECTS}<BROKENATOMS>BROKEN-ATOMS.;10 7207
|
||||
|
||||
:CHANGES-TO (FUNCTIONS WITHOUT-BROKEN-ATOMS TEST-PRETTY-FILE TEST-DEEP-COMPUTATION
|
||||
CURE-BROKEN-ATOM)
|
||||
(VARS BROKEN-ATOMSCOMS)
|
||||
|
||||
:PREVIOUS-DATE "18-Feb-2026 16:08:40" {PROJECTS}<BROKENATOMS>BROKEN-ATOMS.;3)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT BROKEN-ATOMSCOMS)
|
||||
|
||||
(RPAQQ BROKEN-ATOMSCOMS
|
||||
(
|
||||
(* ;; "the representation of a broken atom")
|
||||
|
||||
(RECORDS BROKEN-ATOM)
|
||||
(FUNCTIONS CURE-BROKEN-ATOM)
|
||||
|
||||
(* ;; "for DEFPRINT")
|
||||
|
||||
(FNS BROKEN-ATOM-PRINTER)
|
||||
|
||||
(* ;; "special form")
|
||||
|
||||
(FUNCTIONS WITHOUT-BROKEN-ATOMS)
|
||||
|
||||
(* ;; "setup")
|
||||
|
||||
(P (DEFPRINT 'BROKEN-ATOM 'BROKEN-ATOM-PRINTER))
|
||||
|
||||
(* ;; "Debugging/testing")
|
||||
|
||||
(FUNCTIONS TEST-INTERNAL-BA TEST-EXTERNAL-BA TEST-DEEP-COMPUTATION TEST-PRETTY-FILE)))
|
||||
|
||||
|
||||
|
||||
(* ;; "the representation of a broken atom")
|
||||
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(DATATYPE BROKEN-ATOM ((PACKAGE POINTER)
|
||||
(NAME POINTER)
|
||||
(EXTERNAL FLAG)))
|
||||
)
|
||||
|
||||
(/DECLAREDATATYPE 'BROKEN-ATOM '(POINTER POINTER FLAG)
|
||||
'((BROKEN-ATOM 0 POINTER)
|
||||
(BROKEN-ATOM 2 POINTER)
|
||||
(BROKEN-ATOM 2 (FLAGBITS . 0)))
|
||||
'4)
|
||||
|
||||
(CL:DEFUN CURE-BROKEN-ATOM (CONDITION)
|
||||
"Given an XCL:MISSING-EXTERNAL-SYMBOL condition, return a corresponding BROKEN-ATOM"
|
||||
(COND
|
||||
((TYPEP CONDITION 'XCL:MISSING-PACKAGE) (* ; "no such package ")
|
||||
(create BROKEN-ATOM
|
||||
PACKAGE _ (XCL:MISSING-PACKAGE-PACKAGE-NAME CONDITION)
|
||||
NAME _ (XCL:MISSING-PACKAGE-SYMBOL-NAME CONDITION)
|
||||
EXTERNAL _ (XCL:MISSING-PACKAGE-EXTERNAL CONDITION)))
|
||||
((TYPEP CONDITION 'XCL:MISSING-EXTERNAL-SYMBOL) (* ;
|
||||
"package exists, no such external symbol")
|
||||
(create BROKEN-ATOM
|
||||
PACKAGE _ (CL:PACKAGE-NAME (XCL:MISSING-EXTERNAL-SYMBOL-PACKAGE CONDITION))
|
||||
NAME _ (XCL:MISSING-EXTERNAL-SYMBOL-NAME CONDITION)
|
||||
EXTERNAL _ NIL))
|
||||
(T (HELP "Don't know how to cure" CONDITION))))
|
||||
|
||||
|
||||
|
||||
(* ;; "for DEFPRINT")
|
||||
|
||||
(DEFINEQ
|
||||
|
||||
(BROKEN-ATOM-PRINTER
|
||||
[LAMBDA (BROKEN-ATOM STREAM)
|
||||
(CONS (CONCAT (fetch (BROKEN-ATOM PACKAGE) of BROKEN-ATOM)
|
||||
(if (fetch (BROKEN-ATOM EXTERNAL) of BROKEN-ATOM)
|
||||
then ":"
|
||||
else "::")
|
||||
(fetch (BROKEN-ATOM NAME) of BROKEN-ATOM])
|
||||
)
|
||||
|
||||
|
||||
|
||||
(* ;; "special form")
|
||||
|
||||
|
||||
(DEFMACRO WITHOUT-BROKEN-ATOMS (&BODY FORMS)
|
||||
"Handle any broken-atom errors by producing a BROKEN-ATOM that prints as if the original atom were intact"
|
||||
`[HANDLER-BIND [[XCL:MISSING-PACKAGE #'(CL:LAMBDA (C)
|
||||
(CONDITIONS:INVOKE-RESTART
|
||||
'CREATE-MISSING-PACKAGE-BA (CURE-BROKEN-ATOM
|
||||
C]
|
||||
(XCL:MISSING-EXTERNAL-SYMBOL #'(CL:LAMBDA (C)
|
||||
(CONDITIONS:INVOKE-RESTART
|
||||
'CREATE-EXTERNAL-BA (CURE-BROKEN-ATOM
|
||||
C]
|
||||
(CONDITIONS:RESTART-BIND [(CREATE-MISSING-PACKAGE-BA
|
||||
#'(CL:LAMBDA (V)
|
||||
(RETFROM (FUNCTION RESOLVE-MISSING-PACKAGE)
|
||||
V)
|
||||
V))
|
||||
(CREATE-EXTERNAL-BA #'(CL:LAMBDA (V)
|
||||
(RETFROM (FUNCTION
|
||||
RESOLVE-MISSING-EXTERNAL-SYMBOL
|
||||
)
|
||||
V)
|
||||
V]
|
||||
(PROGN ,@FORMS])
|
||||
|
||||
|
||||
|
||||
(* ;; "setup")
|
||||
|
||||
|
||||
(DEFPRINT 'BROKEN-ATOM 'BROKEN-ATOM-PRINTER)
|
||||
|
||||
|
||||
|
||||
(* ;; "Debugging/testing")
|
||||
|
||||
|
||||
(CL:DEFUN TEST-INTERNAL-BA ()
|
||||
[LET ((FILE NIL))
|
||||
(CL:WITH-OPEN-STREAM (OUT (OPENSTREAM "{nodircore}" 'OUTPUT))
|
||||
(SETQ FILE OUT)
|
||||
(PRINTOUT OUT "BROKEN::INTERNAL-ATOM" T))
|
||||
(CL:WITH-OPEN-STREAM (IN (OPENSTREAM FILE 'INPUT))
|
||||
(WITHOUT-BROKEN-ATOMS (RATOM IN])
|
||||
|
||||
(CL:DEFUN TEST-EXTERNAL-BA ()
|
||||
[LET ((FILE NIL))
|
||||
(CL:WITH-OPEN-STREAM (OUT (OPENSTREAM "{nodircore}" 'OUTPUT))
|
||||
(SETQ FILE OUT)
|
||||
(PRINTOUT OUT "BROKEN:EXTERNAL-ATOM" T))
|
||||
(CL:WITH-OPEN-STREAM (IN (OPENSTREAM FILE 'INPUT))
|
||||
(WITHOUT-BROKEN-ATOMS (RATOM IN])
|
||||
|
||||
(CL:DEFUN TEST-DEEP-COMPUTATION ()
|
||||
"Test that we can handle internal calls to READ that encounter broken atoms"
|
||||
|
||||
(* ;; "make sure it works when there's no error")
|
||||
|
||||
(LET [(RESULT (WITHOUT-BROKEN-ATOMS (CL:LOOP :FOR X :FROM 0 :TO 9 :COLLECT X]
|
||||
(PRINTOUT T "No error loop result: " RESULT T))
|
||||
|
||||
(* ;; "and when reading legit atoms")
|
||||
|
||||
(LET [(RESULT (WITHOUT-BROKEN-ATOMS (CL:LOOP :FOR X :FROM 0 :TO 9 :COLLECT (CL:READ-FROM-STRING
|
||||
(CONCAT "IL:ATOM" X]
|
||||
(PRINTOUT T "No error read loop result: " RESULT T))
|
||||
|
||||
(* ;; "test XCL:MISSING-PACKAGE.")
|
||||
|
||||
(COND
|
||||
((CL:FIND-PACKAGE :BROKEN)
|
||||
(DELETE-PACKAGE :BROKEN)))
|
||||
(LET [(RESULT (WITHOUT-BROKEN-ATOMS (CL:LOOP :FOR X :FROM 0 :TO 9 :COLLECT (CL:READ-FROM-STRING
|
||||
(CONCAT "BROKEN:ATOM"
|
||||
X]
|
||||
(PRINTOUT T "No such package loop result: " RESULT T))
|
||||
|
||||
(* ;; "test XCL:MISSING-EXTERNAL-SYMBOL")
|
||||
|
||||
(CL:UNWIND-PROTECT
|
||||
(PROGN (CL:MAKE-PACKAGE :BROKEN)
|
||||
(LET [(RESULT (WITHOUT-BROKEN-ATOMS (CL:LOOP :FOR X :FROM 0 :TO 9 :COLLECT
|
||||
(CL:READ-FROM-STRING (CONCAT "BROKEN:ATOM" X
|
||||
]
|
||||
(PRINTOUT T "Not external symbol loop result: " RESULT T)))
|
||||
[COND
|
||||
((CL:FIND-PACKAGE :BROKEN)
|
||||
(DELETE-PACKAGE 'BROKEN]))
|
||||
|
||||
(CL:DEFUN TEST-PRETTY-FILE (SOURCE-FILE-NAME OUTPUT-FILE-NAME OUTPUT-TYPE)
|
||||
"Prettyprint a Lisp source file to an imagestream file"
|
||||
(CL:WITH-OPEN-STREAM (OUTPUT-STREAM (OPENIMAGESTREAM OUTPUT-FILE-NAME OUTPUT-TYPE))
|
||||
(WITHOUT-BROKEN-ATOMS (PRETTYFILEINDEX SOURCE-FILE-NAME NIL OUTPUT-STREAM T))
|
||||
(FULLNAME OUTPUT-STREAM)))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (1403 2315 (CURE-BROKEN-ATOM 1403 . 2315)) (2346 2699 (BROKEN-ATOM-PRINTER 2356 . 2697))
|
||||
(2731 4397 (WITHOUT-BROKEN-ATOMS 2731 . 4397)) (4503 4831 (TEST-INTERNAL-BA 4503 . 4831)) (4833 5160
|
||||
(TEST-EXTERNAL-BA 4833 . 5160)) (5162 6829 (TEST-DEEP-COMPUTATION 5162 . 6829)) (6831 7184 (
|
||||
TEST-PRETTY-FILE 6831 . 7184)))))
|
||||
STOP
|
||||
Binary file not shown.
Binary file not shown.
@@ -1,13 +1,13 @@
|
||||
(DEFINE-FILE-INFO :PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10)
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "16-Mar-2026 23:19:02" {WMEDLEY}<lispusers>EDITFONT.;42 26474
|
||||
(FILECREATED "12-Oct-2025 17:39:29" {WMEDLEY}<lispusers>EDITFONT.;41 26261
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (FNS EDITFONT)
|
||||
(RECORDS CHARITEM)
|
||||
:CHANGES-TO (RECORDS CHARITEM)
|
||||
(FNS EF.SAVE)
|
||||
|
||||
:PREVIOUS-DATE "12-Oct-2025 17:39:29" {WMEDLEY}<lispusers>EDITFONT.;41)
|
||||
:PREVIOUS-DATE " 7-Oct-2025 14:56:00" {WMEDLEY}<lispusers>EDITFONT.;40)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT EDITFONTCOMS)
|
||||
@@ -429,8 +429,7 @@
|
||||
(RETURN FONT])
|
||||
|
||||
(EDITFONT
|
||||
[LAMBDA (FONT CHARSET ROWMAJOR NCOLUMNS TITLETAG) (* ; "Edited 16-Mar-2026 23:17 by rmk")
|
||||
(* ; "Edited 7-Oct-2025 14:55 by rmk")
|
||||
[LAMBDA (FONT CHARSET ROWMAJOR NCOLUMNS TITLETAG) (* ; "Edited 7-Oct-2025 14:55 by rmk")
|
||||
(* ; "Edited 5-Oct-2025 15:06 by rmk")
|
||||
(* ; "Edited 4-Sep-2025 09:27 by rmk")
|
||||
(* ; "Edited 29-Aug-2025 22:34 by rmk")
|
||||
@@ -441,8 +440,6 @@
|
||||
(* kbr%: "21-Oct-85 15:35")
|
||||
(* kbr%: "21-Oct-85 15:35")
|
||||
(SETQ FONT (FONTCREATE FONT))
|
||||
(CL:UNLESS (EQ 'DISPLAY (FONTPROP FONT 'DEVICE))
|
||||
(ERROR FONT " is not a display font"))
|
||||
(SETQ CHARSET (OR (CHARSET.DECODE CHARSET)
|
||||
0))
|
||||
(LET (CHARITEMS MENU TITLE HEIGHT WIDTH REGION POS WINDOW)
|
||||
@@ -497,10 +494,10 @@
|
||||
|
||||
(EF.INIT)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (1147 16904 (EF.INIT 1157 . 1791) (EF.PROMPT 1793 . 2375) (EF.MESSAGE 2377 . 2589) (
|
||||
EF.CLOSEFN 2591 . 3118) (EF.CHARITEMS 3120 . 4956) (EF.BUTTONEVENTFN 4958 . 5370) (EF.WHENSELECTEDFN
|
||||
5372 . 5776) (EF.EDITBM 5778 . 7272) (EF.MIDDLEBUTTONFN 7274 . 7519) (EF.CHANGESIZE 7521 . 8850) (
|
||||
EF.DELETE 8852 . 10033) (EF.ENTER 10035 . 10976) (EF.REPLACE 10978 . 11951) (EF.SAVE 11953 . 16196) (
|
||||
COPYFONT 16198 . 16473) (READSTRIKEFONTFILE 16475 . 16902)) (16905 26286 (BLANKCHARSETCREATE 16915 .
|
||||
23000) (EDITFONT 23002 . 26284)))))
|
||||
(FILEMAP (NIL (1146 16903 (EF.INIT 1156 . 1790) (EF.PROMPT 1792 . 2374) (EF.MESSAGE 2376 . 2588) (
|
||||
EF.CLOSEFN 2590 . 3117) (EF.CHARITEMS 3119 . 4955) (EF.BUTTONEVENTFN 4957 . 5369) (EF.WHENSELECTEDFN
|
||||
5371 . 5775) (EF.EDITBM 5777 . 7271) (EF.MIDDLEBUTTONFN 7273 . 7518) (EF.CHANGESIZE 7520 . 8849) (
|
||||
EF.DELETE 8851 . 10032) (EF.ENTER 10034 . 10975) (EF.REPLACE 10977 . 11950) (EF.SAVE 11952 . 16195) (
|
||||
COPYFONT 16197 . 16472) (READSTRIKEFONTFILE 16474 . 16901)) (16904 26073 (BLANKCHARSETCREATE 16914 .
|
||||
22999) (EDITFONT 23001 . 26071)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
Reference in New Issue
Block a user