(FILECREATED "15-Jul-86 21:58:05" {ERIS}<LISPCORE>INTERPRESS>READINTERPRESS.;5 13701
changes to: (FNS PRINTTOKEN PRINTSEQUENCE TOKENFORMAT PRINTMASTER SHORTINT OPCODE)
(MACROS BIN.RIP)
(FILEVARS READINTERPRESSCOMS)
previous date: "28-Mar-85 17:08:33" {ERIS}<LISPCORE>INTERPRESS>READINTERPRESS.;1)
(* Copyright (c) 1983, 1984, 1985, 1986 by Xerox Corporation. All rights reserved.)
(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) (* hdj "15-Jul-86 21:43")
(SELECTQ TYPE
(SEQIDENTIFIER (printout OUTSTREAM 20 "ID: ")
(CHARSET ISTREAM 0)
(bind (CHARSET ← 0) until (EQ LENGTH 0)
do (PRINTCCODE (\NSIN ISTREAM CHARSET CHARSET 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 "] = %"")
(CHARSET ISTREAM 0)
(bind (CHARSET ← 0) until (EQ LENGTH 0)
do (PRINTCCODE (\NSIN ISTREAM CHARSET CHARSET LENGTH)
OUTSTREAM))
(printout OUTSTREAM (QUOTE %")))
(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) (* rmk: "11-JUN-83 20:37")
(for I (RESULT ← 0) from 1 to NBYTES do (SETQ RESULT (LOGOR (LLSH RESULT 8)
(BIN.RIP)))
finally (RETURN (SIGNED RESULT (UNFOLD NBYTES BITSPERBYTE])
(SHOWFILE
[LAMBDA (IPFILE OUTPUTFILE MAXZEROLINES) (* rmk: "16-Jun-84 15:29")
(OR MAXZEROLINES (SETQ MAXZEROLINES 5))
(RESETLST (PROG (STREAM)
[RESETSAVE (SETQ STREAM (OPENFILE IPFILE (QUOTE INPUT)))
(QUOTE (PROGN (CLOSEF? OLDVALUE]
(SETQ STREAM (GETSTREAM STREAM)) (* Don't do an OPENSTREAM until
(OPENP stream) is NIL if stream is closed.)
(RESETSAVE (OUTPUT))
[RESETSAVE (SETQ OUTPUTFILE (OPENFILE OUTPUTFILE (QUOTE OUTPUT)))
(QUOTE (PROGN (CLOSEF? OLDVALUE)
(AND RESETSTATE (DELFILE OLDVALUE]
(OUTPUT OUTPUTFILE)
(printout NIL .FONT DEFAULTFONT (OPENP STREAM (QUOTE 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)))
(BQUOTE (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))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1352 2597 (PRINTMASTER 1362 . 2595)) (2598 12671 (OPCODE 2608 . 2835) (TOKEN 2837 .
3625) (FINDNONPRIMNAME 3627 . 3787) (FINDOPNAME 3789 . 4215) (SHORTINT 4217 . 4554) (TOKENFORMAT 4556
. 4965) (FINDSEQUENCETYPE 4967 . 5246) (PRINTTOKEN 5248 . 7119) (PRINTSEQUENCE 7121 . 10095) (
SEARCHIPLIST 10097 . 10287) (READINT.IP 10289 . 10583) (SHOWFILE 10585 . 12285) (SHOWBYTE 12287 .
12669)))))
STOP