(FILECREATED "16-Feb-86 13:52:31" {QV}<IDL>SOURCES>ROWS.;45 21433
changes to: (VARS ROWSCOMS)
previous date: "16-Feb-86 13:16:16" {QV}<IDL>SOURCES>ROWS.;44)
(* Copyright (c) 1983, 1984, 1985, 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT ROWSCOMS)
(RPAQQ ROWSCOMS [(* Implementation of rows)
(FNS BETWEEN COPYROW EQUALROW FILLROW FIXROW FLOATROW GENROW GETRELT GETRELTD HASNILS INDEXP
RELTPTR REPLACENELTS ROWBLT DROWCREATE ROWCREATETRAN ROWINTOF ROWINTOF1 ROWPTROF
ROWTYPEP SETRELT SETRELTD)
(IF: TESTSYS (RECORDS ROW ROWHEADER ROWSCALAR ROWFLOAT ROWINT ROWPTR)
(DECLTYPES (ROWSCALAR COERCION)
(ROWFLOAT COERCION)
(ROWINT COERCION)
RELTPTR)
(PROP SETFN SETRELT GETRELT SETRELTD GETRELTD)
(PROP (CLISPTYPE LISPFN)
$)
(PROP CLISPINFIX GETRELT)
(ADDVARS (CLISPCHARS $)
(FUNNYATOMLST $$VAL))
(P (SETQ CLISPCHARARRAY (MAKEBITTABLE CLISPCHARS)))
(MACROS BUMPREFCNT INDEXP ROWTYPEP))
(INITRECORDS ROWHEADER)
(MACROS TESTMISSING)
(RECORDS FBOX IBOX)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML)
(LAMA ROWPTROF ROWINTOF
FILLROW])
(* Implementation of rows)
(DEFINEQ
(BETWEEN
[LAMBDA (X Y Z) (* rmk: "11-MAY-79 09:30" posted: "15-MAY-79 17:07")
(* X between Y and Z inclusive.)
(AND (IGEQ X Y)
(ILEQ X Z])
(COPYROW
[DLAMBDA ((R ROW)
(RETURNS ROW (SATISFIES (ZEROP (fetch REFCOUNT of VALUE)))))
(* jop: " 7-Oct-85 23:16")
(* Returns a row exactly like R except that it's
refcont is 0)
(DPROG ((OUTROW (create ROW
NELTS ←(fetch NELTS of R)
RELTTYPE ←(fetch RELTTYPE of R)
MAYHAVENIL ←(fetch MAYHAVENIL of R)) ROW))
(SELECTQ (fetch RELTTYPE of R)
[INTEGER (for I to (fetch NELTS of R)
declare (R ROWINT)
(OUTROW ROWINT)
do (SETRELT OUTROW I (GETRELT R I]
[FLOATING (for I to (fetch NELTS of R)
declare (R ROWFLOAT)
(OUTROW ROWFLOAT)
do (SETRELT OUTROW I (GETRELT R I]
[POINTER (for I to (fetch NELTS of R)
declare (R ROWPTR)
(OUTROW ROWPTR)
do (SETRELT OUTROW I (GETRELT R I))
(SETRELTD OUTROW I (GETRELTD R I]
(SHOULDNT))
(RETURN OUTROW))])
(EQUALROW
[DLAMBDA ((ROW1 ROW)
(ROW2 ROW)
(RETURNS BOOL))
(* bas: "11-OCT-77 11:49" posted: " 5-JUL-77 21:18")
(* Predicate that tests whether 2 rows are equal.)
[OR (EQ ROW1 ROW2)
(AND (EQ (fetch RELTTYPE of ROW1)
(fetch RELTTYPE of ROW2))
(IEQP (fetch NELTS of ROW1)
(fetch NELTS of ROW2))
(for INDEX to ROW1:NELTS always (IEQP (fetch I of (RELTPTR ROW1 INDEX))
(fetch I of (RELTPTR ROW2 INDEX]])
(FILLROW
[LAMBDA NARGS
(CLISP:(RECORD ARGRECORD (ROW STARTINDEX . ELEMENTS))) (* rmk: "15-JUN-78 16:54" posted: "30-JUN-77 11:57")
(* Fills ELEMENTS into ROW starting at STARTINDEX)
(for E R←(ARG NARGS 1) from 3 to NARGS as I from (ARG NARGS 2)
declare (R ROW)
(RETURNS ROW)
do (R$I←(ARG NARGS E)) finally (RETURN R])
(FIXROW
[DLAMBDA ((R ROWSCALAR)
(N INTEGER (SATISFIES (BETWEEN N 0 (fetch NELTS of R)))
(* Can be Zero))
(RETURNS ROWSCALAR [SATISFIES (AND (EQ VALUE R)
(EQ (fetch RELTTYPE of VALUE)
(QUOTE INTEGER]))
(* jop: " 5-Sep-85 17:09")
(* Smashes a row of type FLOATING into one of type
INTEGER)
(ASSERT (EQ (fetch RELTTYPE of R)
(QUOTE FLOATING))) (* Not in SATISFIES as it wont long be satisfied!)
[for I PTR to N
do (SETQ PTR (RELTPTR R I))
(OR (TESTMISSING (fetch I of PTR))
(replace I of PTR with (FIXR (fetch F of PTR]
(replace RELTTYPE of R with (QUOTE INTEGER))
R])
(FLOATROW
[DLAMBDA ((R ROWSCALAR)
(N INTEGER (SATISFIES (BETWEEN N 0 (fetch NELTS of R)))
(* Can be zero))
(RETURNS ROWSCALAR [SATISFIES (AND (EQ VALUE R)
(EQ (fetch RELTTYPE of VALUE)
(QUOTE FLOATING]))
(* jop: " 7-Aug-85 13:34")
(* Smashes a row of type INT into one of type FLOAT)
(ASSERT (EQ (fetch RELTTYPE of R)
(QUOTE INTEGER))) (* Not in SATISFIES as it wont long be satisfied!)
(for I PTR VAL to N declare (VAL FIXP)
do (SETQ PTR (RELTPTR R I))
(OR (TESTMISSING (SETQ VAL (fetch I of PTR)))
(replace F of PTR with VAL)))
(replace RELTTYPE of R with (QUOTE FLOATING))
R])
(GENROW
[DLAMBDA ((L INTEGER)
(R INTEGER)
(RETURNS ROWINT))
(* bas: " 8-FEB-83 11:19" posted: "13-SEP-77 12:19")
(* Creates a row filled with the integers from L to R.
Returns an empty rowint if L is greater than R)
(bind [V ←(create ROWINT
NELTS ←(if (ILESSP R L)
then 0
else (ADD1 (IDIFFERENCE R L]
declare (V ROWINT) for I from 1 as J from L to R do (SETRELT V I J)
finally (RETURN V))])
(GETRELT
[DLAMBDA ((R ROW)
(N INTEGER (SATISFIES (INDEXP R N))))
(* jop: "14-Feb-86 14:37")
(* Gets the nth element of a row)
(PROG ((PTR (RELTPTR R N)))
(RETURN (SELECTQ (fetch RELTTYPE of R)
(INTEGER (if (AND (fetch MAYHAVENIL of R)
(TESTMISSING (fetch I of PTR)))
then NIL
else (fetch I of PTR)))
(FLOATING (if (AND (fetch MAYHAVENIL of R)
(TESTMISSING (fetch I of PTR)))
then NIL
else (fetch F of PTR)))
(POINTER (\GETBASEPTR PTR 0))
NIL)))])
(GETRELTD
[DLAMBDA ((R ROWPTR)
(N INTEGER (SATISFIES (INDEXP R N))))
(* jop: "14-Feb-86 14:43")
(* gets CDR of the nth element of a row)
(\GETBASEPTR (fetch ROWBLKD of R)
(LLSH (SUB1 N)
1))])
(HASNILS
[DLAMBDA ((R ROWSCALAR)
(RETURNS BOOL))
(* bas: " 8-FEB-83 13:21")
(* Tests a row for NILs -
turns the bit off if incorrectly set)
(AND (fetch MAYHAVENIL of R)
(for I to (fetch NELTS of R) when (NULL (GETRELT R I)) do (RETURN T)
finally (replace MAYHAVENIL of R with NIL)))])
(INDEXP
[DLAMBDA ((R ROW)
(N INTEGER)
(RETURNS BOOL))
(* rmk: "15-MAY-79 17:02")
(* checks the index used to access row R)
(BETWEEN N 1 (fetch NELTS of R))])
(RELTPTR
[DLAMBDA ((R ROW)
(N INTEGER (SATISFIES (INDEXP R N)))
(RETURNS RELTPTR))
(* jop: "14-Feb-86 14:29")
(* Computes a raw pointer to the Nth cell of the row
R)
(\ADDBASE (fetch ROWBLK of R)
(LLSH (SUB1 N)
1))])
(REPLACENELTS
[DLAMBDA ((R ROW)
(N INTEGER (SATISFIES (BETWEEN N 0 (fetch PHYSICALNELTS of R))))
(RETURNS INTEGER))
(* bas: "15-FEB-83 14:03")
(* Sets the NELTS of a row. Called from replace-NELTS accessfn. A separate function because of the need to bind the
row when the value is to be checked, lest it be evaluated twice. Compiled open by a macro which is smart about the
binding.)
(replace NELTSVAL of R with N)])
(ROWBLT
[DLAMBDA ((R ROW)
(V ANY))
(* jop: " 7-Oct-85 23:17")
(* Stuffs the value V into all cells of the row R)
(for I to (fetch NELTS of R) do (SETRELT R I V))])
(DROWCREATE
[DLAMBDA ((INITFLAG BOOL)
(PHYSICALNELTS (ONEOF NIL CARDINAL))
(NELTS [ONEOF (NIL (SATISFIES (type? CARDINAL PHYSICALNELTS)))
(CARDINAL (SATISFIES (ILEQ NELTS (OR PHYSICALNELTS NELTS])
(RELTTYPE (MEMQ INTEGER FLOATING POINTER))
(INIT ANY)
(RETURNS ROW))
(* jop: " 6-Dec-84 16:41")
(* Creates rows. Called from CREATE-ROW translations produced by ROWCREATETRAN. Can be compiled open with
ROWCREATEMAC, in which case the order of argments must not be changed, since this order corresponds to the order of
evaluation in the open-code. Otherwise, the record package will confuse the evalution sequence.
However, there seems to be little advantage to compiling this open anyway, and the disadvantage is that many other
functions are larger. Hence, we currently don't run with the macro expansion.)
(OR NELTS (SETQ NELTS PHYSICALNELTS))
(DPROG ((R (create ROWHEADER) ROWHEADER)
(S (OR PHYSICALNELTS NELTS) FIXP)
(PTRP (EQ RELTTYPE (QUOTE POINTER)) BOOL))
(AND (IGREATERP S (CONSTANT (IDIFFERENCE (EXPT 2 16)
4)))
(UERROR "Attempt to allocate array with more than 2↑16 elements: " S))
(replace ROWBLK of R with (\ALLOCBLOCK S PTRP))
(replace ROWBLKD of R with (AND PTRP (\ALLOCBLOCK S T)))
(replace NELTS of R with NELTS)
(replace RELTTYPE of R with RELTTYPE)
(if [AND INITFLAG (NOT (NULL INIT))
(NOT (EQP INIT (SELECTQ RELTTYPE
(INTEGER 0)
(FLOATING 0.0)
(POINTER NIL)
(SHOULDNT]
then (ROWBLT R INIT))
(RETURN R))])
(ROWCREATETRAN
[LAMBDA NIL (* jop: "14-Feb-86 14:48")
(* Does translation-time checking of CREATE-ROW expressions to make sure that some form is specified for NELTS or
PHYSICALNELTS, and for RELTTYPE. Generates a ROWCREATE form to serve as the translation. Passes ROWCREATE a flag to
indicates whether the INIT was specified as NIL or simply absent--this can't be determined at run-time.)
(if (NOT (RECORD.FIELD.VALUE (QUOTE RELTTYPE)))
then (PROGN (LISPXPRIN1 (CONCAT "{in " FAULTFN
"} RELTTYPE must be specified in row create
")
T)
(ERROR!)))
(OR (RECORD.FIELD.VALUE (QUOTE NELTS))
(RECORD.FIELD.VALUE (QUOTE PHYSICALNELTS))
(PROGN (LISPXPRIN1 (CONCAT "{in " FAULTFN
"} (PHYSICAL)NELTS must be specified in row create
")
T)
(ERROR!)))
(CONS (QUOTE DROWCREATE)
(CONS (AND (ASSOC (QUOTE INIT)
FIELDS.IN.CREATE)
T)
(QUOTE (PHYSICALNELTS NELTS RELTTYPE INIT])
(ROWINTOF
[LAMBDA NARGS (* bas: " 8-FEB-83 12:23" posted: "20-JUL-77 15:06")
(* Creates a rowint of its args)
(bind (R ←(create ROWINT
NELTS ← NARGS))
declare (R ROWINT)
(RETURNS ROWINT)
for I to NARGS do (SETRELT R I (the INTEGER (ARG NARGS I))) finally (RETURN R])
(ROWINTOF1
[DLAMBDA ((VALS (LST OF INTEGER))
(RETURNS ROWINT))
(* jop: "12-Nov-84 15:37" posted: "20-JUL-77 15:06")
(* Spread version of ROWINTOF.
Creates a rowint of the values in VALS)
(bind (R ←(create ROWINT
NELTS ←(LENGTH VALS)))
for V in VALS as I from 1
declare (R ROWINT)
(V INTEGER)
(I IJK)
(RETURNS ROWINT)
do (SETRELT R I V) finally (RETURN R))])
(ROWPTROF
[LAMBDA NARGS (* rmk: "15-JUN-78 17:09" posted: "20-JUL-77 15:07")
(* Creates a rowptr of its args)
(bind R←(create ROWPTR
NELTS ← NARGS)
declare (R ROWPTR)
(RETURNS ROWPTR)
for I to NARGS do R$I←(ARG NARGS I) finally (RETURN R])
(ROWTYPEP
[LAMBDA (ROWTYPE ROW) (* rmk: " 6-NOV-77 23:24")
(* Type predicate for various kinds of rows.
Should only be referenced from inside the row record
declarations)
(AND (type? ROW ROW)
(SELECTQ ROWTYPE
[ROWINT (AND (EQ (fetch RELTTYPE of ROW)
(QUOTE INTEGER))
(NOT (HASNILS ROW]
[ROWFLOAT (AND (EQ (fetch RELTTYPE of ROW)
(QUOTE FLOATING))
(NOT (HASNILS ROW]
(ROWSCALAR (NEQ (fetch RELTTYPE of ROW)
(QUOTE POINTER)))
(ROWPTR (EQ (fetch RELTTYPE of ROW)
(QUOTE POINTER)))
(HELP "ILLEGAL ROWTYPE" ROWTYPE])
(SETRELT
[DLAMBDA ((R ROW)
(N INTEGER (SATISFIES (INDEXP R N)))
V)
(* jop: "14-Feb-86 14:42")
(* Returns its input value V)
(if V
then (SELECTQ (fetch RELTTYPE of R)
(INTEGER (if (FIXP V)
then (replace I of (RELTPTR R N) with V)
else (HELP "Not an integer" V)))
(FLOATING (if (NUMBERP V)
then (replace F of (RELTPTR R N) with (FLOAT
V))
else (HELP "Not a number" V)))
(POINTER (\RPLPTR (RELTPTR R N)
0 V))
NIL)
elseif (type? ROWPTR R)
then (\RPLPTR (RELTPTR R N)
0 NIL)
else (replace MAYHAVENIL of R with T)
(replace I of (RELTPTR R N) with (CONSTANT MIN.FIXP)))
V])
(SETRELTD
[DLAMBDA ((R ROWPTR)
(N INTEGER (SATISFIES (INDEXP R N)))
V)
(* jop: "14-Feb-86 14:46")
(\RPLPTR (fetch ROWBLKD of R)
(LLSH (SUB1 N)
1)
V)
V])
)
(DECLARE: DOCOPY
(DECLARE: EVAL@LOADWHEN TESTSYS
[DECLARE: EVAL@COMPILE
(ACCESSFNS ROW ([RELTTYPE (SELECTQ (fetch STORAGEMODE of (the ROW DATUM))
(0 (QUOTE POINTER))
(1 (QUOTE FLOATING))
(3 (QUOTE INTEGER))
(SHOULDNT))
(replace STORAGEMODE of (the ROW DATUM) with (SELECTQ
NEWVALUE
(POINTER 0)
(FLOATING 1)
(INTEGER 3)
(SHOULDNT]
(NELTS (fetch NELTSVAL of (the ROW DATUM))
(REPLACENELTS DATUM NEWVALUE))
(PHYSICALNELTS (COND
((fetch ROWBLK of (the ROW DATUM))
(\#BLOCKDATACELLS (fetch ROWBLK of DATUM)))
(T 0)))
(FIRSTRELTPTR (RELTPTR (the (ROW (WHOSE (NELTS POSINT)))
DATUM)
1))
[LASTRELTPTR (RELTPTR (the ROW DATUM)
(the POSINT (fetch NELTS of DATUM]
(MAYHAVENIL (fetch HMAYNIL of DATUM)
(replace HMAYNIL of DATUM with NEWVALUE))
(INIT NIL))
(CCREATE (ROWCREATETRAN))
(TYPE? (type? ROWHEADER DATUM)))
(DATATYPE ROWHEADER (ROWBLK ROWBLKD (ROWFLAGS WORD)
(NELTSVAL WORD)
(REFCOUNT WORD))
(BLOCKRECORD ROWHEADER (NIL NIL (NIL BITS 13)
(HMAYNIL FLAG)
(STORAGEMODE BITS 2))))
(RECORD ROWSCALAR ROW (SUBRECORD ROW)
(TYPE? (ROWTYPEP (QUOTE ROWSCALAR)
DATUM)))
(RECORD ROWFLOAT ROW (SUBRECORD ROW RELTTYPE ←(QUOTE FLOATING))
(TYPE? (ROWTYPEP (QUOTE ROWFLOAT)
DATUM)))
(RECORD ROWINT ROW (SUBRECORD ROW RELTTYPE ←(QUOTE INTEGER))
(TYPE? (ROWTYPEP (QUOTE ROWINT)
DATUM)))
(RECORD ROWPTR ROW (SUBRECORD ROW RELTTYPE ←(QUOTE POINTER))
(TYPE? (ROWTYPEP (QUOTE ROWPTR)
DATUM)))
]
(/DECLAREDATATYPE (QUOTE ROWHEADER)
(QUOTE (POINTER POINTER WORD WORD WORD))
[QUOTE ((ROWHEADER 0 POINTER)
(ROWHEADER 2 POINTER)
(ROWHEADER 4 (BITS . 15))
(ROWHEADER 5 (BITS . 15))
(ROWHEADER 6 (BITS . 15]
(QUOTE 8))
(DECLARE: EVAL@COMPILE
(DECLTYPES (ROWSCALAR ROWSCALAR COERCION NIL)
(ROWFLOAT ROWFLOAT COERCION NIL)
(ROWINT ROWINT COERCION NIL)
(RELTPTR (SUBTYPE ANY)))
)
(PUTPROPS SETRELT SETFN (GETRELT))
(PUTPROPS GETRELT SETFN SETRELT)
(PUTPROPS SETRELTD SETFN (GETRELTD))
(PUTPROPS GETRELTD SETFN SETRELTD)
(PUTPROPS $ CLISPTYPE (12 . 15))
(PUTPROPS $ LISPFN GETRELT)
(PUTPROPS GETRELT CLISPINFIX $)
(ADDTOVAR CLISPCHARS $)
(ADDTOVAR FUNNYATOMLST $$VAL)
(SETQ CLISPCHARARRAY (MAKEBITTABLE CLISPCHARS))
(DECLARE: EVAL@COMPILE
[PUTPROPS BUMPREFCNT MACRO (ARGS (APPLYFORM (QUOTE [LAMBDA (R)
[replace REFCOUNT of R with
(ADD1 (fetch REFCOUNT of
(the ROW R]
R])
(CAR ARGS]
[PUTPROPS INDEXP MACRO (ARGS (COND [[AND (COVERS (QUOTE ROW)
(DECLOF (CAR ARGS)))
(COVERS (QUOTE FIXP)
(DECLOF (CADR ARGS]
(SUBPAIR (QUOTE (R N))
ARGS
(QUOTE (BETWEEN N 1 (fetch NELTS of R]
(T (QUOTE IGNOREMACRO]
[PUTPROPS ROWTYPEP MACRO
(ARGS (COND [(AND (EQ (CAR (LISTP (CAR ARGS)))
(QUOTE QUOTE))
(LITATOM (CADR ARGS)))
(SUBPAIR (QUOTE (R))
(CDR ARGS)
(LIST (QUOTE AND)
(QUOTE (type? ROW R))
(SELECTQ (CADAR ARGS)
(ROWINT (QUOTE (IEQP (fetch ROWFLAGS of R)
3)))
(ROWFLOAT (QUOTE (IEQP (fetch ROWFLAGS of R)
1)))
[ROWSCALAR (QUOTE (NOT (IEQP (fetch STORAGEMODE of R)
0]
(ROWPTR (QUOTE (IEQP (fetch STORAGEMODE of R)
0)))
(HELP "Illegal ROWTYPE" (CADAR ARGS]
(T (QUOTE IGNOREMACRO]
)
)
)
(/DECLAREDATATYPE (QUOTE ROWHEADER)
(QUOTE (POINTER POINTER WORD WORD WORD))
[QUOTE ((ROWHEADER 0 POINTER)
(ROWHEADER 2 POINTER)
(ROWHEADER 4 (BITS . 15))
(ROWHEADER 5 (BITS . 15))
(ROWHEADER 6 (BITS . 15]
(QUOTE 8))
(DECLARE: EVAL@COMPILE
[PUTPROPS TESTMISSING MACRO (OPENLAMBDA (X)
(AND [EQ 0 (LOGAND X (CONSTANT (LOGNOT MIN.FIXP]
(NULL (EQ 0 (LOGAND X (CONSTANT MIN.FIXP]
)
[DECLARE: EVAL@COMPILE
(BLOCKRECORD FBOX ((F FLOATING)))
(BLOCKRECORD IBOX ((I INTEGER)))
]
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA ROWPTROF ROWINTOF FILLROW)
)
(PUTPROPS ROWS COPYRIGHT ("Xerox Corporation" 1983 1984 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1277 16764 (BETWEEN 1287 . 1561) (COPYROW 1563 . 2775) (EQUALROW 2777 . 3461) (FILLROW
3463 . 3939) (FIXROW 3941 . 4963) (FLOATROW 4965 . 5977) (GENROW 5979 . 6656) (GETRELT 6658 . 7455) (
GETRELTD 7457 . 7835) (HASNILS 7837 . 8360) (INDEXP 8362 . 8695) (RELTPTR 8697 . 9123) (REPLACENELTS
9125 . 9696) (ROWBLT 9698 . 10037) (DROWCREATE 10039 . 11963) (ROWCREATETRAN 11965 . 13095) (ROWINTOF
13097 . 13561) (ROWINTOF1 13563 . 14189) (ROWPTROF 14191 . 14618) (ROWTYPEP 14620 . 15452) (SETRELT
15454 . 16456) (SETRELTD 16458 . 16762)))))
STOP