/*-*-Macsyma-*-*/
/*    (c) Copyright 1984 the Regents of the University of California.
          All Rights Reserved.
          This work was produced under the sponsorship of the
          U.S. Department of Energy.  The Government retains
          certain rights therein.                                     */

EVAL_WHEN([TRANSLATE,BATCH,DEMO],
	  LOAD_PACKAGE(SHAREM,"MAX$DISK:[SHAREM]AUTOLO"))$

HERALD_PACKAGE(DEFSTM)$

EVAL_WHEN([BATCH,DEMO,LOADFILE],MATCHFIX("{","}"))$

ASSESS_MODE(X):=
   IF NOT(SYMBOLP(X)) THEN
      IF PART(X,0)='MODE AND LENGTH(X)=2 AND
	 SYMBOLP(PART(X,1)) AND SYMBOLP(PART(X,2))
	THEN PART(X,2)
      ELSE ERROR("If slot name identifier is not a symbol, it must be of the following form:
MODE(TYPE,SLOT_NAME)[= DEFAULT VALUE] , not",X)$

NAME_OF_SLOT_ID(X):=IF SYMBOLP(X) THEN X ELSE PART(X,1)$

MODE_DECLARE(FUNCTION(EQUAL_OP),BOOLEAN)$

EQUAL_OP(X):=IF NOT(ATOM(X)) AND PART(X,0)="=" THEN TRUE$

SLOT_TYPE(TYPES,INDEX):=IF LISTP(TYPES) THEN TYPES[INDEX] ELSE TYPES$

OBTAIN_DEFAULT_VALUE_FOR_MODE(MODE):=
   CASEQ(MODE,
	 [FIXNUM,RATIONAL],0,
	 [BOOLEAN],FALSE,
	 [FLOAT,NUMBER],0.0,
	 [LIST],[],
	 OTHERWISE,BUILDQ([],'%UNDEFINED%))$

%AUX_ALTERANT%(ALT,EXTEND_NAME,SLOT_NAMES,QUAN,MODE_TYPE,OBJ,ARGS):=
  (MODE_DECLARE([SLOT_NAMES,ARGS],LIST,QUAN,FIXNUM),
   BLOCK([RESULT:[]],
      MODE_DECLARE(RESULT,LIST),
      FOR ELE IN ARGS DO
	 BLOCK([NOM],
	    COND(NOT EQUAL_OP(ELE),
		 ERROR("Alterant argument must specify a value:",ELE),

		 NOT(MEMBER(NOM:LHS(ELE),SLOT_NAMES)),
		 ERROR("Incorrect slot specifier to",ALT,":",NOM),

		 TRUE,
		 FOR I THRU QUAN DO
		    IF SLOT_NAMES[I]=NOM THEN
		       RETURN(RESULT:ENDCONS(BUILDQ([I,VAL:RHS(ELE),
						     TYPE:SLOT_TYPE(MODE_TYPE,I)],
						EXTEND_SET(TEMP,I,MODE_IDENTITY(TYPE,VAL))),
					     RESULT)))),
      IF LENGTH(RESULT)=0 THEN FALSE
      ELSE
	 BUILDQ([RESULT,OBJ,ALT,EXTEND_NAME],
	    BLOCK([TEMP:OBJ],
	       ALTER_EXTEND_CHECK(TEMP,'ALT,'EXTEND_NAME),
	       SPLICE(RESULT),
	       MODE_IDENTITY(EXTEND_NAME,TEMP)))))$

%AUX_CONSTRUCTOR%(CONSTRUCT,SLOT_NAMES,DEFAULTS,QUAN,MODE_TYPE,NAME,ARGS):=
  (MODE_DECLARE([SLOT_NAMES,DEFAULTS,ARGS],LIST,QUAN,FIXNUM),
   BLOCK([INITS:?COPY\-TREE(DEFAULTS)],
      MODE_DECLARE(INITS,LIST),
      FOR ELE IN ARGS DO
	 BLOCK([NOM],
	    COND(NOT EQUAL_OP(ELE),
		 ERROR("Constructor argument must specify a value:",ELE),

		 NOT(MEMBER(NOM:LHS(ELE),SLOT_NAMES)),
		 ERROR("Incorrect slot specifier to",CONSTRUCT,":",NOM),

		 TRUE,
		 FOR I THRU QUAN DO
		    IF SLOT_NAMES[I]=NOM THEN
		       RETURN(INITS[I]:BUILDQ([VAL:RHS(ELE),
					       TYPE:SLOT_TYPE(MODE_TYPE,I)],
					  MODE_IDENTITY(TYPE,VAL))))),
      BUILDQ([INITS,NAME],
	  MODE_IDENTITY(NAME,MAKE_EXTEND('NAME,SPLICE(INITS))))))$

DEFINE_VARIABLE(%%EXISTING_STRUCTURES%%,[],LIST,
    "Hack to allow the properties of only those structures in a file being
     translated to appear in the runtime portion of the translated output.")$

DEF_STRUCTURE(NAME,OPTIONS,[SLOTS])::=
 (MODE_DECLARE([OPTIONS,SLOTS],LIST),
  BLOCK([CONSTRUCT:CONCAT('MAKE_,NAME),ALT:CONCAT('ALTER_,NAME),MODE_TYPE:'ANY,
	 CONC:FALSE,INCLUDE:FALSE,INCLUDED_VALUES:FALSE,FIRST:FALSE,QUAN,
	 SLOT_NUM:1,DEFAULT_VALUE:BUILDQ([],'%UNDEFINED%),INC_MODES],
     MODE_DECLARE([QUAN,SLOT_NUM],FIXNUM),
     IF NOT(SYMBOLP(NAME)) THEN
	 ERROR("First argument to DEF_STRUCTURE must be a name",NAME),
     QUAN:LENGTH(SLOTS),
     FOR OPTION IN OPTIONS DO
	IF NOT(ATOM(OPTION)) AND LHS(OPTION)='MODE THEN
	   BLOCK([VALUE:RHS(OPTION)],
	      MODE_TYPE:VALUE,
	      DEFAULT_VALUE:OBTAIN_DEFAULT_VALUE_FOR_MODE(MODE_TYPE)),
     FOR OPTION IN OPTIONS DO
       IF ATOM(OPTION) THEN
	  CASEQ(OPTION,
		[BUT_FIRST,INCLUDE,MODE],ERROR("The",OPTION,"option to DEF_STRUCTURE must have a value"),
		[CONC_NAME],CONC:CONCAT(NAME,"_"),
		[CONSTRUCTOR,ALTERANT],'DONE,
		OTHERWISE,ERROR("Unknown option to DEF_STRUCTURE",OPTION))
       ELSE
	  BLOCK([VALUE:RHS(OPTION)],
	   BLOCK([MULTIPLE_VALUESP:LISTP(VALUE),SELECTOR:LHS(OPTION)],
	      MODE_DECLARE(MULTIPLE_VALUESP,BOOLEAN),
	      IF MEMBER(SELECTOR,'[CONSTRUCTOR,ALTERANT,CONC_NAME,BUT_FIRST,MODE]) THEN
		 IF MULTIPLE_VALUESP THEN
		    ERROR("Only the INCLUDE option to DEF_STRUCTURE can have a list as its RHS:",OPTION)
		 ELSE
		    IF NOT(SYMBOLP(VALUE)) THEN
		       ERROR("RHS of option",SELECTOR,"must be a name"),
	      CASEQ(SELECTOR,
		    [CONSTRUCTOR],CONSTRUCT:VALUE,
		    [ALTERANT],ALT:VALUE,
		    [CONC_NAME],CONC:VALUE,
		    [BUT_FIRST],FIRST:VALUE,
		    [INCLUDE],
		    BLOCK([],
		      INCLUDE:IF MULTIPLE_VALUESP THEN FIRST(VALUE) ELSE VALUE,
		      IF NOT(SYMBOLP(INCLUDE)) THEN
			 ERROR("First element of RHS list for INCLUDE option to DEF_STRUCTURE must be a name",INCLUDE),
		      INC_MODES:GET(INCLUDE,'MODE_TYPES),
		      IF MULTIPLE_VALUESP THEN
			 BLOCK([N_SLOTS:LENGTH(VALUE)-1],
			    MODE_DECLARE(N_SLOTS,FIXNUM),
			    IF GET(INCLUDE,'N_ARGS)#N_SLOTS THEN
			      ERROR("Incorrect number of slot initializations given to INCLUDE option of DEF_STRUCTURE"),
			    INCLUDED_VALUES:
			      BLOCK([DEFAULTS:MAKELIST(DEFAULT_VALUE,M,1,N_SLOTS),
				     SPECS:REST(VALUE),NAMES:GET(INCLUDE,'SLOT_NAMES)],
				 SLOT_NUM:SLOT_NUM+N_SLOTS,
				 FOR I THRU N_SLOTS DO
				    BLOCK([ARG:SPECS[I]],
				       BLOCK([EQP:EQUAL_OP(ARG)],
					  MODE_DECLARE(EQP,BOOLEAN),
					  BLOCK([NAME_SPEC:IF EQP THEN LHS(ARG) ELSE ARG],
					     BLOCK([TYP:ASSESS_MODE(NAME_SPEC),
						    T:NAME_OF_SLOT_ID(NAME_SPEC)],
						IF NOT(MEMBER(T,NAMES)) THEN
						   ERROR(ARG,"is a bad slot name for",INCLUDE)
						ELSE
						   CATCH(FOR M THRU N_SLOTS DO
							    IF T=NAMES[M] THEN
							      BLOCK([DM:SLOT_TYPE(INC_MODES,M)],
								 IF TYP AND TYP#DM THEN
								   ERROR("Mode spec for included slot disagrees with slot from original structure"),
								 THROW(IF EQP THEN
									  (DEFAULTS[M]:BUILDQ([VAL:RHS(ARG)],VAL),
									   APPLY('MODE_IDENTITY,[DM,RHS(ARG)]))))))))),
				 DEFAULTS))),
		    [MODE],'DONE,
		    OTHERWISE,ERROR("Unknown option to DEF_STRUCTURE",SELECTOR)))),
     BLOCK([DEFAULTS:MAKELIST(DEFAULT_VALUE,M,1,QUAN),
	    SLOT_NAMES:[],RET_MACROS:[],ACCESSORS:[]],
	FOR I THRU QUAN DO
	  BLOCK([SLOT:SLOTS[I]],
	     BLOCK([EQP:EQUAL_OP(SLOT)],
		MODE_DECLARE(EQP,BOOLEAN),
		BLOCK([NOM_SPEC:IF EQP THEN LHS(SLOT) ELSE SLOT],
		   BLOCK([TYPE:ASSESS_MODE(NOM_SPEC),TYPED],
		      MODE_DECLARE(TYPED,BOOLEAN),
		      IF TYPED:IS(TYPE#FALSE) THEN
			 (IF ATOM(MODE_TYPE) AND TYPE#MODE_TYPE THEN
			     MODE_TYPE:MAKELIST(MODE_TYPE,M,1,QUAN),
			  IF LISTP(MODE_TYPE) THEN
			    (MODE_TYPE[I]:TYPE,
			     DEFAULTS[I]:OBTAIN_DEFAULT_VALUE_FOR_MODE(TYPE))),
		      SLOT_NAMES:ENDCONS(NAME_OF_SLOT_ID(NOM_SPEC),SLOT_NAMES),
		      IF EQP THEN
			 (DEFAULTS[I]:BUILDQ([VAL:RHS(SLOT)],VAL),
			  APPLY('MODE_IDENTITY,
				[IF TYPED THEN TYPE ELSE SLOT_TYPE(MODE_TYPE,I),
				 DEFAULTS[I]])))))),
	ACCESSORS:IF CONC=FALSE THEN SLOT_NAMES
		  ELSE MAKELIST(CONCAT(CONC,SLOT_NAMES[K]),K,1,QUAN),
	BLOCK([ARG:IF FIRST=FALSE THEN '%X_%
		   ELSE BUILDQ([FUNCT:FIRST],FUNCT(%X_%))],
	  FOR J THRU QUAN DO
	    (RET_MACROS:ENDCONS(BUILDQ([SLOT_NUM,ELEMENT:ACCESSORS[J],ARG,
					NAME,LAMODE:SLOT_TYPE(MODE_TYPE,J)],
				   ELEMENT(%X_%)::=
				      BUILDQ([%X_%],
					MODE_IDENTITY(LAMODE,REFERENCE_AN_EXTEND(ARG,'ELEMENT,'NAME,SLOT_NUM)))),
				RET_MACROS),
	     SLOT_NUM:SLOT_NUM+1)),
       IF INCLUDE#FALSE THEN
	  (ACCESSORS:APPEND(GET(INCLUDE,'ACCESSORS),ACCESSORS),
	   SLOT_NAMES:APPEND(GET(INCLUDE,'SLOT_NAMES),SLOT_NAMES),
	   MODE_TYPE:COND(LISTP(MODE_TYPE),
			  APPEND(IF LISTP(INC_MODES) THEN INC_MODES
				 ELSE MAKELIST(INC_MODES,M,1,GET(INCLUDE,'N_ARGS)),
				 MODE_TYPE),

			  LISTP(INC_MODES),
			  APPEND(INC_MODES,MAKELIST(MODE_TYPE,M,1,QUAN)),

			  MODE_TYPE#INC_MODES,
			  APPEND(MAKELIST(INC_MODES,M,1,GET(INCLUDE,'N_ARGS)),
				 MAKELIST(MODE_TYPE,M,1,QUAN))),
	   DEFAULTS:APPEND(IF INCLUDED_VALUES=FALSE THEN GET(INCLUDE,'DEFAULTS)
			   ELSE INCLUDED_VALUES,
			   DEFAULTS),
	   QUAN:LENGTH(DEFAULTS)),
       PUSH(NAME,%%EXISTING_STRUCTURES%%),
       PUT(NAME,QUAN,'N_ARGS),
       PUT(NAME,DEFAULTS,'DEFAULTS),
       PUT(NAME,ACCESSORS,'ACCESSORS),
       PUT(NAME,SLOT_NAMES,'SLOT_NAMES),
       PUT(NAME,MODE_TYPE,'MODE_TYPES),
       IF ALT#FALSE THEN
	 RET_MACROS:CONS(BUILDQ([ALT,SLOT_NAMES,QUAN,MODE_TYPE,NAME],
			    ALT(%OBJ_%,[%ARGS_%])::=
				%AUX_ALTERANT%('ALT,'NAME,'SLOT_NAMES,QUAN,
					       'MODE_TYPE,%OBJ_%,%ARGS_%)),
			 RET_MACROS),
       IF CONSTRUCT#FALSE THEN
	 RET_MACROS:CONS(BUILDQ([CONSTRUCT,SLOT_NAMES,DEFAULTS,QUAN,MODE_TYPE,NAME],
			    CONSTRUCT([%ARGS_%])::=
				 %AUX_CONSTRUCTOR%('CONSTRUCT,'SLOT_NAMES,'DEFAULTS,
						   QUAN,'MODE_TYPE,'NAME,%ARGS_%)),
			 RET_MACROS),
       BUILDQ([NAME,RET_MACROS],(SPLICE(RET_MACROS),'NAME)))))$

INITIALIZE_STRUCTURE_LIST():=%%EXISTING_STRUCTURES%%:[]$

SAVE_RUNTIME_STRUCTURE_INFO(FILE):=
 BLOCK([PATH:?MERGE\-PATHNAME\-DEFAULTS('?"=.LSP",?STRIPDOLLAR(FILE))],
    BLOCK([NFILE:?INTERN(?NAMESTRING(PATH)),
	   NAME:CONCAT(?INTERN(?PATHNAME\-NAME(PATH))),
	   VERSION_NO:?PATHNAME\-VERSION(PATH)],
       PUT(NAME,IF VERSION_NO=FALSE THEN '%UNKNOWN% ELSE VERSION_NO,'VERSION),
       APPLY('SAVE,APPEND([NFILE,NAME,'"{"],%%EXISTING_STRUCTURES%%)),
       %%EXISTING_STRUCTURES%%:[],
       COMPILE_LISP_FILE(NFILE)))$