;-*-mode: Lisp; base: 10.; package: RecordPackage -*-
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; This program contains confidential information of Inference Corporation.  Use or copying   ;
; without express written authorization of Inference Corporation is strictly prohibited.     ;
; Copyright ownership rights hereby asserted by Inference Corporation.  Copyright 1984.      ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;

(DEFCONST BogusPackage (PKG-FIND-PACKAGE "InterlispUserHiddenSymbols"))

(DEFCONST BogusSymbol (GENSYM))

(DEFCONST NumberFixnumBits 23)

(DEFUN FieldName (&REST Qualifiers)
  (INTERN-LOCAL
    (APPLY #'STRING-APPEND
	   (FullyQualify
	     (bind Result for qual in Qualifiers do
		   (COND ((NLISTP qual) (SETQ qual (NCONS qual)))
			 (T (SETQ qual (COPYLIST qual))))
		   (for tail on result thereis (EQ (CAR tail) (CAR qual))
			then (OR (AND (<= (LENGTH tail) (LENGTH qual))
				      (for te in tail as qe in qual always (EQ qe te)))
				 (FERROR NIL "Funny qualifier ~S in Qualifers ~S~%"
					 qual Qualifiers))
			(NCONC tail (NTHCDR qual (LENGTH tail)))
			else (SETQ Result (NCONC Result qual)))
		   finally (RETURN Result))))
    BogusPackage))

(DEFSTRUCT (FieldDeclaration :LIST (:CONSTRUCTOR NIL))
  FieldDeclarationName
  ((FieldDeclarationType NIL) (FieldDeclarationReferenceForm NIL))
  ((FieldDeclarationArgument NIL) (FieldDeclarationSetForm NIL)))

(DEFMACRO NamedStructureRecordP (RecordName)
  `(GET ,RecordName 'NamedStructureRecord))

(DEFMACRO ConstructorName (RecordName)
  `(INTERN-LOCAL (STRING-APPEND "MAKE-" ,RecordName) BogusPackage))

(DEFMACRO fetch (Field of Datum) of
	  `(,(FieldName Field) ,Datum))

(DEFMACRO replace (Field of Datum with Value) of with
	  `(LET ((Datum ,Datum) (Value ,Value))
	     (SETF (,(FieldName Field) Datum) Value)
	     Value))

