;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*-
;;; Private patches made by rg
;;; Reason:
;;;  lap quote stuff.
;;; Written 24-Jan-86 11:02:00 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 11:02:11
#8R COMPILER#:
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER")))
  (PATCH-SOURCE-FILE "SYS: SYS; QCLAP  "

(DEFUN LAP-QUOTE-ADR (ITEM &AUX TM)
  (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))
	   (cond ((TREE-EQUAL ITEM (CAR QUOTE-LIST)
			     :TEST ;;>> EQUALP is such a complete dog.
			     (LAMBDA (X Y) (IF (STRINGP X) (EQUAL X Y) (EQL X Y))))
		  (if contains-load-time-eval
		      (rplaca quote-list (list '**used-load-time-eval**)))
		  (RETURN (SETQ TM IDX)))))
	 (+ TM (QLEVAL 'QUOTE-BASE T)))
	(T (BARF ITEM "not on quote-list" 'BARF)
	   0)))

))

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

(DEFUN QADD (X) 
  (cond	((QFIND-CONSTANTS-PAGE X))
	((or (CONTAINS-LOAD-TIME-EVAL X)
	     (null (CL:member 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 X QUOTE-LIST)))
    X)

(DEFUN QLP2-Q (WD)				;Pass 2 for Q area
  (IF (ATOM WD)
      (IF (EQ WD 'PROGSA)
	  T					;Advance to unboxed area
	(BARF WD "Tag in q-area" 'BARF)
	NIL)
    (CASE (CAR WD)
      (QTAG
       (QLP2-DEFSYM (CADR WD) (TRUNCATE ADR 2))
       (IF (EQ (CADR WD) 'QUOTE-BASE)
	   (MAPC 'QLP2-Q QUOTE-LIST)))			;Dump quote table
      (PARAM)
      (ENDLIST				;Terminate list that has just been assembled
       (LAP-STORE-NXTNIL-CDR-CODE))
      (MFEF
       (LAP-MFEF WD))
      (S-V-BLOCK
       (SETQ ADR (QLP2-S-V-BLOCK ADR)))
      (CONSTRUCT-MACRO
       (SETQ LAP-MACRO-FLAG T))
      (A-D-L
       (SETQ ADR (QLP-A-D-L ADR T)))
      (DEBUG-INFO
       (LAP-D-OUT (CDR WD))
       (LAP-STORE-NXTNIL-CDR-CODE)
       (INCF ADR 2))
      (VARIABLES-USED-IN-LEXICAL-CLOSURES
       (LAP-D-OUT (CDR WD))
       (LAP-STORE-NXTNIL-CDR-CODE)
       (INCF ADR 2))
      (SELF-FLAVOR
       (LAP-D-OUT (CADR WD))
       (LAP-STORE-NXTNIL-CDR-CODE)
       (INCF ADR 2))
      (BREAKOFFS
       ;; When we see the BREAKOFFS command,
       ;; we copy the fef offsets of where the ptrs to broken-off fns should go
       ;; into the cars of the list which is the cadr of the breakoffs command.
       ;; That list is shared with a debug-info item
       ;; which is supposed to contain a list of those offsets.
       (DOLIST (OFFSET *BREAKOFF-FUNCTION-OFFSETS*)
	 (SETF (NTH (CDR OFFSET) (CADR WD)) (CAR OFFSET)))
       (WHEN (MEMQ NIL (CADR WD))
	 (BARF NIL "Missing breakoff-function, position"
	       (FIND-POSITION-IN-LIST NIL (CADR WD)))))
      (QUOTE
       (LAP-D-OUT (CADR WD))
       (INCF ADR 2))
      (LOCATIVE-TO-S-V-CELL
       (LAP-Q-OUT NIL 'QZLOC '1 (CADR WD))
       (INCF ADR 2))
      (FUNCTION
       (IF (SYMBOLP (CADR WD))
	   (LAP-Q-OUT NIL 'QZEVCP '2 (CADR WD))
	   (LAP-Q-OUT NIL 'QZEVCP NIL 
		      (IF (EQ LAP-MODE 'COMPILE-TO-CORE)
			  (FDEFINITION-LOCATION (CADR WD))
			(CONS EVAL-AT-LOAD-TIME-MARKER
			      `(FDEFINITION-LOCATION ',(CADR WD))))))
       (FUNCTION-REFERENCED (CADR WD) FCTN-NAME)
       (INCF ADR 2))
      (SELF-REF
       (LAP-Q-OUT NIL 'QZSRP NIL
		  (IF (EQ LAP-MODE 'COMPILE-TO-CORE)
		      (SI:FLAVOR-VAR-SELF-REF-INDEX (CDR WD))
		      (CONS EVAL-AT-LOAD-TIME-MARKER
			    `(SI:FLAVOR-VAR-SELF-REF-INDEX ',(CDR WD)))))
       (INCF ADR 2))
      (BREAKOFF-FUNCTION
       (PUSH (CONS (TRUNCATE ADR 2) (CADDR (CADR WD))) *BREAKOFF-FUNCTION-OFFSETS*)
       (LAP-D-OUT (CADR WD))
       (INCF ADR 2))
      (TAG
       (LAP-D-OUT (QLEVAL (CADR WD) T))
       (INCF ADR 2))
      (FIXE
       (LAP-D-OUT (LAP-WORD-EVAL `(EXTENDED-ADDRESS 0 ,(CADR WD))))
       (INCF ADR 2))
      (T
       (BARF WD "Unknown op in q-area lap" 'BARF)))
    NIL))
))