;;; -*- Mode:LISP; Package:COMPILER; Base:10; Readtable:CL -*-

;; ||| New file -- smh 29sep88

;; This holds macro definitions for cross compiling for the Falcon.
;; It is supposed to be cross compiled and the FDEF file the
;; loaded in as part of the cross compiler.  The actual compiled file
;; might or might not want eventually to be loaded on the Falcon.

(defmacro PUSHNEW (item place &rest testandkey)
  `(setf ,place (adjoin ,item ,place . ,testandkey)))

(inherit-lambda-macro-definitions
  inherit-lambda-macro-definitions
  si::XR-BQ-CONS si::XR-BQ-LIST si::XR-BQ-LIST* si::XR-BQ-APPEND si::XR-BQ-NCONC
  si::XR-BQ-VECTOR si::XR-BQ-VECTOR*
  )

(inherit-lambda-macro-definitions
  defvar
  defmacro defdecl
  defsetf define-setf-method deflocf
  setf locf
  defsubst si::defsubst-with-parent
  inhibit-style-warnings
  )

(inherit-lambda-macro-definitions
  when unless
  dolist dotimes
  psetq
  with-list with-list*)

(inherit-lambda-macro-definitions
  incf decf
  )

(defmacro locf (accessor &environment environment)
  "Return a locative pointer to the place where ACCESSOR's value is stored.
Note that (LOCF (CDR SOMETHING)) is normally equivalent to SOMETHING,
which may be a list rather than a locative."
  (loop
    (let (fcn)
      (cond ((symbolp accessor)			;Special case needed.
	     (return `(variable-location ,accessor)))
	    ((not (symbolp (car accessor)))
	     (ferror "~S non-symbolic function in ~S" (car accessor) 'locf))
	    ;;>> This is OK for now, since environment only includes the lexical stuff
	    ;;>>  around the current function.  However, when environment includes stuff
	    ;;>>  for a whole compilation or set of compilations, we will have to getdecl
	    ;;>>  again (being careful not to getdecl for lexically defined functions!)
	    ((unless (fsymeval-in-environment (car accessor) environment nil)
	       (cond ((eq (getdecl (car accessor) 'locf) 'unlocfable)
		      (nolocf accessor))
		     ((setq fcn (getdecl (car accessor) 'locf-method))
		      (if (symbolp fcn)
			  (return (cons fcn (cdr accessor)))
			(progn (if (eq (cdr fcn) 'nolocf)
				   (nolocf accessor))
			       (return (call (cdr fcn) nil accessor :optional environment)))))
		     ((setq fcn (getdecl (car accessor) 'setf-expand))
		      (setq accessor (funcall fcn accessor)))
		     ((and (fboundp (car accessor)) (arrayp (symbol-function (car accessor))))
		      ;; +++ not yet supported in runtime
		      (return `(si::aloc #',(car accessor) . ,(cdr accessor))))
		     ((and (fboundp (car accessor)) (symbolp (symbol-function (car accessor))))
		      (return `(locf (,(symbol-function (car accessor)) . ,(cdr accessor))))))))
	    ((not (eq accessor (setq accessor (macroexpand-1 accessor environment)))))
	    (t (ferror 'sys:unknown-locf-reference
		       "No way known to do LOCF on ~S." (car accessor)))))))