-
-
Notifications
You must be signed in to change notification settings - Fork 24
/
Copy pathREADINTERPRESS
210 lines (179 loc) · 11.5 KB
/
READINTERPRESS
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "24-Sep-2023 13:52:48" {WMEDLEY}<lispusers>READINTERPRESS.;6 11350
:EDIT-BY rmk
:CHANGES-TO (FNS SHOWFILE)
:PREVIOUS-DATE "22-Jun-2021 10:52:34" {WMEDLEY}<lispusers>READINTERPRESS.;4)
(* ; "
Copyright (c) 1983-1986, 1988, 2021 by Xerox Corporation.
")
(PRETTYCOMPRINT READINTERPRESSCOMS)
(RPAQQ READINTERPRESSCOMS
[(* "Utilities for reading Interpress files")
(FNS PRINTMASTER)
(FNS OPCODE TOKEN FINDNONPRIMNAME FINDOPNAME SHORTINT TOKENFORMAT FINDSEQUENCETYPE PRINTTOKEN
PRINTSEQUENCE SEARCHIPLIST READINT.IP SHOWFILE SHOWBYTE)
(MACROS BIN.RIP)
(DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP)
INTERPRESS))
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML)
(LAMA SHORTINT TOKEN])
(* "Utilities for reading Interpress files")
(DEFINEQ
(PRINTMASTER
(LAMBDA (FILE OUTPUTFILE FROM TO) (* hdj "15-Jul-86 21:04") (RESETLST (PROG (ISTREAM) (RESETSAVE (SETQ ISTREAM (OPENSTREAM FILE (QUOTE INPUT))) (QUOTE (PROGN (CLOSEF OLDVALUE)))) (if OUTPUTFILE then (RESETSAVE (SETQ OUTPUTFILE (OPENSTREAM OUTPUTFILE (QUOTE OUTPUT))) (QUOTE (PROGN (CLOSEF OLDVALUE) (AND RESETSTATE (DELFILE OLDVALUE)))))) (* Print the encoding string) (bind C until (EQ (SETQ C (BIN ISTREAM)) (CHARCODE SPACE)) do (PRINTCCODE C OUTPUTFILE)) (TERPRI OUTPUTFILE) (SETFILEPTR ISTREAM (IMAX (\GETFILEPTR ISTREAM) (OR FROM 0))) (until (EOFP ISTREAM) do (printout OUTPUTFILE |.I5| (GETFILEPTR ISTREAM) "|" 8) (PRINTTOKEN ISTREAM OUTPUTFILE)))))
)
)
(DEFINEQ
(OPCODE
(LAMBDA (BYTE1 BYTE2) (* rmk%: "19-APR-83 17:51") (FINDOPNAME (IPLUS (LLSH (LOGAND BYTE1 31) 8) (OR BYTE2 0))))
)
(TOKEN
(LAMBDA BYTES (* edited%: "20-APR-83 10:06") (COND ((ZEROP BYTES) NIL) ((NLISTP (ARG BYTES 1)) (APPLY (FUNCTION TOKEN) (ARG BYTES 1))) (T (SELECTQ (TOKENFORMAT (ARG BYTES 1)) (SHORTINT (APPLY (FUNCTION SHORTINT) (for I from 1 to BYTES collect (ARG BYTES I)))) (SHORTOP (FINDOPNAME (LOGAND (ARG BYTES 1) 31))) (LONGOP (FINDOPNAME (IPLUS (LLSH (LOGAND (ARG BYTES 1) 31) 8) (OR (ARG BYTES 2) 0)))) (SHORTSEQUENCE (PROG (LEN (TYPE (FINDSEQUENCETYPE (LOGAND (ARG BYTES 1) 31)))) (COND ((IGREATERP BYTES 0) (SETQ LEN (ARG BYTES 2)))))) (LONGSEQUENCE) (SHOULDNT)))))
)
(FINDNONPRIMNAME
(LAMBDA (CODE) (* rmk%: "15-Mar-84 09:07") (SEARCHIPLIST CODE (CONSTANT NONPRIMS))))
(FINDOPNAME
(LAMBDA (CODE) (* rmk%: "16-Jun-84 15:24") (SEARCHIPLIST CODE (CONSTANT (for OP DOTLOC in OPERATORS collect (* Strip off extension) (COND ((SETQ DOTLOC (STRPOS "." (CAR OP))) (LIST (SUBATOM (CAR OP) 1 (SUB1 DOTLOC)) (CADR OP))) (T OP))))))
)
(SHORTINT
(LAMBDA BYTES (* rmk%: "19-APR-83 17:34") (for I (RESULT _ 0) from 1 to BYTES do (SETQ RESULT (LOGOR (LLSH RESULT 8) (ARG BYTES I))) finally (RETURN (IDIFFERENCE RESULT 4000))))
)
(TOKENFORMAT
(LAMBDA (BYTE) (* rmk%: "19-APR-83 17:41") (SELECTQ (LRSH BYTE 7) (0 (QUOTE SHORTINT)) (SELECT (LOGAND (LRSH BYTE 5) 3) (0 (QUOTE SHORTOP)) (1 (QUOTE LONGOP)) (2 (QUOTE SHORTSEQUENCE)) (3 (QUOTE LONGSEQUENCE)) (SHOULDNT))))
)
(FINDSEQUENCETYPE
(LAMBDA (CODE) (* rmk%: "15-Mar-84 09:04") (for X in (CONSTANT SEQUENCETYPES) when (EQ CODE (CADR X)) do (RETURN (CAR X)) finally (RETURN (LIST CODE (QUOTE NOT-A-SEQUENCE-TYPE)))))
)
(PRINTTOKEN
(LAMBDA (ISTREAM OSTREAM) (* hdj "15-Jul-86 21:55") (PROG (CODE BYTE2 (BYTE1 (BIN.RIP ISTREAM OSTREAM))) (SELECTQ (TOKENFORMAT BYTE1) (SHORTINT (SETQ BYTE2 (BIN.RIP ISTREAM OSTREAM)) (printout OSTREAM .TAB 20) (PRINT (SHORTINT BYTE1 BYTE2) OSTREAM)) (SHORTOP (SETQ CODE (LOGAND BYTE1 31)) (printout OSTREAM .TAB 20) (printout OSTREAM (OR (FINDOPNAME CODE) (FINDNONPRIMNAME CODE) (CONCAT CODE "not an opcode")) T)) (LONGOP (SETQ CODE (IPLUS (LLSH (LOGAND BYTE1 31) 8) (BIN.RIP ISTREAM OSTREAM))) (printout OSTREAM .TAB 20) (printout OSTREAM (OR (FINDOPNAME CODE) (FINDNONPRIMNAME CODE) (CONCAT CODE "not an opcode")) T)) (SHORTSEQUENCE (PRINTSEQUENCE ISTREAM OSTREAM (FINDSEQUENCETYPE (LOGAND BYTE1 31)) (BIN.RIP ISTREAM OSTREAM))) (LONGSEQUENCE (PRINTSEQUENCE ISTREAM OSTREAM (FINDSEQUENCETYPE (LOGAND BYTE1 31)) (LOGOR (LLSH (BIN.RIP ISTREAM OSTREAM) 16) (LLSH (BIN.RIP ISTREAM OSTREAM) 8) (BIN.RIP ISTREAM OSTREAM)))) (SHOULDNT))))
)
(PRINTSEQUENCE
[LAMBDA (ISTREAM OUTSTREAM TYPE LENGTH) (* ; "Edited 22-Jun-2021 10:52 by rmk:")
(DECLARE (SPECVARS LENGTH)) (* ; "For byte counting")
(SELECTQ TYPE
(SEQIDENTIFIER (printout OUTSTREAM 20 "ID: ")
(until (EQ LENGTH 0) do (PRINTCCODE (\INCCODE ISTREAM 'LENGTH LENGTH)
OUTSTREAM)))
(SEQINTEGER (printout OUTSTREAM 20)
(for I from 1 to LENGTH do (PRINTTOKEN ISTREAM OUTSTREAM)))
(SEQRATIONAL (PROG [(NUM (READINT.IP ISTREAM (LRSH LENGTH 1)))
(DENOM (READINT.IP ISTREAM (LRSH LENGTH 1]
(printout OUTSTREAM 20 NUM "/" DENOM " = " (FQUOTIENT NUM DENOM))))
(SEQSTRING (printout OUTSTREAM 20 "STR[" LENGTH "] = %"")
(until (EQ LENGTH 0) do (PRINTCCODE (\INCCODE ISTREAM 'LENGTH LENGTH)
OUTSTREAM))
(printout OUTSTREAM '%"))
(SEQCOMMENT (for I from 1 to LENGTH
first (printout OUTSTREAM 20 "Comment vector of " LENGTH " bytes" 22)
do (printout OUTSTREAM .I4 (BIN ISTREAM))))
(SEQPACKEDPIXELVECTOR
(bind YBYTES (I _ 5)
(XBITS _ (READINT.IP ISTREAM 2))
(YBITS _ (READINT.IP ISTREAM 2))
first (printout OUTSTREAM 20 "Packed pixel" " vector of " LENGTH " bytes [" XBITS
"X" YBITS "]")
(SETQ YBYTES (UNFOLD (FOLDHI YBITS BITSPERWORD)
BYTESPERWORD)) (*
"The number of bytes on a line is always even--gets to a word boundary")
while (ILEQ I LENGTH) do (printout OUTSTREAM T 10)
(for J from 1 to YBYTES
do (printout OUTSTREAM .I8.-2.T (BIN ISTREAM))
(add I 1))))
(SEQLARGEVECTOR
(for I VAL (BYTESPERELT _ (BIN ISTREAM)) from 2 to LENGTH
first (printout OUTSTREAM 20 "Large vector of " BYTESPERELT " bytes per element")
do (SETQ VAL (READINT.IP ISTREAM BYTESPERELT))
(printout OUTSTREAM 22 .I5 I ": " VAL)))
(SEQCONTINUED (HELP "Can't handle SEQCONTINUED yet"))
(SEQINSERTFILE (HELP "Can't handle SEQINSERTFILE yet"))
(SEQCOMPRESSPIXELVECTOR
(HELP "Can't handle SEQCOMPRESSPIXELVECTOR yet"))
(SHOULDNT))
(TERPRI OUTSTREAM])
(SEARCHIPLIST
(LAMBDA (CODE IPLIST) (* rmk%: "15-Mar-84 09:15") (for X in IPLIST when (EQ CODE (CADR X)) do (RETURN (CAR X))))
)
(READINT.IP
(LAMBDA (ISTREAM NBYTES) (* ; "Edited 25-Mar-88 17:50 by bvm") (for I (RESULT _ 0) from 1 to NBYTES do (SETQ RESULT (LOGOR (LLSH RESULT 8) (BIN.RIP ISTREAM))) finally (RETURN (SIGNED RESULT (UNFOLD NBYTES BITSPERBYTE)))))
)
(SHOWFILE
[LAMBDA (IPFILE OUTPUTFILE MAXZEROLINES) (* ; "Edited 24-Sep-2023 13:52 by rmk")
(* rmk%: "16-Jun-84 15:29")
(OR MAXZEROLINES (SETQ MAXZEROLINES 5))
(RESETLST
[PROG (STREAM)
[RESETSAVE (SETQ STREAM (OPENSTREAM IPFILE 'INPUT))
'(PROGN (CLOSEF? OLDVALUE] (* Don't do an OPENSTREAM until
(OPENP stream) is NIL if stream is
closed.)
(RESETSAVE (OUTPUT))
[RESETSAVE (SETQ OUTPUTFILE (OPENSTREAM OUTPUTFILE 'OUTPUT))
'(PROGN (CLOSEF? OLDVALUE)
(AND RESETSTATE (DELFILE OLDVALUE]
(OUTPUT OUTPUTFILE)
(printout NIL .FONT DEFAULTFONT (OPENP STREAM 'INPUT)
T T)
[for I B1 B2 B3 B4 B5 B6 B7 B8 (NZEROLINES _ 0) from 1 by 8 until (\EOFP STREAM)
do (printout NIL .I5 I %,,)
(SETQ B1 (SHOWBYTE STREAM))
(SETQ B2 (SHOWBYTE STREAM))
(SETQ B3 (SHOWBYTE STREAM))
(SETQ B4 (SHOWBYTE STREAM))
(printout NIL %,,)
(SETQ B5 (SHOWBYTE STREAM))
(SETQ B6 (SHOWBYTE STREAM))
(SETQ B7 (SHOWBYTE STREAM))
(SETQ B8 (SHOWBYTE STREAM))
(TAB 23)
(COND
(B1 (printout NIL .I4 B1)))
(COND
(B2 (printout NIL .I4 B2)))
(COND
(B3 (printout NIL .I4 B3)))
(COND
(B4 (printout NIL .I4 B4)))
(printout NIL %,,)
(COND
(B5 (printout NIL .I4 B5)))
(COND
(B6 (printout NIL .I4 B6)))
(COND
(B7 (printout NIL .I4 B7)))
(COND
(B8 (printout NIL .I4 B8 T]
(RETURN (LIST (CLOSEF IPFILE)
(CLOSEF OUTPUTFILE])])
(SHOWBYTE
(LAMBDA (STREAM) (* rmk%: "13-JUL-82 18:01") (PROG ((BYTE (COND ((NOT (\EOFP STREAM)) (\BIN STREAM))))) (COND (BYTE (PRIN1 (COND ((AND (IGEQ BYTE (CHARCODE SPACE)) (ILESSP BYTE (CHARCODE DEL)) (NEQ BYTE 96)) (CHARACTER BYTE)) (T (QUOTE %.)))))) (RETURN BYTE)))
)
)
(DECLARE%: EVAL@COMPILE
(PUTPROPS BIN.RIP MACRO [ARGS (LET ((ISTREAM (CAR ARGS))
(OSTREAM (CADR ARGS)))
`(LET [(C (BIN ,ISTREAM]
(COND
((IGREATERP (POSITION ,OSTREAM)
15)
(printout ,OSTREAM 5 "|" 8)))
(printout ,OSTREAM .I3 C " ")
C])
)
(DECLARE%: EVAL@COMPILE DONTCOPY
(FILESLOAD (LOADCOMP)
INTERPRESS)
)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA SHORTINT TOKEN)
)
(PUTPROPS READINTERPRESS COPYRIGHT ("Xerox Corporation" 1983 1984 1985 1986 1988 2021))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (1158 1844 (PRINTMASTER 1168 . 1842)) (1845 10432 (OPCODE 1855 . 1980) (TOKEN 1982 .
2554) (FINDNONPRIMNAME 2556 . 2661) (FINDOPNAME 2663 . 2920) (SHORTINT 2922 . 3115) (TOKENFORMAT 3117
. 3359) (FINDSEQUENCETYPE 3361 . 3565) (PRINTTOKEN 3567 . 4518) (PRINTSEQUENCE 4520 . 7397) (
SEARCHIPLIST 7399 . 7531) (READINT.IP 7533 . 7772) (SHOWFILE 7774 . 10152) (SHOWBYTE 10154 . 10430))))
)
STOP