;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;;
;;;     (c) Copyright 1980 Massachusetts Institute of Technology         ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(macsyma-module opshin macro)

;;; GJC 7:24pm  Saturday, 20 September 1980

;;; For parsing standard option lists.

;;; <Option-header> ::= <name> | (<name> . <option-list>)
;;; <option-list>   ::= (<option-slot> . <option-list>) | ()
;;; <option-slot>    ::= <name> | (<name>) | (<name> <value>)

(DEFVAR OPTION-MASTER)

(DEFUN PARSE-OPTION-HEADER (OPTION-MASTER HEADER)
       (PARSE-OPTION OPTION-MASTER (COND ((ATOM HEADER)
					   `((NAME  ,HEADER)))
					  ((ATOM (CAR HEADER))
					   `((NAME  ,(CAR HEADER))
					     ,@(CDR HEADER)))
					  (T
					   (OPTION-PARSE-ERROR
					    "bad name designation in header."
					    HEADER)))))

(DEFUN PARSE-OPTION (OPTION-MASTER LIST)
       (PARSE-OPTION-SUB (OR (GET OPTION-MASTER 'OPTION-ACTIONS)
			      (ERROR "has no option actions."
				     OPTION-MASTER
				     'FAIL-ACT))
			  (COPY-TOP-LEVEL LIST) NIL))

(DEFUN OPTION-PARSE-ERROR (MESS THING)
       (FORMAT MSGFILES "~&; Error parsing option for ~A" OPTION-MASTER)
       (ERROR MESS THING 'FAIL-ACT))

(DEFUN STANDARD-T (DONE NAME)
       (CONS (CONS NAME T) DONE))

(DEFUN STANDARD-VAL (DONE NAME VAL)
       (CONS (CONS NAME VAL) DONE))

(DEFUN STANDARD-%%EMPTY%% (DONE NAME)
       (CONS (CONS NAME '%%EMPTY%%) DONE))

(DEFSTRUCT (OPTION-ACTION CONC-NAME)
	   NAME
	   (DOCUMENT "")
	   (IF-ATOM #'STANDARD-T)
	   (IF-VAL  #'STANDARD-VAL)
	   (IF-NOT #'STANDARD-%%EMPTY%%))

(DEFUN PARSE-OPTION-SUB (OPTION-ACTIONS LIST DONE)
       (COND ((NULL OPTION-ACTIONS)
	      (IF (NULL LIST) DONE
		  (OPTION-PARSE-ERROR "unknown option." list)))
	     (T
	      (LET* ((ACTION (CAR OPTION-ACTIONS))
		     (NAME (OPTION-ACTION-NAME ACTION))
		     (SLOT (GET-OPTION-SLOT NAME LIST)))
		    (PARSE-OPTION-SUB
		     (CDR OPTION-ACTIONS)
		     (DELETE SLOT LIST)
		     (COND ((null slot)
			    (FUNCALL (OPTION-ACTION-IF-NOT ACTION)
				     DONE NAME))
			   ((ATOM SLOT)
			    (FUNCALL (OPTION-ACTION-IF-ATOM ACTION)
				     DONE NAME))
			   (T
			    (CASEQ (LENGTH SLOT)
				   (1
				    (FUNCALL (OPTION-ACTION-IF-VAL ACTION)
					     DONE NAME NIL))
				    (2
				     (FUNCALL (OPTION-ACTION-IF-VAL ACTION)
					      DONE NAME (CADR SLOT)))
				    (T
				     (OPTION-PARSE-ERROR
				      "bad option spec." slot))))))))))

(DEFUN GET-OPTION-SLOT (NAME LIST)
       (COND ((NULL LIST) NIL)
	     ((ATOM (CAR LIST))
	      (IF (EQ NAME (CAR LIST))
		  (CAR LIST)
		  (GET-OPTION-SLOT NAME (CDR LIST))))
	     ((ATOM (CAAR LIST))
	      (IF (EQ NAME (CAAR LIST))
		  (CAR LIST)
		  (GET-OPTION-SLOT NAME (CDR LIST))))
	     ('ELSE
	      (OPTION-PARSE-ERROR "bad option spec name." (CAAR LIST)))))

(COMMENT |example|
(DEF-OPTION FOO
	     (NAME)
	     (BAZ
	      DOCUMENT "Stupid option to use."
	      IF-ATOM (LAMBDA (FOO BAR) (BAZ FOO BAR)))))

(DEFMACRO DEF-OPTION (NAME &REST OPTION)
	  `(PUTPROP ',NAME
		    (LIST ,@(MAPCAR #'(LAMBDA (U)
					      `(MAKE-OPTION-ACTION
						NAME ',(IF (ATOM U) U (CAR U))
						,@(IF (ATOM U) NIL (CDR U))))
				    OPTION))
		    'OPTION-ACTIONS))