apply-lap.red 11 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348
  1. %
  2. % APPLY-LAP.RED - LAP support for EVAL and APPLY
  3. %
  4. % Author: Eric Benson
  5. % Symbolic Computation Group
  6. % Computer Science Dept.
  7. % University of Utah
  8. % Date: 20 August 1981
  9. % Copyright (c) 1981 University of Utah
  10. %
  11. % <PSL.NEW>APPLY-LAP.RED.2, 9-Dec-82 18:13:02, Edit by PERDUE
  12. % Modified UndefinedFunction to make it continuable
  13. CompileTime flag('(FastLambdaApply), 'InternalFunction);
  14. on SysLisp;
  15. external WVar BndStkPtr, BndStkUpperBound;
  16. % TAG( CodeApply )
  17. % if this could be written in Syslisp, it would look something like this:
  18. % syslsp procedure CodeApply(CodePtr, ArgList);
  19. % begin scalar N;
  20. % N := 0;
  21. % while PairP ArgList do
  22. % << N := N + 1;
  23. % ArgumentRegister[N] := car ArgList;
  24. % ArgList := cdr ArgList >>;
  25. % (jump to address of code pointer)
  26. % end;
  27. lap '((!*entry CodeApply expr 2) %. CodeApply(CodePointer, ArgList)
  28. %
  29. % r1 is code pointer, r2 is list of arguments
  30. %
  31. (!*MOVE (reg 1) (reg t1))
  32. (!*MOVE (reg 2) (reg t2))
  33. (!*MOVE (WConst 1) (reg t3))
  34. Loop
  35. (!*JUMPNOTTYPE (MEMORY (REG T1) (WConst 0)) (reg t2) PAIR)
  36. % jump to code if list is exhauseted
  37. (!*MOVE (CAR (reg t2)) (reg t4))
  38. (!*MOVE (reg t4) (MEMORY (reg t3) 0)) % load argument register
  39. (!*MOVE (CDR (reg t2)) (reg t2))
  40. (!*WPLUS2 (reg t3) (WConst 1)) % increment register pointer
  41. (cain (reg t3) (plus2 (WConst MaxRealRegs) 1)) % skip if neq MaxRegs+1
  42. (!*MOVE (WConst ArgumentBlock) (reg t3)) % else switch to extra args
  43. (!*JUMPWLEQ (Label Loop)
  44. (reg t3)
  45. (WConst (plus2 9 (WConst ArgumentBlock))))
  46. (!*MOVE (QUOTE "Too many arguments to function") (reg 1))
  47. (!*JCALL StdError)
  48. );
  49. % TAG( CodeEvalApply )
  50. % if this could be written in Syslisp, it would look something like this:
  51. % syslsp procedure CodeEvalApply(CodePtr, ArgList);
  52. % begin scalar N;
  53. % N := 0;
  54. % while PairP ArgList do
  55. % << N := N + 1;
  56. % ArgumentRegister[N] := Eval car ArgList;
  57. % ArgList := cdr ArgList >>;
  58. % (jump to address of code pointer)
  59. % end;
  60. lap '((!*entry CodeEvalApply expr 2) %. CodeApply(CodePointer, EvLis Args)
  61. %
  62. % r1 is code pointer, r2 is list of arguments to be evaled
  63. %
  64. (!*PUSH (reg 1)) % code pointer goes on the bottom
  65. (!*PUSH (WConst 0)) % then arg count
  66. Loop % if it's not a pair, then we're done
  67. (!*JUMPNOTTYPE (Label Done) (reg 2) PAIR)
  68. (!*JUMPWLESSP (Label ArgOverflow) (frame 1) (WConst -15))
  69. (!*MOVE (CAR (reg 2)) (reg 1))
  70. (!*MOVE (CDR (reg 2)) (reg 2))
  71. (!*PUSH (reg 2)) % save the cdr
  72. (!*CALL Eval) % eval the car
  73. (!*POP (reg 2)) % grab the list in r2 again
  74. (!*POP (reg 3)) % get count in r3
  75. (!*WDIFFERENCE (reg 3) (WConst 1)) % decrement count
  76. (!*PUSH (reg 1)) % push the evaled arg
  77. (!*PUSH (reg 3)) % and the decremented count
  78. (!*JUMP (Label Loop))
  79. Done
  80. (!*POP (reg 3)) % count in r3, == -no. of args to pop
  81. (!*JUMP (MEMORY (reg 3) (Label ZeroArgs))) % indexed jump
  82. (!*POP (MEMORY (WConst (plus2 (WArray ArgumentBlock) 9)) (WConst 0)))
  83. (!*POP (MEMORY (WConst (plus2 (WArray ArgumentBlock) 8)) (WConst 0)))
  84. (!*POP (MEMORY (WConst (plus2 (WArray ArgumentBlock) 7)) (WConst 0)))
  85. (!*POP (MEMORY (WConst (plus2 (WArray ArgumentBlock) 6)) (WConst 0)))
  86. (!*POP (MEMORY (WConst (plus2 (WArray ArgumentBlock) 5)) (WConst 0)))
  87. (!*POP (MEMORY (WConst (plus2 (WArray ArgumentBlock) 4)) (WConst 0)))
  88. (!*POP (MEMORY (WConst (plus2 (WArray ArgumentBlock) 3)) (WConst 0)))
  89. (!*POP (MEMORY (WConst (plus2 (WArray ArgumentBlock) 2)) (WConst 0)))
  90. (!*POP (MEMORY (WConst (plus2 (WArray ArgumentBlock) 1)) (WConst 0)))
  91. (!*POP (MEMORY (WConst (plus2 (WArray ArgumentBlock) 0)) (WConst 0)))
  92. (!*POP (reg 5))
  93. (!*POP (reg 4))
  94. (!*POP (reg 3))
  95. (!*POP (reg 2))
  96. (!*POP (reg 1))
  97. ZeroArgs
  98. (!*POP (reg t1)) % code pointer in (reg t1)
  99. (!*JUMP (MEMORY (reg t1) (WConst 0))) % jump to address
  100. ArgOverflow
  101. (!*MOVE (QUOTE "Too many arguments to function") (reg 1))
  102. (!*JCALL StdError)
  103. );
  104. % TAG( BindEval )
  105. % if this could be written in Syslisp, it would look something like this:
  106. % syslsp procedure BindEval(Formals, Args);
  107. % begin scalar N;
  108. % N := 0;
  109. % while PairP Args and PairP Formals do
  110. % << N := N + 1;
  111. % Push Eval car ArgList;
  112. % Push car Formals;
  113. % ArgList := cdr ArgList >>;
  114. % if PairP Args or PairP Formals then return -1;
  115. % for I := 1 step 1 until N do
  116. % LBind1(Pop(), Pop());
  117. % return N;
  118. % end;
  119. lap '((!*entry BindEval expr 2) %. BindEval(FormalsList, ArgsToBeEvaledList);
  120. %
  121. % r1 is list of formals, r2 is list of arguments to be evaled
  122. %
  123. (!*PUSH (WConst 0)) % count on the bottom
  124. (!*MOVE (WConst 0) (reg 4))
  125. (!*MOVE (reg 1) (reg 3)) % shift arg1 to r3
  126. EvalLoop % if it's not a pair, then we're done
  127. (!*JUMPNOTTYPE (Label DoneEval) (reg 2) PAIR)
  128. (!*MOVE (CAR (reg 2)) (reg 1))
  129. (!*MOVE (CDR (reg 2)) (reg 2))
  130. (!*PUSH (reg 3)) % save the formals
  131. (!*PUSH (reg 2)) % save the rest of args
  132. (!*CALL Eval) % eval the car
  133. (!*POP (reg 2)) % save then rest of arglist
  134. (!*POP (reg 3)) % and the rest of formals
  135. (!*POP (reg 4)) % and the count
  136. (!*JUMPNOTTYPE (Label ReturnError) (reg 3) PAIR)
  137. % if it's not a pair, then error
  138. (!*WPLUS2 (reg 4) (WConst 1)) % increment the count
  139. (!*MOVE (CAR (reg 3)) (reg 5))
  140. (!*MOVE (CDR (reg 3)) (reg 3))
  141. (!*PUSH (reg 1)) % push the evaluated argument
  142. (!*PUSH (reg 5)) % and next formal
  143. (!*PUSH (reg 4)) % and new count
  144. (!*JUMP (Label EvalLoop))
  145. ReturnError
  146. (!*WSHIFT (reg 4) (WConst 1)) % multiply count by 2
  147. (hrl (reg 4) (reg 4)) % in both halves
  148. (sub (reg st) (reg 4)) % move the stack ptr back
  149. (!*MOVE (WConst -1) (reg 1)) % return -1 as error indicator
  150. (!*EXIT 0)
  151. DoneEval
  152. (!*DEALLOC 1) % removed saved values at top of stack
  153. (!*JUMPTYPE (Label ReturnError) (reg 3) PAIR) % if more formals, error
  154. (!*MOVE (reg 4) (reg 3)) % r3 gets decremented, r4 saved for return
  155. BindLoop
  156. (!*JUMPEQ (Label NormalReturn) (reg 3) (WConst 0))
  157. % if count is zero, then return
  158. (!*POP (reg 1)) % pop ID to bind
  159. (!*POP (reg 2)) % and value
  160. (!*PUSH (reg 3))
  161. (!*PUSH (reg 4))
  162. (!*CALL LBind1)
  163. (!*POP (reg 4))
  164. (!*POP (reg 3))
  165. (soja (reg 3) BindLoop)
  166. NormalReturn
  167. (!*MOVE (reg 4) (reg 1)) % return count
  168. (!*EXIT 0)
  169. );
  170. % TAG( CompiledCallingInterpreted )
  171. % This is pretty gross, but it is essentially the same as LambdaApply, taking
  172. % values from the argument registers instead of a list.
  173. % if this could be written in Syslisp, it would look something like this:
  174. % syslsp procedure CompiledCallingInterpreted IDOfFunction;
  175. % begin scalar LForm, LArgs, N, Result;
  176. % LForm := get(IDOfFunction, '!*LambdaLink);
  177. % LArgs := cadr LForm;
  178. % LForm := cddr LForm;
  179. % N := 1;
  180. % while PairP LArgs do
  181. % << LBind1(car LArgs, ArgumentRegister[N];
  182. % LArgs := cdr LArgs;
  183. % N := N + 1 >>;
  184. % Result := EvProgN LForm;
  185. % UnBindN(N - 1);
  186. % return Result;
  187. % end;
  188. lap '((!*entry CompiledCallingInterpreted expr 0) %. link for lambda
  189. %
  190. % called by JSP T5, from function cell
  191. %
  192. (!*MOVE (reg t5) (reg t1))
  193. (!*WDIFFERENCE (reg t1) (WConst (plus2 (WConst SymFnc) 1)))
  194. (!*MKITEM (reg t1) (WConst BtrTag))
  195. (!*PUSH (reg t1)) % make stack mark for btrace
  196. (!*MOVE (MEMORY (reg t1) (WConst SymPrp)) (reg t1)) % load prop list
  197. LoopFindProp
  198. (!*JUMPNOTTYPE (Label PropNotFound) (reg t1) PAIR)
  199. (!*MOVE (CAR (reg t1)) (reg t2)) % get car of prop list
  200. (!*MOVE (CDR (reg t1)) (reg t1)) % cdr down
  201. (!*JUMPNOTTYPE (Label LoopFindProp) (reg t2) PAIR)
  202. (!*MOVE (CAR (reg t2)) (reg t3)) % its a pair, look at car
  203. (!*JUMPNOTEQ (Label LoopFindProp) (reg t3) '!*LambdaLink)
  204. (!*MOVE (CDR (reg t2)) (reg t2)) % yes, get lambda form
  205. (!*entry FastLambdaApply expr 0) % called from FastApply
  206. (!*MOVE (CDR (reg t2)) (reg t2)) % get cdr of lambda form
  207. (!*MOVE (CDR (reg t2)) (reg t1)) % save cddr in (reg t1)
  208. (!*MOVE (CAR (reg t2)) (reg t2)) % cadr of lambda == arg list
  209. (!*MOVE (WConst 1) (reg t3)) % pointer to arg register in t3
  210. (!*MOVE (WVar BndStkPtr) (reg t4)) % binding stack pointer in t4
  211. (!*PUSH (reg t4)) % save it on the stack
  212. LoopBindingFormals
  213. (!*JUMPNOTTYPE (Label DoneBindingFormals) (reg t2) PAIR)
  214. (!*WPLUS2 (reg t4) (WConst 2)) % adjust binding stack pointer up 2
  215. (caml (reg t4) (WVar BndStkUpperBound)) % if overflow occured
  216. (!*JCALL BStackOverflow) % then error
  217. (!*MOVE (CAR (reg t2)) (reg t5)) % get formal in t5
  218. (hrrzm (reg t5) (Indexed (reg t4) -1)) % store ID number in BndStk
  219. (!*MOVE (MEMORY (reg t5) (WArray SymVal)) (reg t6)) % get old value
  220. (!*MOVE (reg t6) (MEMORY (reg t4) (WConst 0))) % store value in BndStk
  221. (!*MOVE (MEMORY (reg t3) (WConst 0)) (reg t6)) % get reg value in t6
  222. (!*MOVE (reg t6) (MEMORY (reg t5) (WConst SymVal))) % put in value cell
  223. (!*MOVE (CDR (reg t2)) (reg t2)) % cdr down argument list
  224. (!*WPLUS2 (reg t3) (WConst 1)) % increment register pointer
  225. (cain (reg t3) (plus2 (WConst MaxRealRegs) 1)) % Go to extra args?
  226. (movei (reg t3) (WArray ArgumentBlock)) % Yes
  227. (!*JUMP (Label LoopBindingFormals)) % No
  228. DoneBindingFormals
  229. (!*MOVE (reg t4) (WVar BndStkPtr)) % store binding stack
  230. (!*MOVE (reg t1) (reg 1)) % get cddr of lambda form to eval
  231. (!*CALL EvProgN) % implicit progn
  232. (exch (reg 1) (Indexed (reg st) 0)) % save result, get old bind stk ptr
  233. (!*CALL RestoreEnvironment)
  234. (!*POP (reg 1)) % restore old bindings and pickup value
  235. (!*EXIT 1) % throw away backtrace mark and return
  236. PropNotFound
  237. (!*MOVE (QUOTE
  238. "Internal error in function calling mechanism; consult a wizard") (reg 1))
  239. (!*JCALL StdError)
  240. );
  241. % TAG( FastApply )
  242. lap '((!*entry FastApply expr 0) %. Apply with arguments loaded
  243. %
  244. % Called with arguments in the registers and functional form in (reg t1)
  245. %
  246. (!*FIELD (reg t2) (reg t1)
  247. (WConst TagStartingBit)
  248. (WConst TagBitLength))
  249. (!*JUMPEQ (MEMORY (reg t1) (WConst SymFnc)) (reg t2) (WConst ID))
  250. (!*JUMPEQ (MEMORY (reg t1) (WConst 0)) (reg t2) (WConst CODE))
  251. (!*JUMPNOTEQ (Label IllegalFunctionalForm) (reg t2) (WConst PAIR))
  252. (!*MOVE (CAR (reg t1)) (reg t2))
  253. (!*JUMPNOTEQ IllegalFunctionalForm (reg t2) (QUOTE LAMBDA))
  254. (!*MOVE (reg t1) (reg t2)) % put lambda form in (reg t2)
  255. (!*PUSH '()) % align stack
  256. (!*JCALL FastLambdaApply)
  257. IllegalFunctionalForm
  258. (!*MOVE (QUOTE "Illegal functional form %r in Apply") (reg 1))
  259. (!*MOVE (reg t1) (reg 2))
  260. (!*CALL BldMsg)
  261. (!*JCALL StdError)
  262. );
  263. % TAG( UndefinedFunction )
  264. lap '((!*entry UndefinedFunction expr 0) %. Error Handler for non code
  265. %
  266. % also called by JSP T5,
  267. %
  268. (!*WDIFFERENCE (reg t5) (wconst 1))
  269. % T5 now points to the function entry slot of the atom that
  270. % is undefined as a function.
  271. % We will push the entry address onto the stack and transfer
  272. % to it by a POPJ at the end of this routine.
  273. (!*PUSH (reg t5))
  274. (!*PUSH (reg 1)) % Save all the regs (including fakes) (args)
  275. (!*PUSH (reg 2))
  276. (!*PUSH (reg 3))
  277. (!*PUSH (reg 4))
  278. (!*PUSH (reg 5))
  279. (!*PUSH (reg 6))
  280. (!*PUSH (reg 7))
  281. (!*PUSH (reg 8))
  282. (!*PUSH (reg 9))
  283. (!*PUSH (reg 10))
  284. (!*PUSH (reg 11))
  285. (!*PUSH (reg 12))
  286. (!*PUSH (reg 13))
  287. (!*PUSH (reg 14))
  288. (!*PUSH (reg 15))
  289. (!*WDIFFERENCE (reg t5) (WConst SymFnc))
  290. (!*MKITEM (reg t5) (WConst ID))
  291. (!*MOVE (reg t5) (reg 2))
  292. (!*MOVE (QUOTE "Undefined function %r called from compiled code")
  293. (reg 1))
  294. (!*CALL BldMsg)
  295. (!*MOVE (reg 1) (reg 2))
  296. (!*MOVE (WConst 0) (reg 1))
  297. (!*MOVE (reg NIL) (reg 3))
  298. (!*CALL ContinuableError)
  299. (!*POP (reg 15)) % Restore all those possible arguments
  300. (!*POP (reg 14))
  301. (!*POP (reg 13))
  302. (!*POP (reg 12))
  303. (!*POP (reg 11))
  304. (!*POP (reg 10))
  305. (!*POP (reg 9))
  306. (!*POP (reg 8))
  307. (!*POP (reg 7))
  308. (!*POP (reg 6))
  309. (!*POP (reg 5))
  310. (!*POP (reg 4))
  311. (!*POP (reg 3))
  312. (!*POP (reg 2))
  313. (!*POP (reg 1))
  314. (!*EXIT 0)
  315. );
  316. off SysLisp;
  317. END;