(FILECREATED "10-Feb-86 17:03:40" {DSK}<LISPFILES2>PRIM.;1
 4364   

      changes to:  (VARS PRIMCOMS)

      previous date: " 7-Feb-86 00:11:40" {DSK}<LISPFILES2>PRIM.;1)


(* Copyright (c) 1986 by Quintus Computer Systems, Inc. All rights reserved.)

(PRETTYCOMPRINT PRIMCOMS)

(RPAQQ PRIMCOMS
 ((VARS (BYTE.BUFFER.LENGTH 0)
			 (BYTE.BUFFER (ALLOCSTRING 4096)))
	(ADDVARS (GLOBALVARS BYTE.BUFFER.LENGTH)
		 (GLOBALVARS BYTE.BUFFER))
	(FNS QP.ATOM.NUMBER QP.CHARS.FROM.BYTE.BUFFER QP.CLAUSE.ALLOC QP.CLEAR.BYTE.BUFFER 
	     QP.FLOAT.FROM.BYTE.BUFFER QP.FLOAT.TO.BYTE.BUFFER QP.FLOAT.TO.STRING QP.INSTR.FIELDS 
	     QP.INTERN.SYMBOL QP.LEFT.OP.CODE QP.LOAD.GC.PROTECT QP.P.TOKEN.TYPE QP.PUT.BYTE 
	     QP.RAW.FREE.SPACE QP.SYMBOL.CHAR QP.SYMBOL.COMPARE QP.SYMBOL.LENGTH 
	     QP.SYMBOL.TO.BYTE.BUFFER)))

(RPAQQ BYTE.BUFFER.LENGTH
 0)

(RPAQ BYTE.BUFFER
 (ALLOCSTRING 4096))

(ADDTOVAR GLOBALVARS
 BYTE.BUFFER.LENGTH)

(ADDTOVAR GLOBALVARS
 BYTE.BUFFER)
