X-Git-Url: https://jxself.org/git/?a=blobdiff_plain;f=MUDDLE%2Fc.ubd026;fp=MUDDLE%2Fc.ubd026;h=185ab52f3418667665f438085c5c59cec4278d34;hb=39c5769144e7f2a58076bdb973d2c80fa603345c;hp=0000000000000000000000000000000000000000;hpb=bab072f950a643ac109660a223b57e635492ac25;p=pdp10-muddle.git

diff --git a/MUDDLE/c.ubd026 b/MUDDLE/c.ubd026
new file mode 100644
index 0000000..185ab52
--- /dev/null
+++ b/MUDDLE/c.ubd026
@@ -0,0 +1,390 @@
+
+<PACKAGE C>
+
+<EXTERNAL TOOL!-PACKAGE>
+
+<DEFINE <ENTRY MESSAGE> (SEVERITY STR "TUPLE" TEXT)
+	<TERPRI>
+	<PRINC "*** ">
+	<PRINC .SEVERITY>
+	<PRINC "	">
+	<PRINC .STR>
+	<REPEAT ()
+	   <COND (<EMPTY? .TEXT> <RETURN 0>)
+		 (<==? <TYPE <1 .TEXT>> ATOM> <PRINC <1 .TEXT>>)
+		 (ELSE <PRIN1 <1 .TEXT>>)>
+	   <PRINC " ">						        ;"Space"
+	   <CHOP TEXT>>
+	<COND (<==? .SEVERITY ERROR> <EXIT .COMPILER "COMPILATION ABORTED">)
+	      (<==? .SEVERITY STOP> <LISTEN>)>>
+
+<INTERNAL SETUP>
+
+<EXTERNAL OP!-PACKAGE GLOBAL!-PACKAGE>
+
+<DEFINE BLOCK:INITIAL () 0>
+
+<DEFINE BRANCH (TAG) <EMIT <INSTRUCTION JRST .TAG>>>
+
+<DEFINE SUBR:CALL (ADR ARG-NUMBER) <EMIT <INSTRUCTION MCALL .ARG-NUMBER .ADR>>>
+
+<DEFINE BINDINGS:INITIAL () 0>
+
+<DEFINE BINDINGS:FINAL () 0>
+
+<DEFINE TEST:TRUE (TAG)
+	<EMIT <INSTRUCTION HLRZ O* A>>
+	<EMIT <INSTRUCTION CAIE O* TFALSE>>
+	<EMIT <INSTRUCTION JRST .TAG>>>
+
+<SETG INSTRUCTION #SUBR *000000402161*>
+
+<DEFINE BINDING:INITIAL () 0>
+
+<DEFINE BINDING:ATOM (ATM)
+	<REFERENCE .ATM>
+	<EMIT <INSTRUCTION HRRI A* -1>>
+	<STACK:ARGUMENT>>
+
+<DEFINE TAGMAK ("OPTIONAL" (STR "TAG"))
+	<SET STR <STRING .STR <UNPARSE ,TAG:COUNT>>>
+	<SETG TAG:COUNT <+ ,TAG:COUNT 1>>
+	<OR <LOOKUP .STR <MOBLIST INITIAL>> <INSERT .STR <MOBLIST INITIAL>>>>
+
+<DEFINE VARIABLES () ((REFERENCES ()) (CODING ()) (TAGS ()))>
+
+<DEFINE STACK:ARGUMENT ()
+	<EMIT <INSTRUCTION PUSH TP* A>>
+	<EMIT <INSTRUCTION PUSH TP* B>>>
+
+<DEFINE BINDING:FINAL ()
+	<EMIT <INSTRUCTION PUSH TP* [0]>>
+	<EMIT <INSTRUCTION PUSH TP* [0]>>
+	<EMIT <INSTRUCTION PUSHJ P* SPECBIND>>>
+
+<DEFINE LABEL (TAG) <EMIT .TAG>>
+
+<DEFINE EMIT (INSTR)
+	<PUTREST .CODE:PTR (.INSTR)>
+	<SET CODE:PTR <REST .CODE:PTR>>>
+
+<DEFINE TEST:ARG (NUMBER TAG)
+	<EMIT <INSTRUCTION HLRE C* AB>>
+	<EMIT <INSTRUCTION MOVMS C>>
+	<EMIT <INSTRUCTION CAIGE C* <* 2 .NUMBER>>>
+	<EMIT <INSTRUCTION JRST .TAG>>>
+
+<DEFINE REFERENCE (OBJECT "EXTRA" TTYPE)
+	<COND (<AND!-  <==? <PRIMTYPE .OBJECT> WORD>
+		       <SET TTYPE
+			    <LOOKUP <STRING !"T <PNAME <TYPE .OBJECT>>>
+				    <GET OP!-PACKAGE OBLIST>>>>
+	       <EMIT <INSTRUCTION MOVSI A* .TTYPE>>
+	       <EMIT <INSTRUCTION MOVE B* [.OBJECT]>>)
+	      (ELSE
+	       <SET OBJECT <FORM QUOTE .OBJECT>>
+	       <EMIT <INSTRUCTION MOVE A* <FORM MQUOTE .OBJECT> -1>>
+	       <EMIT <INSTRUCTION MOVE B* <FORM MQUOTE .OBJECT>>>)>>
+
+<DEFINE FUNCTION:FINAL (PRINFLG)
+	<EMIT <INSTRUCTION JRST FINIS>>
+	<ASSEMBLE!-CODING <REST .CODE:TOP> .PRINFLG <MOBLIST INITIAL>>>
+
+<DEFINE BINDING:VALUE () <STACK:ARGUMENT>>
+
+<DEFINE BINDING:UNBOUND ()
+	<EMIT <INSTRUCTION MOVSI A* TUNBOUND>>
+	<EMIT <INSTRUCTION SETO B*>>
+	<STACK:ARGUMENT>>
+
+<DEFINE BINDING:ARG (NUMBER)
+	<EMIT <INSTRUCTION PUSH TP* (AB) <- <* .NUMBER 2> 2>>>
+	<EMIT <INSTRUCTION PUSH TP* (AB) <- <* .NUMBER 2> 1>>>>
+
+<DEFINE TEST:FALSE (TAG)
+	<EMIT <INSTRUCTION HLRZ O* A>>
+	<EMIT <INSTRUCTION CAIN O* TFALSE>>
+	<EMIT <INSTRUCTION JRST .TAG>>>
+
+<SETG TAG:COUNT 0>
+
+<DEFINE FUNCTION:INITIAL (NAME) <EMIT <FORM TITLE .NAME>>>
+
+<DEFINE BLOCK:FINAL () 0>
+
+<FINISHUP <SETG INSTRUCTION ,FORM> <SETG TAG:COUNT 0>>
+
+<END>
+
+<INTERNAL COMPL>
+
+
+<DEFINE <ENTRY COMPILE> (NAME "OPTIONAL" (PFLG <>) "NAME" COMPILER)
+	<COND (<NOT <==? <TYPE .NAME> ATOM>>
+	       <MESSAGE ERROR "ARGUMENT NOT ATOMIC">)
+	      (<NOT <GASSIGNED? .NAME>>
+	       <MESSAGE ERROR "GLOBALLY UNASSIGNED" .NAME>)
+	      (<NOT <==? <TYPE ,.NAME> FUNCTION>>
+	       <MESSAGE ERROR "IMPROPERLY VALUED" .NAME>)>
+	<PUT .NAME APPLY:OBJECT <GET RSUBR APPLY:TYPE>>		;"Recursive calls"
+	<SETG .NAME <COMPILE-FUNCTION ,.NAME .NAME>>
+	<PUT .NAME APPLY:OBJECT>				;"Remove"
+	<EXIT .COMPILER "DONE">>
+
+<DEFINE COPY (OBJ)
+	<SUBR:CALL!-SETUP <PRIMTYPE .OBJ>
+			  <REPEAT ((I 0))
+			     <IF <EMPTY? .OBJ> <RETURN .I>>
+			     <COMP <1 .OBJ>>
+			     <STACK:ARGUMENT!-SETUP>
+			     <CHOP OBJ>
+			     <INC I>>>>
+
+
+<DEFINE BINDINGS (ARGS "OPTIONAL" (MODE INITIAL) "NAME" BINDER)
+	<IF-NOT <==? <TYPE .ARGS> LIST> <MESSAGE ERROR "ILLEGAL ARGUMENT LIST" .ARGS>>
+	<IF <EMPTY? .ARGS> <EXIT .BINDER 0>>
+	<BINDINGS:INITIAL!-SETUP>
+	<REPEAT (ITEM DEFAULT:TAG GIVEN:TAG (ARG-NUMBER 1))
+	   <SET ITEM <1 .ARGS>>
+	   <COND (<==? <TYPE .ITEM> ATOM>
+		  <COND (<==? .MODE INITIAL>
+			 <BINDING:INITIAL!-SETUP>
+			 <BINDING:ATOM!-SETUP .ITEM>
+			 <BINDING:ARG!-SETUP .ARG-NUMBER>
+			 <BINDING:FINAL!-SETUP>
+			 <INC ARG-NUMBER>)
+			(<==? .MODE EXTRA>
+			 <BINDING:INITIAL!-SETUP>
+			 <BINDING:ATOM!-SETUP .ITEM>
+			 <BINDING:UNBOUND!-SETUP>
+			 <BINDING:FINAL!-SETUP>)
+			(<==? .MODE OPTIONAL>
+			 <SET DEFAULT:TAG <TAGMAK!-SETUP>>
+			 <SET GIVEN:TAG <TAGMAK!-SETUP>>
+			 <BINDING:INITIAL!-SETUP>
+			 <BINDING:ATOM!-SETUP .ITEM>
+			 <TEST:ARG!-SETUP .ARG-NUMBER .DEFAULT:TAG>
+			 <BINDING:ARG!-SETUP .ARG-NUMBER>
+			 <BRANCH!-SETUP .GIVEN:TAG>
+			 <LABEL!-SETUP .DEFAULT:TAG>
+			 <BINDING:UNBOUND!-SETUP>
+			 <LABEL!-SETUP .GIVEN:TAG>
+			 <BINDING:FINAL!-SETUP>
+			 <INC ARG-NUMBER>)
+			(ELSE <MESSAGE WARNING "BINDING ATTEMPTED FOR" .ITEM .MODE>)>)
+		 (<AND <==? <TYPE .ITEM> LIST> <==? <LENGTH .ITEM> 2>>
+		  <COND (<==? .MODE EXTRA>
+			 <BINDING:INITIAL!-SETUP>
+			 <BINDING:ATOM!-SETUP <1 .ITEM>>
+			 <COMP <2 .ITEM>>
+			 <BINDING:VALUE!-SETUP>
+			 <BINDING:FINAL!-SETUP>)
+			(<==? .MODE OPTIONAL>
+			 <SET DEFAULT:TAG <TAGMAK!-SETUP>>
+			 <SET GIVEN:TAG <TAGMAK!-SETUP>>
+			 <BINDING:INITIAL!-SETUP>
+			 <BINDING:ATOM!-SETUP <1 .ITEM>>
+			 <TEST:ARG!-SETUP .ARG-NUMBER .DEFAULT:TAG>
+			 <BINDING:ARG!-SETUP .ARG-NUMBER>
+			 <BRANCH!-SETUP .GIVEN:TAG>
+			 <LABEL!-SETUP .DEFAULT:TAG>
+			 <COMP <2 .ITEM>>
+			 <BINDING:VALUE!-SETUP>
+			 <LABEL!-SETUP .GIVEN:TAG>
+			 <BINDING:FINAL!-SETUP>
+			 <INC ARG-NUMBER>)
+			(ELSE
+			 <MESSAGE ERROR "BINDING ATTEMPTED FOR" .ITEM>)>)
+		 (<==? <TYPE .ITEM> STRING>
+		  <COND (<=? .ITEM "OPTIONAL"> <SET MODE OPTIONAL>)
+			(<OR <=? .ITEM "EXTRA"> <=? .ITEM "AUX">>
+			 <SET MODE EXTRA>)
+			(ELSE
+			 <MESSAGE UNIMPLEMENTED "BINDINGS FOR" .ITEM>
+			 <CHOP ARGS>)>)
+		 (ELSE <MESSAGE UNIMPLEMENTED "BINDINGS FOR" .ITEM>)>
+	   <IF <EMPTY? <CHOP ARGS>> <RETURN 0>>>
+	<BINDINGS:FINAL!-SETUP>>
+
+<DEFINE COMPILE-FUNCTION (FUNCTN
+			  "OPTIONAL" (NAME NOT-NAMED)
+			  "EXTRA" (CODE:TOP!-SETUP (()))
+				  (CODE:PTR!-SETUP .CODE:TOP!-SETUP)
+				  (INFO!-SETUP ()))
+	<FUNCTION:INITIAL!-SETUP .NAME>
+	<IF <EMPTY? .FUNCTN> <MESSAGE ERROR "EMPTY FUNCTION">>
+	<IF <==? <TYPE <1 .FUNCTN>> ATOM>		    ;"Activation name ?"
+	    <MESSAGE UNIMPLEMENTED "ACTIVATION NAMES">
+	    <CHOP FUNCTN>>
+	<IF <EMPTY? .FUNCTN> <MESSAGE ERROR "NO ARGUMENT LIST">>
+	<BINDINGS <1 .FUNCTN>>
+	<IF <EMPTY? <CHOP FUNCTN>> <MESSAGE ERROR "EMPTY FUNCTION BODY">>
+	<REPEAT ()
+	   <COMP <1 .FUNCTN>>	   ;"Go do the real compilation for this object"
+	   <CHOP FUNCTN>			      ;"Next object in the body"
+	   <IF <EMPTY? .FUNCTN> <RETURN 0>>>
+	<FUNCTION:FINAL!-SETUP .PFLG>>
+
+<DEFINE PROG-REPEAT (OB "EXTRA" (NAME <1 .OB>) AGAIN:TAG EXIT:TAG)
+	<BLOCK:INITIAL!-SETUP>
+	<IF <EMPTY? <CHOP OB>> <MESSAGE ERROR "EMPTY" .NAME>>
+	<IF <==? <TYPE <1 .OB>> ATOM>
+	    <MESSAGE UNIMPLEMENTED "ACTIVATION TAGS">
+	    <CHOP OB>>
+	<IF <EMPTY? .OB> <MESSAGE ERROR "NO VARIABLE LIST" .NAME>>
+	<BINDINGS <1 .OB> EXTRA>
+	<IF <EMPTY? <CHOP OB>> <MESSAGE ERROR "NO BODY FOR" .NAME>>
+	<LABEL!-SETUP <SET AGAIN:TAG <TAGMAK!-SETUP "AGAIN">>>
+	<SET EXIT:TAG <TAGMAK!-SETUP "EXIT">>
+	<REPEAT ()
+	   <IF <==? <TYPE <1 .OB>> ATOM> <LABEL!-SETUP <1 .OB>>>
+	   <COMP <1 .OB>>
+	   <IF <EMPTY? <CHOP OB>> <RETURN 0>>>
+	<IF <==? .NAME REPEAT> <BRANCH!-SETUP .AGAIN:TAG>>
+	<LABEL!-SETUP .EXIT:TAG>
+	<BLOCK:FINAL!-SETUP>>
+
+<DEFINE BOOL (PREDS TEST RESULT "EXTRA" (BOOL:TAG <TAGMAK!-SETUP "BOOL">))
+	<COND (<EMPTY? .PREDS> <COMP .RESULT>)
+	      (ELSE
+	       <REPEAT ()
+		  <SET RESULT <1 .PREDS>>
+		  <IF <EMPTY? <CHOP PREDS>> <RETURN BOOL>>
+		  <COMP .RESULT>
+		  <TEST .BOOL:TAG>>
+	       <COMP .RESULT>
+	       <LABEL!-SETUP .BOOL:TAG>)>>
+
+<DEFINE COMP (OBJECT)
+	<<OR <GET .OBJECT THIS:OBJECT>
+			      ;"Is there some function to compile this object ?"
+	     <GET <TYPE .OBJECT> THIS:TYPE>
+				       ;"Is there some function for this type ?"
+	     ,REFERENCE!-SETUP>
+	 .OBJECT>>
+
+<FINISHUP <PUT VECTOR THIS:TYPE ,COPY>
+	 <PUT UVECTOR THIS:TYPE ,COPY>
+	 <PUT LIST THIS:TYPE ,COPY>
+	 <PUT SEGMENT THIS:TYPE <FUNCTION (OBJ) <MESSAGE UNIMPLEMENTED "SEGMENT" .OBJ>>>
+	 <PUT '<> THIS:OBJECT <FUNCTION (OBJ) <REFERENCE!-SETUP #FALSE ()>>>
+	 <PUT FORM
+	      THIS:TYPE				 ;"FORMs are compiled specially"
+	      <FUNCTION (OBJ)
+		      <PROG APPLICATION
+			    ((APPLY <1 .OBJ>))
+			    <<OR <GET .APPLY APPLY:OBJECT>
+					       ;"Do we know how to apply this ?"
+				 <GET <TYPE .APPLY> APPLY:TYPE>
+							    ;"Apply this type ?"
+				 <GET <PRIMTYPE .APPLY> APPLY:PRIMTYPE>
+							      ;"This primtype ?"
+				 <FUNCTION (OB)
+					 <REFERENCE!-SETUP .OBJECT>
+					       ;"Otherwise go to eval with form"
+					 <STACK:ARGUMENT!-SETUP>
+					 <SUBR:CALL!-SETUP EVAL 1>>>
+			     .OBJ>>>>
+	 <PUT ATOM
+	      APPLY:TYPE	   ;"Apply an ATOM as you would apply its value"
+	      <FUNCTION (OB)
+		      <COND (<GASSIGNED? .APPLY>
+				  ;"Try again with the global value if possible"
+			     <SET APPLY ,.APPLY>
+			     <AGAIN .APPLICATION>)
+			    (<AND <BOUND? .APPLY> <ASSIGNED? .APPLY>>
+						        ;"Else with local value"
+			     <MESSAGE NOTE "LOCAL VALUE USED FOR" .APPLY>
+			     <SET APPLY ..APPLY>
+			     <AGAIN .COMPILE-APPLY>)
+			    (ELSE
+			     <MESSAGE NOTE "NO VALUE FOR" .APPLY>
+			     <REFERENCE!-SETUP .OB>
+					   ;"Otherwise go to EVAL with the form"
+			     <STACK:ARGUMENT!-SETUP>
+			     <SUBR:CALL!-SETUP EVAL 1>)>>>
+	 <PUT SUBR
+	      APPLY:TYPE
+	      <FUNCTION (OB)
+		      <SUBR:CALL!-SETUP <1 .OB>
+					<REPEAT ((I 0))
+					   <IF <EMPTY? <CHOP OB>> <RETURN .I>>
+					   <COMP <1 .OB>>
+					   <STACK:ARGUMENT!-SETUP>
+					   <INC I>>>>>
+	 <PUT RSUBR
+	      APPLY:TYPE
+	      <FUNCTION (OB)
+		      <COMP <1 .OB>>		     ;"Get atomic name of RSUBR"
+		      <STACK:ARGUMENT!-SETUP>
+		      <SUBR:CALL!-SETUP GVAL 1>
+		      <STACK:ARGUMENT!-SETUP>
+		      <SUBR:CALL!-SETUP APPLY
+					<REPEAT ((I 1))
+					   <IF <EMPTY? <CHOP OB>> <RETURN .I>>
+					   <COMP <1 .OB>>
+					   <STACK:ARGUMENT!-SETUP>
+					   <INC I>>>>>
+	 <PUT FIX
+	      APPLY:TYPE       ;"Integer as function is a selector of component"
+	      <FUNCTION (OB)
+		      <IF <NOT <==? <LENGTH .OB> 2>>
+			  <MESSAGE ERROR "IMPROPER SELECTOR" .OB>>
+		      <COMP <2 .OB>>			    ;"Get the structure"
+		      <STACK:ARGUMENT!-SETUP>
+		      <COMP .APPLY>			    ;"Get the indicator"
+		      <STACK:ARGUMENT!-SETUP>
+		      <SUBR:CALL!-SETUP NTH 2>>>
+	 <PUT ,PROG APPLY:OBJECT ,PROG-REPEAT>
+	 <PUT ,REPEAT APPLY:OBJECT ,PROG-REPEAT>
+	 <PUT ,RETURN
+	      APPLY:OBJECT
+	      <FUNCTION (OB)
+		      <IF-NOT <==? <LENGTH .OB> 2>
+			      <MESSAGE ERROR "WRONG NUMBER OF ARGUMENTS TO RETURN">>
+		      <COMP <2 .OB>>
+		      <BRANCH!-SETUP .EXIT:TAG>>>
+	 <PUT ,AGAIN
+	      APPLY:OBJECT
+	      <FUNCTION (OB)
+		      <COND (<EMPTY? <CHOP OB>> <BRANCH!-SETUP .AGAIN:TAG>)
+			    (<==? <LENGTH .OB> 1>
+			     <COMP <1 .OB>>
+			     <STACK:ARGUMENT!-SETUP>
+			     <SUBR:CALL!-SETUP AGAIN 1>)
+			    (ELSE <MESSAGE ERROR "TOO MANY ARGUMENTS TO AGAIN">)>>>
+	 <PUT ,GO
+	      APPLY:OBJECT
+	      <FUNCTION (OB)
+		      <IF <NOT <==? <LENGTH .OB> 2>>
+			  <MESSAGE ERROR "NO TAG IN GO">>
+		      <BRANCH!-SETUP <2 .OB>>>>
+	 <PUT ,COND
+	      APPLY:OBJECT
+	      <FUNCTION (OB "EXTRA" (COND:TAG <TAGMAK!-SETUP "COND">))
+		      <IF <EMPTY? <CHOP OB>> <MESSAGE ERROR "EMPTY COND">>
+		      <REPEAT (PHRASE PHRASE:TAG)
+			 <SET PHRASE:TAG <TAGMAK!-SETUP "PHRASE">>
+			 <IF <EMPTY? <SET PHRASE <1 .OB>>>
+			     <MESSAGE ERROR "MISSING PREDICATE IN COND">>
+			 <COMP <1 .PHRASE>>
+			 <TEST:FALSE!-SETUP .PHRASE:TAG>
+			 <REPEAT ()
+			    <IF <EMPTY? <CHOP PHRASE>> <RETURN 0>>
+			    <COMP <1 .PHRASE>>>
+			 <BRANCH!-SETUP .COND:TAG>
+			 <LABEL!-SETUP .PHRASE:TAG>
+			 <IF <EMPTY? <CHOP OB>> <RETURN 0>>>
+		      <LABEL!-SETUP .COND:TAG>>>
+	 <PUT ,OR
+	      APPLY:OBJECT
+	      <FUNCTION (OB) <BOOL <REST .OB> ,TEST:TRUE!-SETUP T>>>
+	 <PUT ,AND
+	      APPLY:OBJECT
+	      <FUNCTION (OB) <BOOL <REST .OB> ,TEST:FALSE!-SETUP #FALSE ()>>>>
+
+<END>
+
+<END>
+
\ No newline at end of file