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

#|

FOREIGN-SYMBOL.LISP

Provides a compile-time customization mechanism for solving problems
with references to symbols in undefined packages or unloaded systems.

The real-word application of this is for the cross-compiler, when Lambda
system files contain references to symbols in Falcon packages that are
not known to Lambda.  (Got that?)

For each "foreign symbol," a property list of values is associated with
the foreign symbol tag, which is generally a keyword.  For each target
computer, a "native value" for the foreign symbol can be associated with
a particular tag.  (These native values can be anything, but the
existing requirement is to obtain a different symbol as the foreign
symbol value.)

Here's an example of the application of FOREIGN-SYMBOL.  Instead of
doing the following and losing:

  (do-something-with
    (cond
      ((eq *target-computer* 'k)
        ;;array:art-q ;;WKF: 5/18/88
        #+lambda k-array:art-q #+falcon array:art-q
        'art-q)
      ((eq *target-computer* 'lambda)
        ;;etc.
        )))

...one would do something like the following:

1. Define the foreign symbols for each processor, either a) in separate
files using DEF-FOREIGN-SYMBOL, or b) centrally for multiple processors
using DEF-FOREIGN-SYMBOLS.  For example:

  a.1: Define the Lambda native symbol, e.g., in "SYS:SYS;TYPES":

   #+lambda
   (def-foreign-symbol :art-q 'ZL:ART-Q)

  a.2: Define the Falcon native symbol elsewhere:

   (def-foreign-symbol :art-q
     #+lambda 'K-ARRAY:ART-Q
     #+falcon 'ARRAY:ART-Q)

OR:

  b: Define all the versions in one file (currently SYS:SYS;DEF-FOREIGN-SYMBOLS.LISP):
   
   (def-foreign-symbols :art-q
     (:lambda 'zl:art-q)
     #+falcon-system-loaded
     (:k #+lambda 'k-array:art-q #+falcon array:art-q))

3: Refer to the foreign symbol where needed using FOREIGN-SYMBOL:

(defun foo () (print (foreign-symbol :art-q)))

Additional features:

1. FOREIGN-SYMBOL is SETF'able; this translates into DEF-FOREIGN-SYMBOL.

2. The source file of a FOREIGN-SYMBOL is recorded and checked, like DEFUN's, etc.

3. FOREIGN-SYMBOL-VALUE is also provided to provide compile-time lookups
with a further level of indirection: the SYMBOL-VALUE of the native
symbol is returned.

4. INLINE-FOREIGN-SYMBOL and INLINE-FOREIGN-SYMBOL-VALUE are equivalent
to FOREIGN-SYMBOL and FOREIGN-SYMBOL-VALUE, respectively, but they get
optimized into the current (compile-time) values.  This is for code that
is only being compiled to work on or for one processor, and that doesn't
need to get the foreign symbols dynamically, at run time.  I don't know
if anything in the system files will need this.

|#

(defvar *foreign-symbol-table* (make-hash-table)
	"Compile-time lookup table for FOREIGN-SYMBOL entries")

;;;Utility look-up function:

(defun lookup-foreign-symbol (foreign-symbol &optional error-p new-value-p &aux native-value)
  (declare (eh:error-reporter))
  (declare (values native-value value-found-p))
  (flet ((error-string ()
	  (format nil "There is no declared foreign-symbol value for ~S" foreign-symbol)))
    (cond
      ((setq native-value
	     (car-safe (getf (gethash foreign-symbol *foreign-symbol-table*) *target-computer*)))
       (values native-value t))
      (error-p  (error (error-string)))
      (new-value-p
       ;;If allowed, user can set value for undefined foreign-symbol
       (setq native-value (cerror t nil nil (error-string)))
       (def-foreign-symbol foreign-symbol native-value)
       (values native-value t))
      (t (values nil nil)))))

;;;Normal lookup interface:

(defun foreign-symbol (FOREIGN-SYMBOL &optional no-error-p new-value-p)
  "Returns the version of FOREIGN-SYMBOL appropriate to the compilation target
  computer, according to the appropriate CLAUSE in CLAUSES.  
  The second return value is T when the lookup was successful.
NO-ERROR-P non-NIL means don't signal an error when foreign symbol is undefined;
  rather, the second value returned is NIL.
If NEW-VALUE-P is also non-NIL,  the user is offfered a chance to handle an
  undefined foreign symbol by specifying a new value (in the error handler)."
  (lookup-foreign-symbol foreign-symbol (null no-error-p) new-value-p))

;;;Single-processor definition interface:

(defun def-foreign-symbol (foreign-symbol native-value &optional (target-computer *target-computer*))
  (declare (zwei:indentation 2 1))
  (setf (getf (gethash foreign-symbol *foreign-symbol-table*) target-computer)
	(ncons native-value))
  (si:record-source-file-name foreign-symbol 'foreign-symbol))

(defsetf foreign-symbol def-foreign-symbol)

;;;Multiple-processor definition interface:

(defmacro def-foreign-symbols (foreign-symbol &rest native-clauses)
  "Define native processor symbolic equivelents for FOREIGN-SYMBOL.
Each of the remaining arguments is a native processor clause, which
resembles an association list.
The first element of each clause is a processor symbol (e.g., :LAMBDA or :K).
The second element of each clause is the native equivalent symbol name (normally quoted)."
  (declare (zwei:indentation 1 1))
  `(progn
     ,@(do ((clauses native-clauses (cdr clauses))
	    (defs nil))
	   ((null clauses) (reverse defs))
	 (let ((clause (first clauses)))
	   (push (list 'def-foreign-symbol foreign-symbol
		       (second clause)
		       (second (assoc (first clause)
				      `((:lambda 'lambda-interface)
					(:falcon 'k)	;;;@@@Just a synonym.  Fix this later?
					(:k 'k)))))
		 defs)))))

;;;Lookup variant for getting symbol's value:

(defun foreign-symbol-value (foreign-symbol &optional no-error-p new-value-p)
  (symbol-value (lookup-foreign-symbol foreign-symbol (null no-error-p) new-value-p)))

(deff inline-foreign-symbol 'foreign-symbol)
(deff inline-foreign-symbol-value 'foreign-symbol-value)

(defoptimizer compile-time-foreign-symbol inline-foreign-symbol (form)
  `(quote ,(foreign-symbol (second form) (third form))))

(defoptimizer compile-time-foreign-symbol-value inline-foreign-symbol-value (form)
  (foreign-symbol-value (second form) (third form)))

#| Tests:

(def-foreign-symbols :art-q
  (:lambda 'zl:art-q)
  #+falcon-system-loaded
  (:k #+lambda 'k-array:art-q #+falcon array:art-q))

(defun foo () (print (foreign-symbol :art-q)))

(defun foo2 () (print (foreign-symbol-value :art-q)))

(defun foo3 () (print `(quote ,(foreign-symbol :art-q))))

(defun ifoo () (print (inline-foreign-symbol :art-q)))

(defun ifoo2 () (print (inline-foreign-symbol-value :art-q)))

(defun ifoo3 () (print `(quote ,(inline-foreign-symbol :art-q))))

|#