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

#|

PROCESSOR-SYMBOL.LISP

A customization mechanism is proposed for solving problems caused by
compiling Lambda system, on and for Lambda, when Lambda system
files contain Falcon package references that are not known to Lambda.
(Got that?)

In other words, instead of doing the following and losing:

(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* 'falcon)
   ;;etc.
   ))

Do:

 (processor-symbol
   (:lambda "ART-Q" "ZL")
    #+lambda (:falcon "ART-Q" "K-ARRAY")
    #+falcon (:falcon "ART-Q" "ARRAY"))
|#

(defmacro processor-symbol (&rest clauses &aux clause sym-pkg-list sym pkg)
  "Returns a quoted symbol appropriate for the compilation target
  computer, according to the appropriate CLAUSE in CLAUSES.  This provides
  a way to refer to variant symbols for known processor types, where the
  package containing inapplicable variant symbols does not have to exist.
The format is like CASE:  the first element of each clause is a processor type or
 a list of processor type keywords -- :LAMBDA, :FALCON, etc.
 A clause head of T or OTHERWISE provides a default case, where no matching
 element is present.
The rest of each CLAUSE is a list, SYM-DEF.
  The first element of a SYM-DEF /(the second element of a clause) is a string or symbol
    naming a symbol /(it gets passed to INTERN).
  The second element a SYM-DEF /(the third element of a clause) is a string or symbol
    naming a package.  If omitted, the package is interned as a keyword.
/
For example:
/
  /(defun array-type-symbol ()
     (processor-symbol
       (:lambda /"ART-Q/" /"ZL/")
       (:falcon /"ART-Q/" /"ARRAY/")))"
  (declare (zwei:indentation 0 2))
  ;;;We type-check carefully, and barf (warn) on problems, returning NIL
  ;;;as the result of macro-expansion.
  (flet ((barf (format-ctrl &rest format-args)
	       ;;;COMPILER:WARN or LISP:WARN  ???
	       (lisp:warn ;;; :implausible 'invalid-processor-symbol
		 "~S called with ~A for target computer ~S"
		 'processor-symbol
		 (apply #'format nil format-ctrl format-args)
		 *target-computer*)
	       (return-from processor-symbol nil)))
    (setq clause
	  (or (lisp:find (or (cdr (lisp:assoc *target-computer* 
					      '((lambda-interface . :lambda)
						(falcon-interface . :falcon))
					      :test #'string-equal))
			     (barf "invalid processor ~S" *target-computer*))
			 clauses
			 :key #'(lambda (clause)
				  (let ((head (car clause)))
				    (if (atom head) (cons head nil) head)))
			 :test #'(lambda (item key)
				   (lisp:member item key :test #'string-equal)))
	      (lisp:find-if #'(lambda (head)
				(and (symbolp head)
				     (or (eq head t) (string-equal head :otherwise))))
			    clauses
			    :key #'car)))
    ;;;Check the selected clause:
    (typecase clause
      ((and cons (not (satisfies cdddr))))
      (null (barf "no clause"))
      (t (barf "invalid clause ~S" clause)))
    (setq sym-pkg-list (rest clause))
    (typecase sym-pkg-list
      ((and (cons (not (satisfies cddr)))))
      (null (barf "no symbol description"))
      (t (barf "an invalid symbol description ~S" sym-pkg-list)))
    ;;;Check the symbol element:
    (setq sym (first sym-pkg-list))
    (typecase sym
      (null (barf "no symbol"))
      ((or string symbol))
      (t (barf "an invalid symbol")))
    ;;;Check the package element:
    (setq pkg (find-package (or (second sym-pkg-list) :keyword)))	;???
    (typecase pkg
      (package)
      (null (barf "unknown package ~S" (second sym-pkg-list)))
      (t (barf "invalid package ~S" pkg))))
  ;;;Whew! Intern the symbol now, and return the symbol (quoted)
  `',(intern sym pkg))

;;;Some quick tests:

#+regression-testing
(cl-tests:runtest-seq (processor-symbol psym-1 :simple)
    (((psym-1.1) (null (processor-symbol (:bogus "SYM" "???"))))
     ((psym-1.2) (null (processor-symbol ((:bogus) "SYM" "???"))))
     ((psym-1.3) (null (processor-symbol (:lambda "SYM" "???")))) 
     ((psym-1.4) (null (processor-symbol ((T) "SYM" "???")))))
  :doc$ "PROCESSOR-SYMBOL, calls that should signal error")

#+regression-testing
(cl-tests:runtest-seq (processor-symbol psym-2 :simple)
    (((psym-2.1) (eq (processor-symbol (:lambda "SYM" "CL-TESTS")) 'cl-tests:sym))
     ((psym-2.2) (eq (processor-symbol
			(:bogus "SYM" "???")
			((:lambda) "SYM" "CL-TESTS")) 'cl-tests:sym))
     ((psym-2.3) (eq (processor-symbol
			(:bogus "SYM" "???")
			((:lambda) "SYM"))
		     :SYM))
     ((psym-2.4) (eq (processor-symbol
			(:bogus "SYM" "???")
			(T "SYM"))
		     :SYM))
     ((psym-2.4) (eq (processor-symbol
			(:bogus "SYM" "???")
			(otherwise "SYM"))
		     :SYM)))
  :doc$ "PROCESSOR-SYMBOL, calls that should work")

;;;Bogusly test FALCON case

#+regression-testing
(compiler-let ((*target-computer* 'falcon-interface))
  (cl-tests:runtest-seq (processor-symbol psym-3 :simple)
      (((psym-3.1) (eq (processor-symbol (:falcon "SYM" "CL-TESTS")) 'cl-tests:sym))
       ((psym-3.2) (eq (processor-symbol
			  (:bogus "SYM" "???")
			  ((:falcon) "SYM" "CL-TESTS"))
		       'cl-tests:sym))
       ((psym-3.3) (eq (processor-symbol
			  (:bogus "SYM" "???")
			  ((:falcon) "SYM"))
		       :SYM))
       ((psym-3.4) (eq (processor-symbol
			(:bogus "SYM" "???")
			(otherwise "SYM"))
		       :SYM)))
    :doc$ "PROCESSOR-SYMBOL, calls that should work"))