(DEFMACRO create (RecordName . Assignments)
  (LET ((StructureVariable (GET RecordName 'MixedRecordP)))
    (COND (StructureVariable
	   `(LET ((,StructureVariable
		   ,(BuildConstructorForm RecordName Assignments 'MixedRecordBitFieldP)))
	      ,@(for tail on Assignments by (CDDDR tail)
		     unless (GET (CAR tail) 'MixedRecordBitFieldP)
		     collect `(SETF (,(FieldName RecordName (CAR Tail))
				     ,StructureVariable)
				    ,(CADDR tail)))
	      ,StructureVariable))
	  (T 
	   (BuildConstructorForm RecordName Assignments)))))

(DEFUN BuildConstructorForm (RecordName Assignments &OPTIONAL SelectorProperty)
  (LET (DefaultFieldItem SmashIt? CopyDefaults? SpecifiedAssignments Form)
    (SELECTQ (CAR Assignments)
      (smashing (POP Assignments)
		(SETQ DefaultFieldItem (POP Assignments))
		(SETQ SmashIt? T))
      (using (POP Assignments)
	     (SETQ DefaultFieldItem (POP Assignments)))
      (copying (POP Assignments)
	       (SETQ DefaultFieldItem (POP Assignments))
	       (SETQ CopyDefaults? T))
      (OTHERWISE NIL))
    (SETQ SpecifiedAssignments
	  (for tail on Assignments by (CDDDR tail)
	       unless (AND SelectorProperty (NULL (GET (CAR tail) SelectorProperty)))
	       join
	       (COND ((OR (NULL (CDDR tail))
			  (NEQ (CADR tail) '_))
		      (FERROR NIL "Funny assignment tail in create:  ~S~%~
                                 Creating record:  ~S~%~
                                 All assignments:  ~S~%"
			      tail RecordName Assignments))
		     (T (CONS (CAR tail) (NCONS (CADDR tail)))))))
    (COND
      (DefaultFieldItem
       (SETQ SpecifiedAssignments
	     (NCONC (for field in (RECORDFIELDNAMES RecordName)
			 unless (for tail on SpecifiedAssignments by (CDDR tail) thereis
				     (EQ (CAR tail) field))
			 join
			 `(,field
			   ,(COND (CopyDefaults?
				   `(COPY (,(FieldName RecordName field)
					   ,BogusSymbol)))
				  (SmashIt?
				   (for tail on (CDDDR (RECLOOK RecordName)) by (CDDDR tail)
					thereis (EQ (CAR tail) field)
					then (CADDR tail)))
				  (T `(,(FieldName RecordName field)
				       ,BogusSymbol)))))
		    SpecifiedAssignments))))
    (for tail on SpecifiedAssignments by (CDDR tail) do
	 (RPLACA tail (FieldName RecordName (CAR tail))))
    (SETQ Form
	  (COND (SmashIt?
		 `(PROGN
		    ,.(for tail on SpecifiedAssignments by (CDDR tail) collect
			   `(SETF (,(CAR tail) ,BogusSymbol) ,(CADR tail)))
		    ,BogusSymbol))
		(T   (CONS (ConstructorName RecordName)
			   SpecifiedAssignments))))
    (COND (DefaultFieldItem `(LET ((,BogusSymbol ,DefaultFieldItem)) ,Form))
	  (T Form))))

(DEFMACRO type? (RecordName Datum)
  (COND ((NamedStructureRecordP RecordName)
	 `(LET ((Datum ,Datum))
	    (AND (NAMED-STRUCTURE-P Datum)
		 (EQ ',RecordName
		     (NAMED-STRUCTURE-SYMBOL Datum)))))
	(T (FERROR NIL "type? currently only supported on DATATYPES and TYPERECORDS.~%~
                        Record name:  ~S~%~
                        Data Form:  ~S~%"))))

(DEFMACRO BitFieldP (Field)
  `(LET ((Field ,Field))
     (AND (LISTP Field) (EQ (FieldDeclarationType Field) 'BITS))))

(DEFUN BuildRecord (Type Name Fields Declarations &OPTIONAL (FlattenP T))
  (AND (EQ Type ':NAMED) (PUTPROP Name T 'NamedStructureRecord))
  (AND FlattenP (PUTPROP Name (SETQ Fields (Flatten Fields)) 'RecordFieldNames))
  (LET ((PointerFields
	  (for field in Fields unless (BitFieldP field) collect
	       (FieldSpecification Name field Declarations T)))
	(BitFields
	  (for word in (PackBitFields
			 (for field in Fields when (BitFieldP field) collect field))
	       collect
	       (bind (Position _ 0) Size for field in word collect
		     (PROG1 (LIST (NewField (FieldName Name (FieldDeclarationName field)))
				  (PLUS (TIMES 64 Position)
					(SETQ Size (FieldDeclarationArgument field)))
				  (FieldInitialization (CAR field) Declarations))
			    (SETQ Position (PLUS Position Size))))))
	AuxiliaryName)
    (PKG-BIND BogusPackage
	      (COND ((NULL BitFields)	     
		     (EVAL
		       `(DEFSTRUCT (,Name ,Type (:CONSTRUCTOR ,(ConstructorName Name)))
			  ,@PointerFields)))
		    ((NULL PointerFields)
		     (EVAL
		       `(DEFSTRUCT (,Name ,Type (:CONSTRUCTOR ,(ConstructorName Name))
				    (:MAKE-ARRAY (NIL 'ART-32B)))
			  ,@BitFields)))
		    (T
		     (PUTPROP Name (SETQ AuxiliaryName (GENSYM)) 'MixedRecordP)
		     (for word in BitFields do
			  (for field in word do
			       (PUTPROP (CAR field) T 'MixedRecordBitFieldP)))
		     (EVAL
		       `(DEFSTRUCT (,AuxiliaryName :ARRAY-LEADER (:CONSTRUCTOR NIL))
			  ,(GENSYM)
			  ,(GENSYM)
			  ,@PointerFields))
		     (EVAL
		       `(DEFSTRUCT (,Name ,Type (:CONSTRUCTOR ,(ConstructorName Name))
				    (:MAKE-ARRAY (NIL 'ART-32B NIL NIL
						      ,(PLUS (LENGTH PointerFields) 2))))
			  ,@BitFields)))))))

(DEFUN FieldSpecification (RecordName Field Declarations &OPTIONAL New?)
  (LET ((Name (FieldName RecordName
			 (COND ((LISTP Field) (SETQ Field (FieldDeclarationName Field)))
			       (T Field))))
	Initialization)
    (AND New? (NewField Name))
    (COND ((SETQ Initialization (FieldInitialization Field Declarations))
	   (LIST Name Initialization))
	  (T Name))))

(DEFUN FieldInitialization (FieldName Declarations)
  (for Tail on Declarations by (CDDDR Tail) thereis (EQ (CAR Tail) FieldName)
       then (COND ((OR (NULL (CDDR Tail))
		       (NEQ (CADR Tail) '_))
		   (FERROR NIL "Bad declaration of field ~S in declarations~%~S"
			   FieldName Declarations))
		  (T (CADDR Tail)))))

(DEFUN RECORD (&QUOTE Name Fields &REST Declarations)
  (NewRecord 'RECORD Name Fields Declarations)
  (BuildRecord (COND ((SYMBOLP (CDR Fields)) ':LIST)
		     (T ':ARRAY))
	       Name Fields Declarations))

(DEFUN LISTRECORD (&QUOTE Name Fields &REST Declarations)
  (NewRecord 'RECORD Name Fields Declarations)
  (BuildRecord ':LIST Name Fields Declarations))

(DEFUN TYPERECORD (&QUOTE Name Fields &REST Declarations)
  (NewRecord 'TYPERECORD Name Fields Declarations)
  (BuildRecord ':NAMED Name Fields Declarations))

(DEFUN DATATYPE (&QUOTE Name Fields &REST Declarations)
  (NewRecord 'DATATYPE Name Fields Declarations)
  (PUTPROP
    Name
    (for field in Fields collect (COND ((LISTP field) (FieldDeclarationName field))
				       (T field)))
    'RecordFieldNames)
  (BuildRecord ':NAMED Name Fields Declarations NIL))

(DEFUN PackBitFields (Fields)
  (AND Fields (CAR (for words in (PackBitFields1 Fields) min (LENGTH words)))))

(DEFUN PackBitFields1 (Fields)
  (COND ((NULL (CDR Fields))
	 (LIST (LIST Fields)))
	(T (LET ((Possibilities (PackBitFields1 (CDR Fields)))
		 (Field (CAR Fields)))
	     (for possib in Possibilities join
		  (CONS (CONS (LIST Field) possib)
			(for word in possib when (FieldFitsP Field word) collect
			     (CONS (CONS Field word) (REMQ word possib)))))))))

(DEFUN FieldFitsP (Field Word)
  (<= (PLUS
	(FieldDeclarationArgument Field)
	(for wordfield in Word sum (FieldDeclarationArgument wordfield)))
      NumberFixnumBits))

(DEFUN ACCESSFNS (&QUOTE Name Fields &REST Declarations)
  (OR (NULL Declarations)
      (FERROR NIL "ACCESSFNS definition of ~S contains declarations?" Name))
  (NewRecord 'ACCESSFNS Name Fields Declarations)
  (PUTPROP
    Name
    (bind FieldName for Field in Fields collect
	  (OR (LISTP Field)
	      (FERROR NIL "Atomic field ~S in ACCESSFNS ~S??~%" Name Field))
	  (NewField (SETQ FieldName (FieldName Name (FieldDeclarationName Field))))
	  (COND ((FieldDeclarationReferenceForm Field)
		 (PKG-BIND BogusPackage
		   (EVAL
		     `(MACRO ,FieldName
			     (Form)
			     (SUBST (CADR Form) 'DATUM
				    ',(FieldDeclarationReferenceForm Field)))))))
	  (COND ((FieldDeclarationSetForm Field)
		 (PUTPROP FieldName
			  `((,FieldName DATUM) . ,(SUBST 'SI:VAL 'NEWVALUE
							 (FieldDeclarationSetForm Field)))
			  'SETF)))
	  (FieldDeclarationName Field))
    'RecordFieldNames))

(DEFUN ATOMRECORD (&QUOTE Name Fields &REST Declarations)
  (OR (NULL Declarations)
      (FERROR NIL "ATOMRECORD definition of ~S contains declarations?" Name))
  (NewRecord 'ATOMRECORD Name Fields Declarations)
  (PUTPROP
    Name
    (bind FieldName for Field in Fields collect
	  (OR (SYMBOLP Field) (FERROR NIL "List field ~S in ATOMRECORD ~S??~%" Name Field))
	  (NewField (SETQ FieldName (FieldName Name Field)))
	  (PKG-BIND BogusPackage
	    (EVAL
	      `(MACRO ,FieldName (Form) `(GET ,(CADR Form) (QUOTE ,',Field)))))
	  (PUTPROP FieldName
		   `((,FieldName DATUM) PUTPROP DATUM SI:VAL (QUOTE ,Field))
		   'SETF)
	  Field)
    'RecordFieldNames))

(DEFUN Flatten (Structure)
  (COND ((NLISTP Structure) (NCONS Structure))
	(T (for substruc inside Structure join (Flatten substruc)))))

(DEFUN FullyQualify (QualifiedName)
  (LET (Qualifier FieldName)
    (COND ((NULL (CDR QualifiedName))
	   (COND ((SETQ Qualifier (GET (CAR QualifiedName) 'FieldQualifiers))
		  (COND ((NULL (CDR Qualifier))
			 (APPEND (CAR Qualifier) QualifiedName))
			(T (FERROR NIL "Ambiguous field specification:~@
                                        Field:  ~S~@
                                        Possible Qualifiers:  ~S~%"
				   (CAR QualifiedName)
				   Qualifier))))
		 (T (FERROR NIL "Cannot fully qualify the record field name:  ~S~%"
			    (CAR QualifiedName)))))
	  (T (SETQ Qualifier (BUTLAST QualifiedName))
	     (SETQ FieldName (CAR (LAST QualifiedName)))
	     (OR (MEMBER Qualifier (GET FieldName 'FieldQualifiers))
		 (PUSH Qualifier (GET FieldName 'FieldQualifiers)))
	     QualifiedName))))

(DEFUN NewRecord (Type Name Fields Declarations)
  (LET ((Definition (LIST* Type Name Fields Declarations))
	(ExistingDefinition (GET Name 'RecordDefinition)))
    (REMPROP Name 'NamedStructureRecord)
    (REMPROP Name 'MixedRecordP)
    (AND ExistingDefinition
	 (OR (EQUAL Definition ExistingDefinition)
	     (FORMAT :TERMINAL-IO
		     "~S redefined as a record~%"
		     Name)))
    (PUTPROP Name Definition 'RecordDefinition)))

(DEFUN NewField (FieldName)
  (REMPROP FieldName 'SETF) (REMPROP FieldName 'MixedRecordBitFieldP) FieldName)

(DEFUN RECLOOK (Name) (GET Name 'RecordDefinition))

(DEFUN RECORDFIELDNAMES (Name) (GET Name 'RecordFieldNames))