;;; -*- Lisp -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain.
;;; Spice Lisp is currently incomplete and under active development.
;;; If you want to use this code or any part of Spice Lisp, please contact
;;; Scott Fahlman (FAHLMAN@CMUC). 
;;; **********************************************************************
;;;
;;; Defstruct structure definition package.
;;; Written by Skef Wholey.
;;;

;;; Defstruct options:

(eval-when (compile load eval)

(defvar ds-name ())
(defvar ds-options ())
(defvar conc-name ())
(defvar ds-type ())
(defvar type-cat ())
(defvar named ())
(defvar ds-documentation ())
(defvar constructor ())
(defvar predicate ())
(defvar include ())
(defvar print-function ())
(defvar initial-offset ())
(defvar callable-accessors ())
(defvar struct-length ())

;;; Slot information:

(defvar slot-names ())
(defvar pure-names ())
(defvar slot-defaults ())
(defvar slot-options ())
(defvar slot-numbers ())
(defvar writable-slots ())
(defvar new-slot-start ())
(defvar slot-types ())
(defvar slot-keywords ())

)

;;; Useful things for DefStructing around:

(defun concat-pnames (name1 name2)
  (if name1
      (intern (concatenate 'simple-string (symbol-name name1)
			   (symbol-name name2)))
      name2))

(defun elt-form (object index type)
  (case type
    (vector `(svref ,object ,index))
    (list `(nth ,index ,object))
    (t (error "Some strange type, ~S crawled in!" type))))

