(FILECREATED " 8-Feb-86 15:39:54" {DSK}<LISPFILES2>IMPROVEDDCOMS>CALL.;1 4853
changes to: (VARS CALLCOMS))
(* Copyright (c) 1986 by Quintus Computer Systems, Inc. All rights reserved.)
(PRETTYCOMPRINT CALLCOMS)
(RPAQQ CALLCOMS ((FNS R.allocate R.apply R.call R.deallocate R.depart R.execute R.proceed R.progress
W.allocate W.apply W.call W.deallocate W.depart W.execute W.proceed W.progress) (MACROS
dereference-for-apply do.execute) (PROP (Ptr Tag LO HI) get-cell-for-apply)))
(DEFINEQ
(R.allocate
(LAMBDA NIL (* needed C) (put.24 R (get.24 E)) (if (before E B) then (put.24 E (get.24 B)) (put.addr E
saved.B0 (get.24 B0)) else (put.24 E (E.plus.env.size.from.CP)) (put.addr E saved.B0 (get.24 B))) (
put.addr E saved.CP (get.24 CP)) (put.addr E saved.CE (get.24 R)) (check.stack E) (continue 0)))
(R.apply
(LAMBDA NIL (PROG (C P R) (check.heap) (dereference-for-apply A1 C) (dereference-for-apply A3 P) (
dereference-for-apply A2 R) (SELECTC (tag.of A2) (struct.tag.8 (put.32 A1 (get-cell-for-apply R 1)) (
put.32 A2 (get-cell-for-apply R 2)) (put.32 A3 (get-cell-for-apply R 3)) (put.32 A4 (
get-cell-for-apply R 4)) (LET ((I (LLSH (arity.of.cell R) 1))) (if (IGREATERP I 8) then (\BLT (
loc.Amem 5) (\ADDBASE R 10) (IDIFFERENCE I 8))))) (list.tag.8 (put.32 A1 (get-cell-for-apply R 0)) (
put.32 A2 (get-cell-for-apply R 1))) (symbol.tag.8) (SHOULDNT (QUOTE apply))) (put.24 B0 (get.24 B)) (
put.24 C C) (RETURN (continue.at (SELECTQ P (0 (PROC.CLAUSES C)) (1 (PROC.LASTCLAUSE C)) (2 C) (
SHOULDNT (QUOTE apply))))))))
(R.call
(LAMBDA NIL (put.24 CP (add.code P 1)) (do.execute)))
(R.deallocate
(LAMBDA NIL (put.24 CP (get.addr E saved.CP)) (put.24 E (get.addr E saved.CE)) (continue.reading 0)))
(R.depart
(LAMBDA NIL (put.24 CP (get.addr E saved.CP)) (put.24 E (get.addr E saved.CE)) (do.execute)))
(R.execute
(LAMBDA NIL (do.execute)))
(R.proceed
(LAMBDA NIL (continue.at (add.code CP 1))))
(R.progress
(LAMBDA NIL (put.24 CP (get.addr E saved.CP)) (put.24 E (get.addr E saved.CE)) (continue.at (add.code
CP 1))))
(W.allocate
(LAMBDA NIL (* needed C) (put.24 R (get.24 E)) (if (before E B) then (put.24 E (get.24 B)) (put.addr E
saved.B0 (get.24 B0)) else (put.24 E (E.plus.env.size.from.CP)) (put.addr E saved.B0 (get.24 B))) (
put.addr E saved.CP (get.24 CP)) (put.addr E saved.CE (get.24 R)) (check.stack E) (continue 0)))
(W.apply
(LAMBDA NIL (PROG (C P R) (check.heap) (dereference-for-apply A1 C) (dereference-for-apply A3 P) (
dereference-for-apply A2 R) (SELECTC (tag.of A2) (struct.tag.8 (put.32 A1 (get-cell-for-apply R 1)) (
put.32 A2 (get-cell-for-apply R 2)) (put.32 A3 (get-cell-for-apply R 3)) (put.32 A4 (
get-cell-for-apply R 4)) (LET ((I (LLSH (arity.of.cell R) 1))) (if (IGREATERP I 8) then (\BLT (
loc.Amem 5) (\ADDBASE R 10) (IDIFFERENCE I 8))))) (list.tag.8 (put.32 A1 (get-cell-for-apply R 0)) (
put.32 A2 (get-cell-for-apply R 1))) (symbol.tag.8) (SHOULDNT (QUOTE apply))) (put.24 B0 (get.24 B)) (
put.24 C C) (RETURN (continue.at (SELECTQ P (0 (PROC.CLAUSES C)) (1 (PROC.LASTCLAUSE C)) (2 C) (
SHOULDNT (QUOTE apply))))))))
(W.call
(LAMBDA NIL (put.24 CP (add.code P 1)) (do.execute)))
(W.deallocate
(LAMBDA NIL (put.24 CP (get.addr E saved.CP)) (put.24 E (get.addr E saved.CE)) (continue.reading 0)))
(W.depart
(LAMBDA NIL (put.24 CP (get.addr E saved.CP)) (put.24 E (get.addr E saved.CE)) (do.execute)))
(W.execute
(LAMBDA NIL (do.execute)))
(W.proceed
(LAMBDA NIL (continue.at (add.code CP 1))))
(W.progress
(LAMBDA NIL (put.24 CP (get.addr E saved.CP)) (put.24 E (get.addr E saved.CE)) (continue.at (add.code
CP 1))))
)
(DECLARE: EVAL@COMPILE
(PUTPROPS dereference-for-apply MACRO (X (APPLY (FUNCTION (LAMBDA (A R) (if (NOT (MEMB A (QUOTE (A1 A2
A3 A4)))) then (SHOULDNT (QUOTE dereference-for-apply))) (if (NOT (MEMB R (QUOTE (R C P)))) then (
SHOULDNT (QUOTE dereference-for-apply))) (BQUOTE (PROGN (while (EQ (tag.of (\, A)) ref.tag.8) (SETQ (
\, R) (untag.ref (\, A))) (WritePrologTagAndPtr (\, A) (\GETBASEBYTE (\, R) 0) (\GETBASEPTR (\, R) 0))
) (SETQ (\, R) (untag.anything (\, A))))))) X)))
(PUTPROPS do.execute MACRO (OPENLAMBDA NIL (check.heap) (put.24 B0 (get.24 B)) (put.24 C (
address.operand)) (continue.at (PROC.CLAUSES (get.24 C)))))
)
(PUTPROPS get-cell-for-apply Ptr (LAMBDA (Ptr Offset) (BQUOTE (\GETBASEPTR (\, Ptr) (\, (Twice
Offset 0))))))
(PUTPROPS get-cell-for-apply Tag (LAMBDA (Ptr Offset) (BQUOTE (\GETBASEBYTE (\, Ptr) (\, (Twice (
Twice Offset 0) 0))))))
(PUTPROPS get-cell-for-apply LO (LAMBDA (Ptr Offset) (BQUOTE (\GETBASE (\, Ptr) (\, (Twice Offset 1)
)))))
(PUTPROPS get-cell-for-apply HI (LAMBDA (Ptr Offset) (BQUOTE (\GETBASE (\, Ptr) (\, (Twice Offset 0)
)))))
(PUTPROPS CALL COPYRIGHT ("Quintus Computer Systems, Inc" 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (505 3665 (R.allocate 515 . 831) (R.apply 833 . 1559) (R.call 1561 . 1626) (R.deallocate
1628 . 1747) (R.depart 1749 . 1856) (R.execute 1858 . 1899) (R.proceed 1901 . 1959) (R.progress 1961
. 2088) (W.allocate 2090 . 2406) (W.apply 2408 . 3134) (W.call 3136 . 3201) (W.deallocate 3203 . 3322
) (W.depart 3324 . 3431) (W.execute 3433 . 3474) (W.proceed 3476 . 3534) (W.progress 3536 . 3663)))))
STOP