(FILECREATED "30-Jun-86 16:38:25" {PHYLUM}<LANNING>RPC>LUPINE.;1 57734  

      changes to:  (FNS \MakeUnmarshalRecord)

      previous date: " 1-Aug-85 12:16:27" {PHYLUM}<LISP>KOTO>LISPUSERS>LUPINE.;1)


(* Copyright (c) 1984, 1985, 1986 by Xerox Corporation. All rights reserved.)

(PRETTYCOMPRINT LUPINECOMS)

(RPAQQ LUPINECOMS [(DECLARE: DONTCOPY (RECORDS ArgSpec Fragment FunctionSpec FieldSpec LupineType 
						 RecordLayout TypeSpec))
		     (* Basic stub construction)
		     (FNS Lupine \ServerComs \MakeUnmarshal \MakeUnmarshal1 \MakeUnmarshalRecord 
			  \FixedFetch \MakeArgsUnmarshal \ClientComs \MakeMarshal \MakeMarshal1 
			  \MakeMarshalRecord \FixedStore \MakeArgsMarshal)
		     (* Checking of declarations)
		     (FNS \CheckSpec \CheckType \CheckType1 \CheckRecordDecl)
		     (* Type table construction)
		     (FNS \DeclareTypes \Allocate \AllocateRecord)
		     (* Utilities)
		     (FNS \TypeName \BaseType \TypeLayout \TypeSize \LupineNotFixed \StaticsFirst 
			  \IsStatic)
		     (VARS \LupineGetFns \LupinePutFns \LupinePrimativeTypes \LupineInitialTypeTable 
			   \LupineNumberTypes \LupineNotFixedTypes \LupineDummyTypes \LupineStatics 
			   \LupineTypesWithParm)
		     (GLOBALVARS \LupineGetFns \LupinePutFns \LupineStatics \LupineTypesWithParm 
				 \LupinePrimativeTypes \LupineDummyTypes \LupineNotFixedTypes 
				 \LupineNumberTypes \LupineInitialTypeTable)
		     (DECLARE: DONTCOPY (CONSTANTS (\FirstLupineUserCall 4)
						   (\FirstLupineSignal 4])
(DECLARE: DONTCOPY 
[DECLARE: EVAL@COMPILE 

(RECORD ArgSpec (argName argType))

(RECORD Fragment (fixed . notFixed))

(RECORD FunctionSpec (fn . specs))

(RECORD FieldSpec (fieldName fieldType))

(RECORD LupineType (typeName . typeParm))

(RECORD RecordLayout (need . fields))

(RECORD TypeSpec (type typeType definedStubs typeSize . typeBits))
]
)



(* Basic stub construction)

(DEFINEQ

(Lupine
  [LAMBDA (packageName functionSpecList signalSpecList typeList lupineTypeString noServer noClient)
                                                             (* ht: "31-Jul-85 11:47")
    (if (NOT (LITATOM packageName))
	then (ERROR "package name must be an atom" packageName))
    (if (AND functionSpecList (NLISTP functionSpecList))
	then (ERROR "function spec must be a list" functionSpecList))
    (if (AND signalSpecList (NLISTP signalSpecList))
	then (ERROR "signal spec must be a list" signalSpecList))
    (if (AND typeList (NLISTP typeList))
	then (ERROR "type declarations must be a list" typeList))
    (if (NOT lupineTypeString)
	then (printout T "type string defaulted to " [lupineTypeString←(MKSTRING
			   (PACK (LIST packageName (GDATE)
				       (ETHERHOSTNUMBER]
		       T))
    (if (NOT (STRINGP lupineTypeString))
	then lupineTypeString←(MKSTRING lupineTypeString))
    (RESETLST (RESETSAVE DFNFLG T)
	      (LET ((typeTable (\DeclareTypes typeList))
		 sName cName)
		(for s in functionSpecList do (\CheckSpec s typeTable))
		(for s in signalSpecList do (\CheckSpec s typeTable T))
		[if (NOT noServer)
		    then (SET sName←(PACK (LIST (U-CASE packageName)
						'SERVERCOMS))
			      (\ServerComs packageName functionSpecList signalSpecList typeTable 
					   lupineTypeString))
			 (ADDFILE (PACK (LIST (U-CASE packageName)
					      'SERVER]
		[if (NOT noClient)
		    then (SET cName←(PACK (LIST (U-CASE packageName)
						'CLIENTCOMS))
			      (\ClientComs packageName functionSpecList signalSpecList typeTable 
					   lupineTypeString))
			 (ADDFILE (PACK (LIST (U-CASE packageName)
					      'CLIENT]
		(CONS sName cName])

(\ServerComs
  [LAMBDA ($packageName$ functionSpecList signalSpecList typeTable lupineTypeString)
                                                             (* ht: " 1-Aug-85 12:13")
    (DECLARE (SPECVARS $packageName$))
    (LET ($fns$ dfn iName selTerms $rNames$ catchTerms labelTerms movds hideFn loads)
      (DECLARE (SPECVARS $fns$ $rNames$))

          (* * the NCONC is because some stuff gets pushed onto $fns$ underneath here)


      $fns$←(NCONC (bind (i ← \FirstLupineUserCall)
			 argNames nameMap rec rfl fn argSets end result for spec in functionSpecList
		      unless (spec:fn= '*)
		      collect [fn←(PACK (LIST spec:fn 'ServerStub]
			      [argNames←(for aSpec in spec:specs as i from 1
					   until (if (U-CASE aSpec:argName)= 'RETURNS
						     then result←aSpec)
					   collect (CDAR (push nameMap (CONS aSpec:argName
									     (PACK* 'l..arg
										    i]
			      [argSets←(for aSpec in (\StaticsFirst spec:specs typeTable)
					  collect (LIST 'SETQ
							(CDR (ASSOC aSpec:argName nameMap))
							(\MakeUnmarshal aSpec:argType spec:fn 
									aSpec:argName typeTable]
			      (end←(if result
				       then (\MakeArgsMarshal result:argType fn 'RESULT
							      'l..result
							      typeTable)))
			      [APPLY* (FUNCTION DEFINEQ)
				      (BQUOTE (, fn (l..cPup l..conv)
                                                             (* Lupine generated stub)
						 (DECLARE (SPECVARS l..cPup l..conv))
						 (PROG (l..result ,. argNames)
						   ,.
						   argSets
						       (SETQ l..result (, (fetch fn of spec)
									  ,. argNames))
						       (\StartReturn l..cPup)
						   ,.
						   end (RETURN l..cPup]
			      [selTerms←(NCONC1 selTerms (BQUOTE (, i (, fn l..pup l..conv]
			      (push movds (CONS spec:fn (CONS (PACK* 'Hidden.
								     spec:fn)
							      fn)))
			      (add i 1)
			      fn)
		   $fns$)
      dfn←(PACK (LIST $packageName$ 'ServerDispatch))
      (if signalSpecList
	  then (bind (j ← \FirstLupineSignal)
		     cName specs resultSpec margs umres for sSpec in signalSpecList
		  unless (sSpec:fn= '*)
		  do (specs←sSpec:specs)
		     (margs←(if (U-CASE specs:1:argName)= 'ARGS
				then (\MakeArgsMarshal (pop specs):argType sSpec:fn 'SIGARGS
						       'arg
						       typeTable)))
		     (if (U-CASE specs:1:argName)= 'RETURNS
			 then umres←(\MakeArgsUnmarshal specs:1:argType sSpec:fn 'RESULT
							typeTable))
		     [push $fns$ (CAR (APPLY* (FUNCTION DEFINEQ)
					      (BQUOTE (, [SETQ cName
							   (PACK (LIST 'Catch
								       (fetch fn of sSpec]
							 (arg l..conv)
                                                             (* Lupine generated signal catcher)
							 (DECLARE (USEDFREE l..cPup))
							 (\StartSignal l..cPup)
							 (\AddPupWord l..cPup , j)
							 ., margs (SETQ l..cPup
							   (\Call l..cPup NIL l..conv))
							 , umres]
		     [catchTerms←(NCONC catchTerms (APPEND (BQUOTE (, (fetch fn of sSpec)=>
								      (sresume (, cName arg l..conv]
		     (add j 1)))

          (* * the (, (QUOTE enable)) is to keep the form from being prettyprinted)


      [APPLY* (FUNCTION DEFINEQ)
	      (BQUOTE (, dfn (l..pup request l..conv)        (* Lupine generated dispatcher)
			 (, 'enable
			    ., catchTerms (SELECTQ request ., selTerms (SHOULDNT))
			    ., labelTerms]
      (push $fns$ dfn)
      iName←(PACK (LIST $packageName$ 'ServerInterface))
      (if (NOT (BOUNDP iName))
	  then (SET iName NIL))
      [push $fns$ (CAR (APPLY* (FUNCTION DEFINEQ)
			       (BQUOTE (, (PACK (LIST 'Unexport
						      $packageName$))
					  NIL                (* Lupine generated interface)
					  [UnexportInterface (OR , iName (ERROR "not exported"
										(QUOTE , 
										    $packageName$]
					  (SETQ , iName NIL]
      [push $fns$ (CAR (APPLY* (FUNCTION DEFINEQ)
			       (BQUOTE (, (PACK (LIST 'Export
						      $packageName$))
					  (type instance version user password)
                                                             (* Lupine generated interface)
					  (if , iName
					      then (ERROR "Already exported" (QUOTE , $packageName$)))
					  (SETQ , iName (ExportInterface user password
									 (OR type , lupineTypeString)
									 instance version
									 (FUNCTION , dfn]
      [push $fns$ (CAR (APPLY* (FUNCTION DEFINEQ)
			       (BQUOTE (, [SETQ hideFn (PACK (LIST 'Hide
								   $packageName$
								   'ServerMovds]
					  NIL                (* Lupine generated utility)
					  (for p in (QUOTE , movds)
					     do (PUTD (CADR p)
						      (GETD (CAR p)))
						(PUTD (CAR p))
						(CHANGENAME (CDDR p)
							    (CAR p)
							    (CADR p]
      [LET [(files (NCONC1 (bind wh res for r in $rNames$
			      when (if wh←(WHEREIS r 'RECORDS)
				     else (printout T T "Note - the record " r 
						    " is not on any known file"
						    T))
			      do (pushnew res wh:1) finally (RETURN res))
			   'SIGNAL]
	loads←(LIST (BQUOTE (DECLARE: DONTCOPY EVAL@COMPILE EVAL@LOAD (FILES (LOADCOMP)
									     ., files]
      (BQUOTE (                                              (* Created by Lupine , (GDATE))
	       (FNS ,. $fns$)
	       (VARS (, iName))
	       (GLOBALVARS , iName)
	       ., loads (DECLARE: EVAL@LOAD DONTEVAL@COMPILE DOCOPY (FILES (SYSLOAD)
									   RPC))
	       (P (COND
		    ((EQ 'Y
			 (ASKUSER 15 'N
				  "Hide server fns (must have been already loaded)? "))
		      (, hideFn])

(\MakeUnmarshal
  [LAMBDA (type fn name typeTable pupName)                   (* ht: " 1-Aug-85 08:57")
    (if type
	then (if (NOT pupName)
		 then pupName← 'l..cPup)
	     (LET (fragment)
	       fragment←(\MakeUnmarshal1 type fn name typeTable 0 16 pupName)
	       (if NOT (fragment:notFixed)
		   then fragment:fixed
		 else (BQUOTE (LET ((l..datum , (fetch fixed of fragment)))
				.,
				(fetch notFixed of fragment)
				l..datum])

(\MakeUnmarshal1
  [LAMBDA (type fn name typeTable whereAreWe size pupName)   (* ht: " 1-Aug-85 09:09")
    (LET ((typeName (\TypeName type))
       (typeParm (if (LISTP type)
		     then type:typeParm))
       afn typeSpec)
      (SELECTQ typeName
	       ((RECORD SEQRECORD)
		 (SHOULDNT))
	       [LIST (create Fragment
			     fixed ←(BQUOTE (PROGN (SETQ , pupName (\CheckPupExhausted , pupName 2))
						   (for l..i from 1 to (\GetArgDblWord , pupName 
										       l..conv)
						      collect , (\MakeUnmarshal (CAR typeParm)
										fn name typeTable 
										pupName]
	       [REF                                          (* no-op except for SEQRECORDs)
		    (LET ((trueType (\BaseType typeParm:1 typeTable))
		       typeSpec)
		      (if (AND (LISTP trueType)
			       trueType:typeName=
			       'SEQRECORD)
			  then 

          (* * have to back up one)


			       (\MakeUnmarshalRecord (OR typeSpec←(for tte in typeTable thereis
											 
									    tte:typeType=trueType)
							 (SHOULDNT))
						     fn name typeTable whereAreWe
						     (if size=16
							 then typeSpec:typeSize
						       else (SHOULDNT))
						     pupName)
			else (create Fragment
				     fixed ←(LET [(nilCheck (BQUOTE (\GetArgBool , pupName l..conv]
				       [if pupName= 'l..pup
					   then nilCheck←(BQUOTE (PROG1 , nilCheck (SETQ l..pup 
									  l..cPup]
				       (BQUOTE (if , nilCheck
						   then NIL
						 else , (\MakeUnmarshal (CAR typeParm)
									fn name typeTable pupName]
	       [BITS                                         (* Just a bit special)
		     (create Fragment
			     fixed ←(if (ILESSP size 16)
					then (\FixedFetch size type whereAreWe fn name typeTable)
				      elseif whereAreWe~=0
					then (HELP "bad layout")
				      elseif (ILEQ typeParm:1 16)
					then 

          (* * note that even if we get here with a BITS record of <16 size, we just get a whole word)


					     (BQUOTE (\GetArgWord , pupName l..conv))
				      elseif typeParm:1=32
					then                 (* closest we get to LONG CARDINAL)
					     (BQUOTE (\GetArgDblWord , pupName l..conv))
				      else (SHOULDNT]
	       (if (FMEMB typeName \LupinePrimativeTypes)
		   then (if (ILESSP size 16)
			    then (create Fragment
					 fixed ←(\FixedFetch size type whereAreWe fn name typeTable))
			  elseif whereAreWe~=0
			    then (HELP "bad layout")
			  elseif afn←(CDR (ASSOC typeName \LupineGetFns))
			    then 

          (* * note that even if we get here with a BITS record of <16 size, we just get a whole word courtesy of the GetFns 
	  table entry)


				 [create Fragment
					 fixed ←(LET [(sr (BQUOTE (, afn , pupName .,
								     (if typeParm
									 then (LIST (KWOTE typeParm)))
								     l..conv]
					   (if pupName= 'l..cPup
					       then sr
					     else (BQUOTE (PROG1 , sr (SETQ l..pup l..cPup]
			  else (SHOULDNT))
		 elseif typeSpec←(ASSOC typeName typeTable)
		   then (if typeSpec:typeType:type= 'RECORD
			    then (\MakeUnmarshalRecord typeSpec fn name typeTable whereAreWe
						       (if (AND size=16 (IGREATERP typeSpec:typeSize 
										   16))
							   then typeSpec:typeSize
							 else size)
						       pupName)
			  else (\MakeUnmarshal1 typeSpec:typeType fn name typeTable whereAreWe size 
						pupName))
		 else (ERROR "Invalid spec" (LIST fn name type])

(\MakeUnmarshalRecord
  [LAMBDA (spec fn name typeTable startBit bitWidth pupName)
                                                             (* smL "30-Jun-86 16:17")
    (LET ((fnName (PACK* (QUOTE Unmarshal)
			   $packageName$
			   (fetch type of spec)
			   (QUOTE %#)
			   startBit
			   (QUOTE %#)
			   bitWidth))
	  (bits (fetch typeBits of spec))
	  (seq? (EQ (fetch typeName of (fetch typeType of spec))
		      (QUOTE SEQRECORD)))
	  fetches createExpr indirects umc notFixed someNot res seqSpec seqEltFetch seqSubSpec 
	  seqStatic? leftOver)
         [if (NOT (FMEMB fnName (fetch definedStubs of spec)))
	     then (push $rNames$ (fetch type of spec))
		    (if (ILESSP (fetch typeSize of spec)
				    bitWidth)
			then (SETQ bits (CONS (IPLUS (CAR bits)
							     (DIFFERENCE bitWidth
									   (fetch typeSize
									      of spec)))
						    (CDR bits)))
		      elseif (AND (IGREATERP (fetch typeSize of spec)
						   bitWidth)
				      (NOT (ZEROP startBit)))
			then (HELP "bad layout"))
		    [SETQ fetches
		      (bind (whereAreWe ← startBit)
			      (nFixed ← 0)
			      last for field in (fetch typeParm of (fetch typeType
									      of spec))
			 as size in bits
			 join
			  (if (AND (LISTP (fetch fieldType of field))
				       (EQ (fetch typeName of (fetch fieldType of field))
					     (QUOTE SEQUENCE)))
			      then (if seq?
					 then (SETQ seqSpec field)
						[SETQ seqSubSpec
						  (CAR (fetch typeParm
							    of (fetch fieldType of field]

          (* * * This should be a call to \MakeUnmarshal1, but because of a CEDAR Lupine bug, is not 
	  (see below for more discussion) -
	  If CEDAR is ever fixed, the call should be as follows: (SETQ seqEltFetch (\MakeUnmarshal1 seqSubSpec fn name 
	  typeTable whereAreWe size (QUOTE l..pup))))


						[SETQ seqEltFetch (\MakeUnmarshal
						    seqSubSpec fn name typeTable
						    (if (SETQ seqStatic? (\IsStatic seqSubSpec 
											typeTable))
							then (QUOTE l..pup)
						      else (QUOTE l..cPup]
				       else (SHOULDNT))
				     NIL
			    elseif (\LupineNotFixed field typeTable)
			      then (add nFixed 1)
				     (SETQ someNot T)
				     NIL
			    else (SETQ umc (\MakeUnmarshal1 (fetch fieldType of field)
								  fn name typeTable whereAreWe size
								  (QUOTE l..pup)))
				   [if (fetch notFixed of umc)
				       then
					(SETQ notFixed
					  (NCONC1 notFixed
						    (BQUOTE
						      (LET ((l..datum (fetch (, (fetch type
										     of spec)
										  ,
										  (fetch fieldName
										     of field))
									 of l..datum)))
						       .,  (fetch notFixed of umc]
				   (SETQ umc (fetch fixed of umc))
				   (SETQ whereAreWe (LOGAND 15 (IPLUS whereAreWe size)))
				   (if (NOT (ZEROP nFixed))
				       then (SETQ umc (BQUOTE (PROGN (SETQ l..pup
									       (\SkipWordsIn
										 l..pup ,
										 (LLSH nFixed 1)))
									     , umc)))
					      (SETQ nFixed 0))
				   (SETQ last (LIST (fetch fieldName of field)
							(QUOTE ←)
							umc)))
			 finally (if (NOT (ZEROP nFixed))
				       then (SETQ leftOver (BQUOTE (SETQ l..pup
									   (\SkipWordsIn
									     l..pup ,
									     (LLSH nFixed 1]
		    (SETQ createExpr (BQUOTE (create , (fetch type of spec)
							   ., fetches)))
		    [if leftOver
			then (SETQ createExpr (BQUOTE (PROG1 , createExpr , leftOver]
		    (if someNot
			then [SETQ indirects (for field in (fetch typeParm
								      of (fetch typeType
									      of spec))
						    when (\LupineNotFixed field typeTable)
						    collect (SETQ umc
								(\MakeUnmarshal (fetch fieldType
										     of field)
										  fn name typeTable
										  (QUOTE l..cPup)))
							      (BQUOTE (replace
									  (, (fetch type
										of spec)
									     ,
									     (fetch fieldName
										of field))
									   of l..datum
									   with , umc]
			       (SETQ notFixed (NCONC notFixed indirects)))
		    (SETQ createExpr
		      (if seq?
			  then [LET (prelim term f nf)

          (* * the code in this comment is the way this **should** work, with only the non-statics following after, but in 
	  fact as CEDAR Lupine stands if a sequence's element type has any non-static parts, the WHOLE element gets repeated.
	  There is a further patch associated with this higher up in this function. If this ever gets fixed, replace the if 
	  statement which follows this comment with this code: (if (fetch notFixed of seqEltFetch) then 
	  (SETQ f (fetch fixed of seqEltFetch)) (SETQ nf (fetch notFixed of seqEltFetch)) elseif (\LupineNotFixed 
	  (fetch fieldType of seqSpec) typeTable) then (SETQ prelim (BQUOTE (first (\SkipWordsIn l..pup 
	  (LLSH size 1))))) (SETQ nf (fetch fixed of seqEltFetch)) else (SETQ f (fetch fixed of seqEltFetch))))


				      (if seqStatic?
					  then (SETQ f seqEltFetch)
					else [SETQ prelim
						 (BQUOTE (first
							     (\SkipWordsIn
							       l..pup
							       (ITIMES , (LRSH (\TypeSize
										     seqSubSpec 
										     typeTable)
										   4)
									 l..size]
					       (SETQ nf seqEltFetch))
				      [if nf
					  then [SETQ term
						   (if f
						       then (BQUOTE (LET ((l..datum (CAR l..p)))
									 .,
									 nf))
						     else (BQUOTE (RPLACA l..p , nf]
						 (SETQ notFixed
						   (NCONC1
						     notFixed
						     (BQUOTE (for l..p
								  on (fetch (, (fetch type
										      of spec)
										   ,
										   (fetch fieldName
										      of seqSpec))
									  of l..datum)
								  do , term]
				      (BQUOTE ((SETQ l..pup (\CheckPupExhausted l..pup 3))
						 (if (\GetArgBool l..pup l..conv)
						     then NIL
						   else (LET ((l..size (\GetArgDblWord l..pup 
											  l..conv)))
							       (bind (l..result ← , createExpr)
								       ., prelim for l..i
								  from 1 to l..size
								  collect , f
								  finally
								   (replace (, (fetch type
										    of spec)
										 ,
										 (fetch fieldName
										    of seqSpec))
								      of l..result with $$VAL)
								   (RETURN l..result]
			else (LIST createExpr)))
		    [if (AND seq? notFixed)
			then (SETQ notFixed (LIST (BQUOTE (if l..datum
								      then ., notFixed]
		    (APPLY* (FUNCTION DEFINEQ)
			      (BQUOTE (, fnName (l..pup l..conv)
                                                             (* Lupine generated stub)
					   ., createExpr)))

          (* * must record the notFixed generated here so they get used if the function gets re-used)


		    (PUT fnName (QUOTE LupineNotFixed)
			   notFixed)
		    (push $fns$ fnName)
		    (push (fetch definedStubs of spec)
			    fnName)
	   else (SETQ notFixed (APPEND (GETP fnName (QUOTE LupineNotFixed]
         (SETQ res (BQUOTE (, fnName , pupName l..conv)))
         [if pupName=(QUOTE l..pup)
	     then 

          (* * horrible kludge as our function may have reset l..cPup but our caller won't see that)


		    (SETQ res (LIST (QUOTE PROG1)
					res
					(QUOTE (SETQ l..pup l..cPup]
         (create Fragment
		   fixed ← res
		   notFixed ← notFixed])

(\FixedFetch
  [LAMBDA (size type whereAreWe fn name typeTable)           (* ht: " 1-Aug-85 08:54")
    (LET ((typeName (\TypeName type))
       (typeParm (if (LISTP type)
		     then type:typeParm))
       ff bitNum form)
      (SELECTQ typeName
	       (RECORD (SHOULDNT))
	       ((BOOLEAN BITS ENUMERATION)

          (* * compute the field descriptor)


		 bitNum←
		 (IPLUS (LLSH whereAreWe 4)
			size-1)

          (* * make the call to FETCHFIELD)


		 ff←
		 (BQUOTE (FETCHFIELD '(NIL 0 (BITS ., bitNum))
				     (\CurrentPupBase l..pup)))
		 form←
		 (SELECTQ typeName
			  (BITS ff)
			  [ENUMERATION (BQUOTE (CAR (NTH (QUOTE , typeParm)
							 (ADD1 , ff]
			  [BOOLEAN (BQUOTE (NOT (ZEROP , ff]
			  (SHOULDNT))
		 (if (ZEROP whereAreWe)
		     then 

          (* * need to check there is room in the l..pup)


			  (BQUOTE (PROGN (SETQ l..pup (\CheckPupExhausted l..pup 1))
					 , form))
		   elseif (IPLUS whereAreWe size)=16
		     then 

          (* * must advance the counter)


			  (BQUOTE (PROG1 , form (\IncrDataOffset l..pup 1)))
		   else form))
	       (SHOULDNT])

(\MakeArgsUnmarshal
  [LAMBDA (spec fn multTypeName typeTable)                   (* ht: " 1-Aug-85 08:51")
    (LET (resultSpec)
      (if (AND (LITATOM spec)
	       resultSpec←(\BaseType spec typeTable)
	       (LISTP resultSpec)
	       resultSpec:typeName=multTypeName)
	  then                                               (* create the record)
	       (push $rNames$ spec)
	       [NCONC (LIST 'create
			    spec)
		      (for rSpec in (\StaticsFirst resultSpec:typeParm typeTable)
			 join (BQUOTE (, (fetch fieldName of rSpec)← , (\MakeUnmarshal (fetch 
											fieldType
											  of rSpec)
										       fn
										       (fetch 
											fieldName
											  of rSpec)
										       typeTable]
	else (\MakeUnmarshal spec fn 'l..result
			     typeTable])

(\ClientComs
  [LAMBDA ($packageName$ functionSpecList signalSpecList typeTable lupineTypeString)
                                                             (* ht: " 1-Aug-85 09:39")
    (DECLARE (SPECVARS $packageName$))
    (LET ($fns$ dfn selTerms iName cName typeSels $rNames$ sDisp sigTerms movds movdFn result loads)
      (DECLARE (SPECVARS $fns$ $rNames$))
      iName←(PACK (LIST $packageName$ 'ClientInterface))
      sDisp←(PACK (LIST 'Dispatch
			$packageName$
			'Signals))

          (* * the NCONC is because some stuff gets pushed onto $fns$ underneath here)


      $fns$←(NCONC (bind (i ← \FirstLupineUserCall)
			 argNames rec rfl fn argPuts end stubFn for spec in functionSpecList
		      unless spec:fn= '*
		      collect (fn←spec:fn)
			      (stubFn←(PACK (LIST 'RPCClientStub.
						  fn)))
			      (argPuts←(for aSpec in (\StaticsFirst spec:specs typeTable)
					  join (\MakeMarshal aSpec:argType aSpec:argName fn 
							     aSpec:argName typeTable)))
			      [argNames←(NCONC (for aSpec in spec:specs until (if (U-CASE 
										    aSpec:argName)=
										  'RETURNS
										  then result←aSpec)
						  collect aSpec:argName)
					       (LIST 'l..interfaceArg
						     'l..conv]
			      (end←(if result
				       then (\MakeArgsUnmarshal result:argType fn 'RESULT
								typeTable)))
			      [APPLY* (FUNCTION DEFINEQ)
				      (BQUOTE (, stubFn , argNames 
                                                             (* Lupine generated stub)
						 (PROG [l..cPup (l..interface (OR l..interfaceArg
										  (CAR , iName]
						       (DECLARE (SPECVARS l..cPup))
						       (SETQ l..cPup (\StartCall (CAR l..interface)
										 (CDR l..interface)
										 l..conv))
						       (\AddPupWord l..cPup , i l..conv)
						   ,.
						   argPuts
						       (SETQ l..cPup (\Call l..cPup
									    (FUNCTION , sDisp)
									    l..conv))
						       (RETURN (PROG1 , end (\RELEASE.PUP l..cPup]
			      (push movds (CONS stubFn fn))
			      (add i 1)
			      stubFn)
		   $fns$)
      sigTerms←(bind (j ← \FirstLupineSignal)
		     mres umargs specs for sSpec in signalSpecList unless sSpec:fn= '*
		  collect (specs←sSpec:specs)
			  (umargs←(if (U-CASE specs:1:argName)= 'ARGS
				      then (\MakeArgsUnmarshal (pop specs):argType sSpec:fn
							       'SIGARGS
							       typeTable)))
			  (if (U-CASE specs:1:argName)= 'RETURNS
			      then mres←(\MakeArgsMarshal specs:1:argType sSpec:fn 'RESULT
							  'l..result
							  typeTable))
			  (PROG1 (BQUOTE (, j (PROG (l..result)
						    (SETQ l..result
						      (Signal (QUOTE , (fetch fn of sSpec))
							      , umargs))
						    (\StartReturn l..cPup)
						.,
						mres)))
				 (add j 1)))
      (APPLY* (FUNCTION DEFINEQ)
	      (BQUOTE (, sDisp (l..cPup l..conv)             (* Lupine generated dispatcher)
			 (DECLARE (SPECVARS l..cPup l..conv))
			 (SELECTQ (\GetArgWord l..cPup l..conv)
				  ., sigTerms (SHOULDNT))
			 l..cPup)))
      (push $fns$ sDisp)
      (if (NOT (BOUNDP iName))
	  then (SET iName NIL))
      [push $fns$ (CAR (APPLY* (FUNCTION DEFINEQ)
			       (BQUOTE (, (PACK (LIST 'Unimport
						      $packageName$))
					  (l..interface)     (* Lupine generated interface)
					  (if l..interface
					      then (if (FMEMB l..interface , iName)
						       then (UnimportInterface l..interface)
							    (SETQ , iName (DREMOVE l..interface , 
										   iName))
						     else (ERROR "not imported" l..interface))
					    else (for e in , iName do (UnimportInterface e))
						 (SETQ , iName NIL]
      [push $fns$ (CAR (APPLY* (FUNCTION DEFINEQ)
			       (BQUOTE (, (PACK (LIST 'Import
						      $packageName$))
					  (type instance version)
                                                             (* Lupine generated interface)
					  (CAR (push , iName (ImportInterface (OR type , 
										 lupineTypeString)
									      instance version]
      [push $fns$ (CAR (APPLY* (FUNCTION DEFINEQ)
			       (BQUOTE (, (SETQ movdFn (PACK (LIST 'MovdsFor
								   $packageName$)))
					  NIL                (* Lupine generated utility)
					  (for p in (QUOTE , movds)
					     do (PUTD (CDR p)
						      (GETD (CAR p]
      [if $rNames$
	  then (LET [(files (bind wh res for r in $rNames$
			       when (if wh←(WHEREIS r 'RECORDS)
				      else (printout T T "Note - the record " r 
						     " is not on any known file"
						     T))
			       do (pushnew res wh:1) finally (RETURN res]
		 loads←(LIST (BQUOTE (DECLARE: DONTCOPY EVAL@COMPILE EVAL@LOAD (FILES (LOADCOMP)
										      ., files]
      (BQUOTE (                                              (* Created by Lupine , (GDATE))
	       (FNS ,. $fns$)
	       (VARS (, iName))
	       (GLOBALVARS , iName)
	       (P (, movdFn))
	       ., loads (DECLARE: EVAL@LOAD DONTEVAL@COMPILE DOCOPY (FILES (SYSLOAD)
									   RPC])

(\MakeMarshal
  [LAMBDA (type val fn name typeTable pupName)               (* ht: " 1-Aug-85 08:57")
    (if type
	then (if (NOT pupName)
		 then pupName← 'l..cPup)
	     (LET (fragment)
	       fragment←(\MakeMarshal1 type val fn name typeTable 0 16 pupName)
	       (if NOT (fragment:notFixed)
		   then fragment:fixed
		 else (NCONC fragment:fixed (if val~= 'l..datum
						then [LIST (BQUOTE (LET ((l..datum , val))
								     .,
								     (fetch notFixed of fragment]
					      else fragment:notFixed])

(\MakeMarshal1
  [LAMBDA (type val fn name typeTable whereAreWe size pupName)
                                                             (* ht: " 1-Aug-85 08:59")
    (LET ((typeName (\TypeName type))
       (typeParm (if (LISTP type)
		     then type:typeParm))
       afn typeSpec)
      (SELECTQ typeName
	       ((RECORD SEQRECORD)
		 (SHOULDNT))
	       [LIST (create Fragment
			     fixed ←(LIST (BQUOTE (PROGN (\CheckPupOverflow , pupName 4)
							 (\AddPupDblWord , pupName (LENGTH , val)
									 l..conv)
							 (for l..v in , val
							    do ., (\MakeMarshal (CAR typeParm)
										'l..v
										fn name typeTable 
										pupName]
	       [REF                                          (* no-op except for SEQRECORDs)
		    (LET ((trueType (\BaseType typeParm:1 typeTable))
		       typeSpec)
		      (if (AND (LISTP trueType)
			       trueType:typeName=
			       'SEQRECORD)
			  then 

          (* * have to back up one)


			       (\MakeMarshalRecord (OR typeSpec←(for tte in typeTable thereis 
									    tte:typeType=trueType)
						       (SHOULDNT))
						   val fn name typeTable whereAreWe
						   (if size=16
						       then typeSpec:typeSize
						     else (SHOULDNT))
						   pupName)
			else (create Fragment
				     fixed ←(LIST (BQUOTE (if , val
							      then (\AddPupBoolean , pupName NIL 
										   l..conv)
								   .,
								   (\MakeMarshal (CAR typeParm)
										 val fn name 
										 typeTable pupName)
							    else (\AddPupBoolean , pupName T l..conv]
	       [BITS (create Fragment
			     fixed ←(if (ILESSP size 16)
					then (\FixedStore size type val whereAreWe fn name typeTable)
				      elseif whereAreWe~=0
					then (HELP "bad layout")
				      elseif (ILEQ typeParm:1 16)
					then 

          (* * note that even if we get here with a BITS record of <16 size, we just put a whole word)


					     (LIST (BQUOTE (\AddPupWord , pupName , val l..conv)))
				      elseif typeParm:1=32
					then                 (* closest we get to LONG CARDINAL)
					     (LIST (BQUOTE (\AddPupDblWord , pupName , val l..conv)))
				      else (SHOULDNT]
	       (if (FMEMB typeName \LupinePrimativeTypes)
		   then (if (ILESSP size 16)
			    then (create Fragment
					 fixed ←(\FixedStore size type val whereAreWe fn name 
							     typeTable))
			  elseif whereAreWe~=0
			    then (HELP "bad layout")
			  elseif afn←(CDR (ASSOC typeName \LupinePutFns))
			    then 

          (* * note that if we get here with a BITS record of <16 size, we just get a whole word courtesy of the PutFns table 
	  entry)


				 [create Fragment
					 fixed ←(LIST (BQUOTE (, afn , pupName .,
								 (if typeParm
								     then (LIST (KWOTE typeParm)))
								 , val l..conv]
			  else (SHOULDNT))
		 elseif typeSpec←(ASSOC typeName typeTable)
		   then (if typeSpec:typeType:type= 'RECORD
			    then (\MakeMarshalRecord typeSpec val fn name typeTable whereAreWe
						     (if (AND size=16 (IGREATERP typeSpec:typeSize 16)
							      )
							 then typeSpec:typeSize
						       else size)
						     pupName)
			  else (\MakeMarshal1 typeSpec:typeType val fn name typeTable whereAreWe size 
					      pupName))
		 else (ERROR "Invalid spec" (LIST fn name type])

(\MakeMarshalRecord
  [LAMBDA (spec val fn name typeTable startBit bitWidth pupName)
                                                             (* ht: " 1-Aug-85 12:16")
    (LET ((fnName (PACK* 'Marshal
			 $packageName$ spec:type '#
			 startBit
			 '#
			 bitWidth))
       (bits spec:typeBits)
       (seq? spec:typeType:typeName= 'SEQRECORD)
       seqSpec seqSubSpec seqEltStore seqStatic? stores notFixed indirects mc someNot)
      [if (NOT (FMEMB fnName spec:definedStubs))
	  then (push $rNames$ spec:type)
	       (if (ILESSP spec:typeSize bitWidth)
		   then bits←(CONS (IPLUS bits:1 bitWidth-spec:typeSize)
				   bits::1)
		 elseif (AND (IGREATERP spec:typeSize bitWidth)
			     (NOT (ZEROP startBit)))
		   then (HELP "bad layout"))
	       [stores←(bind (whereAreWe ← startBit)
			     (nFixed ← 0) for field in spec:typeType:typeParm as size in bits
			  join (if (AND (LISTP field:fieldType)
					field:fieldType:typeName=
					'SEQUENCE)
				   then (if seq?
					    then (seqSpec←field)
						 (seqSubSpec←field:fieldType:typeParm:1) 

          (* * * This should be a call to \MakeMarshal1 but because of a CEDAR Lupine bug, is not (see below for more 
	  discussion) -
	  If CEDAR is ever fixed, the call should be as follows: (SETQ seqEltStore (\MakeMarshal1 seqSubSpec 
	  (QUOTE l..datum) fn name typeTable whereAreWe size (QUOTE l..pup))))


						 [seqEltStore←(\MakeMarshal seqSubSpec 'l..datum
									    fn name typeTable
									    (if seqStatic?←(\IsStatic
										  seqSubSpec 
										  typeTable)
										then 'l..pup
									      else 'l..cPup]
					  else (SHOULDNT))
					NIL
				 elseif (\LupineNotFixed field typeTable)
				   then (add nFixed 1)
					(someNot←T)
					NIL
				 else (mc←(\MakeMarshal1 field:fieldType
							 (BQUOTE (fetch (, (fetch type of spec)
									   ,
									   (fetch fieldName
									      of field))
								    of l..datum))
							 fn name typeTable whereAreWe size
							 'l..pup))
				      [if mc:notFixed
					  then
					   notFixed←(NCONC1
					     notFixed
					     (BQUOTE (LET ((l..datum (fetch (, (fetch type
										  of spec)
									       ,
									       (fetch fieldName
										  of field))
									of l..datum)))
						       .,
						       (fetch notFixed of mc]
				      (mc←mc:fixed)
				      (whereAreWe←(LOGAND 15 (IPLUS whereAreWe size)))
				      (if (NOT (ZEROP nFixed))
					  then (PROG1 (CONS (BQUOTE (\SkipBytesOut l..pup ,
										   (LLSH nFixed 2)))
							    mc)
						      nFixed←0)
					else mc))
			  finally (if (NOT (ZEROP nFixed))
				      then $$VAL←(NCONC1 $$VAL (BQUOTE (\SkipBytesOut l..pup ,
										      (LLSH nFixed 2]
	       (if someNot
		   then [indirects←(for field in spec:typeType:typeParm when (\LupineNotFixed field 
											typeTable)
				      join (\MakeMarshal field:fieldType
							 (BQUOTE (fetch (, (fetch type of spec)
									   ,
									   (fetch fieldName
									      of field))
								    of l..datum))
							 fn name typeTable 'l..cPup]
			(notFixed←(NCONC notFixed indirects)))
	       [if seq?
		   then (LET (code f nf)

          (* * the code in this comment is the way this **should** work, with only the non-statics following after, but in 
	  fact as CEDAR Lupine stands if a sequence%'s element type has any non-static parts, the WHOLE element gets repeated.
	  There is a further patch associated with this higher up in this function. If this ever gets fixed, replace the if 
	  statement which follows this comment with this code: (if (fetch notFixed of seqEltStore) then 
	  (SETQ f (fetch fixed of seqEltStore)) (SETQ nf (fetch notFixed of seqEltStore)) elseif (\LupineNotFixed 
	  (fetch fieldType of seqSpec) typeTable) then (SETQ code (LIST (QUOTE (\SkipBytesOut l..pup (LLSH 
	  (LENGTH l..sequence) 2))))) (SETQ nf (fetch fixed of seqEltStore)) else (SETQ f (fetch fixed of seqEltStore))))


			  (if seqStatic?
			      then f←seqEltStore
			    else [code←(LIST (BQUOTE (\SkipBytesOut l..pup
								    (ITIMES ,
									    (LRSH (\TypeSize 
										       seqSubSpec 
											typeTable)
										  3)
									    (LENGTH l..sequence]
				 (nf←seqEltStore))
			  [if f
			      then code←(LIST (BQUOTE (for l..datum in l..sequence do ., f]
			  [if nf
			      then notFixed←(NCONC1 notFixed
						    (BQUOTE (for l..datum
							       in (fetch (, (fetch type of spec)
									    ,
									    (fetch fieldName
									       of seqSpec))
								     of l..datum)
							       do ., nf]
			  stores←(BQUOTE ((\CheckPupOverflow l..pup 6)
					  (if l..datum
					      then (LET ((l..sequence (fetch (, (fetch type
										   of spec)
										,
										(fetch fieldName
										   of seqSpec))
									 of l..datum)))
						     (\AddPupBoolean l..pup NIL l..conv)
						     (\AddPupDblWord l..pup (LENGTH l..sequence)
								     l..conv)
						     ., stores ., code)
					    else (\AddPupBoolean l..pup T l..conv]
	       [if (AND seq? notFixed)
		   then notFixed←(LIST (BQUOTE (if l..datum
						   then ., notFixed]
	       (APPLY* (FUNCTION DEFINEQ)
		       (BQUOTE (, fnName (l..pup l..datum l..conv)
                                                             (* Lupine generated stub)
				  ., stores)))

          (* * must record the notFixed generated here so they get used if the function gets re-used)


	       (PUT fnName 'LupineNotFixed
		    notFixed)
	       (push $fns$ fnName)
	       (push spec:definedStubs fnName)
	else notFixed←(APPEND (GETP fnName 'LupineNotFixed]
      (create Fragment
	      fixed ←(LIST (BQUOTE (, fnName , pupName , val l..conv)))
	      notFixed ← notFixed])

(\FixedStore
  [LAMBDA (size type val whereAreWe fn name typeTable)       (* ht: " 1-Aug-85 09:10")
    (LET ((typeName (\TypeName type))
       (typeParm (if (LISTP type)
		     then type:typeParm))
       rf bitNum form)
      (SELECTQ typeName
	       (RECORD (SHOULDNT))
	       ((BOOLEAN BITS ENUMERATION)

          (* * compute the field descriptor)


		 bitNum←
		 (IPLUS (LLSH whereAreWe 4)
			size-1)

          (* * make the call to FETCHFIELD)


		 form←
		 (SELECTQ typeName
			  (BITS val)
			  [ENUMERATION (BQUOTE (for l..i from 0 as l..t in (QUOTE , typeParm)
						  do (if (EQ l..t , val)
							 then (RETURN l..i))
						  finally (Signal 'BoundsCheck
								  (CONS , val (QUOTE , typeParm]
			  (BOOLEAN (BQUOTE (if , val
					       then 1
					     else 0)))
			  (SHOULDNT))
		 rf←
		 (BQUOTE (REPLACEFIELD '(NIL 0 (BITS ., bitNum))
				       (\CurrentPupPosition l..pup)
				       , form))
		 (if (ZEROP whereAreWe)
		     then 

          (* * need to check there is room in the l..pup)


			  (BQUOTE ((\CheckPupOverflow l..pup 2)
				   , rf))
		   elseif (IPLUS whereAreWe size)=16
		     then 

          (* * must advance the counter -
	  must use LIST here because BQUOTE causes NCONC problems)


			  (LIST rf '(\IncrPupLength l..pup 2))
		   else (LIST rf)))
	       (SHOULDNT])

(\MakeArgsMarshal
  [LAMBDA (spec fn multTypeName varName typeTable)           (* ht: "31-Jul-85 11:44")
    (LET (resultSpec)
      (if (AND (LITATOM spec)
	       resultSpec←(\BaseType spec typeTable)
	       (LISTP resultSpec)
	       resultSpec:typeName=multTypeName)
	  then                                               (* unpack a record)
	       (push $rNames$ spec)
	       (for rBit in (\StaticsFirst resultSpec:typeParm typeTable)
		  join (\MakeMarshal rBit:fieldType (BQUOTE (fetch (, spec , (fetch fieldName
										of rBit))
							       of , varName))
				     fn rBit:fieldName typeTable))
	else (\MakeMarshal spec varName fn varName typeTable])
)



(* Checking of declarations)

(DEFINEQ

(\CheckSpec
  [LAMBDA (spec typeTable sigFlg)                            (* ht: "31-Jul-85 11:35")
    (if (NLISTP spec)
	then (ERROR "each spec must be a list" spec))
    (if spec:fn~= '*
	then (if (NOT (LITATOM spec:fn))
		 then (ERROR "the fn/signal of a spec must be an atom" spec:fn))
	     (if (NLISTP spec:specs)
		 then (if spec:specs
			  then (ERROR "the arg specs of a spec must be a list" spec:specs)))
	     (if (OR spec:specs=NIL (U-CASE spec:specs:1:argName)= 'RETURNS)
		 then (printout T "Note: " spec:fn " has no args" T))
	     (bind aSpec argsAlready [an ←(if (AND (NOT sigFlg)
						   (GETD (fetch fn of spec)))
					      then (ARGLIST (fetch fn of spec]
		for specP on spec:specs
		do (if (U-CASE specP:1:argName)= 'RETURNS
		       then (if specP::1
				then (ERROR "RETURNS must be the last spec" specP)
			      else (GO $$OUT))
		     else aSpec←specP:1)
		   (if sigFlg
		       then (if (AND (U-CASE specP:1:argName)= 'ARGS
				     (NOT argsAlready))
				then argsAlready←T
			      else (ERROR "first and only arg spec for a signal must be called ARGS"))
			    (\CheckType aSpec typeTable NIL T)
		     else (if an
			      then [if aSpec:argName=an:1
				       then (pop an)
				     else (ERROR "arg name not right" (CONS aSpec:argName
									    (pop an]
			    else (if (NOT (LITATOM aSpec:argName))
				     then (ERROR "arg name must be litatom" aSpec))
				 (if (GETD spec:fn)
				     then (printout T "Note: spec has more arguments than function" , 
						    spec:fn , aSpec T)))
			  (\CheckType aSpec typeTable))
		finally (if an
			    then (printout T "Note: spec has fewer arguments than function" , spec:fn 
					   T)))
	     (LET ((last spec:-1))
	       (if (U-CASE last:argName)= 'RETURNS
		   then (\CheckType last typeTable NIL T)
		 else (printout T "Note: " spec:fn " has no result" T])

(\CheckType
  [LAMBDA (spec typeTable inDecl inSpecial inRef inSeq)      (* ht: "30-Jul-85 09:01")
    (\CheckType1 spec (\TypeName spec:argType)
		 (if (LISTP spec:argType)
		     then spec:argType:typeParm)
		 typeTable inDecl inSpecial inRef inSeq])

(\CheckType1
  [LAMBDA (spec typeName typeParm typeTable inDecl inSpecial inRef inSeq)
                                                             (* ht: "31-Jul-85 15:57")
    (LET (trueType)
      (if (FMEMB typeName \LupinePrimativeTypes)
	  then (if (FMEMB typeName \LupineTypesWithParm)
		   then (if (NOT typeParm)
			    then (ERROR "Must have type parm for type" spec))
			(SELECTQ typeName
				 ((LIST REF SEQUENCE)
				   (if (AND typeName= 'SEQUENCE
					    (NOT inSeq))
				       then (ERROR "SEQUENCE field can occur only in SEQRECORDs" spec)
				       )
				   (\CheckType spec:argType typeTable NIL NIL typeName= 'REF))
				 (BITS (if (NOT (AND (NUMBERP typeParm:1)
						     (IGREATERP typeParm:1 0)
						     (OR (ILEQ typeParm:1 16)
							 typeParm:1=32)
						     typeParm::1=NIL))
					   then (ERROR 
			   "BITS type must have exactly one  numeric parameter in [1..16] U [32]"
						       spec)))
				 ((RECORD RESULT SIGARGS)
				   (if (NOT inDecl)
				       then (ERROR 
	    "In line RECORDs/RESULTs/SIGARGSs not allowed - must be pre-declared as a named type"
						   spec))
				   (\CheckRecordDecl spec typeParm)
				   (for fs in typeParm do (\CheckType fs typeTable)))
				 (SEQRECORD (if (NOT inDecl)
						then (ERROR 
			  "In line SEQRECORDs not allowed - must be pre-declared as a named type"
							    spec))
					    (\CheckRecordDecl spec typeParm)
					    (if [NOT (for fieldSpecPointer on typeParm
							thereis (PROG1 (if (U-CASE (\TypeName 
								     fieldSpecPointer:1:fieldType))=
									   'SEQUENCE
									   then (if 
									      fieldSpecPointer::1
										    then
										     (ERROR 
						 "SEQUENCE must be the last field of a SEQRECORD"
											    spec)
										  else T))
								       (\CheckType fieldSpecPointer:1 
										   typeTable NIL NIL 
										   NIL T]
						then (ERROR 
						       "SEQRECORD must end with a SEQUENCE field"
							    spec))
					    (if (NOT (FMEMB (\TypeName typeParm:-2:fieldType)
							    \LupineNumberTypes))
						then (printout T 
				  "Warning - next to last field in SEQRECORD not a numeric type?"
							       , spec)))
				 NIL)
		 elseif typeParm
		   then (ERROR "Shouldnt have type parm for type" spec))
	elseif (ASSOC typeName typeTable)
	  then (if typeParm
		   then (ERROR "Shouldnt have type parm for user-defined type" spec))
	       (trueType←(\BaseType typeName typeTable))
	       (if (LISTP trueType)
		   then (if (AND (FMEMB trueType:typeName \LupineDummyTypes)
				 (NOT inSpecial))
			    then (ERROR "Can't use RESULT/SIGARGS except from RETURNS/ARGS spec" spec)
			  elseif (AND trueType:typeName= 'SEQRECORD
				      (NOT inRef))
			    then (ERROR "Must get to SEQRECORD via a REF, not directly" spec)))
	else (ERROR "Not a type" spec])

(\CheckRecordDecl
  [LAMBDA (spec fieldSpecs)                                  (* ht: "30-Jul-85 09:41")
    (LET ((recFields (RECORDFIELDNAMES spec:fieldName)))
      (if (NOT recFields)
	  then (ERROR "No record declaration for record type" spec))
      (if [NOT (AND (LENGTH recFields)=(LENGTH fieldSpecs)
		    (for fieldSpec in fieldSpecs always (FMEMB fieldSpec:fieldName recFields]
	  then (ERROR "Field names in type declaration don't match up  with those of record"
		      (LIST recFields spec])
)



(* Type table construction)

(DEFINEQ

(\DeclareTypes
  [LAMBDA (typeDecls)                                        (* ht: "31-Jul-85 14:50")
    (bind newEntry (typeTable ←(APPEND \LupineInitialTypeTable))
	  allocation for ty in typeDecls unless ty:type= '*
       do (if (NOT (AND ty:type (LITATOM ty:type)))
	      then (ERROR "type declaration must begin with an atomic type name" ty))
	  (if (OR NOT (ty:typeType)
		  ty::2)
	      then (ERROR "there must be one and only one type in a type declaration" ty))
	  (if (U-CASE ty:type)= 'INCLUDE
	      then (if (AND ty:typeType (LITATOM ty:typeType))
		       then typeTable←(NCONC typeTable (\DeclareTypes (EVALV ty:typeType)))
		     else (ERROR "INCLUDE must be of the form (INCLUDE <litatom>)" ty))
	    else (\CheckType ty typeTable T)
		 (newEntry←(create TypeSpec
				   type ← ty:type
				   typeType ← ty:typeType))
		 (if (NOT (AND (LISTP ty:typeType)
			       (FMEMB (U-CASE ty:typeType:typeName)
				      \LupineDummyTypes)))
		     then (allocation←(\Allocate ty:typeType typeTable))
			  (newEntry:typeSize←allocation:need)
			  (newEntry:typeBits←allocation:fields))
		 (push typeTable newEntry))
       finally (RETURN typeTable])

(\Allocate
  [LAMBDA (type typeTable subFlg)                            (* ht: "29-Jul-85 13:38")
    (let ((typeName (\TypeName type))
	  (typeParm (if (LISTP type)
			then type:typeParm))
	  res rRes)
	 res←[SELECTQ typeName
		      ((STRING ATOM LIST STREAM ARB FIXP REF SEQUENCE)
			32)
		      (SSMALLP 16)
		      ((RECORD SEQRECORD)
			rRes←
			(\AllocateRecord typeName typeParm typeTable)
			(if subFlg
			    then rRes:need
			  else rRes))
		      (if (FMEMB typeName \LupinePrimativeTypes)
			  then (let [(need (SELECTQ typeName
						    (BOOLEAN 1)
						    (BITS typeParm:1)
						    [ENUMERATION
						      (IMAX 1 (bind (max ←(SUB1 (LENGTH typeParm)))
								 until (ZEROP max)
								 count max←(LRSH max 1]
						    (SHOULDNT]
				    (if (IGREATERP need 16)
					then (SHOULDNT "Too big")
				      else need))
			else                                 (* user defined type)
			     (fetch typeSize of (\TypeLayout typeName typeTable]
	 (if subFlg
	     then (LIST res)
	   else (OR (LISTP res)
		    (create RecordLayout
			    need ← res
			    fields ←(LIST res])

(\AllocateRecord
  [LAMBDA (typeName typeParm typeTable)                      (* ht: "24-Jul-85 19:33")
    (bind (bitsLeft ← 16)
	  (wordsUsed ← 0)
	  left sub need for t in typeParm
       join (sub←(\Allocate t:fieldType typeTable T))
	    (need←sub:1)
	    (if (IGREATERP need bitsLeft)
		then (if (ZEROP bitsLeft)
			 then 

          (* * run out -
	  fix it)


			      (add wordsUsed 1)
		       elseif bitsLeft~=16
			 then 

          (* * expand the leftmost bit of the last thing to fit)


			      (add left:1 bitsLeft)
			      (add wordsUsed 1))
		     (bitsLeft←16)
		     (if (IGREATERP need 15)
			 then 

          (* * must be some number of words)


			      (add wordsUsed (LRSH need 4))
			      (need←0)
		       else bitsLeft←bitsLeft-need)
	      else bitsLeft←bitsLeft-need)
	    (left←sub)
       finally (if (ZEROP bitsLeft)
		   then (add wordsUsed 1)
		 elseif (AND (NOT (ZEROP wordsUsed))
			     bitsLeft~=16)
		   then 

          (* * only sub-word records are allowed to be not a multiple of 16 -
	  pad)


			(add left:1 bitsLeft)
			(add wordsUsed 1))
	       (RETURN (create RecordLayout
			       need ←(if (ZEROP wordsUsed)
					 then 16-bitsLeft
				       else (LLSH wordsUsed 4))
			       fields ← $$VAL])
)



(* Utilities)

(DEFINEQ

(\TypeName
  [LAMBDA (type)                                             (* ht: "26-Jul-85 09:14")
    (LET ((typen (if (LISTP type)
		     then type:typeName
		   else type)))
      (if (FMEMB (U-CASE typen)
		 \LupinePrimativeTypes)
	  then (U-CASE typen)
	else typen])

(\BaseType
  [LAMBDA (type typeTable)                                   (* ht: "26-Jul-85 09:04")
    (LET ((typeName (\TypeName type)))
      (if (FMEMB typeName \LupinePrimativeTypes)
	  then type
	else (\BaseType (fetch typeType of (\TypeLayout typeName typeTable))
			typeTable])

(\TypeLayout
  [LAMBDA (typeName typeTable)                               (* ht: "24-Jul-85 11:32")
    (OR (ASSOC typeName typeTable)
	(HELP "Type not defined" typeName])

(\TypeSize
  [LAMBDA (type typeTable)                                   (* ht: "31-Jul-85 09:21")
    (LET ((typeName (\TypeName type))
       entry)
      (if entry←(ASSOC typeName typeTable)
	  then entry:typeSize
	elseif (FMEMB typeName \LupineNotFixedTypes)
	  then 32
	else 16])

(\LupineNotFixed
  [LAMBDA (field typeTable)                                  (* ht: "26-Jul-85 09:08")
    (FMEMB (\TypeName (\BaseType field:fieldType typeTable))
	   \LupineNotFixedTypes])

(\StaticsFirst
  [LAMBDA (specs typeTable)                                  (* ht: "25-Jul-85 16:13")
    (bind nonStatics for s in specs when (if (U-CASE s:argName)
					     ~=
					     'RETURNS
					     then (if (\IsStatic s:argType typeTable)
						    else (nonStatics←(NCONC1 nonStatics s))
							 NIL))
       collect s finally (RETURN (NCONC $$VAL nonStatics])

(\IsStatic
  [LAMBDA (type typeTable)                                   (* ht: "26-Jul-85 09:01")
    (LET* ((trueType (\BaseType type typeTable))
       (typeName (\TypeName trueType)))
      (OR (MEMB typeName \LupineStatics)
	  (AND typeName= 'RECORD
	       (for f in trueType:typeParm always (\IsStatic f:fieldType typeTable])
)

(RPAQQ \LupineGetFns ((SSMALLP . \GetArgSmallp)
			(FIXP . \GetArgDblWord)
			(BOOLEAN . \GetArgBool)
			(STRING . \UnmarshalString)
			(ATOM . \UnmarshalAtom)
			(STREAM . \UnmarshalStream)
			(ENUMERATION . \GetArgEnum)
			(ARB . \UnmarshalArb)))

(RPAQQ \LupinePutFns ((SSMALLP . \AddPupSmallp)
			(FIXP . \AddPupDblWord)
			(BOOLEAN . \AddPupBoolean)
			(STRING . \MarshalString)
			(ATOM . \MarshalAtom)
			(STREAM . \MarshalStream)
			(ENUMERATION . \AddPupEnum)
			(ARB . \MarshalArb)
			(BITS . \AddPupWord)))

(RPAQQ \LupinePrimativeTypes (SSMALLP FIXP BOOLEAN STRING ATOM STREAM ENUMERATION ARB BITS LIST 
					RECORD RESULT SIGARGS REF SEQRECORD SEQUENCE))

(RPAQQ \LupineInitialTypeTable ((CARDINAL (BITS 16)
					    NIL 16 16)
				  (* the next is not true, but is as close as we get)
				  (LONGCARDINAL (BITS 32)
						NIL 32 32)))

(RPAQQ \LupineNumberTypes (FIXP SSMALLP ENUMERATION BITS))

(RPAQQ \LupineNotFixedTypes (STRING ATOM STREAM ARB LIST REF))

(RPAQQ \LupineDummyTypes (RESULT SIGARGS))

(RPAQQ \LupineStatics (SSMALLP FIXP BOOLEAN ENUMERATION BITS))

(RPAQQ \LupineTypesWithParm (ENUMERATION BITS LIST REF SEQRECORD SEQUENCE RECORD RESULT SIGARGS 
					   STREAM))
(DECLARE: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \LupineGetFns \LupinePutFns \LupineStatics \LupineTypesWithParm \LupinePrimativeTypes 
	    \LupineDummyTypes \LupineNotFixedTypes \LupineNumberTypes \LupineInitialTypeTable)
)
(DECLARE: DONTCOPY 
(DECLARE: EVAL@COMPILE 

(RPAQQ \FirstLupineUserCall 4)

(RPAQQ \FirstLupineSignal 4)

(CONSTANTS (\FirstLupineUserCall 4)
	   (\FirstLupineSignal 4))
)
)
(PUTPROPS LUPINE COPYRIGHT ("Xerox Corporation" 1984 1985 1986))
(DECLARE: DONTCOPY
  (FILEMAP (NIL (1917 43384 (Lupine 1927 . 3884) (\ServerComs 3886 . 10078) (\MakeUnmarshal 10080 . 
10581) (\MakeUnmarshal1 10583 . 14428) (\MakeUnmarshalRecord 14430 . 22709) (\FixedFetch 22711 . 23977
) (\MakeArgsUnmarshal 23979 . 24867) (\ClientComs 24869 . 30430) (\MakeMarshal 30432 . 31021) (
\MakeMarshal1 31023 . 34722) (\MakeMarshalRecord 34724 . 41100) (\FixedStore 41102 . 42627) (
\MakeArgsMarshal 42629 . 43382)) (43422 49673 (\CheckSpec 43432 . 45630) (\CheckType 45632 . 45912) (
\CheckType1 45914 . 49088) (\CheckRecordDecl 49090 . 49671)) (49710 53777 (\DeclareTypes 49720 . 51058
) (\Allocate 51060 . 52323) (\AllocateRecord 52325 . 53775)) (53800 56008 (\TypeName 53810 . 54128) (
\BaseType 54130 . 54457) (\TypeLayout 54459 . 54650) (\TypeSize 54652 . 54975) (\LupineNotFixed 54977
 . 55188) (\StaticsFirst 55190 . 55629) (\IsStatic 55631 . 56006)))))
STOP