(defun setelt-form (object index newval type)
  `(setf ,(elt-form object index type) ,newval))

;;; Parse-Name-And-Options sets the Defstruct option variables to the values
;;; given in the Defstruct.

(defun parse-name-and-options (em)
  (if (atom em) (setq ds-name em ds-options ())
		(setq ds-name (car em) ds-options (cdr em)))
  (setq	conc-name (concat-pnames ds-name '-)
	ds-type 'vector
	type-cat 'vector
	named t
	constructor (concat-pnames 'make- ds-name)
	predicate (concat-pnames conc-name 'p)
	include ()
	print-function ()
	initial-offset 1
	callable-accessors ())
  (cond
   ((listp em)
    (do ((options (cdr em) (cdr options))
	 (named-found ())
	 (unnamed-found ()))
	((null options)
	 (cond ((or named-found
		    (and (eq type-cat 'vector)
			 (not unnamed-found)))
		(setq named t)
		(setq initial-offset 1))
	       (t
		(setq named ())
		(setq initial-offset 0))))
      (if (listp (car options))
	  (if (symbolp (caar options))
	      (case (caar options)
		(:type (setq ds-type (cadr (car options))
			     type-cat (if (atom ds-type)
					  ds-type
					  (car ds-type))
			     unnamed-found t))
		(:include (setq include (cdr (car options))))
		(:print-function (setq print-function (cadr (car options))))
		(:initial-offset (setq initial-offset (cadr (car options))))
		(:conc-name (setq conc-name (cadr (car options))))
		(:constructor (setq constructor (if (atom (cddr (car options)))
						    (cadr (car options))
						    (cdr (car options)))))
		(:predicate (setq predicate (cadr (car options))))
		(:callable-accessors (setq callable-accessors (cadr (car options))))
		(t (error "~S: Unknown option to DefStruct" (caar options))))
	      (error "~S: Bad option format for DefStruct" (car options)))
	  (if (symbolp (car options))
	      (case (car options)
		(:conc-name)
		(:named (setq named-found t))
		(:unnamed (setq unnamed-found t))
		(:constructor)
		(:predicate)
		(:callable-accessors (setq callable-accessors t))
		(t (error "~S: Unknown option for DefStruct" (car options))))
	      (error "~S: Bad option format for DefStruct" (car options))))))))

;;; Include-Structure sets up Slot-Names, Slot-Defaults, and Slot-Options from
;;; an :include'd structure.

(defun include-structure ()
  (if include
      (let ((info (get (car include) 'defstruct-description)))
	(if info
	    (cond ((equal (defstruct-description-type info) ds-type)
		   (setq slot-names (defstruct-description-slot-names info)
			 pure-names (defstruct-description-slot-pure-names info)
			 slot-keywords (defstruct-description-slot-keywords info)
			 slot-defaults (append (defstruct-description-slot-defaults info) nil)
			 slot-options (defstruct-description-slot-options info)
			 slot-numbers (defstruct-description-slot-numbers info)
			 slot-types (defstruct-description-slot-types info)
			 new-slot-start (length slot-names))
		   (do ((inc-options (cdr include) (cdr inc-options)))
		       ((null inc-options))
		     (let ((slot (car inc-options)))
		       (if (atom slot)
			   (set-corresponding slot slot-defaults ())
			   (when (cadr slot)
			     (set-corresponding (car slot) slot-defaults
						(cadr slot))
			     (add-to-options (car slot) (cddr slot)))))))
		  (t
		   (error "~S: Included structure is not of the same type"
			  ds-type)))
	    (error "~S: Can't find structure to include" (car include))))
      (setq slot-names () slot-keywords () slot-options () slot-defaults ()
	    slot-numbers () writable-slots () pure-names () slot-types ()
	    new-slot-start 0)))

;;; Things to make hacking the Slot-Whatever lists easier:

(defun set-corresponding (thing target-list new-value)
  (do ((target-list target-list (cdr target-list))
       (names pure-names (cdr names))
       (keys slot-keywords (cdr keys)))
      ((null target-list)
       (error "Unknown slot name or keyword in include option: ~S" thing))
    (if (or (eq (car names) thing)
	    (eq (caar keys) thing))
	(return (rplaca target-list new-value)))))

(defun add-to-options (thing new-values)
  (do ((target-list slot-options (cdr target-list))
       (names pure-names (cdr names))
       (keys slot-keywords (cdr keys)))
      ((null target-list)
       (error "Unknown slot name or keyword in include option: ~S" thing))
    (if (or (eq (car names) thing)
	    (eq (caar keys) thing))
	(return (do ((new-values new-values (cdr new-values)))
		    ((null new-values))
		  (if (not (memq (car new-values) (car target-list)))
		      (push (car new-values) (car target-list))))))))

;;; Parse-Slot-Info grovels the slot list and puts useful information into
;;; Slot-Names, Slot-Defaults, and Slot-Options, and builds an association
;;; list of slot names and indicies into the concrete data structure named
;;; Slot-Numbers.  An association list of writable (i.e. non-:read-only)
;;; slots is thrown into Writable-Slots.  A list of pairs of slot-name and
;;; slot-type (for typed slots) is thrown into Slot-Types.  A association
;;; list of keywords formed from the slot names and corresponding slot
;;; numbers in thrown into Slot-Keywords.

(defun parse-slot-info (slots)
  (do ((slots slots (cdr slots))
       (index (+ initial-offset new-slot-start) (1+ index)))
      ((atom slots)
       (setq struct-length index))
    (cond ((atom (car slots))
	   (push (concat-pnames conc-name (car slots)) slot-names)
	   (push (cons (make-keyword (car slots)) index) slot-keywords)
	   (push (car slots) pure-names)
	   (push () slot-defaults)
	   (push () slot-options)
	   (push (cons (car slot-names) index) slot-numbers)
	   (push (car slot-numbers) writable-slots))
	  ((listp (car slots))
	   (push (concat-pnames conc-name (caar slots)) slot-names)
	   (push (cons (make-keyword (caar slots)) index) slot-keywords)
	   (push (caar slots) pure-names)
	   (push (cadar slots) slot-defaults)
	   (push (cddar slots) slot-options)
	   (push (cons (car slot-names) index) slot-numbers)
	   (push (car slot-numbers) writable-slots) ; assume writable...
	   (do ((keywords (car slot-options) (cddr keywords)))
	       ((null keywords))
	     (case (car keywords)
	       (:read-only
		(if (cadr keywords)		    ; ...until proven wrong
		    (setq writable-slots (cdr writable-slots))))
	       (:type
		(push (cons (car slot-names) (cadr keywords)) slot-types))
	       (:invisible
		)
	       (t
		(error "~S: Unknown slot option for Defstruct"
		       (car keywords))))))
	  (t (error "~S: Bad thing in slot list for DefStruct" (car slots))))))


;;; Make-Bare-Structure returns a form which will construct a bare structure.

(defun make-bare-structure (str-type-cat str-length)
  (case str-type-cat
    (list `(make-list ,str-length))
    (vector `(make-vector ,str-length))
    (t (error "~S: Bad type crept into DefStruct" ds-type))))

;;; Make-Initial-Object returns a form which will construct a bare structure
;;; and name it.

(defun make-initial-object (str-named str-type-cat str-name str-length)
  (if str-named
      (let ((temp (gensym)))
	`(let ((,temp ,(make-bare-structure str-type-cat str-length)))
	   ,@(if (eq str-type-cat 'vector)
		 `((%primitive set-vector-subtype ,temp 1)))
	   ,(setelt-form temp 0 `',str-name str-type-cat)
	   ,temp))
      (make-bare-structure str-type-cat str-length)))

