File [eris]<PrologCore>QP1.5>Sources>SECURE!1

(FILECREATED " 8-Feb-86 15:28:06" {DSK}<LISPFILES2>IMPROVEDDCOMS>SECURE.;1 7858   

      previous date: " 3-Feb-86 16:55:50" {GOEDEL}<usr2/pds/updating/lisp>SECURE)


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

(PRETTYCOMPRINT SECURECOMS)

(RPAQQ SECURECOMS ((SCCS) (DECLARE: EVAL@LOAD DONTCOPY (MACROS FLOADBYTE QP.DATE.INTEGER16 
QP.HASH.UNHASH QP.MAKE.VERIFICATION QP.OK.DATE QP.OK.OPTIONS QP.VERIFY)) (CONSTANTS 
QP.GOLDEN.RATIO.HACK) (INITVARS QP.CODE.CACHE) (GLOBALVARS QP.CODE.CACHE PROLOGROOTDIRECTORY) (FNS 
BIGNUM-TO-FIXP FIXP-TO-BIGNUM QP.32BITIPLUS QP.32BITITIMES QP.64BITIMOD QP.OK QP.READ.HEX QP.SECURE 
QP.SKIP.BLANKS QP.STILL.OK)))
(* %%G%  %%W% )
(DECLARE: EVAL@LOAD DONTCOPY 
(DECLARE: EVAL@COMPILE 
(PUTPROPS FLOADBYTE MACRO ((N POS SIZE) (LOGAND (LRSH N POS) (MASK.1'S 0 SIZE))))
(PUTPROPS QP.DATE.INTEGER16 MACRO ((GDATE) (IQUOTIENT (IDIFFERENCE (IDATE GDATE) (CONSTANT (IMOD (
IDATE " 1-JAN-80 00:00:00") (IDIFFERENCE (IDATE " 2-JAN-80 00:00:00") (IDATE " 1-JAN-80 00:00:00")))))
 (CONSTANT (IDIFFERENCE (IDATE " 2-JAN-80 00:00:00") (IDATE " 1-JAN-80 00:00:00"))))))
(PUTPROPS QP.HASH.UNHASH MACRO ((NUMBER HASHKEY) (PROGN (* * This implements hashing by multiplying by
 the golden ratio, taking the fractional part, and then multiplying by 2**32. The hack used to make 
this work is to multiply by the fractional part of the golden ratio * 2**32, and take the low order 32
 bits.) (LOGXOR NUMBER (QP.32BITIPLUS (QP.32BITITIMES (FLOADBYTE HASHKEY 16 16) QP.GOLDEN.RATIO.HACK) 
(QP.32BITITIMES (FLOADBYTE HASHKEY 0 16) QP.GOLDEN.RATIO.HACK))))))
(PUTPROPS QP.MAKE.VERIFICATION MACRO ((X Y) (LET ((1ST X) (2ND Y)) (LOGOR (QP.64BITIMOD 1ST 2ND 5 (
CONSTANT (IREMAINDER (EXPT 2 32) 5))) (LLSH (QP.64BITIMOD 1ST 2ND 7 (CONSTANT (IREMAINDER (EXPT 2 32) 
7))) 3) (LLSH (QP.64BITIMOD 1ST 2ND 13 (CONSTANT (IREMAINDER (EXPT 2 32) 13))) 6) (LLSH (QP.64BITIMOD 
1ST 2ND 23 (CONSTANT (IREMAINDER (EXPT 2 32) 23))) 10) (LLSH (QP.64BITIMOD 1ST 2ND 29 (CONSTANT (
IREMAINDER (EXPT 2 32) 29))) 15) (LLSH (QP.64BITIMOD 1ST 2ND 61 (CONSTANT (IREMAINDER (EXPT 2 32) 61))
) 20) (LLSH (QP.64BITIMOD 1ST 2ND 59 (CONSTANT (IREMAINDER (EXPT 2 32) 59))) 26)))))
(PUTPROPS QP.OK.DATE MACRO ((STOREDDATE) (LET ((DATE STOREDDATE)) (OR (EQ DATE (CONSTANT (
QP.DATE.INTEGER16 " 1-DEC-85 00:00:00"))) (ILEQ (QP.DATE.INTEGER16) DATE)))))
(PUTPROPS QP.OK.OPTIONS MACRO ((OPTIONBITS) T))
(PUTPROPS QP.VERIFY MACRO ((X) (EQP (CADDR X) (QP.MAKE.VERIFICATION (CAR X) (CADR X)))))
)
)
(DECLARE: EVAL@COMPILE 

(RPAQQ QP.GOLDEN.RATIO.HACK -478700649)

(CONSTANTS QP.GOLDEN.RATIO.HACK)
)

(RPAQ? QP.CODE.CACHE NIL)
(DECLARE: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS QP.CODE.CACHE PROLOGROOTDIRECTORY)
)
(DEFINEQ

(BIGNUM-TO-FIXP
(LAMBDA (X) (* pds: "16-Nov-85 20:35") (LET ((LOW32 (IMOD X (CONSTANT (EXPT 2 32))))) (if (IGREATERP 
LOW32 (CONSTANT (EXPT 2 31))) then (LOGOR (IDIFFERENCE LOW32 (CONSTANT (EXPT 2 31))) (CONSTANT (LOGNOT
 (SUB1 (EXPT 2 31))))) else LOW32))))

(FIXP-TO-BIGNUM
(LAMBDA (FIXP) (* pds: "16-Nov-85 20:10") (if (MINUSP FIXP) then (IPLUS FIXP (CONSTANT (EXPT 2 32))) 
else FIXP)))

(QP.32BITIPLUS
(LAMBDA (X Y) (* pds: "31-Jan-86 19:43") (LET ((LOW (IPLUS (FLOADBYTE X 0 16) (FLOADBYTE Y 0 16)))) (
LOGOR (LLSH (FLOADBYTE (IPLUS (FLOADBYTE X 16 16) (FLOADBYTE Y 16 16) (FLOADBYTE LOW 16 16)) 0 16) 16)
 (FLOADBYTE LOW 0 16)))))

(QP.32BITITIMES
(LAMBDA (A B) (* pds: "31-Jan-86 19:27") (* * This macro is executed for side-effect. It multiplies A 
by B, yielding PROD, where A, B, and PROD are 32 bit unsigned quantities, and the result is truncated 
without comment. Each input and output is a 16 bit positive SMALLP. The execution of this code will 
not make any FIXPs or BIGNUMs. To call this macro, pass in SMALLPs for the first four args, and 
variables for the last two; on completion, G and H will be bound to the high and low 16 bits of the 
product, respectively. Gee, this is almost like Prolog!) (PROG ((A3 (FLOADBYTE A 24 8)) (B3 (FLOADBYTE
 B 24 8)) (A2 (FLOADBYTE A 16 8)) (B2 (FLOADBYTE B 16 8)) (A1 (FLOADBYTE A 8 8)) (B1 (FLOADBYTE B 8 8)
) (A0 (FLOADBYTE A 0 8)) (B0 (FLOADBYTE B 0 8)) RESULTHI RESULTLO) (SETQ RESULTLO (IPLUS (ITIMES A0 B0
) (LLSH (IPLUS (ITIMES A1 B0) (ITIMES A0 B1)) 8))) (SETQ RESULTHI (FLOADBYTE (IPLUS (FLOADBYTE 
RESULTLO 16 16) (ITIMES A2 B0) (ITIMES A1 B1) (ITIMES A0 B2) (LLSH (IPLUS (ITIMES A3 B0) (ITIMES A2 B1
) (ITIMES A1 B2) (ITIMES A0 B3)) 8)) 0 16)) (SETQ RESULTLO (FLOADBYTE RESULTLO 0 16)) (RETURN (LOGOR (
LLSH RESULTHI 16) RESULTLO)))))

(QP.64BITIMOD
(LAMBDA (X1 X0 Y Z) (* pds: " 1-Feb-86 12:34") (* * Takes X, a 64 bit integer passed in as two FIXPs, 
and computes X IMOD Y. X1 is the high order 32 bits of X, and X0 is the low 32 bits. Z is 2**32 mod Y.
 Works providing that Y < 65535) (IMOD (IPLUS (IMOD X0 Y) (ITIMES (IMOD X1 Y) Z)) Y)))

(QP.OK
(LAMBDA (X) (* pds: " 1-Feb-86 13:12") (LET ((SERIALNUMBER (LOGOR (LLSH (fetch (IFPAGE NSHost1) of 
\InterfacePage) 16) (fetch (IFPAGE NSHost2) of \InterfacePage)))) (LET ((HASHEDWORD (QP.HASH.UNHASH (
CADR X) SERIALNUMBER))) (AND (EQP (CAR X) (QP.HASH.UNHASH SERIALNUMBER SERIALNUMBER)) (QP.OK.DATE (
FLOADBYTE HASHEDWORD 16 16)) (QP.OK.OPTIONS (FLOADBYTE HASHEDWORD 0 16)) (QP.VERIFY X))))))

(QP.READ.HEX
(LAMBDA (FILE RDTBL) (* pds: "15-Nov-85 11:14") (bind CH while (OR (SYNTAXP (SETQ CH (PEEKCCODE FILE 
RDTBL)) (QUOTE SEPR) RDTBL) (SYNTAXP CH (QUOTE BREAK) RDTBL)) do (READCCODE FILE RDTBL)) (bind (NUM ← 
0) CH until (OR (SYNTAXP (SETQ CH (PEEKCCODE FILE RDTBL)) (QUOTE SEPR) RDTBL) (SYNTAXP CH (QUOTE BREAK
) RDTBL)) do (READCCODE FILE RDTBL) (if (AND (IGEQ CH (CHARCODE 0)) (ILEQ CH (CHARCODE 9))) then (SETQ
 NUM (LOGOR (LLSH NUM 4) (IDIFFERENCE CH (CHARCODE 0)))) elseif (AND (IGEQ CH (CHARCODE A)) (ILEQ CH (
CHARCODE F))) then (SETQ NUM (LOGOR (LLSH NUM 4) (IDIFFERENCE CH (CONSTANT (IDIFFERENCE (CHARCODE A) 
10))))) elseif (AND (IGEQ CH (CHARCODE a)) (ILEQ CH (CHARCODE f))) then (SETQ NUM (LOGOR (LLSH NUM 4) 
(IDIFFERENCE CH (CONSTANT (IDIFFERENCE (CHARCODE a) 10))))) else (ERROR 
"Invalid hexadecimal character" CH)) finally (RETURN NUM))))

(QP.SECURE
(LAMBDA NIL (* pds: " 3-Feb-86 16:19") (OR (AND QP.CODE.CACHE (QP.STILL.OK QP.CODE.CACHE)) (LET ((
FNAME)) (if (NOT (BOUNDP (QUOTE PROLOGROOTDIRECTORY))) then (PRINTOUT T 
"You must set up the variable PROLOGROOTDIRECTORY before running Prolog" T) NIL elseif (NOT (INFILEP (
SETQ FNAME (PACKFILENAME (QUOTE BODY) PROLOGROOTDIRECTORY (QUOTE NAME) (QUOTE codes) (QUOTE EXTENSION)
 NIL)))) then (printout T "Can't find file " FNAME T) NIL else (AND (SETQ QP.CODE.CACHE (bind X (FL ← 
(OPENFILE FNAME (QUOTE INPUT))) eachtime (QP.SKIP.BLANKS FL) until (EOFP FL) do (SETQ X (LIST (
QP.READ.HEX FL) (QP.READ.HEX FL) (QP.READ.HEX FL))) (if (QP.OK X) then (SETQ $$VAL X) (GO $$OUT)) 
finally (CLOSEF FL))) T))))))

(QP.SKIP.BLANKS
(LAMBDA (FL RDTBL) (* pds: "15-Nov-85 11:38") (while (AND (NOT (EOFP FL)) (SYNTAXP (PEEKCCODE FL RDTBL
) (QUOTE SEPR) RDTBL)) do (READC FL RDTBL))))

(QP.STILL.OK
(LAMBDA (X) (* pds: " 3-Feb-86 16:22") (* * We have previously checked this key and it was ok then. So
 we must make sure that the license hasn't expired, and that he hasn't moved the SYSOUT to another, 
unlicensed, machine. This means that we need only check the serial number and date, and can forgo the 
expensive verification of the consistancy of the code.) (LET ((SERIALNUMBER (LOGOR (LLSH (fetch (
IFPAGE NSHost1) of \InterfacePage) 16) (fetch (IFPAGE NSHost2) of \InterfacePage)))) (LET ((HASHEDWORD
 (QP.HASH.UNHASH (CADR X) SERIALNUMBER))) (AND (EQP (CAR X) (QP.HASH.UNHASH SERIALNUMBER SERIALNUMBER)
) (QP.OK.DATE (FLOADBYTE HASHEDWORD 16 16)) (QP.OK.OPTIONS (FLOADBYTE HASHEDWORD 0 16)))))))
)
(PUTPROPS SECURE COPYRIGHT ("Quintus Computer Systems" 1985 1986))
(DECLARE: DONTCOPY
  (FILEMAP (NIL (2736 7769 (BIGNUM-TO-FIXP 2746 . 3008) (FIXP-TO-BIGNUM 3010 . 3144) (QP.32BITIPLUS 3146
 . 3395) (QP.32BITITIMES 3397 . 4564) (QP.64BITIMOD 4566 . 4876) (QP.OK 4878 . 5282) (QP.READ.HEX 5284
 . 6153) (QP.SECURE 6155 . 6875) (QP.SKIP.BLANKS 6877 . 7045) (QP.STILL.OK 7047 . 7767)))))
STOP