(FILECREATED " 2-Feb-86 18:50:49" {DSK}<LISPFILES2>PRIM.LSP;2
 4472   

      changes to:  (VARS PRIMCOMS))


(* 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.HALT 
	     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.OUT)
    (LET ((STR (
OPENSTRINGSTREAM
 QP.SCRATCH.STRING (
QUOTE
 OUTPUT)))
	  (OLDFORMAT (
FLTFMT
))
	  (SCRATCH2))
         (
FLTFMT
 T)
         (
PRINT
 FLOAT STR)
         (
CLOSEF
 STR)
         (
FLTFMT
 OLDFORMAT)
         (
SETQ
 SCRATCH2 (
SUBSTRING
 QP.SCRATCH.STRING 1 (
SETQ
 POSIT (
STRPOS
 (
QUOTE
 %
)
										   QP.SCRATCH.STRING 
										   1))))
         (
COND

	   ((
EQUAL
 46 (
NTHCHARCODE
 QP.SCRATCH.STRING 1))
	     (
RPLCHARCODE
 STRING.OUT 1 48)
	     (
RPLSTRING
 STRING.OUT 2 SCRATCH2)
	     (
ADD1
 POSIT))
	   (T (
RPLSTRING
 STRING.OUT 1 SCRATCH2)
	      POSIT)))))

(QP.HALT

  (LAMBDA (X)
    (
RETFROM
 (
QUOTE
 PROLOG)
	       X)))

(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 (
MKATOM
 (
SUBSTRING
 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
)
    (
COND

      ((
EQ
 (
NCHARS
 ATOM)
	     0)
	1)
      (T (LET ((LASTCHAR (
NTHCHARCODE
 ATOM (
NCHARS
 ATOM))))
	      (
SELECTQ
 (QP.CHARTYPE LASTCHAR)
			 ((small←letter
			     capital←letter
			     digit underbar)
			   1)
			 (agglutinating 2)
			 3))))))

(QP.PUT.BYTE

  (LAMBDA (CHAR)
    (
SETQ
 BYTE.BUFFER.LENGTH (
ADD1
 BYTE.BUFFER.LENGTH))
    (
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

      ((
EQUAL
 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.LSP COPYRIGHT ("Quintus Computer Systems, Inc" 1986))
(DECLARE: DONTCOPY
  (FILEMAP (NIL (923 4381 (QP.ATOM.NUMBER 933 . 997) (QP.CHARS.FROM.BYTE.BUFFER 999 . 1142) (
QP.CLAUSE.ALLOC 1144 . 1345) (QP.CLEAR.BYTE.BUFFER 1347 . 1424) (QP.FLOAT.FROM.BYTE.BUFFER 1426 . 1690
) (QP.FLOAT.TO.BYTE.BUFFER 1692 . 1930) (QP.FLOAT.TO.STRING 1932 . 2625) (QP.HALT 2627 . 2702) (
QP.INSTR.FIELDS 2704 . 2856) (QP.INTERN.SYMBOL 2858 . 3034) (QP.LEFT.OP.CODE 3036 . 3235) (
QP.LOAD.GC.PROTECT 3237 . 3298) (QP.P.TOKEN.TYPE 3300 . 3621) (QP.PUT.BYTE 3623 . 3786) (
QP.RAW.FREE.SPACE 3788 . 3855) (QP.SYMBOL.CHAR 3857 . 3938) (QP.SYMBOL.COMPARE 3940 . 4102) (
QP.SYMBOL.LENGTH 4104 . 4170) (QP.SYMBOL.TO.BYTE.BUFFER 4172 . 4379)))))
STOP