--- /dev/null
+<SETG DEFINE
+ <FUNCTION ("STACK" FUNNAME DEF)
+ <SETG .FUNNAME .DEF>
+ <PRINT .FUNNAME> >>
+
+
+<DEFINE FRAMEN
+ <FUNCTION ("STACK" N)
+ <COND (<0? .N> <FRAME>)
+ (T <FRAME <FRAMEN <- .N 1>>>)>>>\e
+
+
+
+<DEFINE CLEANUP
+ <FUNCTION CF ("STACK" )
+ <FINALIZE>
+ <BUMPER>>>
+
+
+<DEFINE BUMPER
+ <FUNCTION ()
+ <FAILPOINT FP ("STACK" )
+ <> ("STACK" M A)
+ <RESTORE .FP (FAILURE CAUGHT WITH M = .M AND A = .A)>> >>
+
+
+
+<DEFINE THSET
+ <FUNCTION ("STACK" VAR\ VAL "AUX" (OV <RLVAL .VAR\ >))
+ <FAILPOINT ()
+ <SET .VAR\ <RLVAL VAL>>
+ ("STACK" M A)
+ <SET .VAR\ <RLVAL OV>>
+ <FAIL .M .A>> >>
+
+
+<DEFINE THDELQ
+ <FUNCTION ("STACK" ELT L)
+ <COND (<EMPTY? .L> .L)
+ (<==? .ELT <1 .L>>
+ <CHTYPE <REST .L> <TYPE .L>>)
+ (T <THDELQ1 .ELT .L>) >>>
+
+
+<DEFINE THDELQ1
+ <FUNCTION ("STACK" ELT L)
+ <COND (<EMPTY? <REST .L>> .L)
+ (<==? <2 .L> .ELT> <THPUTREST .L <REST .L 2>>)
+ (T <THDELQ1 .ELT <REST .L>>) > >>
+
+
+<DEFINE THPUTREST
+ <FUNCTION ("STACK" LIST1 LIST2)
+ <FAILPOINT ("STACK" (OREST <REST .LIST1>))
+ <PUTREST .LIST1 .LIST2>
+ ("STACK" M A)
+ <PUTREST .LIST1 .OREST>
+ <FAIL .M .A> >>>
+
+
+<DEFINE THPUT
+ <FUNCTION ("STACK" THING IND "OPTIONAL" PROP)
+ <FAILPOINT ("STACK" (OPROP <GET .THING .IND>))
+ <COND (<ASSIGNED? PROP>
+ <PUT .THING .IND .PROP>)
+ (T <PUT .THING .IND>) >
+ ("STACK" M A)
+ <COND (.OPROP <PUT .THING .IND .OPROP>)
+ (<PUT .THING .IND>) >
+ <FAIL .M .A> >>>
+
+
+<DEFINE THSETLOC
+ <FUNCTION ("STACK" LOC VAL "AUX" (OVAL <IN .LOC>))
+ <FAILPOINT ()
+ <SETLOC .LOC <RLVAL VAL>>
+ ("STACK" M A)
+ <SETLOC .LOC <RLVAL OVAL>>
+ <FAIL .M .A> >>>\f<DEFINE FALSE
+ <FUNCTION ("STACK" "ARGS" A) <CHTYPE <EVAL .A> FALSE> >>
+
+
+<DEFINE FORM
+ <FUNCTION ("STACK" "ARGS" A) <CHTYPE <EVAL .A> FORM> >>
+
+<DEFINE UNASSIGNED
+ <FUNCTION ("STACK" "ARGS" A) <CHTYPE <EVAL .A> UNASSIGNED> >>
+
+<DEFINE SEGMENT
+ <FUNCTION ("STACK" "REST" 'A) <CHTYPE <EVAL .A> SEGMENT> >>
+
+<DEFINE CONSTRUCTOR
+ <FUNCTION ("STACK" TYPE)
+ <GET .TYPE 'CONSTRUCTOR> >>
+
+
+<PUT LIST CONSTRUCTOR ,CONSL>
+<PUT FORM CONSTRUCTOR ,FORM>
+<PUT FALSE CONSTRUCTOR ,FALSE>
+<PUT VECTOR CONSTRUCTOR ,CONSV>
+<PUT SEGMENT CONSTRUCTOR ,SEGMENT>
+<PUT UVECTOR CONSTRUCTOR ,CONSU>
+
+
+
+<DEFINE AVAL
+ <FUNCTION ("STACK" ATOM)
+ <COND (<GASSIGNED? .ATOM> <GVAL .ATOM>)
+ (<LVAL .ATOM>)> >>
+\f<DEFINE CLIP
+ <FUNCTION ("STACK" VAR)
+ <FAILPOINT CLIPPER ("STACK" (VAL ..VAR))
+ <FAIL>
+ ("STACK")
+ <COND (<EMPTY? .VAL> <FAIL>)
+ (<RESTORE .CLIPPER
+ <PROG1 <1 .VAL>
+ <SET .VAR <SET VAL <REST .VAL>>>>>) >> >>
+
+
+<DEFINE FULL?
+ <FUNCTION ("STACK" FOO) <NOT <EMPTY? <RLVAL FOO>>>>>
+
+
+<DEFINE FINSPLICE
+ <FUNCTION ACT ("STACK" CURRENTENV NEWENV)
+ <PROG1 <SPLICE .CURRENTENV .NEWENV>
+ <FINALIZE .ACT>> >>
+
+
+<DEFINE ENVIRON
+ <FUNCTION ("STACK" "BIND" FOO) .FOO>>\f<DEFINE RESET
+ <FUNCTION ("STACK" VAR)
+ <FAILPOINT ("STACK" (VAL <RLVAL .VAR>)) <> ("STACK")
+ <SET .VAR <RLVAL VAL>>
+ <FAIL>> >>
+
+<DEFINE PROG1
+ <FUNCTION ("STACK" "REST" A) <1 .A> >>
+
+
+<DEFINE PROG2
+ <FUNCTION ("STACK" "REST" A) <2 .A> >>\f<DEFINE MULTILEVEL
+ <FUNCTION ("STACK" OBJECT)
+ <AND <NOT <MONAD? .OBJECT>>
+ <MEMQ <TYPE .OBJECT> '(LIST FORM VECTOR SEGMENT VECTOR)>> >>
+
+<DEFINE REVERSE
+ <FUNCTION REV ("STACK" L "OPTIONAL" (CFUNC <CONSTRUCTOR <TYPE .L>>)
+ "AUX" (RESULT ()))
+ <COND (<EMPTY? .L> <.CFUNC !.RESULT>)
+ (T <SET RESULT (<1 .L> !.RESULT)>
+ <SET L <REST .L>>
+ <AGAIN .REV>) > >>
+
+
+<DEFINE NCONC
+ <FUNCTION ("STACK" "REST" LSTUPL)
+ <COND (<EMPTY? .LSTUPL> ())
+ (T <CHTYPE <NCONC1 .LSTUPL> <TYPE <1 .LSTUPL>>>) >>>
+
+
+<DEFINE NCONC1
+ <FUNCTION ("STACK" LSTUPL)
+ <COND (<EMPTY? <REST .LSTUPL>> <1 .LSTUPL>)
+ (T <NCONC2 <1 .LSTUPL> <REST .LSTUPL>>) >>>
+
+
+<DEFINE NCONC2
+ <FUNCTION ("STACK" L1 LREST)
+ <COND (<EMPTY? .L1> <NCONC1 .LREST>)
+ (T <PUTREST .L1 <NCONC2 <REST .L1> .LREST>>) >>>\f<DEFINE ANOTHER
+ <FUNCTION ("STACK" OBJ BOUND)
+ <FAILPOINT FP ("STACK")
+ .OBJ ("STACK")
+ <AND <==? .OBJ .BOUND> <FAIL>>
+ <RESTORE .FP <SET OBJ <REST .OBJ>>>> >>
+
+
+\f<DEFINE MAPCAR
+ <FUNCTION MAPPER ("STACK" FUN "REST" EXPS "AUX" (RESULT ()) RES1 LAS)
+ <SET RES1 <APPLY .FUN <LISTFIRSTS .EXPS>>>
+ <COND (<EMPTY? .RESULT>
+ <SET LAS <SET RESULT (.RES1)>>)
+ (T <PUTREST .LAS <SET LAS (.RES1)>>) >
+ <AGAIN .MAPPER> >>
+
+
+<DEFINE MAPC
+ <FUNCTION MAPPER ("STACK" FUN "REST" EXPS "AUX" (RESULT ()))
+ <REPEAT ("STACK") <APPLY .FUN <LISTFIRSTS .EXPS>>> >>
+
+
+<DEFINE MAPCAN
+ <FUNCTION MAPPER ("STACK" FUN "REST" EXPS
+ "AUX" (RESULT ()) RES1 LAS1)
+ <SET RES1 <APPLY .FUN <LISTFIRSTS .EXPS>>>
+ <COND (<EMPTY? .RESULT>
+ <SET RESULT .RES1>)
+ (T <PUTREST .LAS1 .RES1>) >
+ <SET LAS1 <LAST .RES1>>
+ <AGAIN .MAPPER> >>
+
+
+<DEFINE LISTFIRSTS
+ <FUNCTION ("STACK" EXPTUPL)
+ <COND (<EMPTY? .EXPTUPL> ())
+ (<EMPTY? <SET RES1 <1 .EXPTUPL>>> <.MAPPER .RESULT>)
+ ((<PROG1 <1 .RES1>
+ <PUT .EXPTUPL 1 <REST .RES1>>>
+ !<LISTFIRSTS <REST .EXPTUPL>>)) > >>
+
+
+<DEFINE LAST
+ <FUNCTION L ("STACK" EXP)
+ <COND (<EMPTY? .EXP> ())
+ (<EMPTY? <REST .EXP>> .EXP)
+ (T <SET EXP <REST .EXP>>
+ <AGAIN .L>) >>>\f<DEFINE BOTTOM
+ <FUNCTION ("STACK" THING)
+ <COND (<MONAD? .THING> .THING)
+ (<==? <TYPE .THING> LIST> ())
+ (T <REST .THING <LENGTH .THING>>)> >>
+
+
+
+
+<DEFINE SPREAD
+ <FUNCTION ("STACK" VEC "REST" VARS)
+ <MAPC ,SET .VARS .VEC> >>\f\ 3\f
\ No newline at end of file
projects / pdp10-muddle.git / blobdiff