;;;  SHARPA    				 -*-Mode:Lisp;Package:SI;Lowercase:T-*-
;;;  **************************************************************************
;;;  **** NIL ** NIL/MACLISP/LISPM Compatible # Macro Auxiliary  **************
;;;  **************************************************************************
;;;  ******** (c) Copyright 1981 Massachusetts Institute of Technology ********
;;;  ************ this is a read-only file! (all writes reserved) *************
;;;  **************************************************************************

#-LISPM
(herald SHARPAUX /40)

;; temporary, this MUST be usuable in the LISPM for MACSYMA! -gjc
#Q (defprop SHARPAUX (macro) mc:macsyma-module)


(eval-when (eval compile)
  (if (and (fboundp 'DEFSTRUCT)
	   (not (get 'DEFVST 'VERSION)))
      () 
      (defmacro DEFSTRUCT (&rest w) `(DEFVST ,.w)))
)

(defstruct (FEATURE-SET :conc-name (:constructor cons-a-feature-set) :named)
	    target features nofeatures query-mode superiors)

(defprop FEATURE-SET 
	 (FEATURES NOFEATURES QUERY-MODE)
	 SUPPRESSED-COMPONENT-NAMES)

(defmacro DEF-FEATURE-SET (target &rest options)
  (do ((l options (cddr l)))
      ((null l))
    (or (memq (car l) '(:QUERY-MODE :FEATURES :NOFEATURES :SUPERIORS))
	(error "Bad option in options list - DEF-FEATURE-SET" (car l))))
  (setq options (cons 'DEF-FEATURE-SET options))
  (let ((query-mode (if (getl options '(:QUERY-MODE))
			(get options ':QUERY-MODE)
			':QUERY))
	(features (get options ':FEATURES))
	(nofeatures (get options ':NOFEATURES))
	(superiors (get options ':SUPERIORS)))
    (check-type query-mode 
		#'si:query-mode-keyword 
		'DEF-FEATURE-SET)
    (check-type target     #'SYMBOLP 'DEF-FEATURE-SET)
    (check-type features   #'LISTP   'DEF-FEATURE-SET)
    (check-type nofeatures #'LISTP   'DEF-FEATURE-SET)
    (check-type superiors  #'LISTP   'DEF-FEATURE-SET)
    `(PROGN 'COMPILE
	    (PUTPROP ',target 
		     (cons-a-FEATURE-SET TARGET     ',target 
					 FEATURES   ',features
					 NOFEATURES ',nofeatures
					 QUERY-MODE ',query-mode 
					 SUPERIORS  ',superiors )
		     'FEATURE-SET)
	    (SETQ FEATURE-NAMES (CONS ',target (DELQ ',target FEATURE-NAMES)))
	    ',target)))

(defun SI:QUERY-MODE-KEYWORD (query-mode) 
  (memq query-mode '(:QUERY :ERROR T () )))


(defmacro DEF-EQUIVALENCE-FEATURE-SET (name to)
  "Define a feature set name to be equivalent to an existing name"
  (check-type name #'SYMBOLP 'DEF-INDIRECT-FEATURE-SET)
  (check-type to #'SYMBOLP 'DEF-INDIRECT-FEATURE-SET)
  (let ((equiv-var (symbolconc 'FEATURE-SET '- name '= to)))
    `(PROGN 
       (SETQ ,equiv-var ',to)
       (DEF-INDIRECT-FEATURE-SET ,name ,equiv-var))))

(defmacro DEF-INDIRECT-FEATURE-SET (name to)
  "Define a feature set name to indirect through the value of a variable"
  (check-type name #'SYMBOLP 'DEF-INDIRECT-FEATURE-SET)
  (check-type to #'SYMBOLP 'DEF-INDIRECT-FEATURE-SET)
  `(PROGN (PUTPROP ',name
		   ',to 
		   'FEATURE-SET)
	  (SETQ FEATURE-NAMES (CONS ',name (DELQ ',name FEATURE-NAMES)))
	  ',name))



;;; (WHEN-FEATURE                       ;; (WHEN-FEATURES
;;;   (featurespec1 . clause1)          ;;   (featurespec1 . clause1)
;;;   (featurespec2 . clause2)          ;;   (featurespec2 . clause2)
;;;   (featurespec3 . clause3) ...)     ;;   (featurespec3 . clause3) ...)
;;;					;;
;;;   Executes the first clause which	;;   Executes all clauses which
;;;   corresponds to a feature match.	;;   corresponds to a feature match.
;;;
;;; Feature match specs are designated by the following types of forms:
;;;
;;;  T			    - always
;;;  symbol		    - feature name
;;;  (OR spec1 spec2 ...)   - spec disjunction
;;;  (AND spec1 spec2 ...)  - spec conjunction
;;;  (NOT spec)		    - spec negation


(defmacro WHEN-FEATURE (&rest clauses)
  `(COND ,@(mapcar #'(lambda (x)
		       `(,(if (eq (car x) 'T) 
			      'T
			      `(FEATUREP ',(car x)))
			 ,@(cdr x)))
		   clauses)))

(defmacro WHEN-FEATURES (&rest clauses)
  `(PROGN ,@(mapcar #'(lambda (x)
			`(COND (,(if (eq (car x) 'T) 
				     'T
				     `(FEATUREP ',(car x)))
				,@(cdr x))))
		    clauses)))