(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