;     -*- Mode:LISP; Package:OBJ; Base:10; Readtable:CL; Syntax: Common-lisp -*-

;; Copyright (C) Gary Drescher 1984, 1985
;; Licensed to and distributed by Lisp Machine, Inc.
;;   See filename "Copyright" for
;; licensing and release information.

(in-package "OBJ")

;;;; Objects and envlist

; BEGINNING OF REPRESENTATION-DEPENDENT CODE FOR OBJECTS.

(defmicroparameter *object nil)
(defmicroparameter *val-class-disp nil)
(defmicroparameter *fcn-class-disp nil)
(defmicroparameter *instance-envs nil)

(defmicroparameter *shadows nil)

(defun obj-print-fcn (obj #+lambda standard-output  #-lambda *standard-output*
			  ignore) #-(or lambda symbolics) ignore
  (print-object obj))

;MAKE-OBJ is called with a list of environments, innermost to outermost.
(defstruct (obj (:conc-name nil) #+lambda(:callable-constructors nil)
		(:constructor %make-obj (obj-envlist obj-superiors))
		(:print-function #-dec obj-print-fcn #+dec 'obj-print-fcn))
  obj-instance-envs
  obj-val-class-disp  ;;; Value class-bindings dispatch table, if any, else NIL.
  obj-fcn-class-disp  ;;; Procedure class-bindings dispatch table, if any, els NIL
  obj-class?
  obj-envlist       ;;; List of environments comprising this object, innermost to
                    ;;;  outermost.  Global env is implicit.
  obj-superiors     ;;; Args from KINDOF, for documentation.
  obj-index
  )

(defvar *internal-global-obj (%make-obj nil nil))

(defsubst global-obj? (obj)
  (or (null obj) (eq obj *internal-global-obj)))

; END OF REPRESENTATION-DEPENDENT CODE FOR OBJECTS.

;;;; Environments

; BEGINNING OF REPRESENTATION-DEPENDENT CODE FOR ENVIRONMENTS.

(defstruct (environment (:conc-name nil) #+lambda(:callable-constructors nil))
  env-class-objs     ;;All objects in which this is a class env, except any obj
                     ;;; that >shares< its class-disp tables with its superior.
  env-instance-objs  ;;All objects in which this is an instance env.
  (env-val-bindings  ;;Table of values bound locally in this env.
    (make-binding-table))
  (env-fcn-bindings  ;;Table of functions bound locally in this env.
    (make-binding-table))
  env-object         ;;Object for which this is outermost env (for documentation).
  env-instance-var-inits
  )

(defsubst obj-envs (obj)
  (if obj (obj-envlist obj)))

(defmacro own-env (obj)
  `(car (obj-envs ,obj)))

(defmacro global-env? (env)
  `(null ,env))

(defmacro object? (object)
  `(typep ,object 'obj))

(defmacro binding-from-env (link env)
  `(lookup-binding ,link (env-val-bindings ,env)))

(defmacro fbinding-from-env (link env)
  `(lookup-binding ,link (env-fcn-bindings ,env)))

; END OF REPRESENTATION-DEPENDENT CODE FOR ENVIRONMENTS.

; BEGINNNG OF REPRESENTATION-DEPENDENT CODE FOR LINKS.

(defstruct (val-link (:include link)
		     (:conc-name nil) #+lambda(:callable-constructors nil)
		     (:constructor make-val-link
				   (link-key link-index link-dispatch)))
  link-dispatch
  (link-memo-key t)           ;; An envlist, class-disp table, or T if no key.
  link-memo-binding           ;; A binding, if valid.
 )

(defstruct (fcn-link (:include val-link)
		     (:conc-name nil) #+lambda(:callable-constructors nil)
		     (:constructor make-fcn-link
				   (link-key link-index link-dispatch)))
 ;link-memo-binding           ;; Innermost fbinding, if memo is valid.
  link-memo-shadows           ;; List* of remaining fbindings, inner to outer.
)

(defmacro link-symbol (link)
  `(link-key ,link))

(defmacro get-val-link? (sym)
  `(get ,sym 'val-link))

(defmacro get-fcn-link? (sym)
  `(get ,sym 'fcn-link))

(defun linkup-val (sym &aux (link
			      (make-val-link sym (sxhash sym) *val-lookup-global-only)))
  (declare (special *val-lookup-global-only))
  (setf (get sym 'val-link) link)
  (adjust-global-val-lookups link)
  link)

(defun linkup-fcn (sym &aux (link
			      (make-fcn-link sym (sxhash sym) *fcn-lookup-global-only)))
  (declare (special *fcn-lookup-global-only))
  (setf (get sym 'fcn-link) link)
  (adjust-global-fcn-lookups link)
  link)

(defun get-val-link (sym)
  (or (get-val-link? sym)
      (linkup-val sym)))

(defun get-fcn-link (sym)
  (or (get-fcn-link? sym)
      (linkup-fcn sym)))


; END OF REPRESENTATION-DEPENDENT CODE FOR LINKS.


; BEGINNNG OF REPRESENTATION-DEPENDENT CODE FOR DISPATCHES.

(defun make-class-disp-table (&rest key-val-pairs)
  (apply 'make-table key-val-pairs))

(defmacro class-insert (link binding disp)
  `(insert ,link ,binding ,disp))

(defmacro class-remove (link disp)
  `(table-remove ,link ,disp))

(defmacro class-lookup (link disp)
  `(car (lookup ,link ,disp)))

; END OF REPRESENTATION-DEPENDENT CODE FOR DISPATCHES.

;;;; Bindings

; BEGINNING OF REPRESENTATION-DEPENDENT CODE FOR BINDINGS.

; Bindings format: table.
; Binding format:
; RASSQ-CONS of (val/fcn . link) or SYM for global val/fcn cell, except
;  (LOCF SYM) or (LOCF #'SYM) in place of SYM if *LOCF? is nonnull.

(defun make-binding-table (&rest key-val-pairs)
  (apply #'make-table key-val-pairs))

(defmacro make-binding (link val)
  `(cons ,val ,link))

(defmacro insert-binding (link val bindings)
  `(insert ,link ,val ,bindings))

(defmacro remove-binding (link bindings)
  `(table-remove ,link ,bindings))

(defmacro bindings-map (fcn bindings)
  `(table-map ,fcn ,bindings))

(defmacro bindings-map-return (fcn bindings)
  `(table-map-return ,fcn ,bindings))

(defmacro lookup-binding (link bindings)
  `(lookup ,link ,bindings))

(defmacro nonglobal-binding-sym (binding)
  `(link-symbol (cdr ,binding)))

(defmacro nonglobal-binding-link (binding)
  `(cdr ,binding))

(defmacro binding-val (binding)
  (if *locf?
      `(car ,binding)
      `(let ((binding ,binding))
	 (if (symbolp binding)
	     (symbol-value binding)
	     (car binding)))))

(defmacro nonglobal-binding-fcn (binding)
  `(car ,binding))

(defmacro binding-fcn (binding)
  (if *locf?
      `(car ,binding)
      `(let ((binding ,binding))
	 (if (symbolp binding)
	     (symbol-function binding)
	     (nonglobal-binding-fcn binding)))))

(defun %shadowed-noop (&rest args)
  (declare (ignore args))
  nil)

(defmacro global-binding-fcn-for-shadow (symbol-or-loc)
  (if *locf?
      `(let ((loc ,symbol-or-loc))
	 (if (location-boundp loc)
	     (car loc)
	     #'%shadowed-noop))
      `(let ((sym ,symbol-or-loc))
         (if (fboundp sym)
	     (symbol-function sym)
	     #'%shadowed-noop))))

(defmacro binding-fcn-for-shadow (binding)
  `(let ((binding ,binding))
     (if (consp binding)
	 (nonglobal-binding-fcn binding)
         (global-binding-fcn-for-shadow binding))))

(defmacro set-binding-val (binding val)
  (if *locf?
      `(setf (car ,binding) ,val)
      `(let ((binding ,binding))
	 (if (symbolp binding)
	     (set binding ,val)
	     (setf (car binding) ,val)))))

(defmacro set-binding-fcn (binding fcn)
  (if *locf?
      `(setf (car ,binding) ,fcn)
      `(let ((binding ,binding))
	 (if (symbolp ,binding)
	     (setf (symbol-function binding) ,fcn)
	     (setf (car binding) ,fcn)))))


(defmacro global-val-binding (link)
  (if *locf?
      `(locf (symbol-value (link-symbol ,link)))
      `(link-symbol ,link)))

(defmacro global-fcn-binding (link)
  (if *locf?
      `(locf (symbol-function (link-symbol ,link)))
      `(link-symbol ,link)))

; END OF REPRESENTATION-DEPENDENT CODE FOR BINDINGS.

;FINDING BINDINGS.

;Global binding-- the symbol itself-- >IS< included.
(microdefun binding-from-envlist (link envlist)
  (nloop (for-in env envlist)
	 (for binding (binding-from-env link env))
	 (if binding (return-from nil binding))
	 (finally (global-val-binding link))))

;Global binding-- the symbol itself-- is >NOT< included.
(microdefun binding-from-envlist-proper (link envlist)
  (nloop (for-in env envlist)
	 (for binding (binding-from-env link env))
	 (if binding (return binding))))

;Returns list of fbindings of SYM in ENVLIST, inner to outer binding.
;Global binding-- the symbol itself-- >IS< included.
(microdefun fbindings-from-envlist (link envlist)
  (nconc (nloop (collecting t)
		(for-in env envlist)
		(for fbinding (fbinding-from-env link env))
		(if fbinding (collect fbinding)))
	 (ncons (global-fcn-binding link))))

;Returns two values:
; 1) the innermost fbinding of SYM in ENVLIST.
; 2) list of the remaining fbindings of SYM in ENVLIST, inner to outer binding.
;Global binding-- the symbol itself-- is >NOT< included.
(microdefun fbindings-from-envlist-proper (link envlist &aux new-fbinding fbs)
  (setq fbs
	(nloop (collecting t)
	       (for-in env envlist)
	       (for fbinding (fbinding-from-env link env))
	       (when fbinding
		 (if (null new-fbinding)
		     (setq new-fbinding fbinding)
		     (collect fbinding)))))
  (values new-fbinding fbs))

(microdefun fbinding-from-envlist (link envlist)
  (nloop (for-in env envlist)
	 (for fbinding (fbinding-from-env link env))
	 (if fbinding (return fbinding))
	 (finally (global-fcn-binding link))))

(microdefun fbinding-from-object (link obj)
  (fbinding-from-envlist link (obj-envs obj)))

; ADDING (and deleting) BINDINGS

(microdefun revise-val-class-disp-for-obj (link obj)
  (let (binding)
    (setq binding (binding-from-envlist link (obj-envs obj)))
    (if binding
	(class-insert link binding (obj-val-class-disp obj))
	(class-remove link (obj-val-class-disp obj)))))

(microdefun revise-fcn-class-disp-for-obj (link obj)
  (let (bindings)
    (setq bindings (fbindings-from-envlist link (obj-envs obj)))
    (if bindings
	(class-insert link bindings (obj-fcn-class-disp obj))
	(class-remove link (obj-fcn-class-disp obj)))))

(microdefun revise-val-class-disps-for-env (link env)
  (nloop (for-in obj (env-class-objs env))
	 (revise-val-class-disp-for-obj link obj)))

(microdefun revise-fcn-class-disps-for-env (link env)
  (nloop (for-in obj (env-class-objs env))
	 (revise-fcn-class-disp-for-obj link obj)))


(defsubst flush-val-memo (link)
  (setf (link-memo-key link) t))

;Only call if binding doesn't already exist.
(microdefun bind-val-in-env (sym val env)
  (let ((link (get-val-link sym)))
    (progn
      (unless (null (env-class-objs env))
	(first-class-binding link))
      (unless (null (env-instance-objs env))
	(first-instance-binding link))
      (flush-val-memo link)
      (prog1
	;; !!! watch out for ABORTs
	(insert-binding link val (env-val-bindings env))
	(revise-val-class-disps-for-env link env)))))

(defsubst flush-fcn-memo (link)
  (setf (link-memo-key link) t))
  ;;;**** should clobber link-memo-bindings, too.

;Only call if binding doesn't already exist.
(microdefun bind-fcn-in-env (sym fcn env)
  (let ((link (get-fcn-link sym)))
    (progn
      (unless (null (env-class-objs env))
	(first-class-binding link))
      (unless (null (env-instance-objs env))
	(first-instance-binding link))
      (flush-fcn-memo link)
      (prog1
	;; !!! watch out for ABORTs
	(insert-binding link fcn (env-fcn-bindings env))
	(revise-fcn-class-disps-for-env link env)))))

(microdefun unbind-val-in-env (sym env)
  (let ((link (get-val-link sym)))
    (remove-binding link (env-val-bindings env))
    (flush-val-memo link)
    (revise-val-class-disps-for-env link env)))

(microdefun unbind-fcn-in-env (sym env)
  (LET ((link (get-fcn-link sym)))
    (remove-binding link (env-fcn-bindings env))
    (flush-fcn-memo link)
    (revise-fcn-class-disps-for-env link env)))

; RESOLVING LINKS-- (run-time)

;memoize instance-only by instance, class-only by class,
;both-bound by instance (cuz it has to be checked there anyway),
; unless instance-envs null, then use class-disp.

;Returns innermost binding.
;Consults & maintains memoized binding.
(defmacro val-binding-from-link (link)
  `(microfuncall (link-dispatch ,link) ,link))

;WARNING: Redefining this function will invalidate all extant LINK defstructs,
; which can only be fixed by rebooting.
(miscdefun val-lookup-global-only (link)
  (global-val-binding link))

(defvar *val-lookup-global-only (microfunction val-lookup-global-only))
(eval-when (load eval) (setf (symbol-function 'val-lookup-global-only)
			     *val-lookup-global-only))

;WARNING: Redefining this function will invalidate all extant LINK defstructs,
; which can only be fixed by rebooting.
(miscdefun val-lookup-instance-bound-only (link)
  (let ((instance-envs *instance-envs))
    (cond ((null instance-envs) (global-val-binding link))
	  ((eq (link-memo-key link) instance-envs)
	   (link-memo-binding link))
	  (t (atomically
	       (setf (link-memo-key link) instance-envs)
	       (setf (link-memo-binding link)
		     (or (binding-from-envlist-proper link instance-envs)
			 (global-val-binding link))))))))

(defvar *val-lookup-instance-bound-only
	(microfunction val-lookup-instance-bound-only))
(eval-when (load eval) (setf (symbol-function 'val-lookup-instance-bound-only)
			     *val-lookup-instance-bound-only))

;WARNING: Redefining this function will invalidate all extant LINK defstructs,
; which can only be fixed by rebooting.
(miscdefun val-lookup-class-bound-only (link)
  (let ((val-class-disp *val-class-disp))
    (if (eq (link-memo-key link) val-class-disp)
	(link-memo-binding link)
        (atomically
	  (setf (link-memo-key link) val-class-disp)
	  (setf (link-memo-binding link)
		(or (class-lookup link val-class-disp)
		    (global-val-binding link)))))))

(defvar *val-lookup-class-bound-only (microfunction val-lookup-class-bound-only))
(eval-when (load eval) (setf (symbol-function 'val-lookup-class-bound-only)
			     *val-lookup-class-bound-only))

;WARNING: Redefining this function will invalidate all extant LINK defstructs,
; which can only be fixed by rebooting.
(miscdefun val-lookup-both-bound (link)
  (let ((instance-envs *instance-envs))
    (cond ((null instance-envs)
	   (let ((val-class-disp *val-class-disp))
	     (if (eq (link-memo-key link) val-class-disp)
		 (link-memo-binding link)
	         (atomically
		   (setf (link-memo-key link) val-class-disp)
		   (setf (link-memo-binding link)
			 (or (class-lookup link val-class-disp)
			     (global-val-binding link)))))))
	  ((eq (link-memo-key link) instance-envs)
	   (link-memo-binding link))
	  (t (let (binding)
	       (if (setq binding (binding-from-envlist-proper link instance-envs))
		   (atomically
		     (setf (link-memo-key link) instance-envs)
		     (setf (link-memo-binding link) binding))
		   (atomically
		     (setf (link-memo-key link) instance-envs)
		     (setf (link-memo-binding link)
			   (or (class-lookup link (obj-val-class-disp *object))
			       (global-val-binding link))))))))))

(defvar *val-lookup-both-bound (microfunction val-lookup-both-bound))
(eval-when (load eval) (setf (symbol-function 'val-lookup-both-bound)
			     *val-lookup-both-bound))

;Returns innermost fbinding.
;SETQ's *SHADOWS to list or list* of any remaining fbindings,
; inner to outer (incl global).
;Consults & maintains memoized fbindings.
;*SHADOWS is guaranteed NIL coming in here.

(defmacro setup-shadows-and-get-fcn-binding-from-link (link)
  `(microfuncall (link-dispatch ,link) ,link))

;WARNING: Redefining this function will invalidate all extant LINK defstructs,
; which can only be fixed by rebooting.
(miscdefun fcn-lookup-global-only (link)
  (global-fcn-binding link))

(defvar *fcn-lookup-global-only (microfunction fcn-lookup-global-only))
(eval-when (load eval) (setf (symbol-function 'fcn-lookup-global-only)
			     *fcn-lookup-global-only))

;WARNING: Redefining this function will invalidate all extant LINK defstructs,
; which can only be fixed by rebooting.
(miscdefun fcn-lookup-instance-bound-only (link)
  (let ((instance-envs *instance-envs))
    (cond ((null instance-envs) (global-fcn-binding link))
	  ((eq (link-memo-key link) instance-envs)
	   (setq *shadows (link-memo-shadows link))
	   (link-memo-binding link))
	  (t (multiple-value-bind (binding shadows)
		 (fbindings-from-envlist-proper link instance-envs)
	       (if binding
		   (atomically
		     (setf (link-memo-key link) instance-envs)
		     (setq *shadows
			   (setf (link-memo-shadows link)
				 (if shadows
				     (nconc shadows (global-fcn-binding link))
				   (global-fcn-binding link))))
		     (setf (link-memo-binding link)  binding))
		   (atomically
		     (setf (link-memo-key link) instance-envs)
		     (setf (link-memo-shadows link) nil)
		     (setf (link-memo-binding link)
			   (global-fcn-binding link)))))))))

(defvar *fcn-lookup-instance-bound-only
	(microfunction fcn-lookup-instance-bound-only))
(eval-when (load eval) (setf (symbol-function 'fcn-lookup-instance-bound-only)
			     *fcn-lookup-instance-bound-only))

;WARNING: Redefining this function will invalidate all extant LINK defstructs,
; which can only be fixed by rebooting.
(miscdefun fcn-lookup-class-bound-only (link)
  (let ((fcn-class-disp *fcn-class-disp))
    (if (eq (link-memo-key link) fcn-class-disp)
	(progn (setq *shadows (link-memo-shadows link))
	       (link-memo-binding link))
        (let ((bindings (class-lookup link fcn-class-disp)))
	  (atomically
	    (setf (link-memo-key link) fcn-class-disp)
	    (if bindings
		(progn (setq *shadows (setf (link-memo-shadows link)
					    (cdr bindings)))
		       (setf (link-memo-binding link) (car bindings)))
	        (progn (setf (link-memo-shadows link) nil)
		       (setf (link-memo-binding link)
			     (global-fcn-binding link)))))))))

(defvar *fcn-lookup-class-bound-only (microfunction fcn-lookup-class-bound-only))
(eval-when (load eval) (setf (symbol-function 'fcn-lookup-class-bound-only)
			     *fcn-lookup-class-bound-only))

;WARNING: Redefining this function will invalidate all extant LINK defstructs,
; which can only be fixed by rebooting.
(miscdefun fcn-lookup-both-bound (link)
  (let ((instance-envs *instance-envs))
    (cond ((null instance-envs)
	   (let ((fcn-class-disp *fcn-class-disp))
	     (if (eq (link-memo-key link) fcn-class-disp)
		 (progn (setq *shadows (link-memo-shadows link))
			(link-memo-binding link))
	         (let ((bindings (class-lookup link fcn-class-disp)))
		   (atomically
		     (setf (link-memo-key link) fcn-class-disp)
		     (if bindings
			 (progn (setq *shadows (setf (link-memo-shadows link)
						     (cdr bindings)))
				(setf (link-memo-binding link) (car bindings)))
		         (progn (setf (link-memo-shadows link) nil)
				(setf (link-memo-binding link)
				      (global-fcn-binding link)))))))))
	  ((eq (link-memo-key link) instance-envs)
	   (setq *shadows (link-memo-shadows link))
	   (link-memo-binding link))
	  (t (multiple-value-bind (binding shadows)
		 (fbindings-from-envlist-proper link instance-envs)
	       (let ((others (class-lookup link (obj-fcn-class-disp *object))))
		 (if binding
		     (if shadows
			 (nconc shadows (or others (global-fcn-binding link)))
		         (setq shadows (or others (global-fcn-binding link))))
  		     (setq binding
			     (if others (pop others) (global-fcn-binding link))
			   shadows others))
		 (atomically
		   (setf (link-memo-key link) instance-envs)
		   (setq *shadows (setf (link-memo-shadows link) shadows))
		   (setf (link-memo-binding link) binding))))))))

(defvar *fcn-lookup-both-bound (microfunction fcn-lookup-both-bound))
(eval-when (load eval) (setf (symbol-function 'fcn-lookup-both-bound)
			     *fcn-lookup-both-bound))

(defmacro def-adjust-global-val-lookups ()
  (if *global-dispatch-fcns?
      `(defun adjust-global-val-lookups (link)
	 (adjust-get-val-fcn link)
	 (adjust-set-val-fcn link))
      `(defun adjust-global-val-lookups (link)
	 (declare (ignore link))
	 (values))))

(def-adjust-global-val-lookups)

(defmacro def-adjust-global-fcn-lookups ()
  (if *global-dispatch-fcns?
      `(defun adjust-global-fcn-lookups (link)
	 (adjust-get-fcn-fcn link))
      `(defun adjust-global-fcn-lookups (link)
	 (declare (ignore link))
	 (values))))

(def-adjust-global-fcn-lookups)

(defmacro evalcase (key &body clauses)
  `(let ((key ,key))
     (cond ,@(nloop (for-in clause clauses)
	       (collect (if (or (eq (car clause) 't) (eq (car clause) 'otherwise))
			    `(t ,@(cdr clause))
			    `((eq ,(car clause) key) ,@(cdr clause))))))))

(defmacro def-adjust-get-val-fcn ()
  (if *global-dispatch-fcns?
   '(defun adjust-get-val-fcn (link &optional always?
			       &aux (name (get-sym-val-name (link-symbol link)))
			            (link-fcn (link-dispatch link)))
      (when (or always? (fboundp name))
	(setf (symbol-function name)
	      (evalcase link-fcn
		(*val-lookup-global-only
		 (function get-val-lookup-global-only))
		(*val-lookup-instance-bound-only
		 (function get-val-lookup-instance-bound-only))
		(*val-lookup-class-bound-only
		 (function get-val-lookup-class-bound-only))
		(*val-lookup-both-bound
		 (function get-val-lookup-both-bound))
		(otherwise (ferror nil
   "~%Unrecognized dispatch function in link ~s, should be one of ~s." link
                       (list *val-lookup-global-only
			     *val-lookup-instance-bound-only
			     *val-lookup-class-bound-only
			     *val-lookup-both-bound)))))))
   '(defun adjust-get-val-fcn (link &optional always?)
      (declare (ignore link always?))
      (values))))

(def-adjust-get-val-fcn)

(defmacro def-adjust-set-val-fcn ()
  (if *global-dispatch-fcns?
 '(defun adjust-set-val-fcn (link &optional always?
			     &aux (name (set-sym-val-name (link-symbol link)))
			     (link-fcn (link-dispatch link)))
    (when (or always? (fboundp name))
      (setf (symbol-function name)
	    (evalcase link-fcn
	      (*val-lookup-global-only
	       (function set-val-lookup-global-only))
	      (*val-lookup-instance-bound-only
	       (function set-val-lookup-instance-bound-only))
	      (*val-lookup-class-bound-only
	       (function set-val-lookup-class-bound-only))
	      (*val-lookup-both-bound
	       (function set-val-lookup-both-bound))
	      (otherwise (ferror nil
   "~%Unrecognized dispatch function in link ~s, should be one of ~s." link
                       (list *val-lookup-global-only
			     *val-lookup-instance-bound-only
			     *val-lookup-class-bound-only
			     *val-lookup-both-bound)))))))
 '(defun adjust-set-val-fcn (link &optional always?)
    (declare (ignore link always?))
    (values))))

(def-adjust-set-val-fcn)

(defmacro def-adjust-get-fcn-fcn ()
  (if *global-dispatch-fcns?
   '(defun adjust-get-fcn-fcn (link &optional always?
			       &aux (name (get-sym-fcn-name (link-symbol link)))
			            (link-fcn (link-dispatch link)))
  (when (or always? (fboundp name))
    (setf (symbol-function name)
	  (evalcase link-fcn
	    (*fcn-lookup-global-only
	     (function fcncall-lookup-global-only))
	    (*fcn-lookup-instance-bound-only
	     (function fcncall-lookup-instance-bound-only))
	    (*fcn-lookup-class-bound-only
	     (function fcncall-lookup-class-bound-only))
	    (*fcn-lookup-both-bound
	     (function fcncall-lookup-both-bound))
	    (otherwise (ferror nil
   "~%Unrecognized dispatch function in link ~s, should be one of ~s." link
                       (list *fcn-lookup-global-only
			     *fcn-lookup-instance-bound-only
			     *fcn-lookup-class-bound-only
			     *fcn-lookup-both-bound)))))))
   '(defun adjust-get-fcn-fcn (link &optional always?)
      (declare (ignore link always?))
      (values))))

(def-adjust-get-fcn-fcn)

(microdefun first-class-binding (link)
  (evalcase (link-dispatch link)
    (*val-lookup-global-only
     (setf (link-dispatch link) *val-lookup-class-bound-only)
     (adjust-global-val-lookups link))
    (*fcn-lookup-global-only
     (setf (link-dispatch link) *fcn-lookup-class-bound-only)
     (adjust-global-fcn-lookups link))
    (*val-lookup-instance-bound-only
     (setf (link-dispatch link) *val-lookup-both-bound)
     (adjust-global-val-lookups link))
    (*fcn-lookup-instance-bound-only
     (setf (link-dispatch link) *fcn-lookup-both-bound)
     (adjust-global-fcn-lookups link))))

(microdefun first-instance-binding (link)
  (evalcase (link-dispatch link)
    (*val-lookup-global-only
     (setf (link-dispatch link) *val-lookup-instance-bound-only)
     (adjust-global-val-lookups link))
    (*fcn-lookup-global-only
     (setf (link-dispatch link) *fcn-lookup-instance-bound-only)
     (adjust-global-fcn-lookups link))
    (*val-lookup-class-bound-only
     (setf (link-dispatch link) *val-lookup-both-bound)
     (adjust-global-val-lookups link))
    (*fcn-lookup-class-bound-only
     (setf (link-dispatch link) *fcn-lookup-both-bound)
     (adjust-global-fcn-lookups link))))

;;;; Compiled references

(defsubst constant-sym? (form)
  (and (consp form) (memq (car form) '(quote function))
       (symbolp (cadr form)) (null (cddr form))))

; Compile-time reference functions

(defun get-sym-val-name (sym)
  (pkg-new-symbol *obf-pkg
		  "Get-sym-val " (package-name (symbol-package sym)) ":" sym))

(defun set-sym-val-name (sym)
  (pkg-new-symbol *obf-pkg
		  "Set-sym-val " (package-name (symbol-package sym)) ":" sym))

(defun get-sym-fcn-name (sym)
  (pkg-new-symbol *obf-pkg
		  "Get-sym-fcn " (package-name (symbol-package sym)) ":" sym))

(defun form-to-get-sym-val-from-link (sym link-form)
 (if *global-dispatch-fcns?
     `(,(get-sym-val-name sym) ,link-form)
     `(get-sym-val-from-link ,link-form)))

(defun form-to-set-sym-val-from-link (sym link-form val-form)
 (if *global-dispatch-fcns?
     `(,(set-sym-val-name sym) ,link-form ,val-form)
     `(set-sym-val-from-link ,link-form ,val-form)))

(defun form-to-funcall-fcn-sym-from-link (sym link-form arg-forms)
 (if *global-dispatch-fcns?
     `(funcall-fcn-sym-from-link ,(get-sym-fcn-name sym) ,link-form ,@arg-forms)
     `(funcall-fcn-sym-from-link setup-shadows-and-get-sym-fcn-from-link
				 ,link-form ,@arg-forms)))

(defun form-to-apply-fcn-sym-from-link (sym link-form arg-forms)
 (if *global-dispatch-fcns?
     `(apply-fcn-sym-from-link ,(get-sym-fcn-name sym) ,link-form ,@arg-forms)
     `(apply-fcn-sym-from-link setup-shadows-and-get-sym-fcn-from-link
			       ,link-form ,@arg-forms)))

(defun form-to-call-fcn-sym-from-link (sym link-form arg-forms)
 (if *global-dispatch-fcns?
     `(call-fcn-sym-from-link ,(get-sym-fcn-name sym) ,link-form ,@arg-forms)
     `(call-fcn-sym-from-link setup-shadows-and-get-sym-fcn-from-link
			      ,link-form ,@arg-forms)))

(defun warn-if-undeclared-special-aux (sym)
  (declare (special *specials))
  (cond (*walkover? (when (not (or (memq sym *specials)
				   (globally-special? sym)))
		      (push sym *specials)
		      (warn-of-undeclared-special sym)))
	(*obl-compiling? (warn-if-undeclared-special sym))))

(defparameter *no-specials-warning nil)

(defun qsym-ref-form (sym)
  (unless *no-specials-warning (warn-if-undeclared-special-aux sym))
  (if *inside-defobfun
      (progn
	(arrange-to-link-val-ref sym)
	(if *loadtime-constant-links?
	    (form-to-get-sym-val-from-link
	      sym `(delayed-expand (get-val-link ',sym)))
	    (form-to-get-sym-val-from-link
	      sym (global-val-link-form sym))))
      `(get-sym-val ',sym)))

(defun symbol-ref-form (sym-form)
  `(get-sym-val ,sym-form))

(defun qsym-set-form (sym val-form)
  (unless *no-specials-warning (warn-if-undeclared-special-aux sym))
  (if *inside-defobfun
      (progn
	(arrange-to-link-val-set sym)
	(if *loadtime-constant-links?
	    (form-to-set-sym-val-from-link
	      sym `(delayed-expand (get-val-link ',sym))
	      val-form)
	    (form-to-set-sym-val-from-link
	      sym (global-val-link-form sym) val-form)))
      `(set-sym-val ',sym ,val-form)))

(defun symbol-set-form (sym-form val-form)
  `(set-sym-val ,sym-form ,val-form))

(defun symbol-fref-form (sym-form)
  `(get-sym-fcn ,sym-form))

(defun symbol-fset-form (sym-form fcn-form)
  `(set-sym-fcn ,sym-form ,fcn-form))

(defsubst subst-quote-for-fcnquote (fcn-form)
  (if (eq (car fcn-form) 'function)
      (cons 'quote (cdr fcn-form))
      fcn-form))

(defun funcall-form (fcn-form arg-forms &aux sym)
  (if (constant-sym? fcn-form)
      (iff (eq (cadr fcn-form) *shadowed-fcn-sym)
	   `(shadowed-funcall shadows ,@arg-forms)
	(setq sym (cadr fcn-form))
	(if *inside-defobfun
	    (progn
	      (arrange-to-link-fcn-ref sym)
	      (if *loadtime-constant-links?
		  (form-to-funcall-fcn-sym-from-link
		    sym `(delayed-expand (get-fcn-link ',sym)) arg-forms)
	          (form-to-funcall-fcn-sym-from-link
		    sym (global-fcn-link-form sym) arg-forms)))
	    `(funcall-fcn-sym ,(subst-quote-for-fcnquote fcn-form)
			      ,@arg-forms)))
      `(funcall-fcn-?sym ,fcn-form ,@arg-forms)))

(defun apply-form (fcn-form arg-forms &aux sym)
  (if (constant-sym? fcn-form)
      (iff (eq (cadr fcn-form) *shadowed-fcn-sym)
	   `(shadowed-apply shadows ,@arg-forms)
	(setq sym (cadr fcn-form))
	(if *inside-defobfun
	    (progn
	      (arrange-to-link-fcn-ref sym)
	      (if *loadtime-constant-links?
		  (form-to-apply-fcn-sym-from-link
		    sym `(delayed-expand (get-fcn-link ',sym)) arg-forms)
		  (form-to-apply-fcn-sym-from-link
		    sym (global-fcn-link-form sym) arg-forms)))
	    `(apply-fcn-sym ,(subst-quote-for-fcnquote fcn-form) ,@arg-forms)))
      `(apply-fcn-?sym ,fcn-form ,@arg-forms)))

(defun call-form (fcn-form arg-forms &aux sym)
  (if (constant-sym? fcn-form)
      (iff (eq (cadr fcn-form) *shadowed-fcn-sym)
	   `(shadowed-call shadows ,@arg-forms)
	(setq sym (cadr fcn-form))
	(if *inside-defobfun
	    (progn
	      (arrange-to-link-fcn-ref sym)
	      (if *loadtime-constant-links?
		  (form-to-call-fcn-sym-from-link
		    sym `(delayed-expand (get-fcn-link ',sym)) arg-forms)
		  (form-to-call-fcn-sym-from-link
		    sym (global-fcn-link-form sym) arg-forms)))
	    `(call-fcn-sym ,(subst-quote-for-fcnquote fcn-form) ,@arg-forms)))
      `(call-fcn-?sym ,fcn-form ,@arg-forms)))

(defun shadowed-funcall-form (arg-forms)
  `(shadowed-funcall shadows ,@arg-forms))

(defmacro def-global-val-link-form ()
  (if *global-link-symbols?
      '(defun global-val-link-form (sym)
	 (pkg-new-symbol *obf-pkg
			  "Val-link " (package-name (symbol-package sym)) ":" sym))
      '(defun global-val-link-form (sym)
	 (get-val-link sym))))

(def-global-val-link-form)

(defmacro def-global-fcn-link-form ()
  (if *global-link-symbols?
      '(defun global-fcn-link-form (sym)
	 (pkg-new-symbol *obf-pkg
			 "Fcn-link " (package-name (symbol-package sym)) ":" sym))
      '(defun global-fcn-link-form (sym)
	 (list 'get-fcn-link (list 'quote sym)))))

(def-global-fcn-link-form)

; (See DEFOBFUN, DEFOBFUN-INSTALL)
(defun arrange-to-link-val-ref (sym)
  (or (memq sym *val-ref-syms) (push sym *val-ref-syms))
  (when *global-dispatch-fcns?
    (let ((name (get-sym-val-name sym)))
      (unless (fboundp name)
	;; This isn't necessarily the right thing to set it to, but it will
	;; suppress the undef-fcn compiler warning, and will be adjusted later.
	(setf (symbol-function name) (function get-val-lookup-global-only)))))
  (def-val-link sym))

(defun def-val-link (sym &optional link &aux link-sym)
  (when *global-link-symbols?
    (setq link-sym (global-val-link-form sym))
    (unless (boundp link-sym) (proclaim (list 'special link-sym)))
    (unless (null link) (set link-sym link))
    link-sym))

(defun link-val-ref (sym &aux (link (get-val-link sym)))
  (def-val-link sym link)
  (adjust-get-val-fcn link t))

(defun arrange-to-link-val-set (sym)
  (or (memq sym *val-set-syms) (push sym *val-set-syms))
  (when *global-dispatch-fcns?
    (let ((name (set-sym-val-name sym)))
      (unless (fboundp name)
	;; This isn't necessarily the right thing to set it to, but it will
	;; suppress the undef-fcn compiler warning, and will be adjusted later.
	(setf (symbol-function name) (function set-val-lookup-global-only)))))
  (def-val-link sym))

(defun link-val-set (sym &aux (link (get-val-link sym)))
  (def-val-link sym link)
  (adjust-set-val-fcn link t))

(defun arrange-to-link-fcn-ref (sym)
  (or (memq sym *fcn-ref-syms) (push sym *fcn-ref-syms))
  (when *global-dispatch-fcns?
    (let ((name (get-sym-fcn-name sym)))
      (unless (fboundp name)
	;; This isn't necessarily the right thing to set it to, but it will
	;; suppress the undef-fcn compiler warning, and will be adjusted later.
	(setf (symbol-function name) (function fcncall-lookup-global-only)))))
  (def-fcn-link sym))

(defun def-fcn-link (sym &optional link &aux link-sym)
  (when *global-link-symbols?
    (setq link-sym (global-fcn-link-form sym))
    (unless (boundp link-sym) (proclaim (list 'special link-sym)))
    (unless (null link) (set link-sym link))
    link-sym))

(defun link-fcn-ref (sym &aux (link (get-fcn-link sym)))
  (def-fcn-link sym link)
  (adjust-get-fcn-fcn link t))

;These are the reference entry-points.

(miscdefun get-sym-val-from-link (link)
  (binding-val (val-binding-from-link link)))

(defun get-val-lookup-global-only (link)
  (binding-val (val-lookup-global-only link)))

(defun get-val-lookup-instance-bound-only (link)
  (binding-val (val-lookup-instance-bound-only link)))

(defun get-val-lookup-class-bound-only (link)
  (binding-val (val-lookup-class-bound-only link)))

(defun get-val-lookup-both-bound (link)
  (binding-val (val-lookup-both-bound link)))


(miscdefun get-sym-val (sym)
  (let ((link (get-val-link? sym)))
	 (if link
	     (binding-val (val-binding-from-link link))
	     (symbol-value sym))))

(miscdefun set-sym-val-from-link (link val)
  (set-binding-val (val-binding-from-link link) val))

(defun set-val-lookup-global-only (link val)
  (set-binding-val (val-lookup-global-only link) val))

(defun set-val-lookup-instance-bound-only (link val)
  (set-binding-val (val-lookup-instance-bound-only link) val))

(defun set-val-lookup-class-bound-only (link val)
  (set-binding-val (val-lookup-class-bound-only link) val))

(defun set-val-lookup-both-bound (link val)
  (set-binding-val (val-lookup-both-bound link) val))

(miscdefun set-sym-val (sym val)
  (let ((link (get-val-link? sym)))
    (if link
	(set-binding-val (val-binding-from-link link) val)
	(set sym val))))

(miscdefun get-sym-fcn (sym)
  (let ((link (get-fcn-link? sym)))
    (if link
	(binding-fcn (fbinding-from-object link *object))
	(symbol-function sym))))

(miscdefun set-sym-fcn (sym fcn)
  (let ((link (get-fcn-link? sym)))
    (if link
	(set-binding-fcn (fbinding-from-object link *object) fcn)
	(setf (symbol-function sym) fcn))))

(miscdefun setup-shadows-and-get-sym-fcn-from-link (link)
  (binding-fcn (setup-shadows-and-get-fcn-binding-from-link link)))

(defun fcncall-lookup-global-only (link)
  (binding-fcn (fcn-lookup-global-only link)))

(defun fcncall-lookup-instance-bound-only (link)
  (binding-fcn (fcn-lookup-instance-bound-only link)))

(defun fcncall-lookup-class-bound-only (link)
  (binding-fcn (fcn-lookup-class-bound-only link)))

(defun fcncall-lookup-both-bound (link)
  (binding-fcn (fcn-lookup-both-bound link)))

(miscdefun setup-shadows-and-get-sym-fcn (sym)
  (let ((link (get-fcn-link? sym)))
    (if (null link)
	(symbol-function sym)
	(binding-fcn (setup-shadows-and-get-fcn-binding-from-link link)))))

(miscdefun setup-shadows-and-get-?sym-fcn (?sym)
  (if (not (symbolp ?sym))
      ?sym
      (let ((link (get-fcn-link? ?sym)))
	(if (null link)
	    (symbol-function ?sym)
	    (binding-fcn (setup-shadows-and-get-fcn-binding-from-link link))))))

(defmacro funcall-fcn-sym-from-link (lookup-fcn link &rest args)
  `(let ((*shadows nil))
     (funcall (,lookup-fcn ,link) ,@args)))

(defmacro funcall-fcn-sym (sym &rest args)
  `(let ((*shadows nil))
     (funcall (setup-shadows-and-get-sym-fcn ,sym) ,@args)))

(defmacro funcall-fcn-?sym ( sym &rest args)
  `(let ((*shadows nil))
     (funcall (setup-shadows-and-get-?sym-fcn ,sym) ,@args)))

(defmacro apply-fcn-sym-from-link (lookup-fcn link &rest args)
  `(let ((*shadows nil))
     (apply (,lookup-fcn ,link) ,@args)))

(defmacro apply-fcn-sym (sym &rest args)
  `(let ((*shadows nil))
     (apply (setup-shadows-and-get-sym-fcn ,sym) ,@args)))

(defmacro apply-fcn-?sym (sym &rest args)
  `(let ((*shadows nil))
     (apply (setup-shadows-and-get-?sym-fcn ,sym) ,@args)))

(defmacro call-fcn-sym (lookup-fcn link &rest args)
  `(let ((*shadows nil))
     (#-symbolics call #+symbolics zl:call
      (,lookup-fcn ,link) ,@args)))

(defmacro call-fcn-sym (sym &rest args)
  `(let ((*shadows nil))
     (#-symbolics call #+symbolics zl:call
      (setup-shadows-and-get-sym-fcn ,sym) ,@args)))

(defmacro call-fcn-?sym (sym &rest args)
  `(let ((*shadows nil))
     (#-symbolics #'call #+symbolics #'zl:call
      (setup-shadows-and-get-?sym-fcn ,sym) ,@args)))

(miscdefun shadowed-fcn (shadows)
  (COND ((SYMBOLP SHADOWS)
	 (SETQ *SHADOWS NIL)
	 (global-binding-fcn-for-shadow SHADOWS))
	(T
	 (setq *shadows (cdr shadows))
	 (binding-fcn-for-shadow (car shadows)))))

(defmacro shadowed-funcall (shadows &rest args)
  `(let (*shadows)
     (funcall (shadowed-fcn ,shadows) ,@args)))

(defmacro shadowed-apply (shadows &rest args)
  `(let (*shadows)
     (apply (shadowed-fcn ,shadows) ,@args)))

(defmacro shadowed-call (shadows &rest args)
  `(let (*shadows)
     (#-symbolics call #+symbolics zl:call
      (shadowed-fcn ,shadows) ,@args)))

;;;; HAVE, UNHAVE, FHAVE, UNFHAVE
;						(:TODO proceed-already-has-err)

(defun HAVE (&rest sym-val-pairs &aux link (env (own-env *object)) binding)
  (prog1
    (car sym-val-pairs)
    (nloop (stop-if (null sym-val-pairs))
	   (for sym (pop sym-val-pairs))
	   (for val (pop sym-val-pairs))
	   (check-type sym symbol)
	   (cond ((global-obj? *object) (set sym val))
		 ((and (setq link (get-val-link? sym))
		       (setq binding (binding-from-env link env)))
		  (set-binding-val binding val))
		 (t (bind-val-in-env sym val env))))))

(defun UNHAVE (&rest syms &aux link (env (own-env *object)))
  (nloop (for-in sym syms)
	 (check-type sym symbol)
	 (cond ((global-obj? *object)
		(ferror nil "~%Can't remove global variable."))
	       ((or (null (setq link (get-val-link? sym)))
		    (null (binding-from-env link env))) )
	       (t (unbind-val-in-env sym env))))
  (car syms))

(defun FHAVE (&rest sym-fcn-pairs)
  (nloop (stop-if (null sym-fcn-pairs))
	 (for sym (pop sym-fcn-pairs))
	 (for fcn (pop sym-fcn-pairs))
	 (check-type sym symbol)
	 (set-fbinding-in-obj sym fcn *object))
  (car sym-fcn-pairs))

(defun set-fbinding-in-obj (sym fcn obj &aux link fbinding (env (own-env obj)))
  (if (global-obj? obj)
      (setf (symbol-function sym) fcn)
    (if (pkg-unshadowable? sym)
	(ferror nil
		"Attempt to shadow the definition of ~s, an unshadowable symbol."
		sym)
	(if (and (setq link (get-fcn-link? sym))
		 (setq fbinding (fbinding-from-env link env)))
	    (set-binding-fcn fbinding fcn)
	    (bind-fcn-in-env sym fcn env)))))

(defun UNFHAVE (&rest syms &aux link (env (own-env *object)))
  (nloop (for-in sym syms)
	 (check-type sym symbol)
	 (cond ((global-obj? *object)
		(ferror nil "~%Can't remove global procedure."))
	       ((or (null (setq link (get-fcn-link? sym)))
		    (null (fbinding-from-env link env))) )
	       (t (unbind-fcn-in-env sym env))))
  (car syms))

(defmacro OBJ-LET-GLOBALLY (bindings &body body)
  (let ((gen (gensym)) (syms (mapcar #'car bindings)))
    `(let ((,gen (list ,@syms)))
       (unwind-protect (progn (psetq ,@(apply #'append bindings))
			      ,@body)
	 (mapc #'(lambda (sym old) (set sym old)) ',syms ,gen)))))

;;;; DEFOBFUN

#+(or lambda symbolics)
(defprop defobfun "Object Function" si:definition-type-name)

(defun tree-memq (thing tree)
  (or (eq thing tree)
      (and (consp tree)
	   (or (tree-memq thing (car tree))
	       (tree-memq thing (cdr tree))))))

(defun dcl-fcn-parent-form (parent-sym internal-sym)
  #-(or lambda symbolics) (declare (ignore parent-sym internal-sym))
  #+(or lambda symbolics)
  (unless (eq parent-sym internal-sym)
    `((declare (sys:function-parent ,parent-sym defobfun)))))

(defmacro defobfun-install-macro (obj-sym fcn-sym internal-sym)
  `(defobfun-install ,obj-sym ',fcn-sym #',internal-sym
		     ',*val-ref-syms ',*val-set-syms ',*fcn-ref-syms))

;(DEFOBFUN <fcn-sym> ...) or (DEFOBFUN (<fcn-sym> <obj-form>) ...)
;Note that DEFOBFUN >always< compiles the definition if *WALKOVER? is null.
(defmacro DEFOBFUN (fcn-sym vars &body body &aux obj-sym shadowed-sym internal-sym lets)
  (setq internal-sym fcn-sym)
  (multiple-value-setq (vars lets) (hack-keyword-default-pkg vars))
  (unless (null lets) (setq body `((let* ,lets ,@body))))
  (when (consp fcn-sym)
    (setq obj-sym (second fcn-sym)
	  fcn-sym (first fcn-sym)
	  internal-sym (pkg-new-symbol (find-package 'obf)
				       "(" fcn-sym " " obj-sym ")")))
  (setq shadowed-sym (new-symbol "SHADOWED-" fcn-sym))
  (if *walkover?
      (let ((*shadowed-fcn-sym shadowed-sym)
	    (*inside-defobfun t)
	    *val-ref-syms *val-set-syms *fcn-ref-syms)
	`(progn 'compile
	    (record-source-file-name ',fcn-sym 'defobfun t)
	    ,(if (or (tree-memq shadowed-sym vars)
		     (tree-memq shadowed-sym body))
		 (if (application-in-arglist? vars)
		     #-lambda
		     `(defun ,internal-sym (&rest args &aux (shadows *shadows))
			,@(dcl-fcn-parent-form fcn-sym internal-sym)
			(apply #',(walkover `(lambda (shadows ,@vars) ,@body))
				shadows args))
		     #+lambda
		     `(defun ,internal-sym (&rest args &aux (shadows *shadows))
			args
			,@(dcl-fcn-parent-form fcn-sym internal-sym)
			,(walkover `(destructuring-bind ,vars args ,@body)))
		     (walkover `(defun ,internal-sym ,vars
				  ,@(dcl-fcn-parent-form fcn-sym internal-sym)
				  (let ((shadows *shadows))
				    ,@body))))
		 (walkover `(defun ,internal-sym ,vars
			      ,@(dcl-fcn-parent-form fcn-sym internal-sym)
			      ,@body)))
	    (defobfun-install ,obj-sym ',fcn-sym #',internal-sym
	      ',*val-ref-syms ',*val-set-syms ',*fcn-ref-syms)))
      `(compiler-let ((*shadowed-fcn-sym ',shadowed-sym)
		      (*inside-defobfun t)
		      (*val-ref-syms nil) (*val-set-syms nil) (*fcn-ref-syms nil))
	 (progn 'compile
	    (record-source-file-name ',fcn-sym 'defobfun t)
	    ,(if (or (tree-memq shadowed-sym vars)
		     (tree-memq shadowed-sym body))
		 (if (application-in-arglist? vars)
		     #-lambda
		     `(defun ,internal-sym (&rest args &aux (shadows *shadows))
			,@(dcl-fcn-parent-form fcn-sym internal-sym)
			(apply #'(lambda (shadows ,@vars) ,@body)
				shadows args))
		     #+lambda
		     `(defun ,internal-sym (&rest args &aux (shadows *shadows))
			args
			,@(dcl-fcn-parent-form fcn-sym internal-sym)
			(destructuring-bind ,vars args ,@body))
		     `(defun ,internal-sym ,vars
			,@(dcl-fcn-parent-form fcn-sym internal-sym)
			(let ((shadows *shadows)) ,@body)))
		 `(defun ,internal-sym ,vars
		    ,@(dcl-fcn-parent-form fcn-sym internal-sym)
		    ,@body))
	    (eval-when (eval) (compile ',internal-sym))
	    (defobfun-install-macro ,obj-sym ,fcn-sym ,internal-sym)))))

(defun defobfun-install (obj fcn-sym fcn val-refs val-sets fcn-refs)
  (mapc #'link-val-ref val-refs)
  (mapc #'link-val-set val-sets)
  (mapc #'link-fcn-ref fcn-refs)
  (when obj
    (check-type obj obj)
    (set-fbinding-in-obj fcn-sym fcn obj))
  nil)

(defun application-in-arglist? (arglist)
  (some #'(lambda (form) (and (consp form) (consp (cadr form))))
	arglist))

; Code to support &KEY* for DEFOBFUN, and plain &KEY for deficient Commonlisps.

(defmacro cons-end (thing-form list-form)
  `(if (null ,list-form)
       (setf ,list-form (list ,thing-form))
       (rplacd (last ,list-form) (list ,thing-form))))

(defun hack-keyword-default-pkg (lambda-list &aux new)
  (setq new  (nloop (stop-if (null lambda-list))
	       (for thing (pop lambda-list))
	       (if (eq thing '&key*)
		   (return (nconc new
				  (cons '&key (collect-keyword-args lambda-list))
				  '(&allow-other-keys)))
		   (cons-end thing new))
	       (finally new)))
  (hack-manual-&keys new))

(defmacro defun-hack-manual-&keys ()
 (if (not *manual-&keys?) '(defun hack-manual-&keys (args) args)
; 2 vals returned: new arglist, list of LET* var forms.
 '(defun hack-manual-&keys (args &aux keys restarg new keywds keyargs inits)
  (setq keys (cdr (memq '&key args)))
  (iff (null keys)
      args
    (setq restarg (cdr (memq '&rest args)))
    (if (null restarg)
	(progn
	  (setq restarg 'restarg)
	  (nloop (stop-if (null args)) (for arg (pop args))
		 (stop-if (eq arg '&key))
		 (push arg new))
	  (push '&rest new) (push 'restarg new))
	(progn
	 (setq restarg (car restarg))
	 (nloop (stop-if (null args)) (for arg (pop args))
		(stop-if (eq arg '&key))
		(push arg new))))
    ;; NEW now holds (in reverse order) args up to, but not including, &KEY, and
    ;;  ending with &REST ,RESTARG.
    (nloop (with ks keys) (stop-if (null ks)) (with aux nil)
	   (for key (pop ks))
	   (if (eq key '&aux)
	       (setq aux t  key (pop ks)))
	   (cond ((eq key '&allow-other-keys) nil) ;Punt this, no more &KEY.
		 ((memq key lambda-list-keywords)
		  ;; Shouldn't really be any keywd here, but if so, pass the buck.
		  (push key new) (unless (null ks) (push (pop ks) new)))
		 (aux (cond ((listp key) (push (car key) keyargs)
					 (push (cadr key) inits))
			    (t (push key keyargs) (push nil inits)))
		      (push nil keywds))
		 ((listp key)
		  (push (cadr key) inits)
		  (cond ((listp (car key)) (push (caar key) keywds)
					   (push (cadar key) keyargs))
			(t (push (car key) keyargs)
			   (push (intern (symbol-name (car key)) 'keyword)
				 keywds))))
		 (t (push key keyargs) (push nil inits)
		    (push (intern (symbol-name key) 'keyword) keywds))))
    (values (nreverse new)
	    (nconc (if (eq restarg 'restarg)
		       (list '(arg nil))
		       (list '(arg nil) `(restarg ,restarg)))
		   (nloop (for-in arg (nreverse keyargs))
			  (for-in word (nreverse keywds))
			  (for-in init (nreverse inits))
			  (collect
			    `(,arg ,(if (null word)
					init
				        `(extract ,word ,init)))))))))))

(defun-hack-manual-&keys)

(defmacro extract (key init)
  `(if (setq arg (extract-key ',key restarg))
       (car arg)
       ,init))

(defun extract-key (key args)
  (nloop (stop-if (null args)) (for key1 (pop args))
	 (if (eq key1 key) (return args))
	 (pop args)))

; Be sure that this conses a fresh list, because its caller NCONC's it.
(defun collect-keyword-args (lambda-list &aux new)
  (nloop (stop-if (null lambda-list))
	 (for thing (pop lambda-list))
	 (cond ((eq thing '&aux)
		(return (nconc new (cons '&aux lambda-list))))
	       ((memq thing lambda-list-keywords) (cons-end thing new))
	       ((symbolp thing)
		(cons-end `((,thing ,thing)) new))
	       ((symbolp (car thing))
		(cons-end `((,(car thing) ,(car thing)) ,@(cdr thing)) new))
	       (t (cons-end thing new)))
	(finally new)))


(defun new-symbol (&rest strings)
  (intern (apply #'string-append strings)))

(defun pkg-new-symbol (pkg &rest strings)
  (intern (apply #'string-append strings) pkg))

;;;; ASK, KINDOF

(miscdefun check-obj (arg)
  (or (null arg) (check-type arg obj "an object")))

; (Returns OB.)
(miscdefun set-obj (ob)
  (if (null ob)
      (setq ob *internal-global-obj)
      (check-type ob obj "an object"))
  (setq	*instance-envs (obj-instance-envs ob)
	*val-class-disp (obj-val-class-disp ob)
	*fcn-class-disp (obj-fcn-class-disp ob))
  (setq *object ob))

(defmacro ASK (obj-form &body body)
  (if *walkover?
      `(ask-aux ,obj-form ,@(if *obl-walking?
				body
			        (walkover (if (null (cdr body))
					      body `((progn ,@body))))))
      `(obl (ask-aux ,obj-form ,@body))))

(defmacro ask-aux (obj-form &body body)
  `(let ((obj ,obj-form)
	 *object *instance-envs *val-class-disp *fcn-class-disp)
     (set-obj obj)
     ,@(or body (list nil))))

(defmacro ASK-FUNCALL (obj sym &rest args)
 `(let ((values (list ,@args)))
    (ask ,obj (apply ,sym values))))

(defmacro MAPC-ASK (objs &body body)
  `(mapc #'(lambda (obj) (ask obj ,@body)) ,objs))

(defmacro MAP-ASK (objs &body body)
  `(map #'(lambda (obj) (ask obj ,@body)) ,objs))   

(defmacro MAPCAR-ASK (objs &body body)
  `(mapcar #'(lambda (obj) (ask obj ,@body)) ,objs))

(defun TALKTO (&optional obj)
  (set-obj obj))

; KINDOF

(defun KINDOF (&rest objs)
  (%kindof t nil nil (copy-list objs)))

(defun MAKE-OBJ (&rest objs)
  (%kindof t nil nil (copy-list objs)))

(defun refresh-subobjs (obj &aux (subobjs (specializations obj)))
  (mapc #'refresh-obj subobjs)
  (mapc #'refresh-subobjs subobjs))

(defun REMAKE-OBJ (obj &rest bases)
  (check-obj obj)
  (let ((new-envs (flatten-objs-envs bases))
	(old-envs (obj-envs obj)))
    (unless (and (not (null old-envs))	; No new obj if still the same.
		 (equal (cdr old-envs) new-envs))
      ;;Replace old obj but keep the same 1st env.
      (%kindof nil (obj-class? obj) (not (obj-class? obj)) (copy-list bases)
	       (cons (own-env obj) new-envs)
	       obj)
      (refresh-subobjs obj)))
  obj)

(defun refresh-obj (obj)
  (apply #'remake-obj obj (obj-superiors obj)))

(defun ONEOF (class-obj &rest exist-args &aux instance-obj)
  (setq instance-obj (%kindof t nil t (ncons class-obj)))
  (ask-aux instance-obj
    (apply-fcn-sym 'exist exist-args))
  instance-obj)

(defvar *next-obj-index 0)

(defun next-obj-index ()
  (incf *next-obj-index))

;OBJS is list of superclasses (for KINDOF etc) or NIL (for nonstd. obj creation).
;ENVS should be environments to make new obj from,
; defaulting to flattening of OBJS' environments.
;An object made by KINDOF is an instance if any of its superclasses is,
; or if there are no superclasses.  Otherwise it's a class.
;(An object made by ONEOF is an instance. An object made by DEFKIND is a class.
; An object made by REMAKE-OBJ keeps its old status.)
(defun %kindof (own? force-class? force-instance? objs
		&optional (envs (progn (mapc #'check-obj objs)
				       (flatten-objs-envs objs)))
		          (oldobj nil)	; Recycle old obj-defstruct if provided.
		&aux class? env nenvs obj)
  (iff (not own?)
       (setq nenvs envs)
    (setq env (make-environment))
    (setq nenvs (cons env envs)))
  (iff (null oldobj)
       (progn (setq obj (%make-obj nenvs objs))
	      (setf (obj-index obj) (next-obj-index)))
    (setq obj oldobj)
    (setf (obj-envlist obj) nenvs)
    (setf (obj-superiors obj) objs))
  (when own?
    (setf (env-object env) obj))
  (setq class?
	(or force-class?
	    (and (not force-instance?)
		 (not (null objs))
		 (every #'(lambda (obj) (obj-class? obj))
			objs))))
  (setf (obj-class? obj) class?)
  (if class?
      (setup-class-disp-tables-for-object obj nenvs)
      (setup-disp-tables-for-instance-object obj objs nenvs))
  obj)

;Takes list of objects.  Returns list of environments.
(defun flatten-objs-envs (objs &aux temp new-envs)
  (nloop (for-in obj objs)
	 (nloop (for-in env (obj-envs obj))
		(push env temp)))
  (nloop (for-in env temp)
	 (or (memq env new-envs)
	     (push env new-envs)))
  new-envs)

(defun flush-env-memos-for-conversion (env class-to-instance?)
  (bindings-map #'(lambda (binding &aux (link (nonglobal-binding-link binding)))
		    (if class-to-instance?
			(first-instance-binding link)
		        (first-class-binding link))
		    (flush-val-memo link))
		(env-val-bindings env))
  (bindings-map #'(lambda (binding &aux (link (nonglobal-binding-link binding)))
		    (if class-to-instance?
			(first-instance-binding link)
		        (first-class-binding link))
		    (flush-fcn-memo link))
		(env-fcn-bindings env)))

(defun record-class-usage (obj class-envs &optional sharing-class-disps?)
  (nloop
    (for-in env class-envs)
    ;; If env was previously instance-only, punt memoization of its bindings.
    (when (null (env-class-objs env))
      (flush-env-memos-for-conversion env nil))
    (if (not sharing-class-disps?)
	(unless (memq obj (env-class-objs env))
	  (push obj (env-class-objs env))))))

(defun setup-class-disp-tables-for-object (obj envs
				          &aux (val-disp (make-class-disp-table))
				               (fcn-disp (make-class-disp-table)))
  (record-class-usage obj envs)
  (setf (obj-val-class-disp obj) val-disp)
  (setf (obj-fcn-class-disp obj) fcn-disp)
  (nloop (for-in env (reverse envs))
	 (bindings-map #'(lambda (val-binding)
			   (class-insert (nonglobal-binding-link val-binding)
					  val-binding val-disp))
		       (env-val-bindings env))
	 (bindings-map #'(lambda (fcn-binding &aux link old)
			   (setq link (nonglobal-binding-link fcn-binding)
				 old (class-lookup link fcn-disp))
			   (class-insert link
					 (if old
					     (cons fcn-binding old)
					     (list fcn-binding
						   (global-fcn-binding link)))
					 fcn-disp))
		       (env-fcn-bindings env))))

(defun setup-disp-tables-for-instance-object (obj objs nenvs
					      &aux (final-class-objs objs)
					           class-envs)
  ;; Find longest tail of OBJS consisting of 1 (or 0 if none) instance obj
  ;; followed by 0 or more class objs.
  (nloop (for-on ?finals objs)
	 (for obj (car ?finals))
	 (if (not (obj-class? obj))
	     (setq final-class-objs ?finals)))
  ;; All envs before 1st final-class-obj's 1st class env are instance envs.
  ;; Remainder are class-envs.
  (setf (obj-instance-envs obj)
	(nloop (with new-class (car final-class-objs))
	       (with final-env
		     (if final-class-objs
			 (let ((last-instance (car (last (obj-instance-envs
							   new-class)))))
			   (if (null last-instance)
			       (own-env (car final-class-objs))
			       (cadr
				 (memq last-instance (obj-envlist new-class)))))))
	       (for-on cenvs nenvs)
	       (for env (car cenvs))
	       (stop-if (eq env final-env))
	       ;; If env was previously class-only, punt memoization of its bindings.
	       (when (null (env-instance-objs env))
		 (flush-env-memos-for-conversion env t))
	       (unless (memq obj (env-instance-objs env))
		 (push obj (env-instance-objs env)))
	       (collect env)
	       (finally (setq class-envs cenvs))))
  (cond ((= (length final-class-objs) 1)
	 ;; Special case: if exactly one class obj, just share its class-disp tables.
	 (setf (obj-val-class-disp obj)
	       (obj-val-class-disp (car final-class-objs)))
	 (setf (obj-fcn-class-disp obj)
	       (obj-fcn-class-disp (car final-class-objs)))
	 (record-class-usage obj class-envs t))
	(t ;; Otherwise make fresh disp tables.
	 (setup-class-disp-tables-for-object obj class-envs))))

(defun BASE-OBJS (&optional (obj *object))
  (if (global-obj? obj)
      nil
      (obj-superiors obj)))

(defun INHERITED-OBJS (&optional (obj *object))
  (if (global-obj? obj)
      nil
      (mapcar #'env-object (cdr (obj-envlist obj)))))

(defun OBJ-EQUAL (obj1 obj2)
  (or (eq obj1 obj2)
      (and (object? obj1) (object? obj2)
	   (equal (obj-envs obj1) (obj-envs obj2)))))

;;;; Toplevel, Print-rep

; Toplevel

(defun obj-listener-loop ()
  #+lambda (micro-load)
  (setq *shadows nil)
  (ask-aux nil
    (read-compile-print-loop)))

;Use this to make toplev forms (other than ASK, DEFOBFUN) work in a file.
(defmacro obl (form &body forms)
  (if *walkover?
      (if (null *obl-walking?)
	  (if forms (walkover `(progn ,form ,@forms))
	      (walkover form))
	  (if (null forms) form `(progn ,form ,@forms)))
      (if (or *obl-compiling? *inside-defobfun
 );	      #+lambda compiler:qc-file-in-progress)
	  (if (null forms) form `(progn ,form ,@forms))
	  `(progn 'compile
		  (inhibiting-fdefine-warnings
		    (let ((*no-specials-warning t))
		      (defobfun %run-dummy () ,form ,@forms))
		    (%run-dummy))))))

(defun read-compile-print-loop ()
  (catch 'exit
    (error-restart-loop ((#+lambda error #+symbolics dbg:error
			  #+(or lambda symbolics) sys:abort)
			 "Return to obLisp read-compile-print loop")
      (catch 'continue
	(print-apply-compile-read #+lambda "~%~a-> "
				  #+symbolics   "~a-> ")))))

(defun print-apply-compile-read (&optional prompt &aux vals)
  (setq + (if prompt
	      (prompt-and-read :expression prompt
			       (if (global-obj? *object)
				   "" (if (own? 'obj-name)
					  (get-sym-val 'obj-name)
					*object)))
	      (read)))
  (if (and (consp +) (memq (car +) '(defobfun defclassvar defclassvars
				      definstancevar definstancevars defkind)))
      (setq vals (multiple-value-list (eval +)))
      (iff *walkover?
	   (setq vals (multiple-value-list (eval (walkover +))))
	(eval `(inhibiting-fdefine-warnings
		 (let ((*no-specials-warning t))
		   (defobfun %run-dummy () ,+))))
	(setq vals (multiple-value-list (%run-dummy)))))
  (setq * (car vals))
  (mapc #'print vals))

(defun undefined-function-error ()
  (ferror nil "~%Undefined ObjectLisp function"))


; Print-rep

(defun print-object (obj)
  (ask-aux obj
    (apply-fcn-sym 'print-self nil)))

#+lambda
(defparameter *micro-loaded? nil)

#+lambda
(defun micro-load ()
 (if *microcode? (unless *micro-loaded?
		   (apply 'compiler:ma-load *microcode-fcns)
		   (mapc 'compiler:enable-micro-misc *misccode-fcns)))
 (setq *micro-loaded? t))

#+lambda (micro-load)