3 <DEFINE FIND-CALL (ATM LIST)
4 #DECL ((ATM) ATOM (LIST) <LIST [REST ATOM]>)
6 <COND (<EMPTY? .LIST> <RETURN <>>)>
7 <COND (<SAME-NAME? .ATM <1 .LIST>> <RETURN T>)>
8 <SET LIST <REST .LIST>>>>
10 <DEFINE SAME-NAME? (X Y "AUX" S1 S2)
11 #DECL ((X Y) ATOM (S1 S2) STRING)
12 <COND (<NOT ,INT-MODE>
18 <AND <G? <LENGTH .S1> 2>
21 <=? <REST .S1 2> .S2>>
22 <AND <G? <LENGTH .S2> 2>
25 <=? <REST .S2 2> .S1>>>)>>
27 <DEFINE INIT-CALL-DISPATCH ()
28 <SETG RTE-DISP-TABLE <IVECTOR ,RTE-DISPATCH-TABLE-SIZE <>>>
29 <SETG RTE-PTR ,DISPATCH-TABLE-START>>
33 <DEFINE CREATE-CALL-DESC (NAME FLUSH? RESULT?
35 "AUX" ANAME (OFF ,RTE-PTR))
36 #DECL ((NAME) STRING (OFF) FIX (FLUSH?) BOOLEAN
37 (RESULT?) <OR FALSE DATUM>)
39 <OR <LOOKUP .NAME ,MIMOP-OBLIST> <INSERT .NAME ,MIMOP-OBLIST>>>
40 <PUT ,RTE-DISP-TABLE <+ </ .OFF 4> 1> .ANAME>
42 <CHTYPE <VECTOR .OFF .ANAME <VECTOR !.ARGS> .RESULT? .FLUSH?>
44 <SETG RTE-PTR <+ ,RTE-PTR 4>>>
46 <DEFINE CREATE-DATUM (TYP TAC VAC)
47 #DECL ((TYP TAC VAC) <OR FALSE ATOM>)
48 <CHTYPE <VECTOR .TYP .TAC .VAC> DATUM>>
50 <DEFINE RTE-ARGS (KIND TAC VAC)
51 #DECL ((KIND VAC) ATOM (TAC) <OR FALSE ATOM>)
52 <COND (<NOT <MEMQ .KIND '[VALUE TYPE-VALUE-PAIR COUNT-VALUE-PAIR]>>
53 <ERROR "BAD-AC-LDESC" CREATE-AC-LDESC>)>
54 <COND (<AND .TAC <OR <NOT <GASSIGNED? .TAC>> <NOT <TYPE? ,.TAC AC>>>>
55 <ERROR "BAD AC" CREATE-AC-LDESC>)>
56 <COND (<OR <NOT <GASSIGNED? .VAC>> <NOT <TYPE? ,.VAC AC>>>
57 <ERROR "BAD AC" CREATE-AC-LDESC>)>
58 <CHTYPE <VECTOR .KIND .TAC .VAC> AC-LDESC>>
62 <DEFINE CALL-RTE (CDESC INST DEST HINT "TUPLE" ARGS "AUX" JAC JADDR)
63 #DECL ((CDESC) CALL-DESCRIPTOR (INST) ATOM
64 (DEST) <OR ATOM FALSE VARTBL> (HINT) <OR FALSE HINT ATOM>)
65 <COND (<AND <TYPE? .DEST VARTBL>
66 <NOT <MEMQ .DEST .ARGS>>
67 <OR <VAR-VALUE-IN-AC? .DEST>
68 <VAR-TYPE-IN-AC? .DEST>
69 <VAR-COUNT-IN-AC? .DEST>
70 <VAR-TYPE-WORD-IN-AC? .DEST>>>
74 <PROCESS-RTE-ARG <1 .SARGS>
81 <FREE-RESULT-ACS <CD-ARGS .CDESC> <CD-RESULT .CDESC>>
82 <COND (<CD-FLUSH?-ACS .CDESC> <FLUSH-ALL-ACS>)>
83 <SET JADDR <CD-DISP-OFFSET .CDESC>>
84 <COND (<==? .INST CALL> <EMIT ,INST-JSB <MA-ABS .JADDR>>)
85 (<==? .INST JUMP> <EMIT ,INST-JMP <MA-ABS .JADDR>>)>
86 <SET-RTE-RESULT <CD-RESULT .CDESC> .DEST .HINT>
90 <DEFINE FREE-RESULT-ACS (ARGS RESULT "AUX" VAC)
91 #DECL ((ARGS) <VECTOR [REST ARG-DESCRIPTOR]> (RESULT) <OR FALSE
93 <COND (<TYPE? .RESULT DATUM>
94 <COND (<SET VAC <DATUM-TAC .RESULT>>
95 <OR <CALLUSE? .VAC .ARGS> <GET-AC ,.VAC T>>)>
96 <COND (<SET VAC <DATUM-VAC .RESULT>>
97 <OR <CALLUSE? .VAC .ARGS> <GET-AC ,.VAC T>>)>)>
100 <DEFINE CALLUSE? (VAC ARGS "AUX" (RES <>))
101 #DECL ((VAC) ATOM (ARGS) <VECTOR [REST ARG-DESCRIPTOR]>)
104 <COND (<AND <TYPE? .ARG AC-LDESC>
105 <OR <==? <AC-LDESC-TAC .ARG> .VAC>
106 <==? <AC-LDESC-VAC .ARG> .VAC>>>
112 <DEFINE SET-RTE-RESULT (RDAT DEST HINT)
113 #DECL ((DEST) <OR FALSE ATOM VARTBL> (RDAT) <OR FALSE DATUM>
114 (HINT) <OR FALSE HINT ATOM>)
115 <COND (<AND .RDAT .DEST>
116 <COND (<DATUM-TAC .RDAT>
117 <DEST-PAIR ,<DATUM-VAC .RDAT> ,<DATUM-TAC .RDAT> .DEST>)
119 <DEST-DECL ,<DATUM-VAC .RDAT> .DEST <DATUM-TYPE .RDAT>>)
120 (<ERROR "BAD DATUM" SET-RTE-RESULT>)>
121 <PROCESS-DESTINATION-HINT .HINT .DEST>)>>
123 <NEWTYPE ARG-DONE FIX>
125 <DEFINE PROCESS-RTE-ARG PRA (ARG AD SARGS ARGS ADS "AUX" VAC TAC)
126 #DECL ((ARGS) TUPLE (ADS) VECTOR (ARG) ANY (AD) <OR AC-LDESC ATOM>)
128 (<NOT <TYPE? .ARG ARG-DONE>>
129 <COND (<==? .AD STACK>
130 <COND (<TYPE? .ARG VARTBL> <PUSH-VAR .ARG>)
131 (ELSE <PUSH-CONSTANT .ARG>)>)
132 (<AND <TYPE? .AD AC-LDESC>
133 <==? <AC-LDESC-KIND .AD> TYPE-VALUE-PAIR>
134 <==? <NEXT-AC <SET TAC ,<AC-LDESC-TAC .AD>>>
135 <SET VAC ,<AC-LDESC-VAC .AD>>>>
136 <CHECK-AC-USE .ARGS .SARGS .ADS .ARG .TAC .VAC>
137 <COND (<TYPE? <SET ARG <1 .SARGS>> ARG-DONE> <RETURN T .PRA>)>
138 <LOAD-AC-PAIR .ARG <> ,<AC-LDESC-TAC .AD>>
141 (<TYPE? .AD AC-LDESC>
148 <COND (<TYPE? <SET ARG <1 .SARGS>> ARG-DONE> <RETURN T .PRA>)>
149 <COND (<TYPE? .ARG VARTBL>
152 <COND (<==? <AC-LDESC-KIND .AD>
157 ,<AC-LDESC-VAC .AD>>>
160 <SET VAC <GET-AC ,<AC-LDESC-VAC .AD> T>>
162 <MOVE-VALUE .ARG .VAC>
164 <COND (<TYPE? .ARG VARTBL>
165 <COND (<==? <AC-LDESC-KIND .AD> TYPE-VALUE-PAIR>
167 <LOAD-VAR .ARG TYPE-WORD T ,<AC-LDESC-TAC
170 (<==? <AC-LDESC-KIND .AD> COUNT-VALUE-PAIR>
171 <SET VAC <LOAD-VAR .ARG COUNT T ,<AC-LDESC-TAC
173 <PROTECT-USE .VAC>)>)
175 <COND (<==? <AC-LDESC-KIND .AD> TYPE-VALUE-PAIR>
176 <SET VAC <GET-AC ,<AC-LDESC-TAC .AD> T>>
178 <MOVE-TYPE .ARG <MA-REG .VAC>>
180 (<==? <AC-LDESC-KIND .AD> COUNT-VALUE-PAIR>
181 <SET VAC <GET-AC ,<AC-LDESC-TAC .AD> T>>
183 <LOAD-CONSTANT .VAC <LENGTH .ARG>>
185 <1 .SARGS <CHTYPE 0 ARG-DONE>>)>>
187 <DEFINE CHECK-AC-USE (ARGS SARGS ADS ARG
189 #DECL ((SARGS ARGS) TUPLE (ADS) VECTOR (ACS) TUPLE)
192 #DECL ((AC) <OR FALSE AC ATOM>)
193 <COND (<TYPE? .AC ATOM> <SET AC ,.AC>)>
197 <FUNCTION (LINKVAR "AUX" TV (VAR <LINKVAR-VAR .LINKVAR>))
199 (<OR <AND <==? .AC <LINKVAR-VALUE-AC .LINKVAR>>
200 <NOT <LINKVAR-VALUE-STORED .LINKVAR>>>
201 <AND <==? .AC <LINKVAR-TYPE-AC .LINKVAR>>
202 <NOT <LINKVAR-TYPE-STORED .LINKVAR>>>
203 <AND <==? .AC <LINKVAR-COUNT-AC .LINKVAR>>
204 <NOT <LINKVAR-COUNT-STORED .LINKVAR>>>
205 <AND <==? .AC <LINKVAR-TYPE-WORD-AC .LINKVAR>>
206 <NOT <LINKVAR-TYPE-STORED .LINKVAR>>>>
207 ;"Might be something in here"
210 (<SET TV <MEMQ .VAR .TV>>
211 ;"It's OK if current arg is in right AC"
215 (<L? <LENGTH .TV> <LENGTH .SARGS>>
218 <NTH .ADS <+ 1 <- <LENGTH .ADS> <LENGTH .TV>>>>
223 <ISTORE-VAR .LINKVAR <> T>
224 ; "Can't use will-die? here"
230 <DEFINE RESET-FRAME-LABEL-TABLE () <SETG FRAME-LABEL-TABLE ()>>
232 <DEFINE SFRAME-GEN ("OPTIONAL" (NAME <>))
235 <DEFINE FRAME-GEN ("OPTIONAL" (NAME <>) (SEG <>) "AUX" TLAB ELAB VAC)
236 #DECL ((NAME) <OR FALSE ATOM>)
237 <COND (<AND ,GLUE .NAME <QUICK-CALL? .NAME>>
238 <EMIT-PUSH <TYPE-CODE <COND (.SEG QSFRAME)
239 (ELSE QFRAME)>> WORD>
240 <SET TLAB <MAKE-LABEL>>
241 <SETG FRAME-LABEL-TABLE (.TLAB !,FRAME-LABEL-TABLE)>
242 <EMIT-PUSH-LABEL .TLAB>
243 <EMIT-PUSH <MA-REG ,AC-F> LONG>
244 <SET ELAB <MAKE-LABEL>>
245 <COND (<AND ,MAKTUP-FLAG <0? ,ICALL-LEVEL>>
246 <SET VAC <GET-AC PREF-VAL T>>
247 <EMIT-MOVE <MA-BD ,AC-F -4> <MA-REG .VAC> LONG>
248 <EMIT ,INST-TSTB <MA-BD .VAC -1>>
249 <GEN-BRANCH ,INST-BLSS .ELAB <>>
250 <EMIT-MOVE <MA-BD .VAC -4> <MA-REG .VAC> LONG>
251 <EMIT-LABEL .ELAB <>>
252 <EMIT-PUSH <MA-REG .VAC> LONG>)
254 <EMIT-PUSH <MA-BD ,AC-F -4> LONG>
255 <GEN-BRANCH ,INST-BGEQ .ELAB <>>
256 <EMIT-MOVE <MA-REG ,AC-F> <MA-BD ,AC-TP -4> LONG>
257 <EMIT-LABEL .ELAB <>>)>)
258 (<CALL-RTE <COND (.SEG ,ISFRAME!-MIMOP)
259 (ELSE ,IFRAME!-MIMOP)> CALL <> <>>)>
262 <DEFINE SCALL-GEN (NAME NARGS RES DIR TAG COUNT "OPTIONAL" (HINT <>))
263 <CCALL-GEN .NAME .NARGS .RES .TAG .COUNT .HINT>>
265 <DEFINE CALL-GEN (NAME NARGS "OPTIONAL" (RES <>) (HINT <>))
266 <CCALL-GEN .NAME .NARGS .RES <> <> .HINT>>
268 <DEFINE CCALL-GEN (NAME NARGS RES TAG COUNT HINT "AUX" (TLAB <MAKE-LABEL>))
269 #DECL ((NAME) <OR ATOM VARTBL> (NARGS) <OR FIX VARTBL>
270 (RES) <OR ATOM VARTBL FALSE> (HINT) <OR FALSE ATOM>)
271 <COND (<AND ,GLUE <TYPE? .NAME ATOM> <QUICK-CALL? .NAME>>
272 <COND (<TYPE? .NARGS FIX>
275 <MA-DISP ,AC-TP <* -8 .NARGS>>
277 <LOAD-CONSTANT ,AC-0 .NARGS>
278 <EMIT-CALL .NAME .NARGS>)
280 <LOAD-VAR .NARGS VALUE T ,AC-0>
282 <FUNCTION (X) <COND (<N==? .X ,AC-0>
293 <EMIT-CALL .NAME -1>)>
294 <EMIT-LABEL <1 ,FRAME-LABEL-TABLE> <>>
295 <SETG FRAME-LABEL-TABLE <REST ,FRAME-LABEL-TABLE>>
297 <EMIT-BRANCH ,INST-BRB .TLAB <> 0 <> T>
298 <EMIT ,INST-ADDL2 <MA-REG ,AC-1> <ADDR-VAR-VALUE .COUNT>>
299 <GEN-BRANCH ,INST-BRB .TAG <>>)>
300 <EMIT-LABEL .TLAB <>>
301 <SET-RTE-RESULT <CD-RESULT ,MCALL!-MIMOP> .RES .HINT>)
302 (<CALL-RTE ,MCALL!-MIMOP
304 <COND (.TAG <>) (ELSE .RES)>
309 <EMIT-BRANCH ,INST-BRB .TLAB <> 0 <> T>
310 <EMIT ,INST-ADDL2 <MA-REG ,AC-1> <ADDR-VAR-VALUE .COUNT>>
311 <GEN-BRANCH ,INST-BRB .TAG UNCONDITIONAL-BRANCH>
312 <EMIT-LABEL .TLAB <>>
313 <SET-RTE-RESULT <CD-RESULT ,MCALL!-MIMOP> .RES .HINT>)>)>
316 <DEFINE CALL-STACK-FUNCTION (ARGS CALLR TYP "TUPLE" CARGS "AUX" DEST (CNT 0))
317 #DECL ((ARGS) TUPLE (CALLR) CALL-DESCRIPTOR (TYP) <OR ATOM FALSE>)
319 <FCN (FARGS "AUX" (ARG <1 .FARGS>))
320 <COND (<OR <==? .ARG STACK> <TYPE? .ARG VARTBL>>
322 <COND (<OR <1? <LENGTH .FARGS>> <TYPE? <2 .FARGS> LIST>>
324 (ELSE <PUSH-GEN .ARG> <SET CNT <+ .CNT 1>>)>>
326 <CALL-RTE .CALLR CALL .DEST .TYP !.CARGS .CNT>
329 <DEFINE QUICK-CALL? (NAME)
331 <FIND-CALL .NAME ,GLUE-FCNS>>
333 <DEFINE CHANNEL-OP-GEN (TYPE OPER CHANNEL "TUPLE" ARGS
334 "AUX" (RES ,HAS-RESULT) FROB)
335 #DECL ((TYPE OPER) ATOM (CHANNEL) VARTBL)
337 <SET FROB <CT-QUERY .TYPE .OPER>>
339 ; "If we know what we're calling, and are compiling it, we'll make
344 <CALL-RTE ,IFRAME!-MIMOP CALL <> <>>)>
347 <PUSH-CONSTANT .OPER>
351 <COND (<TYPE? .ARG VARTBL>
354 <PUSH-CONSTANT .ARG>)>>
359 ; "If glued call, go through normal code"
360 <CALL-GEN .FROB <+ 2 <LENGTH .ARGS>> .RES>)
363 <MA-DEF-DISP ,AC-M <+ <ADD-MVEC <CHTYPE (.TYPE .OPER) XCHANNEL-OP>>
365 <MA-REG ,AC-0> DOUBLE>
366 ; "Get atom to call (1st element of funny list stored in mvector)"
367 <EMIT-MOVE <MA-IMM <+ 2 <LENGTH .ARGS>>> <MA-REG ,AC-0> LONG>
369 <EMIT ,INST-JSB <MA-ABS <CD-DISP-OFFSET ,MCALL!-MIMOP>>>
371 <SET-RTE-RESULT <CD-RESULT ,MCALL!-MIMOP> .RES <>>