;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*-
;;; Private patches made by rg
;;; Reason:
;;;  lap quote stuff.
;;; Written 24-Jan-86 10:48:18 by rg of LMI Cambridge
;;; while running on Explorer Two from band 3
;;; with Experimental System 109.92, Experimental Local-File 64.1, Experimental FILE-Server 17.1, Experimental MagTape 3.5, microcode 1346, GC5 FS LAM.



; From modified file DJ: L.SYS; QCLAP.LISP#265 at 24-Jan-86 10:48:28
#8R COMPILER#:
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER")))
  (PATCH-SOURCE-FILE "SYS: SYS; QCLAP  "

(DEFUN QADD (X) 
  (INCF QUOTE-COUNT)
  (cond	((QFIND-CONSTANTS-PAGE X))
	((or (CONTAINS-LOAD-TIME-EVAL X)
	     (null (CL:ASSOC X QUOTE-LIST
	       ;; EQUALP is such as dog
			     :TEST (LAMBDA (X Y)
				     (TREE-EQUAL X Y
						 :TEST (LAMBDA (X Y) (IF (STRINGP X)
									 (EQUAL X Y)
								       (EQL X Y))))))))
	 (PUSH (CONS X QUOTE-COUNT) QUOTE-LIST)))
    X)

))

; From modified file DJ: L.SYS; QCLAP.LISP#265 at 24-Jan-86 10:48:36
#8R COMPILER#:
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER")))
  (PATCH-SOURCE-FILE "SYS: SYS; QCLAP  "

(DEFUN LAP-QUOTE-ADR (ITEM &AUX TM)
  (INCF QUOTE-COUNT)
  (COND ((SETQ TM (QFIND-CONSTANTS-PAGE ITEM))
	 (+ TM (GET 'CONST-PAGE 'QLVAL)))
	((DO ((IDX 0 (1+ IDX))
	       (QUOTE-LIST QUOTE-LIST (CDR QUOTE-LIST))
	       (contains-load-time-eval (CONTAINS-LOAD-TIME-EVAL ITEM)))
	     ((NULL QUOTE-LIST) (SETQ TM NIL))
	   (if (if contains-load-time-eval
		   (= QUOTE-COUNT (CDAR QUOTE-LIST))
		 (TREE-EQUAL ITEM (CAAR QUOTE-LIST)
			     :TEST ;;>> EQUALP is such a complete dog.
			     (LAMBDA (X Y) (IF (STRINGP X) (EQUAL X Y) (EQL X Y)))))
	       (RETURN (SETQ TM IDX))))
	 (+ TM (QLEVAL 'QUOTE-BASE T)))
	(T (BARF ITEM "not on quote-list" 'BARF)
	   0)))

))