;;; -*- Mode: Lisp; Package: Prolog; Base: 10. ; -*-
;;; (C) Copyright 1983,1984,1985, Uppsala University

;;This file contains more macros and utility functions for LM-Prolog

#+(or cadr symbolics)
(defvar *structure-area*
        (make-area ':name 'structure-area
                   ':region-size #o400000
                   ':gc ':static)
  "an area for all permanent (or semi-permanent) consing in Prolog")

#-(or cadr symbolics)
(defvar *structure-area*
        (make-area ':name 'structure-area
                   ':region-size #o400000
                   ':gc ':dynamic ':volatility 2)
  "an area for all permanent (or semi-permanent) consing in Prolog")

;;so that I can use setf, push, etc. on gethash

#-CommonLisp ;obsolete on LMI. Symbolics?
(defprop gethash ((gethash key table) puthash key si:val table) setf)

(defsubst assq-2 (x y)
  ;;this is to avoid a spurious error from Symbolics' microcoded ASSQ
  #-symbolics (assq x y)
  #+symbolics (ass 'eq x y))

(defsubst memq-2 (x y)
  ;;this is to avoid a spurious error from Symbolics' microcoded MEMQ
  #-symbolics (memq x y)
  #+symbolics (mem 'eq x y))

;STRING-EQUAL got a surprisingly high ranking when I metered DEFINE.
(defmacro string-equal-symbol (string symbol &optional prefix-p)
  `(%string-equal ,string 0 (get-pname ,symbol) 0
		  ,(cond ((and prefix-p (stringp string))
			  (array-active-length string))
			 (prefix-p `(array-active-length ,string)))))

;;VARIABLE-SYNTAX contribution by Manny.

;;;   The implementation is done by maintaining four global variables which
;;; are used as prefixes. If a define-predicate is run with :VARIABLE-SYNTAX
;;; something other than the current value, the variables get bound for the  
;;; duration of the call to MAKE-DEFINITION-1, otherwise nothing happens.
;;; This means that the overhead involved is fairly small.

(defvar *variable-prefix* "?")

(defvar *double-variable-prefix* "??")

(defvar *ignore-syntax* "?ignore")

(defvar *variable-underscore-prefix* "?_")

(defvar *syntax-customization-alist* nil)