(DEFINEQ

(QP.ATOM.NUMBER

  (LAMBDA (
ATOM
)
    (
\LOLOC
 ATOM)))

(QP.CHARS.FROM.BYTE.BUFFER

  (LAMBDA NIL
    (FOR
 I FROM
 1 TO
 BYTE.BUFFER.LENGTH COLLECT
 (
NTHCHARCODE
 BYTE.BUFFER I))))

(QP.CLAUSE.ALLOC

  (LAMBDA (
LENGTH
)
    (LET* ((
ARRAY
 (
ARRAY
 LENGTH (
QUOTE
 WORD)))
	   (
BLOCK
 (
\GETBASEPTR
 ARRAY 0)))
          (QP.LOAD.GC.PROTECT
 ARRAY)
      BLOCK)))

(QP.CLEAR.BYTE.BUFFER

  (LAMBDA NIL
    (
SETQ
 BYTE.BUFFER.LENGTH 0)))

(QP.FLOAT.FROM.BYTE.BUFFER

  (LAMBDA NIL
    (LET* ((STR (
OPENSTRINGSTREAM
 (
SUBSTRING
 BYTE.BUFFER 1 BYTE.BUFFER.LENGTH)
				    (
QUOTE
 INPUT)))
	   (OBJ (
READ
 STR)))
          (
COND

	    ((
FLOATP
 OBJ)
	      OBJ)
	    (T (
PACK
))))))

(QP.FLOAT.TO.BYTE.BUFFER

  (LAMBDA (
FLOAT
)
    (
COND

      ((
FLOATP
 FLOAT)
	(
SETQ
 BYTE.BUFFER.LENGTH (
IDIFFERENCE
 (QP.FLOAT.TO.STRING
 FLOAT BYTE.BUFFER)
						  1)))
      (T (
SETQ
 BYTE.BUFFER.LENGTH 0)))))

(QP.FLOAT.TO.STRING

  (LAMBDA (
FLOAT
 STRING)
    (LET ((OLDFORMAT (
FLTFMT
))
	  (STREAM (
OPENSTRINGSTREAM
 QP.SCRATCH.STRING (
QUOTE
 OUTPUT))))
         (
FLTFMT
 T)
         (
PRINT
 FLOAT STREAM)
         (
CLOSEF
 STREAM)
         (
FLTFMT
 OLDFORMAT))
    (LET* ((POS (
STRPOS
 (
QUOTE
 %
)
			  QP.SCRATCH.STRING 1))
	   (SCRATCH (
SUBSTRING
 QP.SCRATCH.STRING 1 POS)))
          (IF
 (
EQ
 (
NTHCHARCODE
 SCRATCH 1)
		      46)
	      THEN
 (
RPLCHARCODE
 STRING 1 48)
		     (
RPLSTRING
 STRING 2 SCRATCH)
		     (
ADD1
 POS)
	    ELSE
 (
RPLSTRING
 STRING 1 SCRATCH)
		   POS))))

(QP.INSTR.FIELDS

  (LAMBDA (INSTRUCTION)
    (
CDR
 (
GETHASH
 (
GETHASH
 INSTRUCTION QP.INSTRUCTION.HARRAY)
		      QP.INSTRUCTION.HARRAY))))

(QP.INTERN.SYMBOL

  (LAMBDA NIL
    (
COND

      ((
EQ
 BYTE.BUFFER.LENGTH 0)
	QP.NULL.ATOM)
      (T (
SUBATOM
 BYTE.BUFFER 1 BYTE.BUFFER.LENGTH)))))

(QP.LEFT.OP.CODE

  (LAMBDA (INSTRUCTION)
    (
SETQ
 INSTRUCTION (
QP.OP.CODE
 INSTRUCTION))
    (
COND

      ((
GEQ
 INSTRUCTION 256)
	INSTRUCTION)
      (T (
LLSH
 INSTRUCTION 8)))))

(QP.LOAD.GC.PROTECT

  (LAMBDA (CELL)
    (\ADDREF CELL)))

(QP.P.TOKEN.TYPE

  (LAMBDA (
ATOM
)
    (LET ((
CHAR
 (
NTHCHARCODE
 ATOM -1)))
         (IF
 (
NULL
 CHAR)
	     THEN
 1
	   ELSE
 (
SELECTQ
 (QP.CHARTYPE CHAR)
			     ((small←letter
				 capital←letter
				 digit underbar)
			       1)
			     (agglutinating 2)
			     3)))))

(QP.PUT.BYTE

  (LAMBDA (
CHAR
)
    (
SETQ
 BYTE.BUFFER.LENGTH (
IPLUS
 BYTE.BUFFER.LENGTH 1))
    (
RPLCHARCODE
 BYTE.BUFFER BYTE.BUFFER.LENGTH CHAR)
    T))

(QP.RAW.FREE.SPACE

  (LAMBDA (IGNORE CELL)
    (\DELREF CELL)))

(QP.SYMBOL.CHAR

  (LAMBDA (INDEX SYMBOL)
    (
NTHCHARCODE
 SYMBOL INDEX)))

(QP.SYMBOL.COMPARE

  (LAMBDA (SYMBOL1 SYMBOL2)
    (
COND

      ((
EQ
 SYMBOL1 SYMBOL2)
	0)
      ((
ALPHORDER
 SYMBOL1 SYMBOL2)
	-1)
      (T 1))))

(QP.SYMBOL.LENGTH

  (LAMBDA (SYMBOL)
    (
NCHARS
 SYMBOL)))

(QP.SYMBOL.TO.BYTE.BUFFER

  (LAMBDA (SYMBOL)
    (
RPLSTRING
 BYTE.BUFFER (
ADD1
 BYTE.BUFFER.LENGTH)
		 SYMBOL)
    (
SETQ
 BYTE.BUFFER.LENGTH (
IPLUS
 BYTE.BUFFER.LENGTH (
NCHARS
 SYMBOL)))))
)
(PUTPROPS PRIM COPYRIGHT ("Quintus Computer Systems, Inc" 1986))
(DECLARE: DONTCOPY
  (FILEMAP (NIL (980 4277 (QP.ATOM.NUMBER 990 . 1054) (QP.CHARS.FROM.BYTE.BUFFER 1056 . 1199) (
QP.CLAUSE.ALLOC 1201 . 1402) (QP.CLEAR.BYTE.BUFFER 1404 . 1481) (QP.FLOAT.FROM.BYTE.BUFFER 1483 . 1747
) (QP.FLOAT.TO.BYTE.BUFFER 1749 . 1987) (QP.FLOAT.TO.STRING 1989 . 2628) (QP.INSTR.FIELDS 2630 . 2782)
 (QP.INTERN.SYMBOL 2784 . 2945) (QP.LEFT.OP.CODE 2947 . 3146) (QP.LOAD.GC.PROTECT 3148 . 3209) (
QP.P.TOKEN.TYPE 3211 . 3513) (QP.PUT.BYTE 3515 . 3685) (QP.RAW.FREE.SPACE 3687 . 3754) (QP.SYMBOL.CHAR
 3756 . 3837) (QP.SYMBOL.COMPARE 3839 . 3998) (QP.SYMBOL.LENGTH 4000 . 4066) (QP.SYMBOL.TO.BYTE.BUFFER
 4068 . 4275)))))
STOP