;;; Make-Constructor returns a Defun which defines the constructor function.

(defun make-constructor ()
  `(defun ,constructor (&rest initial-values)
     (do ((initial-values initial-values (cddr initial-values))
	  (object ,(make-initial-object named type-cat ds-name struct-length))
	  (slots-done ()))
	 ((null initial-values)
	  ,@(do ((slots slot-keywords (cdr slots))
		 (defaults slot-defaults (cdr defaults))
		 (init-forms ()))
		((null slots) init-forms)
	      (if (car defaults)
		  (push `(if (not (memq ',(caar slots) slots-done))
			     ,(setelt-form 'object (cdar slots)
					   (car defaults) ds-type))
			init-forms)))
	  object)
       (let ((slot-number (cdr (assoc (car initial-values) ',slot-keywords))))
	 (cond (slot-number
		,(setelt-form 'object 'slot-number '(cadr initial-values)
			      ds-type)
		(push (car initial-values) slots-done))
	       (t
		(error "Unknown option to DefStruct constructor.")))))))

;;; Make-By-Position-Constructor returns a Defun for a by-position
;;; constructor function.

(defun make-by-position-constructor ()
  (do ((arglist (cadr constructor) (cdr arglist))
       (bound-slots ())
       (object-name (gensym))
       (slot-pure-numbers (mapcar #'(lambda (x y) `(,x . ,(cdr y)))
				  pure-names slot-numbers)))
      ((null arglist)
       `(defun ,(car constructor) ,(cadr constructor)
	  (let ((,object-name ,(make-initial-object named type-cat
						    ds-name struct-length)))
	    ,@(mapcar #'(lambda (slot-pair)
			  (setelt-form object-name (cdr slot-pair)
				       (car slot-pair) type-cat))
		      bound-slots)
	    ,@(do ((slots slot-pure-numbers (cdr slots))
		   (defaults slot-defaults (cdr defaults))
		   (sets ()))
		  ((null slots) sets)
		(if (not (assq (caar slots) bound-slots))
		    (push (setelt-form object-name (cdar slots)
				       (car defaults) type-cat)
			  sets)))
	    ,object-name)))
    (let* ((arg (car arglist))
	   (mostarg (if (atom arg) arg (car arg))))
      (if (not (memq arg '(&optional &rest &key &aux)))
	  (if (memq mostarg pure-names)
	      (push (cons mostarg
			  (cdr (assoc mostarg slot-pure-numbers)))
		    bound-slots)
	      (error "~S: Not a known slot name." mostarg))))))

;;; Make-Accessors returns a list of Defuns which define accessors for the
;;; structure.  Accessors are defined only for "new" (i.e. non-included) slots.

(defun make-accessors ()
  (do ((slots (nthcdr new-slot-start (reverse slot-numbers)) (cdr slots))
       (index 0 (1+ index))
       (definitions ()))
      ((null slots) definitions)
    (push `(defun ,(caar slots) (object)
	     ,(elt-form 'object (cdar slots) type-cat))
	  definitions)))

;;; Make-Declarations returns a list of Declare forms which declare the
;;; function argument and result types of the functions defined by DefStruct,
;;; and declares the access functions INLINE.

(defun make-declarations ()
  (do ((slot-types slot-types (cdr slot-types))
       (declarations ()))
      ((null slot-types)
       (cons `(proclaim '(inline ,@slot-names))
	     declarations))
    (push `(proclaim '(function ,(caar slot-types)
				(,ds-name) ,(cdar slot-types)))
	  declarations)))

;;; Make-Pred returns the definition of the Mumble-P function.

(defun make-pred ()
  `(defun ,predicate (thing)
     ,(case type-cat
	(vector `(and (simple-vector-p thing)
		      (= (%primitive get-vector-subtype thing) 1)
		      (let ((type (svref thing 0)))
			(or (eq type ',ds-name)
			    (eq (get type 'included-structure) ',ds-name)))))
	(list `(and (listp thing)
		    (or (eq (car thing) ',ds-name)
			(and (symbolp (car thing))
			     (eq (get (car thing) 'included-structure)
				 ',ds-name)))))
	(t (error "~S: Somehow this strange type crawled in." ds-type)))))

;;; Make-DefSetfs returns a list of DefSetfs for the structure.

(defun make-defsetfs ()
  (do ((slots writable-slots (cdr slots))
       (defsetfs ()))
      ((null slots) defsetfs)
    (push `(defsetf ,(caar slots) (structure) (new-value)
	     (setelt-form structure ,(cdar slots) new-value ',type-cat))
	  defsetfs)))

;;; Defstruct:

(defmacro defstruct (name+options &rest slots)
  "Structure defining macro.  See manual for details."
  (let (;; Defstruct options:
	ds-name ds-options conc-name ds-type type-cat named
	ds-documentation constructor predicate include
	print-function initial-offset callable-accessors
	struct-length
	;; Slot options:
	slot-names pure-names slot-defaults slot-options slot-numbers
	writable-slots new-slot-start slot-types slot-keywords)
    (parse-name-and-options name+options)
    (if (stringp (car slots))
	(setq ds-documentation (car slots)
	      slots (cdr slots))
	(setq ds-documentation ()))
    (include-structure)
    (parse-slot-info slots)
    `(progn
      ,(if (atom constructor) (make-constructor))
      ,(if (listp constructor) (make-by-position-constructor))
      ,@(make-declarations)
      ,@(make-accessors)
      ,(if (and named predicate) (make-pred))
      (eval-when (compile load eval)
	,@(make-defsetfs))
      ,(if ds-documentation
	   `(%put ',ds-name '%struct-documentation ,ds-documentation))
      ,(if print-function
	   `(%put ',ds-name 'structure-print ',print-function))
      ,(if include
	   `(%put ',ds-name 'included-structure ',(car include)))
      (eval-when (compile load eval)
	,(if named (catalog-structure)))
      ',ds-name)))

;;; Internal structures used to Catalog a structure:
;;; These are of type List so that the structures may be made in MacLisp.
;;; When things move over to Spice Lisp, the (:type list) should be removed.

(defstruct (defstruct-description :unnamed (:type list))
  (name ds-name :read-only t)
  (type ds-type :read-only t)
  (options ds-options :read-only t)
  (size struct-length :read-only t)
  (conc-name conc-name :read-only t)
  (constructor constructor :read-only t)
  (slot-names slot-names :read-only t)
  (slot-pure-names pure-names :read-only t)
  (slot-defaults slot-defaults :read-only t)
  (slot-options slot-options :read-only t)
  (slot-numbers slot-numbers :read-only t)
  (slot-types slot-types :read-only t)
  (slot-keywords slot-keywords :read-only t)
  (slot-options slot-options :read-only t))

;;; Catalog-Structure throws a description of the structure on the
;;; Defstruct-Description property of the structure name.

(defun catalog-structure ()
  `(%put ',ds-name
	 'defstruct-description
	 ',(make-defstruct-description)))