(deffun find-syntax-customizers (string)
  (cond ((assoc string *syntax-customization-alist*))
	(t (push `(,string
		    ,(format nil "~a~a" string string)
		    ,(format nil "~Aignore" string)
		    ,(format nil "~A_" string))
		  *syntax-customization-alist*)
	   (find-syntax-customizers string))))

(defmacro with-syntax-customized (string . body)
  `(let ((customizers (find-syntax-customizers ,string)))
     (let-globally ((*variable-prefix* (first customizers))
		    (*double-variable-prefix* (second customizers))
		    (*ignore-syntax* (third customizers))
		    (*variable-underscore-prefix* (fourth customizers)))
       . ,body)))

(defun syntactic-variable-p (item)
  ;;a variable is a symbol beginning with `?', by default.
  (and (symbolp item)
       (string-equal-symbol *variable-prefix* item t)
       (not (string-equal-symbol *double-variable-prefix* item t))))

(deffun anonymous (x) (and (symbolp x) (string-equal-symbol *variable-prefix* x)))

(defsubst getprop (x y) (get x y))

(defstruct (definition (:type list)
                       (:constructor nil)
                       :conc-name)
  prover            ;;function of the continuation and the predication's arguments
  interpreter-slot  ;;see below
  indexer           ;;function for adding new clauses 
  predicator        ;;name of predicate defined
  options           ;;options given to define merged with *default-options*
  indexes)          ;;hash tables for indexes of predicate

(defstruct (interpreter-slot (:type list)
                             (:constructor nil)
                             :conc-name)
  deterministic     ;;non-nil if the predicate is deterministic
  prover            ;;either the prover or NIL if the interpreter can handle it
  clauses)           ;;the clauses making up the definition

(defsubst definition-clauses (definition)
  (interpreter-slot-clauses (definition-interpreter-slot definition)))

(defsubst definition-deterministic (definition)
  (interpreter-slot-deterministic (definition-interpreter-slot definition)))

(defsubst qc-file-in-progress ()
  #-symbolics compiler:undo-declarations-flag
  #+symbolics compiler:compiling-whole-file-p)

(defun create-definition (prover deterministic indexer predicator options
                          clauses interpret-p &optional indexes)
  (let-if (qc-file-in-progress) ((*structure-area* default-cons-area))
    (list-in-area *structure-area*
                  prover
                  (list-in-area *structure-area*
                                deterministic
                                (and (not interpret-p) prover)
                                clauses)
                  indexer predicator options indexes)))

(defsubst fast-car-location (list)
  ;;this is essentially car-location
  (%make-pointer dtp-locative list))

(defsubst bound-p (value) (not (value-cell-p value)))

(defsubst bound-cell-p (cell) (not (value-cell-p (contents cell))))

(define-dtp-table lisp-form-1 (x mode)
  ':initial-value #'prog1)

(define-dtp-table copy-term-1 (x)
  ':initial-value #+3600 #'prog1 #-3600 #'list*)

(define-dtp-table make-interpreter-template-1 (x)
  ':initial-value #+3600 #'prog1 #-3600 #'list*)

;;supporting lazy and eager collections, constraints, read-only variables etc.

;Base flavor for all flavors whose instances should be unifiable etc. Essential
;messages are
;;; :CAR(), :CDR()
;;; :LISP-FORM(copy/query/invoke/dont-invoke)
;;; :COPY() by default is SELF (ok if there are no unbound variables inside)
;;; :VARIABLE-P() by default is NIL (ok if it can't be an unbound variable)
;;; :QUERY-USER() by default asks what to do, returns yes, no, or proceed
;;; :UNIFY(term) by default unifies term with (send self ':ordinary-term)

;;the following must be defined for each kind of prolog-flavor
;;; :ORDINARY-TERM()  ;;return an ordinary LM-Prolog term (i.e. an s-expression)
;;can also return a prolog-flavor (e.g. itself even) but then must return T
;;as a second value

(eval-when (compile eval load)
  (defflavor prolog-flavor () ()) ;;here for TYPEP calls to compile much better

  (defflavor read-only-variable (cell) (prolog-flavor)
    :initable-instance-variables
    :gettable-instance-variables
    :settable-instance-variables)

)

(defun unbound-variable-p (x)
  (or (value-cell-p x)
      (and (typep x 'prolog-flavor)
           (send x ':variable-p))))


;;WHEN LEXICAL CLOSURES REALLY WORK, INSTALL THE FOLLOWING:
#+lexical
(defmacro continuation (body)
  (cond ((eq 'invoke (careful-first body)) (second body))
	((and (consp body) (null (cdr body))) `#',(car body))
	(t `#'(lambda () ,body))))

;;This once used Lisp Machine closures but the variables need not be special and
;;there are no side-effects performed upon them
;;instead of (funcall delayed-value) I use invoke (i.e. apply <first> <rest>)
#-lexical
(defmacro continuation (body)
  (cond ((atom body) `(continuation (prog1 ,body)))
        ((eq 'invoke (car body)) (cadr body))
        ((and (memq (car body) '(send funcall))
              (or (atom (cadr body))
                  (neq 'entrypoint-in-world (caadr body))))
         `(PROLOG-LIST ,@(cdr body)))
        ((and (eq 'lexpr-funcall (car body))
              (or (atom (cadr body))
                  (neq 'entrypoint-in-world (caadr body))))
         `(PROLOG-LIST* ,@(CDR BODY)))
        ((null (cdr body)) `',body)
        ((and (atom (car body)) (atom (cadr body)) (null (cddr body)))
         `(PROLOG-LIST #',(car body) ,(cadr body)))
        (t (let ((variables (union () (continuation-variables body))))
             `(PROLOG-LIST #'(lambda ,variables ,body) ,@variables)))))

(deffun continuation-variables (body &optional is-a-cdr sofar)
  (cond ((symbolp body)
         (cond ((getprop body ':compiled-local-variable) (cons body sofar))
               (t sofar)))
        ((consp body)
         (cond (is-a-cdr
                (continuation-variables (car body) nil
                 (continuation-variables (cdr body) t sofar)))
               ((eq 'quote (car body)) sofar)
               ((memq (car body) '(let let*))
		(nconc
		  (nset-difference
		    (continuation-variables (cdr body) t ())
		    (mapcar #'careful-first (cadr body)))
		  sofar))
               ((memq (car body) '(with-stack-list with-stack-list*))
		(nconc
		  (delq (caadr body) (continuation-variables (cdr body) t ()))
		  sofar))
               (t (continuation-variables (car body) nil
                   (continuation-variables (cdr body) t sofar)))))
        (t sofar)))

;;Source terms in compiled code aren't in *structure-area*
(defsubst structure-area-p (area)
  (memq area '#,(list *structure-area*
		      #-CommonLisp si:fasl-constants-area
		      #+CommonLisp si:macro-compiled-program)))

#+symbolics
(defsubst temporary-area-p (area)
  (plusp (si:%logldb si:%%region-temporary (si:area-region-bits area))))

#-symbolics
(defsubst temporary-area-p (area)
 (si:area-temporary-p area))

;;These three were written to reduce wasteful consing when tracing and printing...
(defun prolog-string (control-string &rest args)
  (let-if *prolog-work-area* ((default-cons-area *prolog-work-area*))
    (lexpr-funcall #'format nil control-string args)))

(defun prolog-symbol (control-string &rest args)
  (let-if *prolog-work-area* ((default-cons-area *prolog-work-area*))
    (make-symbol
      (lexpr-funcall #'format nil control-string args))))

(defun permanent-symbol (control-string &rest args)
  (make-symbol (lexpr-funcall #'format nil control-string args) t))

(defun prolog-intern (control-string &rest args)
  (intern (lexpr-funcall #'prolog-string control-string args)))

(defun prolog-db-symbol (predicator world category)
  (let ((package (pkg-find-package "PROLOG")))
    (prolog-intern "~S-IN-~S-~A" predicator world category)))

(defsubst create-permanent-symbol (name)
  (create-symbol-1 name #'permanent-symbol))

(defsubst create-symbol (name)
  (create-symbol-1 name #'prolog-symbol))

(defsubst generate-interned-symbol (name)
  (create-symbol-1 name #'careful-intern))

(defun careful-intern (control-string &rest args)
  (multiple-value-bind (symbol old-p)
      (lexpr-funcall #'prolog-intern control-string args)
    (cond (old-p (generate-interned-symbol symbol))
          (t symbol))))

(deffun create-symbol-1 (name symbol-maker)
  ;;a much friendlier version of gensym
  (cond ((symbolp name)
         (let ((position-of-underbar (string-search-char #\_ (string name))))
           (cond ((null position-of-underbar)
                  (funcall symbol-maker
			   "~a_~d"
			   ;;make a string <name>_<generation-number>
			   name
			   (putprop name
				    (1+ (or (get name 'generation-number) 0))
				    'generation-number)))
                 (t (create-symbol-1 (substring name 0 position-of-underbar)
				     symbol-maker)))))
        ((consp name) (create-symbol-1 (first name) symbol-maker))
        ((numberp name)
	 (create-symbol-1 (prolog-intern "NUMBER_~d" name) symbol-maker))
        ((stringp name) (create-symbol-1 (prolog-intern name) symbol-maker))
        (t (prolog-ferror ':bad-symbol "Can't make a symbol out of ~s" name))))

;;a world is represented by a symbol
;;on its property list (under prolog-predicates)
;;are the predicates defined in that world
;;The primary use of worlds is to select among various definitions of the same
;;predicate indexed by worlds

(defsubst predicators (world) (get world 'prolog-predicators))

;;be careful about areas here since it goes into A-memory
(setq *universe* (list-in-area sys:permanent-storage-area ':user ':system))

(deffun universe-ok (worlds)
  (cond ((null worlds))
	((and (consp worlds)
	      (symbolp (first worlds))
	      ;;Why, Ken?
	      ;;(neq (%p-data-type worlds) dtp-external-value-cell-pointer)
	      (not (temporary-area-p (%area-number worlds))))
	 (universe-ok (rest1 worlds)))
	(t ;;(prolog-error ':bad-universe "bad ~S" worlds)
	 nil)))

(deffun set-universe (worlds)
  ;;this is a seperate function so that it can be advised
;;  (cond ((universe-ok worlds)
	 (setq *universe* worlds))
;;	(t (print `(bad ,worlds))
;;         (setq *universe* (copylist worlds default-cons-area)))))

(defsubst definitions (predicator)
  (get predicator 'prolog-definitions))

;;the prolog-definitions are a list of the form:
;;((<universe-of-last-current-definition> . <last-current-definition>)
;; (<world-1> . <definition-in-world-1>)
;; ...
;; (<world-n> . <definition-in-world-n>))

(defsubst definition-in-world (predicator world)
  (REST1 (assq world (definitions predicator))))

#+(and (not symbolics) CommonLisp)
(defsetf definition-in-world (predicator world) (definition)
  `(put-definition-in-world ,definition ,predicator ,world))

#-(and (not symbolics) CommonLisp)
(defprop definition-in-world
         ((definition-in-world predicator world)
          put-definition-in-world
          si:val predicator world)
         setf)

(defsubst last-definition-universe (definitions)
  (first (first definitions)))

(defsubst last-definition (definitions)
  (REST1 (first definitions)))

(deffun put-definition-in-world (definition predicator world)
  (cond ((null definition) ;;really removing the definition
         (setf (definitions predicator)
               (delq (assq world (definitions predicator))
                     (definitions predicator))))
        (t (let ((definitions (definitions predicator)))
             (cond ((null definitions)
                    (setf (definitions predicator)
                          (list-in-area *structure-area*
                                        (list*-in-area *structure-area* nil nil)
                                        (list*-in-area *structure-area*
						       world
						       definition))))
                    (t (let ((old-pair (assq world definitions)))
                         (cond ((null old-pair)
                                (setf (definitions predicator)
                                      (list*-in-area *structure-area*
                                                     (first definitions)
                                                     (list*-in-area *structure-area*
								    world
								    definition)
                                                     (rest1 definitions))))
                               (t (setf (REST1 old-pair) definition))))
                       ;;flush current definition cache
                       (setf (last-definition-universe definitions) nil)))))))

(deffsubst memq-difference (x list end-list)
  (cond ((eq x (first list)) list)
        ((neq list end-list)
         (memq-difference x (rest1 list) end-list))))

(deffsubst find-first-definition (definitions worlds
                                              &optional worlds-checked best-so-far)
  (cond ((null definitions) best-so-far)
        (t (let ((new-worlds-checked
                   (memq-difference (first (first definitions))
                                    worlds
                                    worlds-checked)))
             (cond ((eq new-worlds-checked worlds) ;;i.e. in the first world
                    (REST1 (first definitions)))
                   ((null new-worlds-checked) ;;inactive definition
                    (find-first-definition (rest1 definitions)
                                           worlds worlds-checked best-so-far))
                   (t (find-first-definition (rest1 definitions)
                                             worlds new-worlds-checked
                                             (REST1 (first definitions)))))))))

(defmacro predication-definition (predication &optional (worlds '*universe*))
  `(let ((definitions (predication-definitions ,predication)))
     (cond ((eq (last-definition-universe definitions) ,worlds)
            (last-definition definitions))
           (t (find-and-cache-first-definition definitions ,worlds)))))

(defmacro sharp-comma (x)
  (cond ((qc-file-in-progress)
         `'(,compiler:eval-at-load-time-marker . ,x))
        (t `',(eval x))))

;;In normal predicate-to-predicate calls in compiled code, the predicator is known, and
;;we use optimizations in CURRENT-ENTRYPOINT. The interpreter and runtime sys
;;use this.
(defmacro current-definition
	  (predicator-form &optional (error-p t) (worlds '*universe*))
  `(cond ((symbolp ,predicator-form)
	  (let ((definitions (definitions ,predicator-form)))
	    (cond ((eq (last-definition-universe definitions) ,worlds)
		   (last-definition definitions))
		  ((find-and-cache-first-definition
		     definitions ,worlds ,(and error-p predicator-form))))))
	 (t ,(cond (error-p
		    `(current-definition-error ,predicator-form ,worlds))))))

(deffun current-definition-error (predicator worlds)
  (let ((new (prolog-error ':predicator-not-symbolic
			   "the predicator ~S should be a symbol"
			   predicator)))
    (current-definition new t worlds)))

(defun find-and-cache-first-definition-nostep
        (definitions worlds &optional predicator-or-no-error)
  (let ((current-definition (find-first-definition (rest1 definitions) worlds)))
    (cond ((not (null current-definition))
           (setf (last-definition-universe definitions) worlds)
           (setf (last-definition definitions) current-definition)
           current-definition)
          (predicator-or-no-error
           (undefined-predicate predicator-or-no-error worlds)))))

(setf #'find-and-cache-first-definition #'find-and-cache-first-definition-nostep)

(defstruct (index (:type list)
                  :conc-name
                  (:constructor nil))
 key-finder table)

(defsubst create-index (key-finder table)
  (list-in-area *structure-area* key-finder table))

(defprop prolog-error t :error-reporter)

(defun prolog-error (type string &rest format-arguments)
  (lexpr-funcall #'cerror t nil type string format-arguments))

(defprop prolog-ferror t :error-reporter)

(defun prolog-ferror (type string &rest format-arguments)
  (lexpr-funcall #'cerror nil nil type string format-arguments))

(defconst *prolog-help*
          (format nil
                  "The syntax of LM-Prolog is:
/(define-predicate <predicator> <clause> <clause> ...) where:
A clause is a cons of a head and a list of goals.
Heads and goals are predications.
A predication is a cons of a symbol and a term.
A term is any s-expression.
A variable is a symbol whose name begins with a single ~a.

~c switches languages.
~c lets you talk to LM-Prolog.
~c returns you to Lisp.

~c rejects the last answer given,
~c accepts the last answer given,
~c undoes the last acceptence made by ~c.

LM-Prolog idioms are available in the PUSER: package.

Type (option (:documentation ~ad) ~apredicator) to get documentation on predicates.
Try running (demos)."
                  *variable-prefix* *roman-iii* *roman-ii* *roman-i*
                  *hand-down* *hand-up* *control-hand-down* *hand-up*
		  *variable-prefix* *variable-prefix*))

(defvar *circularity-mode* ':handle) ;;Can be either 'ignore, ':handle or ':prevent

(defvar *default-lisp-form-mode* ':query)

(defvar *variable-template*)
(defvar *template-index*)

#-PROLOG-MICRO-CODE
(PROGN 'COMPILE

(DEFSUBST TEMPLATE-NAME (TEMPLATE) (CDR TEMPLATE))

(DEFUN make-cons (first rest) (list*-in-area *structure-area* 3 first rest))

(DEFUN make-constant (x) (cons-in-area 0 x *structure-area*))

(DEFUN make-first-occurrence (name index READ-ONLY)
  (COND (READ-ONLY
	 (list*-in-area *structure-area* 4 index READ-ONLY))
	(T (list*-in-area *structure-area* 1 index name))))

(DEFUN make-non-first-occurrence (variable read-only)
  (list*-in-area *structure-area*
		 (cond (read-only 5)
		       (t 2))
		 (second variable) (rest2 variable)))

(DEFUN make-void (name) (list*-in-area *structure-area* 7 name))

(DEFUN first-occurrence-p (term) (MEMQ (first term) '(1 4)))

;THIS IS USED DESTRUCTIVELY
(DEFUN MAKE-VOID-OCCURRENCE (VARIABLE)
  (SETF (CAR VARIABLE) (CDR (ASSQ (CAR VARIABLE) '((1 . 7) (4 . 6)))))
  (SETF (CDR VARIABLE) (CDDR VARIABLE)))

)

#+PROLOG-MICRO-CODE #8R
(PROGN 'COMPILE

(DEFSUBST TEMPLATE-NAME (TEMPLATE) TEMPLATE)

(DEFUN MAKE-CONS (FIRST REST) (CONS-IN-AREA FIRST REST *STRUCTURE-AREA*))

(DEFUN MAKE-CONSTANT (X) (AND X (%MAKE-POINTER DTP-LOCATIVE (LIST-IN-AREA *STRUCTURE-AREA* X))))

(DEFUN MAKE-OCCURRENCE (NAME CLASS INDEX)
  (LET* ((DEFAULT-CONS-AREA *STRUCTURE-AREA*)
	 (V (MAKE-SYMBOL (STRING NAME))))
    (SETF (SYMEVAL V) (SI:%LOGDPB CLASS 2503 INDEX))
    V))

(DEFUN MAKE-FIRST-OCCURRENCE (NAME INDEX READ-ONLY)
  (COND (READ-ONLY (MAKE-OCCURRENCE READ-ONLY 4 INDEX))
	(T (MAKE-OCCURRENCE NAME 0 INDEX))))

(DEFUN MAKE-NON-FIRST-OCCURRENCE (TEMPLATE READ-ONLY)
  (MAKE-OCCURRENCE TEMPLATE (COND (READ-ONLY 5) (T 1)) (SYMEVAL TEMPLATE)))

(DEFUN MAKE-VOID (NAME)
  (MAKE-OCCURRENCE NAME 2 0))

(DEFUN FIRST-OCCURRENCE-P (TEMPLATE)
  (ZEROP (SI:%LOGLDB 2502 (SYMEVAL TEMPLATE))))

;THIS IS USED DESTRUCTIVELY
(DEFUN MAKE-VOID-OCCURRENCE (TEMPLATE)
  (SETF (SYMEVAL TEMPLATE) (SI:%LOGDPB 2 2502 (SI:%LOGDPB 0 0023 (SYMEVAL TEMPLATE))))
  TEMPLATE)

)





(defvar *contains-cut*)

(defun clause-template (predications)
  (let* ((*variable-template* ())
         (*template-index* 0)
         (*contains-cut* nil)
         (template
           (cons-in-area (make-interpreter-template (rest1 (first predications)))
                         (make-interpreter-template (rest1 predications))
                         *structure-area*)))
    (void-if-unique *variable-template* (first predications))
    (values template *contains-cut*)))

(defsubst read-only-name (syntactic-variable)
  (let* ((name (get-pname syntactic-variable))
	 (length (string-length name)))
    (and (string-equal name *variable-prefix* (sub1 length))
         (intern (substring name 0 (sub1 length))
                 (symbol-package syntactic-variable)))))

(define-dtp-entry make-interpreter-template-1 dtp-list (term)
  (multiple-value-bind (first template-first-p)
      (make-interpreter-template-1 (first term))
    (multiple-value-bind (rest template-rest-p)
	(make-interpreter-template-1 (rest1 term))
      (cond ((or template-first-p template-rest-p)
	     (values
	       (make-cons
		 (cond (template-first-p first)
		       (t (make-constant first)))
		 (cond (template-rest-p rest)
		       (t (make-constant rest))))
	       t))
	    (t (cond ((equal '(cut) term) (setq *contains-cut* t)))
	       (values (select (%area-number term)
			 (*structure-area* term)
			 (otherwise (cons first rest)))
		       nil))))))

(define-dtp-entry make-interpreter-template-1 dtp-symbol (term)
  (cond ((syntactic-variable-p term)
	 (cond ((anonymous term)
		(values (make-void term) t))
	       (t (LET ((READ-ONLY-NAME (READ-ONLY-NAME TERM)))
		    (template-of-variable
		      (OR READ-ONLY-NAME TERM) nil read-only-name)))))
	((and (null (symbol-package term))
	      (temporary-area-p (%area-number term)))
	 (prolog-ferror ':attempt-to-assert-temporary-symbol
		 "The symbol ~s was created in a temporary area ~
 			and cannot be added to database." term))
	(t (values term nil))))

(define-dtp-entry make-interpreter-template-1 dtp-locative (term)
  (template-of-variable term t nil))	   ;7.12

(define-dtp-entry make-interpreter-template-1 dtp-instance (term)
  (cond ((typep term 'prolog-flavor)
	 (multiple-value-bind (ordinary-term prolog-flavor-p)
	     (send term ':ordinary-term)
	   (cond (prolog-flavor-p
		    (COND ((TYPEP TERM 'READ-ONLY-VARIABLE)
			   (let ((cell (send term ':cell)))
			     (template-of-variable cell t (value-cell-name cell))))
			  (T (values ordinary-term nil))))
		 (t (make-interpreter-template-1 ordinary-term)))))
	(t (values term nil))))

(defun make-interpreter-template (term)
 (multiple-value-bind (template-or-constant template-p)
     (make-interpreter-template-1 term)
   (cond (template-p template-or-constant)
         (t (make-constant template-or-constant)))))

(defun template-of-variable (term locative-p read-only)
  (let ((old-variable-template (assq term *variable-template*)))
    (cond ((null old-variable-template)
           (let ((template (make-first-occurrence  ;7.12
			     ;;For compiler's sake the v.c. name must not be NIL.
			     (cond ((not locative-p) term)
				   ((value-cell-name term))
				   (t (prolog-intern *variable-prefix*)))
			     (1- (incf *template-index*))
			     read-only)))
             (push-in-area (prolog-list term template) *variable-template* *prolog-work-area*)
             (values template t)))
          ((first-occurrence-p (second old-variable-template))
           (let ((template
		   (make-non-first-occurrence (second old-variable-template) read-only)))
             (setf (second old-variable-template) template)
             (values template t)))
          (t (values (make-non-first-occurrence (second old-variable-template) read-only)
		     t)))))

(defvar *warn-if-variable-occurs-once* t)

#-symbolics
(deff prolog-warn 'compiler:warn)

#+symbolics
(defun prolog-warn (ignore ignore control-string &rest arguments)
  ;;compiler:warn incompatibly changed on Symbolics
  (terpri)
  (lexpr-funcall #'format t control-string arguments))

(deffun void-if-unique (VARIABLE-TEMPLATE-PAIRS head)
 (cond ((not (null VARIABLE-TEMPLATE-PAIRS))
	(LET ((TEMPLATE (second (first VARIABLE-TEMPLATE-PAIRS))))
	  (COND ((FIRST-OCCURRENCE-P TEMPLATE)
		 (MAKE-VOID-OCCURRENCE TEMPLATE)
		 (LET ((NAME (TEMPLATE-NAME TEMPLATE)))
		   (and *warn-if-variable-occurs-once*
			(symbolp name)
			(or (null name);;a dynamic assertion without variable names
			    (string-equal-symbol *ignore-syntax* name t)
			    (string-equal-symbol *variable-underscore-prefix* name t)
			    (string-equal-symbol *variable-prefix* name nil)
			    (prolog-warn ':variable-occurs-once
					 ':implausible
					 "~%Warning: ~s occurs just once in (~a ...)."
					 name
					 head))))))
	  (void-if-unique (rest1 VARIABLE-TEMPLATE-PAIRS) head)))))
 
(defvar *global-names* ()
  "alist associating global variable names and their value cells")

(defsubst global-value (name) (rest1 (assq name *global-names*)))

(defvar *parse-alist*)

(defun parse-term (term &optional top-level-p)
  (let ((*parse-alist*)) (parse-term-1 term top-level-p)))

(defun parse-term-1 (term &optional top-level-p)	;8.2
  (cond ((consp term)
         (prolog-cons
           (parse-term-1 (car term) top-level-p)
           (parse-term-1 (cdr term) top-level-p)))
        ((anonymous term) (%cell term))
        ((syntactic-variable-p term)
         (let ((name (read-only-name term)))
           (cond ((null name)
                  (cond ((cdr (assq term *parse-alist*)))
                        (top-level-p
                         (let ((value-cell (global-value term)))
                           (cond (value-cell
                                  (parse-term-1 value-cell top-level-p))
                                 (t (let ((cell (%cell term)))
				      (push-in-area (prolog-cons term cell)
						    *global-names*
						    *prolog-work-area*)
                                      (push-in-area (prolog-cons term cell)
                                                    *parse-alist*
						    *prolog-work-area*)
                                      cell)))))
                        (t (let ((cell (%cell term)))
                             (push-in-area (prolog-cons term cell)
                                           *parse-alist*
					   *prolog-work-area*)
                             cell))))
                 (t (make-instance-in-area *prolog-work-area*
                                           'read-only-variable
                                           ':cell
                                           (parse-term-1 name top-level-p))))))
	((and (symbolp term) (string-equal-symbol *variable-prefix* term t))
	 ;;must strip a ?
	 (let-if *prolog-work-area* ((default-cons-area *prolog-work-area*))
	   (cond ((symbol-package term)
		  (intern (substring term 1 nil) (symbol-package term)))
		 (t (make-symbol (substring term 1 nil))))))
        (t term)))

(defvar *variables-alist* () "Alist used when copying terms to preserve isomorphy")

;;*vector* is long enough for 4 recursive entries to %unify-term-with-template
;;or %construct, beyond that the more expensive stack list are used.
;;the need for a new *vector* is when unifying constraints or clauses
;;inside of the interpreter
(defvar *original-vector* (make-list 256. ':area *structure-area*))
(setq *vector* *original-vector*)

(defmacro with-new-*vector* (&body body)
 `(let ((*vector* (rest1 (%make-pointer-offset dtp-list *vector* 63.))))
    (cond ((null *vector*)
	   (with-stack-list
	     (*vector* . #.(MAKE-LIST 64. ':INITIAL-VALUE NIL))
	     ,@body))
	  (t ,@body))))

(defsubst plain-displace (old new)
  (setf (first old) (first new))
  (setf (rest1 old) (rest1 new)))

(defmacro push-if-not-memq (item access)
  `(let ((item ,item))
     (cond ((not (memq item ,access)) (push item ,access)))))

(defmacro push-if-not-member (item access)
  `(let ((item ,item))
     (cond ((not (member item ,access)) (push item ,access)))))

(defconst *circularity-marker* (cons nil nil))
(defconst *circularity-cons* (cons *circularity-marker* *circularity-marker*))

;;Can't tail recurse due to WITH-CONS-BOUND-TO-CONS.
(defun circular-p (x)
  (cond ((consp x)
	 (cond ((structure-area-p (%area-number x)) nil)
	       (t
		(WITH-CONS-PARTS X
		  (let ((first (first x))
			(rest1 (rest1 x)))
		    (cond ((or (eq first *circularity-marker*)
			       (eq rest1 *circularity-marker*)))
			  (t (WITH-CONS-BOUND-TO-CONS x *circularity-cons*
			       (or (circular-p first) (circular-p rest1))))))))))
        ((typep x 'prolog-flavor)
         (multiple-value-bind (ordinary-term prolog-flavor-p)
             (send x ':ordinary-term)
           (and (not prolog-flavor-p) (circular-p ordinary-term))))))

(define-dtp-entry copy-term-1 dtp-locative (x)
  (let ((assq (assq x *variables-alist*)))
    (cond (assq (cdr assq))
          (t (let ((c (%cell (value-cell-name x))))
	       (push-in-area (prolog-cons x c) *variables-alist* *prolog-work-area*)
	       c)))))

(define-dtp-entry copy-term-1 dtp-list (ignore)
  (prolog-ferror ':no-circularity-mode
		 "No circularity mode seems to have been selected!"))

;;This is what we want to say. Unfortunately, DTP-RPLACD-FORWARD trick doesn't work here.
;;(defun copy-cons-circular (x)
;;  (with-cons-parts x
;;    (cond ((or (eq (car x) 'to-be-clobbered) (eq (cdr x) 'to-be-clobbered))
;;	     x)
;;	  (t (let ((car-x (car x))
;;		   (cdr-x (cdr x))
;;		   (temporary
;;		     (cons-in-area
;;		       'to-be-clobbered 'to-be-clobbered *prolog-work-area*)))
;;	       (with-cons-bound-to-cons x temporary
;;		 (rplaca temporary (%reference (copy-term-1 car-x)))
;;		 (rplacd temporary (%reference (copy-term-1 cdr-x)))
;;		 temporary))))))

(defun copy-cons-circular (x)
  (cond ((structure-area-p (%area-number x)) x)
	(t (let ((item (assq x *conses-alist*))) ;;the slow but simple way...
	     (cond (item (cdr item))
		   (t (with-stack-list*
			(pair x (cons-in-area 'to-be-clobbered 'to-be-clobbered
					      *prolog-work-area*))
			(with-stack-list* (*conses-alist* pair *conses-alist*)
			  (rplaca (cdr pair) (%reference (copy-term-1 (car x))))
			  (rplacd (cdr pair) (%reference (copy-term-1 (cdr x))))
			  (cdr pair)))))))))

(defun copy-cons-no-circular (x)
  (cond ((structure-area-p (%area-number x)) x)
	(t (prolog-cons (copy-term-1 (car x)) (copy-term-1 (cdr x))))))

(define-dtp-entry copy-term-1 dtp-instance (x)
  (cond ((typep x 'prolog-flavor) (send x ':copy)) (t x)))

(defun copy-term (term)
  (let ((*variables-alist* ())) (copy-term-1 term)))

(deffun keyify (value)
  (select (%data-type value)
    (dtp-list (keyify (car value)))
    (dtp-instance
     (cond ((typep value 'prolog-flavor)
            (multiple-value-bind (ordinary-term prolog-flavor-p)
                (send value ':ordinary-term)
              (cond (prolog-flavor-p ordinary-term)
                    (t (keyify ordinary-term)))))
           (t value)))
    (t value)))

(deffun index-selector-form (arglist form)
  (cond ((and (symbolp arglist) (string-equal-symbol "+" arglist t)) form)
        ((CONSP arglist)
         (or (index-selector-form (car arglist) `(careful-first ,form))
             (index-selector-form (cdr arglist) `(careful-rest1 ,form))))))

(deffun do-to-each-index (indexes argument-list action)
  (cond (indexes
         (let* ((index (first indexes))
                (table (index-table index))
                (key (funcall (index-key-finder index) argument-list)))
           (cond ((not (value-cell-p key))
                  (funcall action key table (gethash key table))))
           (do-to-each-index (rest1 indexes) argument-list action)))))


(defun make-instance-in-area (area flavor &rest init-plist)
  (instantiate-flavor flavor (locf init-plist) nil nil area))

(defun make-instance-in-area-and-initialize (area flavor &rest init-plist)
  (instantiate-flavor flavor (locf init-plist) t nil area))

;Default methods for PROLOG-FLAVOR.

(defmethod (prolog-flavor :car) ()
  (multiple-value-bind (ordinary-term prolog-flavor-p)
      (send self ':ordinary-term)
    (cond (prolog-flavor-p
           (prolog-error ':cant-take-car "Can't take CAR of ~s" ordinary-term))
          (t (car ordinary-term)))))

(defmethod (prolog-flavor :cdr) ()
  (multiple-value-bind (ordinary-term prolog-flavor-p)
      (send self ':ordinary-term)
    (cond (prolog-flavor-p
           (prolog-error ':cant-take-cdr "Can't take CDR of ~s" ordinary-term))
          (t (cdr ordinary-term)))))

(defmethod (prolog-flavor :copy) () self)

(defmethod (prolog-flavor :unify) (other)
  (multiple-value-bind (ordinary-term prolog-flavor-p)
      (send self ':ordinary-term)
    (and (not prolog-flavor-p) ;;what about EQ?
         (%unify-term-with-term ordinary-term other))))

(defmethod (prolog-flavor :lisp-form) (mode)
  (selectq mode
    ((:invoke :copy)
     (multiple-value-bind (ordinary-term prolog-flavor-p)
         (send self ':ordinary-term)
       (cond (prolog-flavor-p ordinary-term)	;Dangerous if the mode is :copy ...
             (t (lisp-form-1 ordinary-term mode)))))
    (:dont-invoke self)
    (:query 
     (selectq (send self ':query-user)
       (no self)
       (yes
        (multiple-value-bind (ordinary-term prolog-flavor-p)
            (send self ':ordinary-term)
          (cond (prolog-flavor-p ordinary-term)
                (t (lisp-form-1 ordinary-term mode)))))
       (proceed
        (multiple-value-bind (ordinary-term prolog-flavor-p)
            (send self ':ordinary-term)
          (cond (prolog-flavor-p ordinary-term)
                (t (lisp-form-1 ordinary-term ':invoke)))))))
    (otherwise
     (send self ':lisp-form
	   (prolog-error 'bad-lisp-form-mode
			 "~s is not a recoginized lisp-form mode" mode)))))

(defmethod (prolog-flavor :query-user) () 'yes) ;;good default???

(defmethod (prolog-flavor :variable-p) () nil) ;;good default

;;This used to be per window, still being used somewhere in the compiler.
(defvar *value-cell-names* ())

(define-dtp-entry lisp-form-1 dtp-locative (x mode)	;8.2
  (selectq mode
    (:print					;for constraints
     (cond ((value-cell-name x) (extended-name x))
	   (t (prolog-symbol
	       ;;if the garbage collector came by here...
	       "~a~d"
	       *variable-prefix*
	       (- (%pointer x) (sys:region-origin (%region-number x)))))))
    (:copy
     (cond ((value-cell-name x) (intern (get-pname (extended-name x))))
	   (t (prolog-intern
	       ;;if the garbage collector came by here...
	       "~a~d"
	       *variable-prefix*
	       (- (%pointer x) (sys:region-origin (%region-number x)))))))
    (t x)))

(defvar *value-cell-names-array* (make-array 256.)
  "Indexed by area number, each elt holds an alist of value cell and print name.")

(defun extended-name (x)
  ;;Compute a unique print name of the value cell X.
  (let* ((*prolog-work-area* (%area-number x))
	 (name (rest1 (assq x (aref *value-cell-names-array* *prolog-work-area*)))))
    (cond (name name)
	  (t (setq name (value-cell-name x))
	     (cond ((not (symbolp name))
		    (prolog-ferror ':bad-name "~S is not a symbol" name))
		   (t (let ((number-with-same-name
			      (count-cells-with-name
				name (aref *value-cell-names-array* *prolog-work-area*))))
			(cond ((and (zerop number-with-same-name)
				    (not (string-equal-symbol *variable-prefix* name))))
			      (t (setq name (prolog-symbol
					      "~a_~d" name number-with-same-name)))))
		      (push-in-area (cons-in-area x name *prolog-work-area*)
				    (aref *value-cell-names-array* *prolog-work-area*)
				    *prolog-work-area*)
		      name))))))

(define-dtp-entry lisp-form-1 dtp-symbol (x mode)	;8.2
  (cond ((string-equal-symbol *variable-prefix* x t)
	 ;;symbols beginning with ? are really symbols beginning with ??
	 (cond ((symbol-package x)
		(let ((package (symbol-package x)))
		  (prolog-intern "~a~a" *variable-prefix* x)))
	       (t (permanent-symbol "~a~a" *variable-prefix* x))))
	((and (eq mode ':copy)
	      (null (symbol-package x))
	      (temporary-area-p (%area-number x)))
	 (permanent-symbol (get-pname x)))
	(t x)))

(define-dtp-entry lisp-form-1 dtp-list (ignore ignore)
  (prolog-ferror ':no-circularity-mode
		 "No circularity mode seems to have been selected!"))

;;This is what we want to say. Unfortunately, DTP-RPLACD-FORWARD trick doesn't work here.
;;(defun cons-form-circular (x)
;;  (with-cons-parts x
;;    (cond ((or (eq (car x) 'to-be-clobbered) (eq (cdr x) 'to-be-clobbered))
;;	     x)
;;	  (t (let ((car-x (car x))
;;		   (cdr-x (cdr x))
;;		   (temporary
;;		     (cons-in-area
;;		       'to-be-clobbered 'to-be-clobbered *prolog-work-area*)))
;;	       (with-cons-bound-to-cons x temporary
;;		 (rplaca temporary (%reference (lisp-form-1 car-x)))
;;		 (rplacd temporary (%reference (lisp-form-1 cdr-x)))
;;		 temporary))))))

(defun cons-form-circular (x mode)
  (cond ((structure-area-p (%area-number x)) x)
	(t
	 (let ((item (assq x *conses-alist*))) ;;the slow but simple way...
	   (cond (item (cdr item))
		 (t (with-stack-list*
		      (pair x (cons-in-area 'to-be-clobbered 'to-be-clobbered
					    *prolog-work-area*))
		      (with-stack-list* (*conses-alist* pair *conses-alist*)
			(rplaca (cdr pair) (%reference (lisp-form-1 (car x) mode)))
			(rplacd (cdr pair) (%reference (lisp-form-1 (cdr x) mode)))
			(cdr pair)))))))))

(defun cons-form-no-circular (x mode)
  (cond ((structure-area-p (%area-number x)) x)
	((eq mode ':copy)
	 (prolog-cons (lisp-form-1 (first x) mode) (lisp-form-1 (rest1 x) mode)))
	(t
	 (let ((new-first (lisp-form-1 (first x) mode))
	       (new-rest (lisp-form-1 (rest1 x) mode)))
	   (cond ((and (eq new-first (first x)) (eq new-rest (rest1 x))) x)
		 (t (prolog-cons new-first new-rest)))))))

(define-dtp-entry lisp-form-1 dtp-instance (x mode)
  (cond  ((typep x 'prolog-flavor) (send x ':lisp-form mode))
	 (t x)))

(defun lisp-form (x &optional (mode *default-lisp-form-mode*))
  ;;Called by run-time system, not by compiled code.
 (selectq mode
   (:dont-invoke x)
   (:COPY (LET ((*PROLOG-WORK-AREA* WORKING-STORAGE-AREA)) (LISP-FORM-1 X MODE)))
   (otherwise (lisp-form-1 x mode))))

(deffun count-cells-with-name (name value-cells-plus &optional (count 0))
  (cond ((null value-cells-plus) count)
        ((%STRING-EQUAL (GET-PNAME name) 0
			(GET-PNAME (value-cell-name (first (first value-cells-plus)))) 0
			NIL)
         (count-cells-with-name name (rest1 value-cells-plus) (add1 count)))
        (t (count-cells-with-name name (rest1 value-cells-plus) count))))

(defmacro establish-condition-handlers (&body body)
  `(condition-bind (((sys:undefined-function)
		     #'(lambda (condition)
			 (cond ((definitions (send condition ':function-name))
				(going-to-prolog-p (send condition ':function-name))))))
		    #-symbolics
		    ((eh:stack-frame-too-large)
                     #'(lambda (ignore)
                         (prolog-ferror ':unbound-variable-as-rest-argument
"The Prolog compiler does not support calls
whose last cons ends with a unbound variable.")))
                    ((sys:unclaimed-message)
                     #'(lambda (condition)
                         (let ((message
				 (send condition #-symbolics ':get ':message)))
                           (cond ((eq message ':unify)
                                  ;;should change arguments too!!
                                  (values ':new-operation ':send-if-handles))))))
                    ((sys:wrong-type-argument)
                     #'(lambda (condition)
			 (let (argument)
			   (cond ((setq argument
					(send condition ':send-if-handles
					      ':arg-pointer))
				  (cond ((typep argument 'prolog-flavor)
					 (values ':argument-value
						 (send argument
						       ':ordinary-term)))))
				 ((setq argument
					(send condition ':send-if-handles
					      ':old-value))
				  (cond ((typep argument 'prolog-flavor)
					 (values ':substitute-new-value-in-stack-call
						 (send argument
						       ':ordinary-term))))))))))
		   ,@body))

(defvar *variables-shared-between-top-level-stack-groups*
        '(*trail-array* function continuation arglist
	  *prolog-work-area* *cut-tag*
	  *vector* ;;*universe* etc. are missing here
	  terminal-io standard-input standard-output query-io
	  #-symbolics package ;;I don't know why but otherwise I really break the reader
           ))

(defvar *variables-shared-between-stack-groups*
        '(*trail-array* function continuation arglist
	  *prolog-work-area* *cut-tag*
	  *vector* *universe* *default-lisp-form-mode*
	  terminal-io standard-input standard-output query-io
	  #-symbolics package ;;I don't know why but otherwise I really break the reader
	  )) 

(advise si:print-random-object :around print-value-cell nil
  (or (print-value-cell (first arglist) (second arglist)) :do-it))

(defun print-value-cell (object stream)
  (cond ((and (value-cell-p object)
	      (eq object (%p-contents-as-locative object))
	      (= dtp-locative (%p-data-type object)))
	 ;;then we are probably an unbound prolog value cell
	 (cond ((null (value-cell-name object))
		(format stream
			"~a~d"
			*variable-prefix*
			(- (%pointer object) (sys:region-origin (%region-number object)))))
	       ((symbolp (value-cell-name object))
		(send stream ':string-out (get-pname (extended-name object))))
	       (t (format stream
			  "~a[~S]"
			  *variable-prefix*
			  (value-cell-name object))))
         object)))


;;used in control-primitives and by instead-of-ucode
(deffun variables-in-no-circularity (term &optional so-far)
  (cond ((consp term)
         (variables-in-no-circularity
	  (rest1 term)
	  (variables-in-no-circularity (first term) so-far)))
        ((unbound-variable-p term)
         (cond ((memq-2 term so-far) so-far)
               (t (prolog-cons term so-far))))
        (t so-far)))

(defun variables-in-circularity (term &optional so-far)
  (cond ((consp term)
         (with-cons-parts term
           (let ((first (first term))
                 (rest1 (rest1 term)))
             (cond ((eq first *circularity-marker*) so-far)
                   (t (with-cons-bound-to-cons term *circularity-cons*
                        (variables-in-circularity first
                             (variables-in-circularity rest1 so-far))))))))
        ((unbound-variable-p term)
         (cond ((memq-2 term so-far) so-far)
               (t (prolog-cons term so-far))))
        (t so-far)))

(deffun variable-names-in-no-circularity (term &optional so-far)
  (cond ((consp term)
         (variable-names-in-no-circularity
	  (rest1 term)
	  (variable-names-in-no-circularity (first term) so-far)))
        ((value-cell-p term)
         (let ((name (value-cell-name term)))
           (cond ((memq-2 name so-far) so-far)
                 (t (prolog-cons name so-far)))))
        (t so-far)))

(defun variable-names-in-circularity (term &optional so-far)
  (cond ((consp term)
         (with-cons-parts term
           (let ((first (first term))
                 (rest1 (rest1 term)))
             (cond ((eq first *circularity-marker*) so-far)
                   (t (with-cons-bound-to-cons term *circularity-cons*
                        (variable-names-in-circularity first
                             (variable-names-in-circularity rest1 so-far))))))))
        ((value-cell-p term)
         (let ((name (value-cell-name term)))
           (cond ((memq-2 name so-far) so-far)
                 (t (prolog-cons name so-far)))))
        (t so-far)))

(deffun not-ground-p-no-circularity (x)		;7.12
  (cond ((consp x)
         (or (not-ground-p-no-circularity (car x))
	     (not-ground-p-no-circularity (cdr x))))
         ((unbound-variable-p x) x)))

(defun not-ground-p-circularity (x)		;7.12
  (cond ((consp x)
         (with-cons-parts x
           (let ((first (first x))
                 (rest1 (rest1 x)))
             (cond ((eq first *circularity-marker*) nil)
                   (t (with-cons-bound-to-cons x *circularity-cons*
                        (or (not-ground-p-circularity first)
			    (not-ground-p-circularity rest1))))))))
        ((unbound-variable-p x) x)))

;;This returns either T or NIL,some-x,some-y where some-x,some-y is a counter-example.
(defun identical-p (x y)
  (let ((mark *trail*))
    (cond ((eq x y) t)
	  ((not (unify x y)) (untrail mark) (values nil t nil))
	  ((= mark *trail*) t)
	  ((value-cell-p (aref *trail-array* mark))
	   (let* ((item1 (aref *trail-array* mark))
		  (item2 (cdr item1)))
	     (untrail mark)
	     (values nil (%dereference item1) (%dereference item2))))
	  ((value-cell-p (aref *trail-array* (1+ mark)))
	   (let* ((item1 (aref *trail-array* (1+ mark)))
		  (item2 (cdr item1)))
	     (untrail mark)
	     (values nil (%dereference item1) (%dereference item2))))
	  (t (prolog-ferror ':internal "IDENTICAL can't find values to return.")))))

(defun set-circularity-mode (mode-name)
  (selectq mode-name
    (:ignore (install-circularity-mode-ignore)
             (alter-dtp-entry lisp-form-1 dtp-list #'cons-form-no-circular)
             (alter-dtp-entry copy-term-1 dtp-list #'copy-cons-no-circular)
             (setf #'variables-in 'variables-in-no-circularity)
             (setf #'variable-names-in 'variable-names-in-no-circularity)
             (setf #'not-ground-p 'not-ground-p-no-circularity)
             (setq *circularity-mode* mode-name))
    (:handle (install-circularity-mode-handle)
             (alter-dtp-entry lisp-form-1 dtp-list #'cons-form-circular)
             (alter-dtp-entry copy-term-1 dtp-list #'copy-cons-circular)
             (setf #'variables-in 'variables-in-circularity)
             (setf #'variable-names-in 'variable-names-in-circularity)
             (setf #'not-ground-p 'not-ground-p-circularity)
             (setq *circularity-mode* mode-name))
    (:prevent (install-circularity-mode-prevent)
              (alter-dtp-entry lisp-form-1 dtp-list #'cons-form-no-circular)
              (alter-dtp-entry copy-term-1 dtp-list #'copy-cons-no-circular)
              (setf #'variables-in 'variables-in-no-circularity)
              (setf #'variable-names-in 'variable-names-in-no-circularity)
              (setf #'not-ground-p 'not-ground-p-no-circularity)
              (setq *circularity-mode* mode-name))
    (otherwise
     (set-circularity-mode
       (prolog-error ':bad-circularity-mode
                     "~s should be either :IGNORE, :HANDLE, or :PREVENT" mode-name)))))

(set-circularity-mode ':ignore) ;;for speed

#+3600
(advise compiler:phase-1-warning :around let-if-spurious-warning 0
  (cond ((not (string-equal
                (first arglist) 
                "VALUE-CELL-LOCATION on local or instance variable ~S; ~
use LOCF or VARIABLE-LOCATION"))
         :do-it)))

(defmacro with-who-line (string &body body)
  `(let ((old-who-state (tv:process-whostate current-process)))
    (unwind-protect
      (progn (setf (tv:process-whostate current-process) ,string)
             (tv:who-line-run-state-update)
             ,@body)
      (setf (tv:process-whostate current-process) old-who-state)
      (tv:who-line-run-state-update))))

(compile-encapsulations 'si:print-random-object)

;;This logically belongs to DB-SUPPORT, but is used there inside another macroexpansion.
;;With an EVAL-WHEN, it screws Symbolics and LMI pre-Release 2.
;;Without an EVAL-WHEN, it screws LMI post-Release 2.
(defmacro option-value (type-form options
                        &optional (default-options '*default-options*))
  (cond ((and (consp type-form) (eq (first type-form) 'quote))
         (let* ((type (second type-form))
                (selector (get type 'value-option-selector)))
           (cond ((null selector)
                  (prolog-ferror ':undefined-define-option
				 "~s is not a define-predicate option" type))
                 (t `(,selector
                      (or (assq-2 ,type-form (rest1 ,options))
                          (assq-2 ,type-form (rest1 ,default-options))))))))
        (t `(funcall (or (get ,type-form 'value-option-selector)
                         (prolog-ferror ':undefined-define-option
					"~s is not a define-predicate option" ,type-form))
                     (or (assq-2 ,type-form (rest1 ,options))
                         (assq-2 ,type-form (rest1 ,default-options)))))))