--- /dev/null
+<USE "CHANNEL-TYPE">
+
+<DEFINE FIND-CALL (ATM LIST)
+ #DECL ((ATM) ATOM (LIST) <LIST [REST ATOM]>)
+ <REPEAT ()
+ <COND (<EMPTY? .LIST> <RETURN <>>)>
+ <COND (<SAME-NAME? .ATM <1 .LIST>> <RETURN T>)>
+ <SET LIST <REST .LIST>>>>
+
+<DEFINE SAME-NAME? (X Y "AUX" S1 S2)
+ #DECL ((X Y) ATOM (S1 S2) STRING)
+ <COND (<NOT ,INT-MODE>
+ <==? .X .Y>)
+ (T
+ <SET S1 <SPNAME .X>>
+ <SET S2 <SPNAME .Y>>
+ <OR <==? .X .Y>
+ <AND <G? <LENGTH .S1> 2>
+ <==? <1 .S1> !\T>
+ <==? <2 .S1> !\$>
+ <=? <REST .S1 2> .S2>>
+ <AND <G? <LENGTH .S2> 2>
+ <==? <1 .S2> !\T>
+ <==? <2 .S2> !\$>
+ <=? <REST .S2 2> .S1>>>)>>
+
+<DEFINE INIT-CALL-DISPATCH ()
+ <SETG RTE-DISP-TABLE <IVECTOR ,RTE-DISPATCH-TABLE-SIZE <>>>
+ <SETG RTE-PTR ,DISPATCH-TABLE-START>>
+
+<GDECL (RTE-PTR) FIX>
+
+<DEFINE CREATE-CALL-DESC (NAME FLUSH? RESULT?
+ "TUPLE" ARGS
+ "AUX" ANAME (OFF ,RTE-PTR))
+ #DECL ((NAME) STRING (OFF) FIX (FLUSH?) BOOLEAN
+ (RESULT?) <OR FALSE DATUM>)
+ <SET ANAME
+ <OR <LOOKUP .NAME ,MIMOP-OBLIST> <INSERT .NAME ,MIMOP-OBLIST>>>
+ <PUT ,RTE-DISP-TABLE <+ </ .OFF 4> 1> .ANAME>
+ <SETG .ANAME
+ <CHTYPE <VECTOR .OFF .ANAME <VECTOR !.ARGS> .RESULT? .FLUSH?>
+ CALL-DESCRIPTOR>>
+ <SETG RTE-PTR <+ ,RTE-PTR 4>>>
+
+<DEFINE CREATE-DATUM (TYP TAC VAC)
+ #DECL ((TYP TAC VAC) <OR FALSE ATOM>)
+ <CHTYPE <VECTOR .TYP .TAC .VAC> DATUM>>
+
+<DEFINE RTE-ARGS (KIND TAC VAC)
+ #DECL ((KIND VAC) ATOM (TAC) <OR FALSE ATOM>)
+ <COND (<NOT <MEMQ .KIND '[VALUE TYPE-VALUE-PAIR COUNT-VALUE-PAIR]>>
+ <ERROR "BAD-AC-LDESC" CREATE-AC-LDESC>)>
+ <COND (<AND .TAC <OR <NOT <GASSIGNED? .TAC>> <NOT <TYPE? ,.TAC AC>>>>
+ <ERROR "BAD AC" CREATE-AC-LDESC>)>
+ <COND (<OR <NOT <GASSIGNED? .VAC>> <NOT <TYPE? ,.VAC AC>>>
+ <ERROR "BAD AC" CREATE-AC-LDESC>)>
+ <CHTYPE <VECTOR .KIND .TAC .VAC> AC-LDESC>>
+
+<SETG SAME-STACK <>>
+
+<DEFINE CALL-RTE (CDESC INST DEST HINT "TUPLE" ARGS "AUX" JAC JADDR)
+ #DECL ((CDESC) CALL-DESCRIPTOR (INST) ATOM
+ (DEST) <OR ATOM FALSE VARTBL> (HINT) <OR FALSE HINT ATOM>)
+ <COND (<AND <TYPE? .DEST VARTBL>
+ <NOT <MEMQ .DEST .ARGS>>
+ <OR <VAR-VALUE-IN-AC? .DEST>
+ <VAR-TYPE-IN-AC? .DEST>
+ <VAR-COUNT-IN-AC? .DEST>
+ <VAR-TYPE-WORD-IN-AC? .DEST>>>
+ <DEAD-VAR .DEST>)>
+ <MAPR <>
+ <FUNCTION (SARGS ADS)
+ <PROCESS-RTE-ARG <1 .SARGS>
+ <1 .ADS>
+ .SARGS
+ .ARGS
+ <CD-ARGS .CDESC>>>
+ .ARGS
+ <CD-ARGS .CDESC>>
+ <FREE-RESULT-ACS <CD-ARGS .CDESC> <CD-RESULT .CDESC>>
+ <COND (<CD-FLUSH?-ACS .CDESC> <FLUSH-ALL-ACS>)>
+ <SET JADDR <CD-DISP-OFFSET .CDESC>>
+ <COND (<==? .INST CALL> <EMIT ,INST-JSB <MA-ABS .JADDR>>)
+ (<==? .INST JUMP> <EMIT ,INST-JMP <MA-ABS .JADDR>>)>
+ <SET-RTE-RESULT <CD-RESULT .CDESC> .DEST .HINT>
+ <CLEAR-STATUS>
+ NORMAL>
+
+<DEFINE FREE-RESULT-ACS (ARGS RESULT "AUX" VAC)
+ #DECL ((ARGS) <VECTOR [REST ARG-DESCRIPTOR]> (RESULT) <OR FALSE
+ DATUM>)
+ <COND (<TYPE? .RESULT DATUM>
+ <COND (<SET VAC <DATUM-TAC .RESULT>>
+ <OR <CALLUSE? .VAC .ARGS> <GET-AC ,.VAC T>>)>
+ <COND (<SET VAC <DATUM-VAC .RESULT>>
+ <OR <CALLUSE? .VAC .ARGS> <GET-AC ,.VAC T>>)>)>
+ T>
+
+<DEFINE CALLUSE? (VAC ARGS "AUX" (RES <>))
+ #DECL ((VAC) ATOM (ARGS) <VECTOR [REST ARG-DESCRIPTOR]>)
+ <MAPF <>
+ <FCN (ARG)
+ <COND (<AND <TYPE? .ARG AC-LDESC>
+ <OR <==? <AC-LDESC-TAC .ARG> .VAC>
+ <==? <AC-LDESC-VAC .ARG> .VAC>>>
+ <SET RES T>
+ <MAPLEAVE>)>>
+ .ARGS>
+ .RES>
+
+<DEFINE SET-RTE-RESULT (RDAT DEST HINT)
+ #DECL ((DEST) <OR FALSE ATOM VARTBL> (RDAT) <OR FALSE DATUM>
+ (HINT) <OR FALSE HINT ATOM>)
+ <COND (<AND .RDAT .DEST>
+ <COND (<DATUM-TAC .RDAT>
+ <DEST-PAIR ,<DATUM-VAC .RDAT> ,<DATUM-TAC .RDAT> .DEST>)
+ (<DATUM-TYPE .RDAT>
+ <DEST-DECL ,<DATUM-VAC .RDAT> .DEST <DATUM-TYPE .RDAT>>)
+ (<ERROR "BAD DATUM" SET-RTE-RESULT>)>
+ <PROCESS-DESTINATION-HINT .HINT .DEST>)>>
+
+<NEWTYPE ARG-DONE FIX>
+
+<DEFINE PROCESS-RTE-ARG PRA (ARG AD SARGS ARGS ADS "AUX" VAC TAC)
+ #DECL ((ARGS) TUPLE (ADS) VECTOR (ARG) ANY (AD) <OR AC-LDESC ATOM>)
+ <COND
+ (<NOT <TYPE? .ARG ARG-DONE>>
+ <COND (<==? .AD STACK>
+ <COND (<TYPE? .ARG VARTBL> <PUSH-VAR .ARG>)
+ (ELSE <PUSH-CONSTANT .ARG>)>)
+ (<AND <TYPE? .AD AC-LDESC>
+ <==? <AC-LDESC-KIND .AD> TYPE-VALUE-PAIR>
+ <==? <NEXT-AC <SET TAC ,<AC-LDESC-TAC .AD>>>
+ <SET VAC ,<AC-LDESC-VAC .AD>>>>
+ <CHECK-AC-USE .ARGS .SARGS .ADS .ARG .TAC .VAC>
+ <COND (<TYPE? <SET ARG <1 .SARGS>> ARG-DONE> <RETURN T .PRA>)>
+ <LOAD-AC-PAIR .ARG <> ,<AC-LDESC-TAC .AD>>
+ <PROTECT-USE .TAC>
+ <PROTECT-USE .VAC>)
+ (<TYPE? .AD AC-LDESC>
+ <CHECK-AC-USE .ARGS
+ .SARGS
+ .ADS
+ .ARG
+ <AC-LDESC-TAC .AD>
+ <AC-LDESC-VAC .AD>>
+ <COND (<TYPE? <SET ARG <1 .SARGS>> ARG-DONE> <RETURN T .PRA>)>
+ <COND (<TYPE? .ARG VARTBL>
+ <SET VAC
+ <LOAD-VAR .ARG
+ <COND (<==? <AC-LDESC-KIND .AD>
+ TYPE-VALUE-PAIR>
+ VALUE)
+ (ELSE JUST-VALUE)>
+ T
+ ,<AC-LDESC-VAC .AD>>>
+ <PROTECT-USE .VAC>)
+ (ELSE
+ <SET VAC <GET-AC ,<AC-LDESC-VAC .AD> T>>
+ <PROTECT-USE .VAC>
+ <MOVE-VALUE .ARG .VAC>
+ <MUNG-AC .VAC>)>
+ <COND (<TYPE? .ARG VARTBL>
+ <COND (<==? <AC-LDESC-KIND .AD> TYPE-VALUE-PAIR>
+ <SET VAC
+ <LOAD-VAR .ARG TYPE-WORD T ,<AC-LDESC-TAC
+ .AD>>>
+ <PROTECT-USE .VAC>)
+ (<==? <AC-LDESC-KIND .AD> COUNT-VALUE-PAIR>
+ <SET VAC <LOAD-VAR .ARG COUNT T ,<AC-LDESC-TAC
+ .AD>>>
+ <PROTECT-USE .VAC>)>)
+ (ELSE
+ <COND (<==? <AC-LDESC-KIND .AD> TYPE-VALUE-PAIR>
+ <SET VAC <GET-AC ,<AC-LDESC-TAC .AD> T>>
+ <PROTECT-USE .VAC>
+ <MOVE-TYPE .ARG <MA-REG .VAC>>
+ <MUNG-AC .VAC>)
+ (<==? <AC-LDESC-KIND .AD> COUNT-VALUE-PAIR>
+ <SET VAC <GET-AC ,<AC-LDESC-TAC .AD> T>>
+ <PROTECT-USE .VAC>
+ <LOAD-CONSTANT .VAC <LENGTH .ARG>>
+ <MUNG-AC .VAC>)>)>)>
+ <1 .SARGS <CHTYPE 0 ARG-DONE>>)>>
+
+<DEFINE CHECK-AC-USE (ARGS SARGS ADS ARG
+ "TUPLE" ACS)
+ #DECL ((SARGS ARGS) TUPLE (ADS) VECTOR (ACS) TUPLE)
+ <MAPF <>
+ <FUNCTION (AC)
+ #DECL ((AC) <OR FALSE AC ATOM>)
+ <COND (<TYPE? .AC ATOM> <SET AC ,.AC>)>
+ <COND
+ (.AC
+ <MAPF <>
+ <FUNCTION (LINKVAR "AUX" TV (VAR <LINKVAR-VAR .LINKVAR>))
+ <COND
+ (<OR <AND <==? .AC <LINKVAR-VALUE-AC .LINKVAR>>
+ <NOT <LINKVAR-VALUE-STORED .LINKVAR>>>
+ <AND <==? .AC <LINKVAR-TYPE-AC .LINKVAR>>
+ <NOT <LINKVAR-TYPE-STORED .LINKVAR>>>
+ <AND <==? .AC <LINKVAR-COUNT-AC .LINKVAR>>
+ <NOT <LINKVAR-COUNT-STORED .LINKVAR>>>
+ <AND <==? .AC <LINKVAR-TYPE-WORD-AC .LINKVAR>>
+ <NOT <LINKVAR-TYPE-STORED .LINKVAR>>>>
+ ;"Might be something in here"
+ <REPEAT ((TV .ARGS))
+ <COND
+ (<SET TV <MEMQ .VAR .TV>>
+ ;"It's OK if current arg is in right AC"
+ <COND
+ (<==? .TV .SARGS>
+ <SET TV <REST .TV>>)
+ (<L? <LENGTH .TV> <LENGTH .SARGS>>
+ <PROCESS-RTE-ARG
+ <1 .TV>
+ <NTH .ADS <+ 1 <- <LENGTH .ADS> <LENGTH .TV>>>>
+ .TV
+ .ARGS
+ .ADS>)
+ (T ;"Loop detected"
+ <ISTORE-VAR .LINKVAR <> T>
+ ; "Can't use will-die? here"
+ <RETURN>)>)
+ (<RETURN>)>>)>>
+ <AC-VARS .AC>>)>>
+ .ACS>>
+
+<DEFINE RESET-FRAME-LABEL-TABLE () <SETG FRAME-LABEL-TABLE ()>>
+
+<DEFINE SFRAME-GEN ("OPTIONAL" (NAME <>))
+ <FRAME-GEN .NAME T>>
+
+<DEFINE FRAME-GEN ("OPTIONAL" (NAME <>) (SEG <>) "AUX" TLAB ELAB VAC)
+ #DECL ((NAME) <OR FALSE ATOM>)
+ <COND (<AND ,GLUE .NAME <QUICK-CALL? .NAME>>
+ <EMIT-PUSH <TYPE-CODE <COND (.SEG QSFRAME)
+ (ELSE QFRAME)>> WORD>
+ <SET TLAB <MAKE-LABEL>>
+ <SETG FRAME-LABEL-TABLE (.TLAB !,FRAME-LABEL-TABLE)>
+ <EMIT-PUSH-LABEL .TLAB>
+ <EMIT-PUSH <MA-REG ,AC-F> LONG>
+ <SET ELAB <MAKE-LABEL>>
+ <COND (<AND ,MAKTUP-FLAG <0? ,ICALL-LEVEL>>
+ <SET VAC <GET-AC PREF-VAL T>>
+ <EMIT-MOVE <MA-BD ,AC-F -4> <MA-REG .VAC> LONG>
+ <EMIT ,INST-TSTB <MA-BD .VAC -1>>
+ <GEN-BRANCH ,INST-BLSS .ELAB <>>
+ <EMIT-MOVE <MA-BD .VAC -4> <MA-REG .VAC> LONG>
+ <EMIT-LABEL .ELAB <>>
+ <EMIT-PUSH <MA-REG .VAC> LONG>)
+ (ELSE
+ <EMIT-PUSH <MA-BD ,AC-F -4> LONG>
+ <GEN-BRANCH ,INST-BGEQ .ELAB <>>
+ <EMIT-MOVE <MA-REG ,AC-F> <MA-BD ,AC-TP -4> LONG>
+ <EMIT-LABEL .ELAB <>>)>)
+ (<CALL-RTE <COND (.SEG ,ISFRAME!-MIMOP)
+ (ELSE ,IFRAME!-MIMOP)> CALL <> <>>)>
+ NORMAL>
+
+<DEFINE SCALL-GEN (NAME NARGS RES DIR TAG COUNT "OPTIONAL" (HINT <>))
+ <CCALL-GEN .NAME .NARGS .RES .TAG .COUNT .HINT>>
+
+<DEFINE CALL-GEN (NAME NARGS "OPTIONAL" (RES <>) (HINT <>))
+ <CCALL-GEN .NAME .NARGS .RES <> <> .HINT>>
+
+<DEFINE CCALL-GEN (NAME NARGS RES TAG COUNT HINT "AUX" (TLAB <MAKE-LABEL>))
+ #DECL ((NAME) <OR ATOM VARTBL> (NARGS) <OR FIX VARTBL>
+ (RES) <OR ATOM VARTBL FALSE> (HINT) <OR FALSE ATOM>)
+ <COND (<AND ,GLUE <TYPE? .NAME ATOM> <QUICK-CALL? .NAME>>
+ <COND (<TYPE? .NARGS FIX>
+ <FLUSH-ALL-ACS>
+ <EMIT ,INST-MOVAL
+ <MA-DISP ,AC-TP <* -8 .NARGS>>
+ <MA-REG ,AC-F>>
+ <LOAD-CONSTANT ,AC-0 .NARGS>
+ <EMIT-CALL .NAME .NARGS>)
+ (ELSE
+ <LOAD-VAR .NARGS VALUE T ,AC-0>
+ <MAPF <>
+ <FUNCTION (X) <COND (<N==? .X ,AC-0>
+ <MUNG-AC .X>)>>
+ ,ALL-ACS>
+ <EMIT ,INST-ASHL
+ <MA-IMM 3>
+ <MA-REG ,AC-0>
+ <MA-REG ,AC-1>>
+ <EMIT ,INST-SUBL3
+ <MA-REG ,AC-1>
+ <MA-REG ,AC-TP>
+ <MA-REG ,AC-F>>
+ <EMIT-CALL .NAME -1>)>
+ <EMIT-LABEL <1 ,FRAME-LABEL-TABLE> <>>
+ <SETG FRAME-LABEL-TABLE <REST ,FRAME-LABEL-TABLE>>
+ <COND (.TAG
+ <EMIT-BRANCH ,INST-BRB .TLAB <> 0 <> T>
+ <EMIT ,INST-ADDL2 <MA-REG ,AC-1> <ADDR-VAR-VALUE .COUNT>>
+ <GEN-BRANCH ,INST-BRB .TAG <>>)>
+ <EMIT-LABEL .TLAB <>>
+ <SET-RTE-RESULT <CD-RESULT ,MCALL!-MIMOP> .RES .HINT>)
+ (<CALL-RTE ,MCALL!-MIMOP
+ CALL
+ <COND (.TAG <>) (ELSE .RES)>
+ .HINT
+ .NARGS
+ .NAME>
+ <COND (.TAG
+ <EMIT-BRANCH ,INST-BRB .TLAB <> 0 <> T>
+ <EMIT ,INST-ADDL2 <MA-REG ,AC-1> <ADDR-VAR-VALUE .COUNT>>
+ <GEN-BRANCH ,INST-BRB .TAG UNCONDITIONAL-BRANCH>
+ <EMIT-LABEL .TLAB <>>
+ <SET-RTE-RESULT <CD-RESULT ,MCALL!-MIMOP> .RES .HINT>)>)>
+ NORMAL>
+
+<DEFINE CALL-STACK-FUNCTION (ARGS CALLR TYP "TUPLE" CARGS "AUX" DEST (CNT 0))
+ #DECL ((ARGS) TUPLE (CALLR) CALL-DESCRIPTOR (TYP) <OR ATOM FALSE>)
+ <MAPR <>
+ <FCN (FARGS "AUX" (ARG <1 .FARGS>))
+ <COND (<OR <==? .ARG STACK> <TYPE? .ARG VARTBL>>
+ <SET DEST .ARG>)>
+ <COND (<OR <1? <LENGTH .FARGS>> <TYPE? <2 .FARGS> LIST>>
+ <MAPLEAVE>)
+ (ELSE <PUSH-GEN .ARG> <SET CNT <+ .CNT 1>>)>>
+ .ARGS>
+ <CALL-RTE .CALLR CALL .DEST .TYP !.CARGS .CNT>
+ NORMAL>
+
+<DEFINE QUICK-CALL? (NAME)
+ #DECL ((NAME) ATOM)
+ <FIND-CALL .NAME ,GLUE-FCNS>>
+
+<DEFINE CHANNEL-OP-GEN (TYPE OPER CHANNEL "TUPLE" ARGS
+ "AUX" (RES ,HAS-RESULT) FROB)
+ #DECL ((TYPE OPER) ATOM (CHANNEL) VARTBL)
+ <COND (<AND ,GLUE
+ <SET FROB <CT-QUERY .TYPE .OPER>>
+ <QUICK-CALL? .FROB>>
+ ; "If we know what we're calling, and are compiling it, we'll make
+ a glued call"
+ <FRAME-GEN .FROB>)
+ (T
+ <SET FROB <>>
+ <CALL-RTE ,IFRAME!-MIMOP CALL <> <>>)>
+ <PUSH-VAR .CHANNEL>
+ ; "Push channel"
+ <PUSH-CONSTANT .OPER>
+ ; "Push operation"
+ <MAPF <>
+ <FUNCTION (ARG)
+ <COND (<TYPE? .ARG VARTBL>
+ <PUSH-VAR .ARG>)
+ (T
+ <PUSH-CONSTANT .ARG>)>>
+ .ARGS>
+ ; "Push args"
+ <FLUSH-ALL-ACS>
+ <COND (.FROB
+ ; "If glued call, go through normal code"
+ <CALL-GEN .FROB <+ 2 <LENGTH .ARGS>> .RES>)
+ (T
+ <EMIT-MOVE
+ <MA-DEF-DISP ,AC-M <+ <ADD-MVEC <CHTYPE (.TYPE .OPER) XCHANNEL-OP>>
+ 4>>
+ <MA-REG ,AC-0> DOUBLE>
+ ; "Get atom to call (1st element of funny list stored in mvector)"
+ <EMIT-MOVE <MA-IMM <+ 2 <LENGTH .ARGS>>> <MA-REG ,AC-0> LONG>
+ ; "Number of args"
+ <EMIT ,INST-JSB <MA-ABS <CD-DISP-OFFSET ,MCALL!-MIMOP>>>
+ ; "Do call"
+ <SET-RTE-RESULT <CD-RESULT ,MCALL!-MIMOP> .RES <>>
+ ; "Hack result"
+ <CLEAR-STATUS>
+ NORMAL)>>
\ No newline at end of file
projects / pdp10-muddle.git / blobdiff