(FILECREATED " 8-Feb-86 15:12:56" {DSK}<LISPFILES2>IMPROVEDDCOMS>PRIM.;1 3572
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.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.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 (894 3485 (QP.ATOM.NUMBER 904 . 954) (QP.CHARS.FROM.BYTE.BUFFER 956 . 1073) (
QP.CLAUSE.ALLOC 1075 . 1223) (QP.CLEAR.BYTE.BUFFER 1225 . 1292) (QP.FLOAT.FROM.BYTE.BUFFER 1294 . 1486
) (QP.FLOAT.TO.BYTE.BUFFER 1488 . 1672) (QP.FLOAT.TO.STRING 1674 . 2164) (QP.INSTR.FIELDS 2166 . 2293)
(QP.INTERN.SYMBOL 2295 . 2426) (QP.LEFT.OP.CODE 2428 . 2585) (QP.LOAD.GC.PROTECT 2587 . 2642) (
QP.P.TOKEN.TYPE 2644 . 2846) (QP.PUT.BYTE 2848 . 2989) (QP.RAW.FREE.SPACE 2991 . 3052) (QP.SYMBOL.CHAR
3054 . 3125) (QP.SYMBOL.COMPARE 3127 . 3248) (QP.SYMBOL.LENGTH 3250 . 3306) (QP.SYMBOL.TO.BYTE.BUFFER
3308 . 3483)))))
STOP