1% "ccomp.red" Copyright 1991-2010, Codemist Ltd 2% 3% Compiler that turns Lisp code into C in a way that fits in 4% with the conventions used with CSL/CCL 5% 6% A C Norman 7% 8 9%% 10%% Copyright (C) 2010, following the master REDUCE source files. * 11%% * 12%% Redistribution and use in source and binary forms, with or without * 13%% modification, are permitted provided that the following conditions are * 14%% met: * 15%% * 16%% * Redistributions of source code must retain the relevant * 17%% copyright notice, this list of conditions and the following * 18%% disclaimer. * 19%% * Redistributions in binary form must reproduce the above * 20%% copyright notice, this list of conditions and the following * 21%% disclaimer in the documentation and/or other materials provided * 22%% with the distribution. * 23%% * 24%% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS * 25%% "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT * 26%% LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS * 27%% FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE * 28%% COPYRIGHT OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, * 29%% INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, * 30%% BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS * 31%% OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND * 32%% ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR * 33%% TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF * 34%% THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH * 35%% DAMAGE. * 36%% 37 38 39symbolic; 40 41global '(!*fastvector !*unsafecar); 42flag('(fastvector unsafecar), 'switch); 43 44% 45% I start with some utility functions that provide something 46% related to a FORMAT or PRINTF facility 47% 48 49fluid '(C_file L_file O_file L_contents Setup_name File_name); 50 51symbolic macro procedure c!:printf(u,!&optional,env); 52% inspired by the C printf function, but much less general. 53% This macro is to provide the illusion that printf can take an 54% arbitrary number of arguments. 55 list('c!:printf1, cadr u, 'list . cddr u); 56 57symbolic procedure c!:printf1(fmt, args); 58% this is the inner works of print formatting. 59% the special sequences that can occur in format strings are 60% %s use princ (to print a name?) 61% %d use princ (to print a number?) 62% %a use prin 63% %c as prin, but do not generate the sequence 64% "*/" as part of the output (!) 65% %t do a ttab() 66% %< ensure at least 2 free chars on line 67% %v print a variable.... magic for this compiler 68% \n do a terpri() 69% \q princ '!" to display quote marks 70 begin 71 scalar a, c; 72 fmt := explode2 fmt; 73 while fmt do << 74 c := car fmt; 75 fmt := cdr fmt; 76 if c = '!\ and (car fmt = '!n or car fmt = '!N) then << 77 terpri(); 78 fmt := cdr fmt >> 79 else if c = '!\ and (car fmt = '!q or car fmt = '!Q) then << 80 princ '!"; 81 fmt := cdr fmt >> 82 else if c = '!% then << 83 c := car fmt; 84 if null args then a := 'missing_arg 85 else a := car args; 86 if c = '!v or c = '!V then 87 if flagp(a, 'c!:live_across_call) then << 88 princ "stack["; 89 princ(-get(a, 'c!:location)); 90 princ "]" >> 91 else princ a 92 else if c = '!c or c = '!C then c!:safeprin a 93 else if c = '!a or c = '!A then prin a 94 else if c = '!t or c = '!T then ttab a 95 else if c = '!< then << 96 args := nil . args; % dummy so in effect no arg is used. 97 if posn() > 70 then terpri() >> 98 else princ a; 99 if args then args := cdr args; 100 fmt := cdr fmt >> 101 else princ c >> 102 end; 103 104% The following yukky code is for use in displaying C comments. I want to be 105% able to annotate my code as in 106% ... /* load the literal "something" */ 107% where the literal is displayed. But if the literal were to be a string 108% with the character sequence "*/" within it I would get into trouble... 109 110symbolic procedure c!:safeprin x; 111 begin 112 scalar a, b; 113 a := explode x; 114 while a do << 115 if eqcar(a, '!/) and b then princ " "; 116 princ car a; 117 b := eqcar(a, '!*); 118 a := cdr a >>; 119 end; 120 121symbolic procedure c!:valid_fndef(args, body); 122 if ('!&optional memq args) or ('!&rest memq args) then nil 123 else c!:valid_list body; 124 125symbolic procedure c!:valid_list x; 126 if null x then t 127 else if atom x then nil 128 else if not c!:valid_expr car x then nil 129 else c!:valid_list cdr x; 130 131symbolic procedure c!:valid_expr x; 132 if atom x then t 133 else if not atom car x then << 134 if not c!:valid_list cdr x then nil 135 else if not eqcar(car x, 'lambda) then nil 136 else if atom cdar x then nil 137 else c!:valid_fndef(cadar x, cddar x) >> 138 else if not idp car x then nil 139 else if eqcar(x, 'quote) then t 140 else begin 141 scalar h; 142 h := get(car x, 'c!:valid); 143 if null h then return c!:valid_list cdr x; 144 return funcall(h, cdr x) 145 end; 146 147% This establishes a default handler for each special form so that 148% any that I forget to treat more directly will cause a tidy error 149% if found in compiled code. 150 151symbolic procedure c!:cspecform(x, env); 152 error(0, list("special form", x)); 153 154symbolic procedure c!:valid_specform x; 155 nil; 156 157<< put('and, 'c!:code, function c!:cspecform); 158!#if common!-lisp!-mode 159 put('block, 'c!:code, function c!:cspecform); 160!#endif 161 put('catch, 'c!:code, function c!:cspecform); 162 put('compiler!-let, 'c!:code, function c!:cspecform); 163 put('cond, 'c!:code, function c!:cspecform); 164 put('declare, 'c!:code, function c!:cspecform); 165 put('de, 'c!:code, function c!:cspecform); 166!#if common!-lisp!-mode 167 put('defun, 'c!:code, function c!:cspecform); 168!#endif 169 put('eval!-when, 'c!:code, function c!:cspecform); 170 put('flet, 'c!:code, function c!:cspecform); 171 put('function, 'c!:code, function c!:cspecform); 172 put('go, 'c!:code, function c!:cspecform); 173 put('if, 'c!:code, function c!:cspecform); 174 put('labels, 'c!:code, function c!:cspecform); 175!#if common!-lisp!-mode 176 put('let, 'c!:code, function c!:cspecform); 177!#else 178 put('!~let, 'c!:code, function c!:cspecform); 179!#endif 180 put('let!*, 'c!:code, function c!:cspecform); 181 put('list, 'c!:code, function c!:cspecform); 182 put('list!*, 'c!:code, function c!:cspecform); 183 put('macrolet, 'c!:code, function c!:cspecform); 184 put('multiple!-value!-call, 'c!:code, function c!:cspecform); 185 put('multiple!-value!-prog1, 'c!:code, function c!:cspecform); 186 put('or, 'c!:code, function c!:cspecform); 187 put('prog, 'c!:code, function c!:cspecform); 188 put('prog!*, 'c!:code, function c!:cspecform); 189 put('prog1, 'c!:code, function c!:cspecform); 190 put('prog2, 'c!:code, function c!:cspecform); 191 put('progn, 'c!:code, function c!:cspecform); 192 put('progv, 'c!:code, function c!:cspecform); 193 put('quote, 'c!:code, function c!:cspecform); 194 put('return, 'c!:code, function c!:cspecform); 195 put('return!-from, 'c!:code, function c!:cspecform); 196 put('setq, 'c!:code, function c!:cspecform); 197 put('tagbody, 'c!:code, function c!:cspecform); 198 put('the, 'c!:code, function c!:cspecform); 199 put('throw, 'c!:code, function c!:cspecform); 200 put('unless, 'c!:code, function c!:cspecform); 201 put('unwind!-protect, 'c!:code, function c!:cspecform); 202 put('when, 'c!:code, function c!:cspecform) ; 203 204% I comment out lines here when (a) the special form involved is 205% supported by my compilation into C and (b) its syntax is such that 206% I can analyse it as if it was an ordinary function. Eg (AND a b c) 207% 208% Cases like PROG are left in because the syntax (PROG (v1 v2) ...) needs 209% special treatment. 210% 211% Cases like UNWIND-PROTECT are left in because at the time of writing this 212% comment they are not supported. 213 214 215% put('and, 'c!:valid, function c!:valid_specform); 216!#if common!-lisp!-mode 217% put('block, 'c!:valid, function c!:valid_specform); 218!#endif 219 put('catch, 'c!:valid, function c!:valid_specform); 220 put('compiler!-let, 'c!:valid, function c!:valid_specform); 221 put('cond, 'c!:valid, function c!:valid_specform); 222 put('declare, 'c!:valid, function c!:valid_specform); 223 put('de, 'c!:valid, function c!:valid_specform); 224!#if common!-lisp!-mode 225 put('defun, 'c!:valid, function c!:valid_specform); 226!#endif 227 put('eval!-when, 'c!:valid, function c!:valid_specform); 228 put('flet, 'c!:valid, function c!:valid_specform); 229 put('function, 'c!:valid, function c!:valid_specform); 230% put('go, 'c!:valid, function c!:valid_specform); 231% put('if, 'c!:valid, function c!:valid_specform); 232 put('labels, 'c!:valid, function c!:valid_specform); 233!#if common!-lisp!-mode 234 put('let, 'c!:valid, function c!:valid_specform); 235!#else 236 put('!~let, 'c!:valid, function c!:valid_specform); 237!#endif 238 put('let!*, 'c!:valid, function c!:valid_specform); 239% put('list, 'c!:valid, function c!:valid_specform); 240% put('list!*, 'c!:valid, function c!:valid_specform); 241 put('macrolet, 'c!:valid, function c!:valid_specform); 242 put('multiple!-value!-call, 'c!:valid, function c!:valid_specform); 243 put('multiple!-value!-prog1, 'c!:valid, function c!:valid_specform); 244% put('or, 'c!:valid, function c!:valid_specform); 245 put('prog, 'c!:valid, function c!:valid_specform); 246 put('prog!*, 'c!:valid, function c!:valid_specform); 247% put('prog1, 'c!:valid, function c!:valid_specform); 248% put('prog2, 'c!:valid, function c!:valid_specform); 249% put('progn, 'c!:valid, function c!:valid_specform); 250 put('progv, 'c!:valid, function c!:valid_specform); 251 put('quote, 'c!:valid, function c!:valid_specform); 252% put('return, 'c!:valid, function c!:valid_specform); 253% put('return!-from, 'c!:valid, function c!:valid_specform); 254% put('setq, 'c!:valid, function c!:valid_specform); 255% put('tagbody, 'c!:valid, function c!:valid_specform); 256 put('the, 'c!:valid, function c!:valid_specform); 257 put('throw, 'c!:valid, function c!:valid_specform); 258% put('unless, 'c!:valid, function c!:valid_specform); 259 put('unwind!-protect, 'c!:valid, function c!:valid_specform); 260% put('when, 'c!:valid, function c!:valid_specform) 261 >>; 262 263fluid '(c!:current_procedure c!:current_args c!:current_block c!:current_contents 264 c!:all_blocks c!:registers c!:stacklocs); 265 266fluid '(c!:available c!:used); 267 268c!:available := c!:used := nil; 269 270symbolic procedure c!:reset_gensyms(); 271 << remflag(c!:used, 'c!:live_across_call); 272 remflag(c!:used, 'c!:visited); 273 while c!:used do << 274 remprop(car c!:used, 'c!:contents); 275 remprop(car c!:used, 'c!:why); 276 remprop(car c!:used, 'c!:where_to); 277 remprop(car c!:used, 'c!:count); 278 remprop(car c!:used, 'c!:live); 279 remprop(car c!:used, 'c!:clash); 280 remprop(car c!:used, 'c!:chosen); 281 remprop(car c!:used, 'c!:location); 282 if plist car c!:used then begin 283 scalar o; o := wrs nil; 284 princ "+++++ "; prin car c!:used; princ " "; 285 prin plist car c!:used; terpri(); 286 wrs o end; 287 c!:available := car c!:used . c!:available; 288 c!:used := cdr c!:used >> >>; 289 290!#if common!-lisp!-mode 291 292fluid '(my_gensym_counter); 293my_gensym_counter := 0; 294 295!#endif 296 297symbolic procedure c!:my_gensym(); 298 begin 299 scalar w; 300 if c!:available then << w := car c!:available; c!:available := cdr c!:available >> 301!#if common!-lisp!-mode 302 else w := compress1 303 ('!v . explodec (my_gensym_counter := my_gensym_counter + 1)); 304!#else 305 else w := gensym1 "v"; 306!#endif 307 c!:used := w . c!:used; 308 if plist w then << princ "????? "; prin w; princ " => "; prin plist w; terpri() >>; 309 return w 310 end; 311 312symbolic procedure c!:newreg(); 313 begin 314 scalar r; 315 r := c!:my_gensym(); 316 c!:registers := r . c!:registers; 317 return r 318 end; 319 320symbolic procedure c!:startblock s; 321 << c!:current_block := s; 322 c!:current_contents := nil 323 >>; 324 325symbolic procedure c!:outop(a,b,c,d); 326 if c!:current_block then 327 c!:current_contents := list(a,b,c,d) . c!:current_contents; 328 329symbolic procedure c!:endblock(why, where_to); 330 if c!:current_block then << 331% Note that the operations within a block are in reversed order. 332 put(c!:current_block, 'c!:contents, c!:current_contents); 333 put(c!:current_block, 'c!:why, why); 334 put(c!:current_block, 'c!:where_to, where_to); 335 c!:all_blocks := c!:current_block . c!:all_blocks; 336 c!:current_contents := nil; 337 c!:current_block := nil >>; 338 339% 340% Now for a general driver for compilation 341% 342 343symbolic procedure c!:cval_inner(x, env); 344 begin 345 scalar helper; 346% NB use the "improve" function from the regular compiler here... 347 x := s!:improve x; 348% atoms and embedded lambda expressions need their own treatment. 349 if atom x then return c!:catom(x, env) 350 else if eqcar(car x, 'lambda) then 351 return c!:clambda(cadar x, cddar x, cdr x, env) 352% a c!:code property gives direct control over compilation 353 else if helper := get(car x, 'c!:code) then 354 return funcall(helper, x, env) 355% compiler-macros take precedence over regular macros, so that I can 356% make special expansions in the context of compilation. Only used if the 357% expansion is non-nil 358 else if (helper := get(car x, 'c!:compile_macro)) and 359 (helper := funcall(helper, x)) then 360 return c!:cval(helper, env) 361% regular Lisp macros get expanded 362 else if idp car x and (helper := macro!-function car x) then 363 return c!:cval(funcall(helper, x), env) 364% anything not recognised as special will be turned into a 365% function call, but there will still be special cases, such as 366% calls to the current function, calls into the C-coded kernel, etc. 367 else return c!:ccall(car x, cdr x, env) 368 end; 369 370symbolic procedure c!:cval(x, env); 371 begin 372 scalar r; 373 r := c!:cval_inner(x, env); 374 if r and not member!*!*(r, c!:registers) then 375 error(0, list(r, "not a register", x)); 376 return r 377 end; 378 379symbolic procedure c!:clambda(bvl, body, args, env); 380% This is for ((lambda bvl body) args) and it will need to deal with 381% local declarations at the head of body. On this call body is a list of 382% forms. 383 begin 384 scalar w, w1, fluids, env1, decs; 385 env1 := car env; 386 w := for each a in args collect c!:cval(a, env); 387 w1 := s!:find_local_decs(body, nil); 388 localdecs := car w1 . localdecs; 389 w1 := cdr w1; 390% Tidy up so that body is a single expression. 391 if null w1 then body := nil 392 else if null cdr w1 then body := car w1 393 else body := 'progn . w1; 394 for each x in bvl do 395 if not fluidp x and not globalp x and 396 c!:local_fluidp(x, localdecs) then << 397 make!-special x; 398 decs := x . decs >>; 399 for each v in bvl do << 400 if globalp v then begin scalar oo; 401 oo := wrs nil; 402 princ "+++++ "; prin v; 403 princ " converted from GLOBAL to FLUID"; terpri(); 404 wrs oo; 405 unglobal list v; 406 fluid list v end; 407 if fluidp v then << 408 fluids := (v . c!:newreg()) . fluids; 409 flag(list cdar fluids, 'c!:live_across_call); % silly if not 410 env1 := ('c!:dummy!:name . cdar fluids) . env1; 411 c!:outop('ldrglob, cdar fluids, v, c!:find_literal v); 412 c!:outop('strglob, car w, v, c!:find_literal v) >> 413 else << 414 env1 := (v . c!:newreg()) . env1; 415 c!:outop('movr, cdar env1, nil, car w) >>; 416 w := cdr w >>; 417 if fluids then c!:outop('fluidbind, nil, nil, fluids); 418 env := env1 . append(fluids, cdr env); 419 w := c!:cval(body, env); 420 for each v in fluids do 421 c!:outop('strglob, cdr v, car v, c!:find_literal car v); 422 unfluid decs; 423 localdecs := cdr localdecs; 424 return w 425 end; 426 427symbolic procedure c!:locally_bound(x, env); 428 atsoc(x, car env); 429 430flag('(nil t), 'c!:constant); 431 432fluid '(literal_vector); 433 434symbolic procedure c!:find_literal x; 435 begin 436 scalar n, w; 437 w := literal_vector; 438 n := 0; 439 while w and not (car w = x) do << 440 n := n + 1; 441 w := cdr w >>; 442 if null w then literal_vector := append(literal_vector, list x); 443 return n 444 end; 445 446symbolic procedure c!:catom(x, env); 447 begin 448 scalar v, w; 449 v := c!:newreg(); 450% I may need to think harder here about things that are both locally 451% bound AND fluid. But when I bind a fluid I put a dummy name onto env 452% and use that as a place to save the old value of the fluid, so I believe 453% I may be safe. Well not quite I guess. How about 454% (prog (a) % a local variable 455% (prog (a) (declare (special a)) % hah this one os fluid! 456% reference "a" here... 457% and related messes. So note that the outer binding means that a is 458% locally bound but the inner binding means that a fluid binding must 459% be used. 460 if idp x and (fluidp x or globalp x) then 461 c!:outop('ldrglob, v, x, c!:find_literal x) 462 else if idp x and (w := c!:locally_bound(x, env)) then 463 c!:outop('movr, v, nil, cdr w) 464 else if null x or x = 't or c!:small_number x then 465 c!:outop('movk1, v, nil, x) 466 else if not idp x or flagp(x, 'c!:constant) then 467 c!:outop('movk, v, x, c!:find_literal x) 468% If a variable that is referenced is not locally bound then it is treated 469% as being fluid/global without comment. 470 else c!:outop('ldrglob, v, x, c!:find_literal x); 471 return v 472 end; 473 474symbolic procedure c!:cjumpif(x, env, d1, d2); 475 begin 476 scalar helper, r; 477 x := s!:improve x; 478 if atom x and (not idp x or 479 (flagp(x, 'c!:constant) and not c!:locally_bound(x, env))) then 480 c!:endblock('goto, list (if x then d1 else d2)) 481 else if not atom x and (helper := get(car x, 'c!:ctest)) then 482 return funcall(helper, x, env, d1, d2) 483 else << 484 r := c!:cval(x, env); 485 c!:endblock(list('ifnull, r), list(d2, d1)) >> 486 end; 487 488fluid '(c!:current); 489 490symbolic procedure c!:ccall(fn, args, env); 491 c!:ccall1(fn, args, env); 492 493fluid '(c!:visited); 494 495symbolic procedure c!:has_calls(a, b); 496 begin 497 scalar c!:visited; 498 return c!:has_calls_1(a, b) 499 end; 500 501symbolic procedure c!:has_calls_1(a, b); 502% true if there is a path from node a to node b that has a call instruction 503% on the way. 504 if a = b or not atom a or memq(a, c!:visited) then nil 505 else begin 506 scalar has_call; 507 c!:visited := a . c!:visited; 508 for each z in get(a, 'c!:contents) do 509 if eqcar(z, 'call) then has_call := t; 510 if has_call then return 511 begin scalar c!:visited; 512 return c!:can_reach(a, b) end; 513 for each d in get(a, 'c!:where_to) do 514 if c!:has_calls_1(d, b) then has_call := t; 515 return has_call 516 end; 517 518symbolic procedure c!:can_reach(a, b); 519 if a = b then t 520 else if not atom a or memq(a, c!:visited) then nil 521 else << 522 c!:visited := a . c!:visited; 523 c!:any_can_reach(get(a, 'c!:where_to), b) >>; 524 525symbolic procedure c!:any_can_reach(l, b); 526 if null l then nil 527 else if c!:can_reach(car l, b) then t 528 else c!:any_can_reach(cdr l, b); 529 530symbolic procedure c!:pareval(args, env); 531 begin 532 scalar tasks, tasks1, merge, split, r; 533 tasks := for each a in args collect (c!:my_gensym() . c!:my_gensym()); 534 split := c!:my_gensym(); 535 c!:endblock('goto, list split); 536 for each a in args do begin 537 scalar s; 538% I evaluate each arg as what is (at this stage) a separate task 539 s := car tasks; 540 tasks := cdr tasks; 541 c!:startblock car s; 542 r := c!:cval(a, env) . r; 543 c!:endblock('goto, list cdr s); 544% If the task did no procedure calls (or only tail calls) then it can be 545% executed sequentially with the other args without need for stacking 546% anything. Otherwise it more care will be needed. Put the hard 547% cases onto tasks1. 548!#if common!-lisp!-mode 549 tasks1 := s . tasks1 550!#else 551% The "t or" here is to try to FORCE left to right evaluation, even though 552% doing so may hurt performance. It at present looks as if some parts 553% of REDUCE have been coded making assumptions about this. 554 if t or c!:has_calls(car s, cdr s) then tasks1 := s . tasks1 555 else merge := s . merge 556!#endif 557 end; 558%-- % if there are zero or one items in tasks1 then again it is easy - 559%-- % otherwise I flag the problem with a notionally parallel construction. 560%-- if tasks1 then << 561%-- if null cdr tasks1 then merge := car tasks1 . merge 562%-- else << 563%-- c!:startblock split; 564%-- printc "***** ParEval needed parallel block here..."; 565%-- c!:endblock('par, for each v in tasks1 collect car v); 566%-- split := c!:my_gensym(); 567%-- for each v in tasks1 do << 568%-- c!:startblock cdr v; 569%-- c!:endblock('goto, list split) >> >> >>; 570 for each z in tasks1 do merge := z . merge; % do sequentially 571%-- 572%-- 573% Finally string end-to-end all the bits of sequential code I have left over. 574 for each v in merge do << 575 c!:startblock split; 576 c!:endblock('goto, list car v); 577 split := cdr v >>; 578 c!:startblock split; 579 return reversip r 580 end; 581 582symbolic procedure c!:ccall1(fn, args, env); 583 begin 584 scalar tasks, merge, r, val; 585 fn := list(fn, cdr env); 586 val := c!:newreg(); 587 if null args then c!:outop('call, val, nil, fn) 588 else if null cdr args then 589 c!:outop('call, val, list c!:cval(car args, env), fn) 590 else << 591 r := c!:pareval(args, env); 592 c!:outop('call, val, r, fn) >>; 593 c!:outop('reloadenv, 'env, nil, nil); 594 return val 595 end; 596 597fluid '(restart_label reloadenv does_call c!:current_c_name); 598 599% Reminder: s!:find_local_decs(body, isprog) returns (L . B') where 600% L is a list of local declarations and B' is the body with any 601% initial DECLARE and string-comments removed. The body passed in and 602% the result returned are both lists of forms. 603 604 605symbolic procedure c!:local_fluidp1(v, decs); 606 decs and ((eqcar(car decs, 'special) and memq(v, cdar decs)) or 607 c!:local_fluidp1(v, cdr decs)); 608 609symbolic procedure c!:local_fluidp(v, decs); 610 decs and (c!:local_fluidp1(v, car decs) or 611 c!:local_fluidp(v, cdr decs)); 612 613% 614% The "proper" recipe here arranges that functions that expect over 2 args use 615% the "va_arg" mechanism to pick up ALL their args. This would be pretty 616% heavy-handed, and at least on a lot of machines it does not seem to 617% be necessary. I will duck it for a while more at least. BUT NOTE THAT THE 618% CODE I GENERATE HERE IS AT LEAST OFFICIALLY INCORRECT. If at some stage I 619% find a computer where the implementation of va_args is truly incompatible 620% with that for known numbers of arguments I will need to adjust things 621% here. Yuk. 622% 623% Just so I know, the code at presently generated tends to go 624% 625% Lisp_Object f(Lisp_Object env, int nargs, Lisp_Object a1, Lisp_Object a2, 626% Lisp_Object a3, ...) 627% { // use a1, a2 and a3 as arguments 628% and note that it does put the "..." there! 629% 630% What it maybe ought to be is 631% 632% Lisp_Object f(Lisp_Object env, int nargs, ...) 633% { Lisp_Object a1, a2, a3; 634% va_list aa; 635% va_start(aa, nargs); 636% argcheck(nargs, 3, "f"); 637% a1 = va_arg(aa, Lisp_Object); 638% a2 = va_arg(aa, Lisp_Object); 639% a3 = va_arg(aa, Lisp_Object); 640% va_end(aa); 641% 642% Hmm that is not actually that hard to arrange! Remind me to do it some time! 643 644fluid '(proglabs blockstack localdecs); 645 646symbolic procedure c!:cfndef(c!:current_procedure, 647 c!:current_c_name, argsbody, checksum); 648 begin 649 scalar env, n, w, c!:current_args, c!:current_block, restart_label, 650 c!:current_contents, c!:all_blocks, entrypoint, exitpoint, args1, 651 c!:registers, c!:stacklocs, literal_vector, reloadenv, does_call, 652 blockstack, proglabs, args, body, localdecs; 653 args := car argsbody; 654 body := cdr argsbody; 655% If there is a (DECLARE (SPECIAL ...)) extract it here, aned leave a body 656% that is without it. 657 w := s!:find_local_decs(body, nil); 658 body := cdr w; 659 if atom body then body := nil 660 else if atom cdr body then body := car body 661 else body := 'progn . body; 662 localdecs := list car w; 663% I expect localdecs to be a list a bit like 664% ( ((special a b) (special c d) ...) ...) 665% and hypothetically it could have entries that were not tagged as 666% SPECIAL in it. 667% 668% The next line prints it to check. 669% if localdecs then << princ "localdecs = "; print localdecs >>; % @@@ 670% 671% Normally comment out the next line... It just shows what I am having to 672% compile and may be useful when debugging. 673% print list(c!:current_procedure, c!:current_c_name, args, body); 674 c!:reset_gensyms(); 675 wrs C_file; 676 linelength 200; 677 c!:printf("\n\n/* Code for %a %<*/\n\n", c!:current_procedure); 678 679 c!:find_literal c!:current_procedure; % For benefit of backtraces 680% 681% cope with fluid vars in an argument list by expanding the definition 682% (de f (a B C d) body) B and C fluid 683% into 684% (de f (a x y c) (prog (B C) (setq B x) (setq C y) (return body))) 685% so that the fluids get bound by PROG. 686% 687 c!:current_args := args; 688 for each v in args do 689 if v = '!&optional or v = '!&rest then 690 error(0, "&optional and &rest not supported by this compiler (yet)") 691 else if globalp v then begin scalar oo; 692 oo := wrs nil; 693 princ "+++++ "; prin v; 694 princ " converted from GLOBAL to FLUID"; terpri(); 695 wrs oo; 696 unglobal list v; 697 fluid list v; 698 n := (v . c!:my_gensym()) . n end 699 else if fluidp v or c!:local_fluidp(v, localdecs) then 700 n := (v . c!:my_gensym()) . n; 701 if !*r2i then body := s!:r2i(c!:current_procedure, args, body); 702 restart_label := c!:my_gensym(); 703 body := list('c!:private_tagbody, restart_label, body); 704% This bit sets up the PROG block for binding fluid arguments. 705 if n then << 706 body := list list('return, body); 707 args := subla(n, args); 708 for each v in n do 709 body := list('setq, car v, cdr v) . body; 710 body := 'prog . (for each v in reverse n collect car v) . body >>; 711 c!:printf "static Lisp_Object "; 712 if null args or length args >= 3 then c!:printf("MS_CDECL "); 713 c!:printf("%s(Lisp_Object env", c!:current_c_name); 714 if null args or length args >= 3 then c!:printf(", int nargs"); 715 n := t; 716 env := nil; 717 718% Hah - here is where I will change things to use va_args for >= 3 args. 719 for each x in args do begin 720 scalar aa; 721 c!:printf ","; 722 if n then << c!:printf "\n "; n := nil >> 723 else n := t; 724 aa := c!:my_gensym(); 725 env := (x . aa) . env; 726 c!:registers := aa . c!:registers; 727 args1 := aa . args1; 728 c!:printf(" Lisp_Object %s", aa) end; 729 if null args or length args >= 3 then c!:printf(", ..."); 730 c!:printf(")\n{\n"); 731 732% Now I would need to do va_arg calls to declare the args and init them... 733% Except that I must do that within optimise_flowgraph after all possible 734% declarations have been generated. 735 736 c!:startblock (entrypoint := c!:my_gensym()); 737 exitpoint := c!:current_block; 738 c!:endblock('goto, list list c!:cval(body, env . nil)); 739 740 c!:optimise_flowgraph(entrypoint, c!:all_blocks, env, 741 length args . c!:current_procedure, args1); 742 743 c!:printf("}\n\n"); 744 wrs O_file; 745 746 L_contents := (c!:current_procedure . literal_vector . checksum) . 747 L_contents; 748 return nil 749 end; 750 751% c!:ccompile1 directs the compilation of a single function, and bind all the 752% major fluids used by the compilation process 753 754flag('(rds deflist flag fluid global 755 remprop remflag unfluid 756 unglobal dm carcheck C!-end), 'eval); 757 758flag('(rds), 'ignore); 759 760fluid '(!*backtrace); 761 762symbolic procedure c!:ccompilesupervisor; 763 begin 764 scalar u, w; 765top:u := errorset('(read), t, !*backtrace); 766 if atom u then return; % failed, or maybe EOF 767 u := car u; 768 if u = !$eof!$ then return; % end of file 769 if atom u then go to top 770% the apply('C!-end, nil) is here because C!-end has a "stat" 771% property and so it will mis-parse if I just write "C!-end()". Yuk. 772 else if eqcar(u, 'C!-end) then return apply('C!-end, nil) 773 else if eqcar(u, 'rdf) then << 774!#if common!-lisp!-mode 775 w := open(u := eval cadr u, !:direction, !:input, 776 !:if!-does!-not!-exist, nil); 777!#else 778 w := open(u := eval cadr u, 'input); 779!#endif 780 if w then << 781 terpri(); 782 princ "Reading file "; print u; 783 w := rds w; 784 c!:ccompilesupervisor(); 785 princ "End of file "; print u; 786 close rds w >> 787 else << princ "Failed to open file "; print u >> >> 788 else c!:ccmpout1 u; 789 go to top 790 end; 791 792global '(c!:char_mappings); 793 794c!:char_mappings := '( 795 (! . !A) (!! . !B) (!# . !C) (!$ . !D) 796 (!% . !E) (!^ . !F) (!& . !G) (!* . !H) 797 (!( . !I) (!) . !J) (!- . !K) (!+ . !L) 798 (!= . !M) (!\ . !N) (!| . !O) (!, . !P) 799 (!. . !Q) (!< . !R) (!> . !S) (!: . !T) 800 (!; . !U) (!/ . !V) (!? . !W) (!~ . !X) 801 (!` . !Y)); 802 803fluid '(c!:names_so_far); 804 805symbolic procedure c!:inv_name n; 806 begin 807 scalar r, w; 808% The next bit ararnges that if there are several definitions of the 809% same function in the same module that they get different C names. 810% Specifically they will be called CC_f, CC1_f, CC2_c, CC3_f, ... 811 if (w := assoc(n, c!:names_so_far)) then w := cdr w + 1 812 else w := 0; 813 c!:names_so_far := (n . w) . c!:names_so_far; 814 r := '(!C !C !"); 815 if not zerop w then r := append(reverse explodec w, r); 816 r := '!_ . r; 817!#if common!-lisp!-mode 818 for each c in explode2 package!-name symbol!-package n do << 819 if c = '_ then r := '_ . r 820 else if alpha!-char!-p c or digit c then r := c . r 821 else if w := atsoc(c, c!:char_mappings) then r := cdr w . r 822 else r := '!Z . r >>; 823 r := '!_ . '!_ . r; 824!#endif 825 for each c in explode2 n do << 826 if c = '_ then r := '_ . r 827!#if common!-lisp!-mode 828 else if alpha!-char!-p c or digit c then r := c . r 829!#else 830 else if liter c or digit c then r := c . r 831!#endif 832 else if w := atsoc(c, c!:char_mappings) then r := cdr w . r 833 else r := '!Z . r >>; 834 r := '!" . r; 835!#if common!-lisp!-mode 836 return compress1 reverse r 837!#else 838 return compress reverse r 839!#endif 840 end; 841 842fluid '(c!:defnames pending_functions); 843 844symbolic procedure c!:ccmpout1 u; 845 begin 846 scalar pending_functions; 847 pending_functions := list u; 848 while pending_functions do << 849 u := car pending_functions; 850 pending_functions := cdr pending_functions; 851 c!:ccmpout1a u >> 852 end; 853 854symbolic procedure c!:ccmpout1a u; 855 begin 856 scalar w, checksum; 857 if atom u then return nil 858 else if eqcar(u, 'progn) then << 859 for each v in cdr u do c!:ccmpout1a v; 860 return nil >> 861 else if eqcar(u, 'C!-end) then nil 862 else if flagp(car u, 'eval) or 863 (car u = 'setq and not atom caddr u and flagp(caaddr u, 'eval)) then 864 errorset(u, t, !*backtrace); 865 if eqcar(u, 'rdf) then begin 866!#if common!-lisp!-mode 867 w := open(u := eval cadr u, !:direction, !:input, 868 !:if!-does!_not!-exist, nil); 869!#else 870 w := open(u := eval cadr u, 'input); 871!#endif 872 if w then << 873 princ "Reading file "; print u; 874 w := rds w; 875 c!:ccompilesupervisor(); 876 princ "End of file "; print u; 877 close rds w >> 878 else << princ "Failed to open file "; print u >> end 879!#if common!-lisp!-mode 880 else if eqcar(u, 'defun) then return c!:ccmpout1a macroexpand u 881!#endif 882 else if eqcar(u, 'de) then << 883 u := cdr u; 884 checksum := md60 u; 885!#if common!-lisp!-mode 886 w := compress1 ('!" . append(explodec package!-name 887 symbol!-package car u, 888 '!@ . '!@ . append(explodec symbol!-name car u, 889 append(explodec "@@Builtin", '(!"))))); 890 w := intern w; 891 c!:defnames := list(car u, c!:inv_name car u, length cadr u, w, checksum) . c!:defnames; 892!#else 893 c!:defnames := list(car u, c!:inv_name car u, length cadr u, checksum) . c!:defnames; 894!#endif 895% if posn() neq 0 then terpri(); 896 princ "Compiling "; prin caar c!:defnames; princ " ... "; 897 c!:cfndef(caar c!:defnames, cadar c!:defnames, cdr u, checksum); 898!#if common!-lisp!-mode 899 L_contents := (w . car L_contents) . cdr L_contents; 900!#endif 901 terpri() >> 902 end; 903 904fluid '(!*defn dfprint!* dfprintsave); 905 906!#if common!-lisp!-mode 907symbolic procedure c!:concat(a, b); 908 compress1('!" . append(explode2 a, append(explode2 b, '(!")))); 909!#else 910symbolic procedure c!:concat(a, b); 911 compress('!" . append(explode2 a, append(explode2 b, '(!")))); 912!#endif 913 914symbolic procedure c!:ccompilestart(name, setupname, dir, hdrnow); 915 begin 916 scalar o, d, w; 917 reset!-gensym 0; % Makes output more consistent 918!#if common!-lisp!-mode 919 my_gensym_counter := 0; 920!#endif 921 c!:registers := c!:available := c!:used := nil; 922% File_name will be the undecorated name as a string when hdrnow is false, 923 File_name := list!-to!-string explodec name; 924 Setup_name := explodec setupname; 925% I REALLY want the user to give me a module name that is a valid C 926% identifier, but in REDUCE I find just one case where a name has an embedded 927% "-", so I will just map that onto "_". When loading modules I will need to 928% take care to be aware of this! Also if any idiot tried to have two modules 929% called a-b and a_b they would now clash with one another. 930 Setup_name := subst('!_, '!-, Setup_name); 931 Setup_name := list!-to!-string Setup_name; 932 if dir then << 933 if 'win32 memq lispsystem!* then 934 name := c!:concat(dir, c!:concat("\", name)) 935 else name := c!:concat(dir, c!:concat("/", name)) >>; 936princ "C file = "; print name; 937!#if common!-lisp!-mode 938 C_file := open(c!:concat(name, ".c"), !:direction, !:output); 939!#else 940 C_file := open(c!:concat(name, ".c"), 'output); 941!#endif 942 L_file := c!:concat(name, ".lsp"); 943 L_contents := nil; 944 c!:names_so_far := nil; 945% Here I turn a date into a form like "12-Oct-1993" as expected by the 946% file signature mechanism that I use. This seems a pretty ugly process. 947 o := reverse explode date(); 948 for i := 1:5 do << d := car o . d; o := cdr o >>; 949 d := '!- . d; 950 o := cdddr cdddr cddddr o; 951 w := o; 952 o := cdddr o; 953 d := caddr o . cadr o . car o . d; 954!#if common!-lisp!-mode 955 d := compress1('!" . cadr w . car w . '!- . d); 956!#else 957 d := compress('!" . cadr w . car w . '!- . d); 958!#endif 959 O_file := wrs C_file; 960 c!:defnames := nil; 961 if hdrnow then 962 c!:printf("\n/* Module: %s %tMachine generated C code %<*/\n\n", setupname, 25) 963 else c!:printf("\n/* %s.c %tMachine generated C code %<*/\n\n", name, 25); 964 c!:printf("/* Signature: 00000000 %s %<*/\n\n", d); 965 c!:printf "#include <stdio.h>\n"; 966 c!:printf "#include <stdlib.h>\n"; 967 c!:printf "#include <string.h>\n"; 968 c!:printf "#include <ctype.h>\n"; 969 c!:printf "#include <stdarg.h>\n"; 970 c!:printf "#include <time.h>\n"; 971 c!:printf "#ifndef _cplusplus\n"; 972 c!:printf "#include <setjmp.h>\n"; 973 c!:printf "#endif\n\n"; 974% The stuff I put in the file here includes written-in copies of header 975% files. The main "csl_headers" should be the same for all systems built 976% based on the current sources, but the "config_header" is specific to a 977% particular build. So if I am genarating C code that is JUST for use on the 978% current platform I can write-in the config header here and now, but if 979% there is any chance that I might save the generated C and compile it 980% elsewhere I should leave "#include "config.h"" in there. 981 if hdrnow then print!-config!-header() 982 else c!:printf "#include \qconfig.h\q\n\n"; 983 print!-csl!-headers(); 984% Now a useful prefix for when compiling as a DLL 985 if hdrnow then c!:print!-init(); 986 wrs O_file; 987 return nil 988 end; 989 990symbolic procedure c!:print!-init(); 991 << 992 c!:printf "\n"; 993 c!:printf "Lisp_Object *C_nilp;\n"; 994 c!:printf "Lisp_Object **C_stackp;\n"; 995 c!:printf "Lisp_Object * volatile * stacklimitp;\n"; 996 c!:printf "\n"; 997 c!:printf "void init(Lisp_Object *a, Lisp_Object **b, Lisp_Object * volatile *c)\n"; 998 c!:printf "{\n"; 999 c!:printf " C_nilp = a;\n"; 1000 c!:printf " C_stackp = b;\n"; 1001 c!:printf " stacklimitp = c;\n"; 1002 c!:printf "}\n"; 1003 c!:printf "\n"; 1004 c!:printf "#define C_nil (*C_nilp)\n"; 1005 c!:printf "#define C_stack (*C_stackp)\n"; 1006 c!:printf "#define stacklimit (*stacklimitp)\n"; 1007 c!:printf "\n" 1008 >>; 1009 1010symbolic procedure C!-end; 1011 C!-end1 t; 1012 1013procedure C!-end1 create_lfile; 1014 begin 1015 scalar checksum, c1, c2, c3; 1016 wrs C_file; 1017 if create_lfile then 1018 c!:printf("\n\nsetup_type const %s_setup[] =\n{\n", Setup_name) 1019 else c!:printf("\n\nsetup_type_1 const %s_setup[] =\n{\n", Setup_name); 1020 c!:defnames := reverse c!:defnames; 1021 while c!:defnames do begin 1022 scalar name, nargs, f1, f2, cast, fn; 1023!#if common!-lisp!-mode 1024 name := cadddr car c!:defnames; 1025 checksum := cadddr cdar c!:defnames; 1026!#else 1027 name := caar c!:defnames; 1028 checksum := cadddr car c!:defnames; 1029!#endif 1030 f1 := cadar c!:defnames; 1031 nargs := caddar c!:defnames; 1032 cast := "(n_args *)"; 1033 if nargs = 1 then << 1034 f2 := '!t!o!o_!m!a!n!y_1; cast := ""; fn := '!w!r!o!n!g_!n!o_1 >> 1035 else if nargs = 2 then << 1036 f2 := f1; f1 := '!t!o!o_!f!e!w_2; cast := ""; 1037 fn := '!w!r!o!n!g_!n!o_2 >> 1038 else << fn := f1; f1 := '!w!r!o!n!g_!n!o_!n!a; 1039 f2 := '!w!r!o!n!g_!n!o_!n!b >>; 1040 if create_lfile then c!:printf(" {\q%s\q,%t%s,%t%s,%t%s%s},\n", 1041 name, 32, f1, 48, f2, 63, cast, fn) 1042 else 1043 begin 1044 scalar c1, c2; 1045 c1 := divide(checksum, expt(2, 31)); 1046 c2 := cdr c1; 1047 c1 := car c1; 1048 c!:printf(" {\q%s\q, %t%s, %t%s, %t%s%s, %t%s, %t%s},\n", 1049 name, 24, f1, 40, f2, 52, cast, fn, 64, c1, 76, c2) 1050 end; 1051 c!:defnames := cdr c!:defnames end; 1052 c3 := checksum := md60 L_contents; 1053 c1 := remainder(c3, 10000000); 1054 c3 := c3 / 10000000; 1055 c2 := remainder(c3, 10000000); 1056 c3 := c3 / 10000000; 1057 checksum := list!-to!-string append(explodec c3, 1058 '! . append(explodec c2, '! . explodec c1)); 1059 c!:printf(" {NULL, (one_args *)%a, (two_args *)%a, 0}\n};\n\n", 1060 Setup_name, checksum); 1061 c!:printf "%</* end of generated code %<*/\n"; 1062 close C_file; 1063 if create_lfile then << 1064!#if common!-lisp!-mode 1065 L_file := open(L_file, !:direction, !:output); 1066!#else 1067 L_file := open(L_file, 'output); 1068!#endif 1069 wrs L_file; 1070 linelength 72; 1071 terpri(); 1072!#if common!-lisp!-mode 1073 princ ";;; "; 1074!#else 1075 princ "% "; 1076!#endif 1077 princ Setup_name; 1078 princ ".lsp"; ttab 20; 1079 princ "Machine generated Lisp"; 1080% princ " "; princ date(); % I omit the date now because it makes 1081 % file comparisons messier 1082 terpri(); terpri(); 1083!#if common!-lisp!-mode 1084 princ "(in-package lisp)"; terpri(); terpri(); 1085 princ "(c::install "; 1086!#else 1087 princ "(c!:install "; 1088!#endif 1089 princ '!"; princ Setup_name; princ '!"; 1090 princ " "; princ checksum; printc ")"; 1091 terpri(); 1092 for each x in reverse L_contents do << 1093!#if common!-lisp!-mode 1094 princ "(c::install '"; 1095 prin car x; 1096 princ " '"; 1097 x := cdr x; 1098!#else 1099 princ "(c!:install '"; 1100!#endif 1101 prin car x; 1102 princ " '"; 1103 prin cadr x; 1104!#if (not common!-lisp!-mode) 1105 princ " "; 1106 prin cddr x; 1107!#endif 1108 princ ")"; 1109 terpri(); terpri() >>; 1110 terpri(); 1111!#if common!-lisp!-mode 1112 princ ";;; End of generated Lisp code"; 1113!#else 1114 princ "% End of generated Lisp code"; 1115!#endif 1116 terpri(); terpri(); 1117 L_contents := nil; 1118 wrs O_file; 1119 close L_file; 1120 !*defn := nil; 1121 dfprint!* := dfprintsave >> 1122 else << 1123 checksum := checksum . reverse L_contents; 1124 L_contents := nil; 1125 return checksum >> 1126 end; 1127 1128put('C!-end, 'stat, 'endstat); 1129 1130symbolic procedure C!-compile u; 1131 begin 1132 terpri(); 1133 princ "C!-COMPILE "; 1134 prin u; princ ": IN files; or type in expressions"; terpri(); 1135 princ "When all done, execute C!-END;"; terpri(); 1136 verbos nil; 1137 c!:ccompilestart(car u, car u, nil, nil); 1138 dfprintsave := dfprint!*; 1139 dfprint!* := 'c!:ccmpout1; 1140 !*defn := t; 1141 if getd 'begin then return nil; 1142 c!:ccompilesupervisor(); 1143 end; 1144 1145put('C!-compile, 'stat, 'rlis); 1146 1147% 1148% Global treatment of a flow-graph... 1149% 1150 1151symbolic procedure c!:print_opcode(s, depth); 1152 begin 1153 scalar op, r1, r2, r3, helper; 1154 op := car s; r1 := cadr s; r2 := caddr s; r3 := cadddr s; 1155 helper := get(op, 'c!:opcode_printer); 1156 if helper then funcall(helper, op, r1, r2, r3, depth) 1157 else << prin s; terpri() >> 1158 end; 1159 1160symbolic procedure c!:print_exit_condition(why, where_to, depth); 1161 begin 1162 scalar helper, lab1, drop1, lab2, drop2, negate; 1163% An exit condition is one of 1164% goto (lab) 1165% goto ((return-register)) 1166% (ifnull v) (lab1 lab2) ) etc, where v is a register and 1167% (ifatom v) (lab1 lab2) ) lab1, lab2 are labels for true & false 1168% (ifeq v1 v2) (lab1 lab2) ) and various predicates are supported 1169% ((call fn) a1 a2) () tail-call to given function 1170% 1171 if why = 'goto then << 1172 where_to := car where_to; 1173 if atom where_to then << 1174 c!:printf(" goto %s;\n", where_to); 1175 c!:display_flowgraph(where_to, depth, t) >> 1176 else << c!:printf " "; c!:pgoto(where_to, depth) >>; 1177 return nil >> 1178 else if eqcar(car why, 'call) then return begin 1179 scalar args, locs, g, w; 1180 if w := get(cadar why, 'c!:direct_entrypoint) then << 1181 for each a in cdr why do 1182 if flagp(a, 'c!:live_across_call) then << 1183 if null g then c!:printf " {\n"; 1184 g := c!:my_gensym(); 1185 c!:printf(" Lisp_Object %s = %v;\n", g, a); 1186 args := g . args >> 1187 else args := a . args; 1188 if depth neq 0 then << 1189 if g then c!:printf " "; 1190 c!:printf(" popv(%s);\n", depth) >>; 1191 if g then c!:printf " "; 1192!#if common!-lisp!-mode 1193 c!:printf(" { Lisp_Object retVal = %s(", cdr w); 1194!#else 1195 c!:printf(" return %s(", cdr w); 1196!#endif 1197 args := reversip args; 1198 if args then << 1199 c!:printf("%v", car args); 1200 for each a in cdr args do c!:printf(", %v", a) >>; 1201 c!:printf(");\n"); 1202!#if common!-lisp!-mode 1203 if g then c!:printf " "; 1204 c!:printf(" errexit();\n"); 1205 if g then c!:printf " "; 1206 c!:printf(" return onevalue(retVal); }\n"); 1207!#endif 1208 if g then c!:printf " }\n" >> 1209 else if w := get(cadar why, 'c!:c_entrypoint) then << 1210% I think there may be an issue here with functions that can accept variable 1211% numbers of args. I seem to support just ONE C entrypoint which I will 1212% call in all circumstances... Yes there ARE such issues, and the one 1213% I recently fall across was "error" which in my implementation can take 1214% any number of arguments. So I have removed it from the list of things 1215% that can be called as direct C code... 1216 for each a in cdr why do 1217 if flagp(a, 'c!:live_across_call) then << 1218 if null g then c!:printf " {\n"; 1219 g := c!:my_gensym(); 1220 c!:printf(" Lisp_Object %s = %v;\n", g, a); 1221 args := g . args >> 1222 else args := a . args; 1223 if depth neq 0 then c!:printf(" popv(%s);\n", depth); 1224 c!:printf(" return %s(nil", w); 1225 if null args or length args >= 3 then c!:printf(", %s", length args); 1226 for each a in reversip args do c!:printf(", %v", a); 1227 c!:printf(");\n"); 1228 if g then c!:printf " }\n" >> 1229 else begin 1230 scalar nargs; 1231 nargs := length cdr why; 1232 c!:printf " {\n"; 1233 for each a in cdr why do 1234 if flagp(a, 'c!:live_across_call) then << 1235 g := c!:my_gensym(); 1236 c!:printf(" Lisp_Object %s = %v;\n", g, a); 1237 args := g . args >> 1238 else args := a . args; 1239 if depth neq 0 then c!:printf(" popv(%s);\n", depth); 1240 c!:printf(" fn = elt(env, %s); %</* %c %<*/\n", 1241 c!:find_literal cadar why, cadar why); 1242 if nargs = 1 then c!:printf(" return (*qfn1(fn))(qenv(fn)") 1243 else if nargs = 2 then c!:printf(" return (*qfn2(fn))(qenv(fn)") 1244 else c!:printf(" return (*qfnn(fn))(qenv(fn), %s", nargs); 1245 for each a in reversip args do c!:printf(", %s", a); 1246 c!:printf(");\n }\n") end; 1247 return nil end; 1248 lab1 := car where_to; 1249 drop1 := atom lab1 and not flagp(lab1, 'c!:visited); 1250 lab2 := cadr where_to; 1251 drop2 := atom lab2 and not flagp(drop2, 'c!:visited); 1252 if drop2 and get(lab2, 'c!:count) = 1 then << 1253 where_to := list(lab2, lab1); 1254 drop1 := t >> 1255 else if drop1 then negate := t; 1256 helper := get(car why, 'c!:exit_helper); 1257 if null helper then error(0, list("Bad exit condition", why)); 1258 c!:printf(" if ("); 1259 if negate then << 1260 c!:printf("!("); 1261 funcall(helper, cdr why, depth); 1262 c!:printf(")") >> 1263 else funcall(helper, cdr why, depth); 1264 c!:printf(") "); 1265 if not drop1 then << 1266 c!:pgoto(car where_to, depth); 1267 c!:printf(" else ") >>; 1268 c!:pgoto(cadr where_to, depth); 1269 if atom car where_to then c!:display_flowgraph(car where_to, depth, drop1); 1270 if atom cadr where_to then c!:display_flowgraph(cadr where_to, depth, nil) 1271 end; 1272 1273symbolic procedure c!:pmovr(op, r1, r2, r3, depth); 1274 c!:printf(" %v = %v;\n", r1, r3); 1275 1276put('movr, 'c!:opcode_printer, function c!:pmovr); 1277 1278symbolic procedure c!:pmovk(op, r1, r2, r3, depth); 1279 c!:printf(" %v = elt(env, %s); %</* %c %<*/\n", r1, r3, r2); 1280 1281put('movk, 'c!:opcode_printer, function c!:pmovk); 1282 1283symbolic procedure c!:pmovk1(op, r1, r2, r3, depth); 1284 if null r3 then c!:printf(" %v = nil;\n", r1) 1285 else if r3 = 't then c!:printf(" %v = lisp_true;\n", r1) 1286 else c!:printf(" %v = (Lisp_Object)%s; %</* %c %<*/\n", r1, 16*r3+1, r3); 1287 1288put('movk1, 'c!:opcode_printer, function c!:pmovk1); 1289flag('(movk1), 'c!:uses_nil); % Well it does SOMETIMES 1290 1291symbolic procedure c!:preloadenv(op, r1, r2, r3, depth); 1292% will not be encountered unless reloadenv variable has been set up. 1293 c!:printf(" env = stack[%s];\n", -reloadenv); 1294 1295put('reloadenv, 'c!:opcode_printer, function c!:preloadenv); 1296 1297symbolic procedure c!:pldrglob(op, r1, r2, r3, depth); 1298 c!:printf(" %v = qvalue(elt(env, %s)); %</* %c %<*/\n", r1, r3, r2); 1299 1300put('ldrglob, 'c!:opcode_printer, function c!:pldrglob); 1301 1302symbolic procedure c!:pstrglob(op, r1, r2, r3, depth); 1303 c!:printf(" qvalue(elt(env, %s)) = %v; %</* %c %<*/\n", r3, r1, r2); 1304 1305put('strglob, 'c!:opcode_printer, function c!:pstrglob); 1306 1307symbolic procedure c!:pnilglob(op, r1, r2, r3, depth); 1308 c!:printf(" qvalue(elt(env, %s)) = nil; %</* %c %<*/\n", r3, r2); 1309 1310put('nilglob, 'c!:opcode_printer, function c!:pnilglob); 1311flag('(nilglob), 'c!:uses_nil); 1312 1313symbolic procedure c!:pnull(op, r1, r2, r3, depth); 1314 c!:printf(" %v = (%v == nil ? lisp_true : nil);\n", r1, r3); 1315 1316put('null, 'c!:opcode_printer, function c!:pnull); 1317put('not, 'c!:opcode_printer, function c!:pnull); 1318flag('(null not), 'c!:uses_nil); 1319 1320symbolic procedure c!:pfastget(op, r1, r2, r3, depth); 1321 << 1322 c!:printf(" if (!symbolp(%v)) %v = nil;\n", r2, r1); 1323 c!:printf(" else { %v = qfastgets(%v);\n", r1, r2); 1324 c!:printf(" if (%v != nil) { %v = elt(%v, %s); %</* %c %<*/\n", 1325 r1, r1, r1, car r3, cdr r3); 1326 c!:printf("#ifdef RECORD_GET\n"); 1327 c!:printf(" if (%v != SPID_NOPROP)\n", r1); 1328 c!:printf(" record_get(elt(fastget_names, %s), 1);\n", car r3); 1329 c!:printf(" else record_get(elt(fastget_names, %s), 0),\n", car r3); 1330 c!:printf(" %v = nil; }\n", r1); 1331 c!:printf(" else record_get(elt(fastget_names, %s), 0); }\n", car r3); 1332 c!:printf("#else\n"); 1333 c!:printf(" if (%v == SPID_NOPROP) %v = nil; }}\n", r1, r1); 1334 c!:printf("#endif\n"); 1335 >>; 1336 1337put('fastget, 'c!:opcode_printer, function c!:pfastget); 1338flag('(fastget), 'c!:uses_nil); 1339 1340symbolic procedure c!:pfastflag(op, r1, r2, r3, depth); 1341 << 1342 c!:printf(" if (!symbolp(%v)) %v = nil;\n", r2, r1); 1343 c!:printf(" else { %v = qfastgets(%v);\n", r1, r2); 1344 c!:printf(" if (%v != nil) { %v = elt(%v, %s); %</* %c %<*/\n", 1345 r1, r1, r1, car r3, cdr r3); 1346 c!:printf("#ifdef RECORD_GET\n"); 1347 c!:printf(" if (%v == SPID_NOPROP)\n", r1); 1348 c!:printf(" record_get(elt(fastget_names, %s), 0),\n", car r3); 1349 c!:printf(" %v = nil;\n", r1); 1350 c!:printf(" else record_get(elt(fastget_names, %s), 1),\n", car r3); 1351 c!:printf(" %v = lisp_true; }\n", r1); 1352 c!:printf(" else record_get(elt(fastget_names, %s), 0); }\n", car r3); 1353 c!:printf("#else\n"); 1354 c!:printf(" if (%v == SPID_NOPROP) %v = nil; else %v = lisp_true; }}\n", r1, r1, r1); 1355 c!:printf("#endif\n"); 1356 >>; 1357 1358put('fastflag, 'c!:opcode_printer, function c!:pfastflag); 1359flag('(fastflag), 'c!:uses_nil); 1360 1361symbolic procedure c!:pcar(op, r1, r2, r3, depth); 1362 begin 1363 if not !*unsafecar then << 1364 c!:printf(" if (!car_legal(%v)) ", r3); 1365 c!:pgoto(c!:find_error_label(list('car, r3), r2, depth), depth) >>; 1366 c!:printf(" %v = qcar(%v);\n", r1, r3) 1367 end; 1368 1369put('car, 'c!:opcode_printer, function c!:pcar); 1370 1371symbolic procedure c!:pcdr(op, r1, r2, r3, depth); 1372 begin 1373 if not !*unsafecar then << 1374 c!:printf(" if (!car_legal(%v)) ", r3); 1375 c!:pgoto(c!:find_error_label(list('cdr, r3), r2, depth), depth) >>; 1376 c!:printf(" %v = qcdr(%v);\n", r1, r3) 1377 end; 1378 1379put('cdr, 'c!:opcode_printer, function c!:pcdr); 1380 1381symbolic procedure c!:pqcar(op, r1, r2, r3, depth); 1382 c!:printf(" %v = qcar(%v);\n", r1, r3); 1383 1384put('qcar, 'c!:opcode_printer, function c!:pqcar); 1385 1386symbolic procedure c!:pqcdr(op, r1, r2, r3, depth); 1387 c!:printf(" %v = qcdr(%v);\n", r1, r3); 1388 1389put('qcdr, 'c!:opcode_printer, function c!:pqcdr); 1390 1391symbolic procedure c!:patom(op, r1, r2, r3, depth); 1392 c!:printf(" %v = (consp(%v) ? nil : lisp_true);\n", r1, r3); 1393 1394put('atom, 'c!:opcode_printer, function c!:patom); 1395flag('(atom), 'c!:uses_nil); 1396 1397symbolic procedure c!:pnumberp(op, r1, r2, r3, depth); 1398 c!:printf(" %v = (is_number(%v) ? lisp_true : nil);\n", r1, r3); 1399 1400put('numberp, 'c!:opcode_printer, function c!:pnumberp); 1401flag('(numberp), 'c!:uses_nil); 1402 1403symbolic procedure c!:pfixp(op, r1, r2, r3, depth); 1404 c!:printf(" %v = integerp(%v);\n", r1, r3); 1405 1406put('fixp, 'c!:opcode_printer, function c!:pfixp); 1407flag('(fixp), 'c!:uses_nil); 1408 1409symbolic procedure c!:piminusp(op, r1, r2, r3, depth); 1410 c!:printf(" %v = ((intptr_t)(%v) < 0 ? lisp_true : nil);\n", r1, r3); 1411 1412put('iminusp, 'c!:opcode_printer, function c!:piminusp); 1413flag('(iminusp), 'c!:uses_nil); 1414 1415symbolic procedure c!:pilessp(op, r1, r2, r3, depth); 1416 c!:printf(" %v = ((intptr_t)%v < (intptr_t)%v) ? lisp_true : nil;\n", 1417 r1, r2, r3); 1418 1419put('ilessp, 'c!:opcode_printer, function c!:pilessp); 1420flag('(ilessp), 'c!:uses_nil); 1421 1422symbolic procedure c!:pigreaterp(op, r1, r2, r3, depth); 1423 c!:printf(" %v = ((intptr_t)%v > (intptr_t)%v) ? lisp_true : nil;\n", 1424 r1, r2, r3); 1425 1426put('igreaterp, 'c!:opcode_printer, function c!:pigreaterp); 1427flag('(igreaterp), 'c!:uses_nil); 1428 1429% The "int32_t" here is deliberate, and ensures that if the intereg-mode 1430% arithmetic strays outside 32-bits that truncation is done at that 1431% level even on 64-bit architectures. 1432 1433symbolic procedure c!:piminus(op, r1, r2, r3, depth); 1434 c!:printf(" %v = (Lisp_Object)(2-((int32_t)(%v)));\n", r1, r3); 1435 1436put('iminus, 'c!:opcode_printer, function c!:piminus); 1437 1438symbolic procedure c!:piadd1(op, r1, r2, r3, depth); 1439 c!:printf(" %v = (Lisp_Object)((int32_t)(%v) + 0x10);\n", r1, r3); 1440 1441put('iadd1, 'c!:opcode_printer, function c!:piadd1); 1442 1443symbolic procedure c!:pisub1(op, r1, r2, r3, depth); 1444 c!:printf(" %v = (Lisp_Object)((int32_t)(%v) - 0x10);\n", r1, r3); 1445 1446put('isub1, 'c!:opcode_printer, function c!:pisub1); 1447 1448symbolic procedure c!:piplus2(op, r1, r2, r3, depth); 1449 c!:printf(" %v = (Lisp_Object)(int32_t)((int32_t)%v + (int32_t)%v - TAG_FIXNUM);\n", 1450 r1, r2, r3); 1451 1452put('iplus2, 'c!:opcode_printer, function c!:piplus2); 1453 1454symbolic procedure c!:pidifference(op, r1, r2, r3, depth); 1455 c!:printf(" %v = (Lisp_Object)(int32_t)((int32_t)%v - (int32_t)%v + TAG_FIXNUM);\n", 1456 r1, r2, r3); 1457 1458put('idifference, 'c!:opcode_printer, function c!:pidifference); 1459 1460symbolic procedure c!:pitimes2(op, r1, r2, r3, depth); 1461 c!:printf(" %v = fixnum_of_int((int32_t)(int_of_fixnum(%v) * int_of_fixnum(%v)));\n", 1462 r1, r2, r3); 1463 1464put('itimes2, 'c!:opcode_printer, function c!:pitimes2); 1465 1466symbolic procedure c!:pmodular_plus(op, r1, r2, r3, depth); 1467 << 1468 c!:printf(" { int32_t w = int_of_fixnum(%v) + int_of_fixnum(%v);\n", 1469 r2, r3); 1470 c!:printf(" if (w >= current_modulus) w -= current_modulus;\n"); 1471 c!:printf(" %v = fixnum_of_int(w);\n", r1); 1472 c!:printf(" }\n") 1473 >>; 1474 1475put('modular!-plus, 'c!:opcode_printer, function c!:pmodular_plus); 1476 1477symbolic procedure c!:pmodular_difference(op, r1, r2, r3, depth); 1478 << 1479 c!:printf(" { int32_t w = int_of_fixnum(%v) - int_of_fixnum(%v);\n", 1480 r2, r3); 1481 c!:printf(" if (w < 0) w += current_modulus;\n"); 1482 c!:printf(" %v = fixnum_of_int(w);\n", r1); 1483 c!:printf(" }\n") 1484 >>; 1485 1486put('modular!-difference, 'c!:opcode_printer, function c!:pmodular_difference); 1487 1488symbolic procedure c!:pmodular_minus(op, r1, r2, r3, depth); 1489 << 1490 c!:printf(" { int32_t w = int_of_fixnum(%v);\n", r3); 1491 c!:printf(" if (w != 0) w = current_modulus - w;\n"); 1492 c!:printf(" %v = fixnum_of_int(w);\n", r1); 1493 c!:printf(" }\n") 1494 >>; 1495 1496put('modular!-minus, 'c!:opcode_printer, function c!:pmodular_minus); 1497 1498!#if (not common!-lisp!-mode) 1499 1500symbolic procedure c!:passoc(op, r1, r2, r3, depth); 1501 c!:printf(" %v = Lassoc(nil, %v, %v);\n", r1, r2, r3); 1502 1503put('assoc, 'c!:opcode_printer, function c!:passoc); 1504flag('(assoc), 'c!:uses_nil); 1505 1506!#endif 1507 1508symbolic procedure c!:patsoc(op, r1, r2, r3, depth); 1509 c!:printf(" %v = Latsoc(nil, %v, %v);\n", r1, r2, r3); 1510 1511put('atsoc, 'c!:opcode_printer, function c!:patsoc); 1512flag('(atsoc), 'c!:uses_nil); 1513 1514!#if (not common!-lisp!-mode) 1515 1516symbolic procedure c!:pmember(op, r1, r2, r3, depth); 1517 c!:printf(" %v = Lmember(nil, %v, %v);\n", r1, r2, r3); 1518 1519put('member, 'c!:opcode_printer, function c!:pmember); 1520flag('(member), 'c!:uses_nil); 1521 1522!#endif 1523 1524symbolic procedure c!:pmemq(op, r1, r2, r3, depth); 1525 c!:printf(" %v = Lmemq(nil, %v, %v);\n", r1, r2, r3); 1526 1527put('memq, 'c!:opcode_printer, function c!:pmemq); 1528flag('(memq), 'c!:uses_nil); 1529 1530!#if common!-lisp!-mode 1531 1532symbolic procedure c!:pget(op, r1, r2, r3, depth); 1533 c!:printf(" %v = get(%v, %v, nil);\n", r1, r2, r3); 1534 1535flag('(get), 'c!:uses_nil); 1536!#else 1537 1538symbolic procedure c!:pget(op, r1, r2, r3, depth); 1539 c!:printf(" %v = get(%v, %v);\n", r1, r2, r3); 1540 1541!#endif 1542 1543put('get, 'c!:opcode_printer, function c!:pget); 1544 1545symbolic procedure c!:pqgetv(op, r1, r2, r3, depth); 1546 << c!:printf(" %v = *(Lisp_Object *)((char *)%v + (CELL-TAG_VECTOR) +", 1547 r1, r2); 1548 c!:printf(" ((int32_t)%v/(16/CELL)));\n", r3) >>; 1549 1550put('qgetv, 'c!:opcode_printer, function c!:pqgetv); 1551 1552symbolic procedure c!:pqputv(op, r1, r2, r3, depth); 1553 << 1554 c!:printf(" *(Lisp_Object *)((char *)%v + (CELL-TAG_VECTOR) +", r2); 1555 c!:printf(" ((int32_t)%v/(16/CELL))) = %v;\n", r3, r1) >>; 1556 1557put('qputv, 'c!:opcode_printer, function c!:pqputv); 1558 1559symbolic procedure c!:peq(op, r1, r2, r3, depth); 1560 c!:printf(" %v = (%v == %v ? lisp_true : nil);\n", r1, r2, r3); 1561 1562put('eq, 'c!:opcode_printer, function c!:peq); 1563flag('(eq), 'c!:uses_nil); 1564 1565!#if common!-lisp!-mode 1566symbolic procedure c!:pequal(op, r1, r2, r3, depth); 1567 c!:printf(" %v = (cl_equal(%v, %v) ? lisp_true : nil);\n", 1568 r1, r2, r3, r2, r3); 1569!#else 1570symbolic procedure c!:pequal(op, r1, r2, r3, depth); 1571 c!:printf(" %v = (equal(%v, %v) ? lisp_true : nil);\n", 1572 r1, r2, r3, r2, r3); 1573!#endif 1574 1575put('equal, 'c!:opcode_printer, function c!:pequal); 1576flag('(equal), 'c!:uses_nil); 1577 1578symbolic procedure c!:pfluidbind(op, r1, r2, r3, depth); 1579 nil; 1580 1581put('fluidbind, 'c!:opcode_printer, function c!:pfluidbind); 1582 1583symbolic procedure c!:pcall(op, r1, r2, r3, depth); 1584 begin 1585% r3 is (name <fluids to unbind on error>) 1586 scalar w, boolfn; 1587 if w := get(car r3, 'c!:direct_entrypoint) then << 1588 c!:printf(" %v = %s(", r1, cdr w); 1589 if r2 then << 1590 c!:printf("%v", car r2); 1591 for each a in cdr r2 do c!:printf(", %v", a) >>; 1592 c!:printf(");\n") >> 1593 else if w := get(car r3, 'c!:direct_predicate) then << 1594 boolfn := t; 1595 c!:printf(" %v = (Lisp_Object)%s(", r1, cdr w); 1596 if r2 then << 1597 c!:printf("%v", car r2); 1598 for each a in cdr r2 do c!:printf(", %v", a) >>; 1599 c!:printf(");\n") >> 1600 else if car r3 = c!:current_procedure then << 1601% Things could go sour here if a function tried to call itself but with the 1602% wrong number of args. And this happens at one place in the REDUCE source 1603% code (I hope it will be fixed soon!). I will patch things up here by 1604% discarding any excess args or padding with NIL if not enough had been 1605% written. 1606 r2 := c!:fix_nargs(r2, c!:current_args); 1607 c!:printf(" %v = %s(env", r1, c!:current_c_name); 1608 if null r2 or length r2 >= 3 then c!:printf(", %s", length r2); 1609 for each a in r2 do c!:printf(", %v", a); 1610 c!:printf(");\n") >> 1611 else if w := get(car r3, 'c!:c_entrypoint) then << 1612 c!:printf(" %v = %s(nil", r1, w); 1613 if null r2 or length r2 >= 3 then c!:printf(", %s", length r2); 1614 for each a in r2 do c!:printf(", %v", a); 1615 c!:printf(");\n") >> 1616 else begin 1617 scalar nargs; 1618 nargs := length r2; 1619 c!:printf(" fn = elt(env, %s); %</* %c %<*/\n", 1620 c!:find_literal car r3, car r3); 1621 if nargs = 1 then c!:printf(" %v = (*qfn1(fn))(qenv(fn)", r1) 1622 else if nargs = 2 then c!:printf(" %v = (*qfn2(fn))(qenv(fn)", r1) 1623 else c!:printf(" %v = (*qfnn(fn))(qenv(fn), %s", r1, nargs); 1624 for each a in r2 do c!:printf(", %v", a); 1625 c!:printf(");\n") end; 1626 if not flagp(car r3, 'c!:no_errors) then << 1627 if null cadr r3 and depth = 0 then c!:printf(" errexit();\n") 1628 else << 1629 c!:printf(" nil = C_nil;\n"); 1630 c!:printf(" if (exception_pending()) "); 1631 c!:pgoto(c!:find_error_label(nil, cadr r3, depth) , depth) >> >>; 1632 if boolfn then c!:printf(" %v = %v ? lisp_true : nil;\n", r1, r1); 1633 end; 1634 1635symbolic procedure c!:fix_nargs(r2, act); 1636 if null act then nil 1637 else if null r2 then nil . c!:fix_nargs(nil, cdr act) 1638 else car r2 . c!:fix_nargs(cdr r2, cdr act); 1639 1640put('call, 'c!:opcode_printer, function c!:pcall); 1641 1642symbolic procedure c!:pgoto(lab, depth); 1643 begin 1644 if atom lab then return c!:printf("goto %s;\n", lab); 1645 lab := get(car lab, 'c!:chosen); 1646 if zerop depth then c!:printf("return onevalue(%v);\n", lab) 1647 else if flagp(lab, 'c!:live_across_call) then 1648 c!:printf("{ Lisp_Object res = %v; popv(%s); return onevalue(res); }\n", lab, depth) 1649 else c!:printf("{ popv(%s); return onevalue(%v); }\n", depth, lab) 1650 end; 1651 1652symbolic procedure c!:pifnull(s, depth); 1653 c!:printf("%v == nil", car s); 1654 1655put('ifnull, 'c!:exit_helper, function c!:pifnull); 1656 1657symbolic procedure c!:pifatom(s, depth); 1658 c!:printf("!consp(%v)", car s); 1659 1660put('ifatom, 'c!:exit_helper, function c!:pifatom); 1661 1662symbolic procedure c!:pifsymbol(s, depth); 1663 c!:printf("symbolp(%v)", car s); 1664 1665put('ifsymbol, 'c!:exit_helper, function c!:pifsymbol); 1666 1667symbolic procedure c!:pifnumber(s, depth); 1668 c!:printf("is_number(%v)", car s); 1669 1670put('ifnumber, 'c!:exit_helper, function c!:pifnumber); 1671 1672symbolic procedure c!:pifizerop(s, depth); 1673 c!:printf("(%v) == 1", car s); 1674 1675put('ifizerop, 'c!:exit_helper, function c!:pifizerop); 1676 1677symbolic procedure c!:pifeq(s, depth); 1678 c!:printf("%v == %v", car s, cadr s); 1679 1680put('ifeq, 'c!:exit_helper, function c!:pifeq); 1681 1682!#if common!-lisp!-mode 1683symbolic procedure c!:pifequal(s, depth); 1684 c!:printf("cl_equal(%v, %v)", 1685 car s, cadr s, car s, cadr s); 1686!#else 1687symbolic procedure c!:pifequal(s, depth); 1688 c!:printf("equal(%v, %v)", 1689 car s, cadr s, car s, cadr s); 1690!#endif 1691 1692put('ifequal, 'c!:exit_helper, function c!:pifequal); 1693 1694symbolic procedure c!:pifilessp(s, depth); 1695 c!:printf("((int32_t)(%v)) < ((int32_t)(%v))", car s, cadr s); 1696 1697put('ifilessp, 'c!:exit_helper, function c!:pifilessp); 1698 1699symbolic procedure c!:pifigreaterp(s, depth); 1700 c!:printf("((int32_t)(%v)) > ((int32_t)(%v))", car s, cadr s); 1701 1702put('ifigreaterp, 'c!:exit_helper, function c!:pifigreaterp); 1703 1704symbolic procedure c!:display_flowgraph(s, depth, dropping_through); 1705 if not atom s then << 1706 c!:printf " "; 1707 c!:pgoto(s, depth) >> 1708 else if not flagp(s, 'c!:visited) then begin 1709 scalar why, where_to; 1710 flag(list s, 'c!:visited); 1711 if not dropping_through or not (get(s, 'c!:count) = 1) then 1712 c!:printf("\n%s:\n", s); 1713 for each k in reverse get(s, 'c!:contents) do c!:print_opcode(k, depth); 1714 why := get(s, 'c!:why); 1715 where_to := get(s, 'c!:where_to); 1716 if why = 'goto and (not atom car where_to or 1717 (not flagp(car where_to, 'c!:visited) and 1718 get(car where_to, 'c!:count) = 1)) then 1719 c!:display_flowgraph(car where_to, depth, t) 1720 else c!:print_exit_condition(why, where_to, depth); 1721 end; 1722 1723fluid '(c!:startpoint); 1724 1725symbolic procedure c!:branch_chain(s, count); 1726 begin 1727 scalar contents, why, where_to, n; 1728% do nothing to blocks already visted or return blocks. 1729 if not atom s then return s 1730 else if flagp(s, 'c!:visited) then << 1731 n := get(s, 'c!:count); 1732 if null n then n := 1 else n := n + 1; 1733 put(s, 'c!:count, n); 1734 return s >>; 1735 flag(list s, 'c!:visited); 1736 contents := get(s, 'c!:contents); 1737 why := get(s, 'c!:why); 1738 where_to := for each z in get(s, 'c!:where_to) collect 1739 c!:branch_chain(z, count); 1740% Turn movr a,b; return a; into return b; 1741 while contents and eqcar(car contents, 'movr) and 1742 why = 'goto and not atom car where_to and 1743 caar where_to = cadr car contents do << 1744 where_to := list list cadddr car contents; 1745 contents := cdr contents >>; 1746 put(s, 'c!:contents, contents); 1747 put(s, 'c!:where_to, where_to); 1748% discard empty blocks 1749 if null contents and why = 'goto then << 1750 remflag(list s, 'c!:visited); 1751 return car where_to >>; 1752 if count then << 1753 n := get(s, 'c!:count); 1754 if null n then n := 1 1755 else n := n + 1; 1756 put(s, 'c!:count, n) >>; 1757 return s 1758 end; 1759 1760symbolic procedure c!:one_operand op; 1761 << flag(list op, 'c!:set_r1); 1762 flag(list op, 'c!:read_r3); 1763 put(op, 'c!:code, function c!:builtin_one) >>; 1764 1765symbolic procedure c!:two_operands op; 1766 << flag(list op, 'c!:set_r1); 1767 flag(list op, 'c!:read_r2); 1768 flag(list op, 'c!:read_r3); 1769 put(op, 'c!:code, function c!:builtin_two) >>; 1770 1771for each n in '(car cdr qcar qcdr null not atom numberp fixp iminusp 1772 iminus iadd1 isub1 modular!-minus) do c!:one_operand n; 1773!#if common!-lisp!-mode 1774for each n in '(eq equal atsoc memq iplus2 idifference 1775 itimes2 ilessp igreaterp qgetv get 1776 modular!-plus modular!-difference 1777 ) do c!:two_operands n; 1778!#else 1779for each n in '(eq equal atsoc memq iplus2 idifference 1780 assoc member 1781 itimes2 ilessp igreaterp qgetv get 1782 modular!-plus modular!-difference 1783 ) do c!:two_operands n; 1784!#endif 1785 1786 1787flag('(movr movk movk1 ldrglob call reloadenv fastget fastflag), 'c!:set_r1); 1788flag('(strglob qputv), 'c!:read_r1); 1789flag('(qputv fastget fastflag), 'c!:read_r2); 1790flag('(movr qputv), 'c!:read_r3); 1791flag('(ldrglob strglob nilglob movk call), 'c!:read_env); 1792% special opcodes: 1793% call fluidbind 1794 1795fluid '(fn_used nil_used nilbase_used); 1796 1797symbolic procedure c!:live_variable_analysis c!:all_blocks; 1798 begin 1799 scalar changed, z; 1800 repeat << 1801 changed := nil; 1802 for each b in c!:all_blocks do 1803 begin 1804 scalar w, live; 1805 for each x in get(b, 'c!:where_to) do 1806 if atom x then live := union(live, get(x, 'c!:live)) 1807 else live := union(live, x); 1808 w := get(b, 'c!:why); 1809 if not atom w then << 1810 if eqcar(w, 'ifnull) or eqcar(w, 'ifequal) then nil_used := t; 1811 live := union(live, cdr w); 1812 if eqcar(car w, 'call) and 1813 (flagp(cadar w, 'c!:direct_predicate) or 1814 (flagp(cadar w, 'c!:c_entrypoint) and 1815 not flagp(cadar w, 'c!:direct_entrypoint))) then 1816 nil_used := t; 1817 if eqcar(car w, 'call) and 1818 not (cadar w = c!:current_procedure) and 1819 not get(cadar w, 'c!:direct_entrypoint) and 1820 not get(cadar w, 'c!:c_entrypoint) then << 1821 fn_used := t; live := union('(env), live) >> >>; 1822 for each s in get(b, 'c!:contents) do 1823 begin % backwards over contents 1824 scalar op, r1, r2, r3; 1825 op := car s; r1 := cadr s; r2 := caddr s; r3 := cadddr s; 1826 if op = 'movk1 then << 1827 if r3 = nil then nil_used := t 1828 else if r3 = 't then nilbase_used := t >> 1829 else if atom op and flagp(op, 'c!:uses_nil) then nil_used := t; 1830 if flagp(op, 'c!:set_r1) then 1831!#if common!-lisp!-mode 1832 if memq(r1, live) then live := remove(r1, live) 1833!#else 1834 if memq(r1, live) then live := delete(r1, live) 1835!#endif 1836 else if op = 'call then nil % Always needed 1837 else op := 'nop; 1838 if flagp(op, 'c!:read_r1) then live := union(live, list r1); 1839 if flagp(op, 'c!:read_r2) then live := union(live, list r2); 1840 if flagp(op, 'c!:read_r3) then live := union(live, list r3); 1841 if op = 'call then << 1842 if not flagp(car r3, 'c!:no_errors) or 1843 flagp(car r3, 'c!:c_entrypoint) or 1844 get(car r3, 'c!:direct_predicate) then nil_used := t; 1845 does_call := t; 1846 if not eqcar(r3, c!:current_procedure) and 1847 not get(car r3, 'c!:direct_entrypoint) and 1848 not get(car r3, 'c!:c_entrypoint) then fn_used := t; 1849 if not flagp(car r3, 'c!:no_errors) then 1850 flag(live, 'c!:live_across_call); 1851 live := union(live, r2) >>; 1852 if flagp(op, 'c!:read_env) then live := union(live, '(env)) 1853 end; 1854!#if common!-lisp!-mode 1855 live := append(live, nil); % because CL sort is destructive! 1856!#endif 1857 live := sort(live, function orderp); 1858 if not (live = get(b, 'c!:live)) then << 1859 put(b, 'c!:live, live); 1860 changed := t >> 1861 end 1862 >> until not changed; 1863 z := c!:registers; 1864 c!:registers := c!:stacklocs := nil; 1865 for each r in z do 1866 if flagp(r, 'c!:live_across_call) then c!:stacklocs := r . c!:stacklocs 1867 else c!:registers := r . c!:registers 1868 end; 1869 1870symbolic procedure c!:insert1(a, b); 1871 if memq(a, b) then b 1872 else a . b; 1873 1874symbolic procedure c!:clash(a, b); 1875 if flagp(a, 'c!:live_across_call) = flagp(b, 'c!:live_across_call) then << 1876 put(a, 'c!:clash, c!:insert1(b, get(a, 'c!:clash))); 1877 put(b, 'c!:clash, c!:insert1(a, get(b, 'c!:clash))) >>; 1878 1879symbolic procedure c!:build_clash_matrix c!:all_blocks; 1880 begin 1881 for each b in c!:all_blocks do 1882 begin 1883 scalar live, w; 1884 for each x in get(b, 'c!:where_to) do 1885 if atom x then live := union(live, get(x, 'c!:live)) 1886 else live := union(live, x); 1887 w := get(b, 'c!:why); 1888 if not atom w then << 1889 live := union(live, cdr w); 1890 if eqcar(car w, 'call) and 1891 not get(cadar w, 'c!:direct_entrypoint) and 1892 not get(cadar w, 'c!:c_entrypoint) then 1893 live := union('(env), live) >>; 1894 for each s in get(b, 'c!:contents) do 1895 begin 1896 scalar op, r1, r2, r3; 1897 op := car s; r1 := cadr s; r2 := caddr s; r3 := cadddr s; 1898 if flagp(op, 'c!:set_r1) then 1899 if memq(r1, live) then << 1900!#if common!-lisp!-mode 1901 live := remove(r1, live); 1902!#else 1903 live := delete(r1, live); 1904!#endif 1905 if op = 'reloadenv then reloadenv := t; 1906 for each v in live do c!:clash(r1, v) >> 1907 else if op = 'call then nil 1908 else << 1909 op := 'nop; 1910 rplacd(s, car s . cdr s); % Leaves original instrn visible 1911 rplaca(s, op) >>; 1912 if flagp(op, 'c!:read_r1) then live := union(live, list r1); 1913 if flagp(op, 'c!:read_r2) then live := union(live, list r2); 1914 if flagp(op, 'c!:read_r3) then live := union(live, list r3); 1915% Maybe CALL should be a little more selective about need for "env"? 1916 if op = 'call then live := union(live, r2); 1917 if flagp(op, 'c!:read_env) then live := union(live, '(env)) 1918 end 1919 end; 1920% The next few lines are for debugging... 1921%%- c!:printf "Scratch registers:\n"; 1922%%- for each r in c!:registers do 1923%%- c!:printf("%s clashes: %s\n", r, get(r, 'c!:clash)); 1924%%- c!:printf "Stack items:\n"; 1925%%- for each r in c!:stacklocs do 1926%%- c!:printf("%s clashes: %s\n", r, get(r, 'c!:clash)); 1927 return nil 1928 end; 1929 1930symbolic procedure c!:allocate_registers rl; 1931 begin 1932 scalar schedule, neighbours, allocation; 1933 neighbours := 0; 1934 while rl do begin 1935 scalar w, x; 1936 w := rl; 1937 while w and length (x := get(car w, 'c!:clash)) > neighbours do 1938 w := cdr w; 1939 if w then << 1940 schedule := car w . schedule; 1941 rl := deleq(car w, rl); 1942 for each r in x do put(r, 'c!:clash, deleq(car w, get(r, 'c!:clash))) >> 1943 else neighbours := neighbours + 1 1944 end; 1945 for each r in schedule do begin 1946 scalar poss; 1947 poss := allocation; 1948 for each x in get(r, 'c!:clash) do 1949 poss := deleq(get(x, 'c!:chosen), poss); 1950 if null poss then << 1951 poss := c!:my_gensym(); 1952 allocation := append(allocation, list poss) >> 1953 else poss := car poss; 1954% c!:printf("%</* Allocate %s to %s, to miss %s %<*/\n", 1955% r, poss, get(r, 'c!:clash)); 1956 put(r, 'c!:chosen, poss) 1957 end; 1958 return allocation 1959 end; 1960 1961symbolic procedure c!:remove_nops c!:all_blocks; 1962% Remove no-operation instructions, and map registers to reflect allocation 1963 for each b in c!:all_blocks do 1964 begin 1965 scalar r; 1966 for each s in get(b, 'c!:contents) do 1967 if not eqcar(s, 'nop) then 1968 begin 1969 scalar op, r1, r2, r3; 1970 op := car s; r1 := cadr s; r2 := caddr s; r3 := cadddr s; 1971 if flagp(op, 'c!:set_r1) or flagp(op, 'c!:read_r1) then 1972 r1 := get(r1, 'c!:chosen); 1973 if flagp(op, 'c!:read_r2) then r2 := get(r2, 'c!:chosen); 1974 if flagp(op, 'c!:read_r3) then r3 := get(r3, 'c!:chosen); 1975 if op = 'call then 1976 r2 := for each v in r2 collect get(v, 'c!:chosen); 1977 if not (op = 'movr and r1 = r3) then 1978 r := list(op, r1, r2, r3) . r 1979 end; 1980 put(b, 'c!:contents, reversip r); 1981 r := get(b, 'c!:why); 1982 if not atom r then 1983 put(b, 'c!:why, 1984 car r . for each v in cdr r collect get(v, 'c!:chosen)) 1985 end; 1986 1987fluid '(c!:error_labels); 1988 1989symbolic procedure c!:find_error_label(why, env, depth); 1990 begin 1991 scalar w, z; 1992 z := list(why, env, depth); 1993 w := assoc!*!*(z, c!:error_labels); 1994 if null w then << 1995 w := z . c!:my_gensym(); 1996 c!:error_labels := w . c!:error_labels >>; 1997 return cdr w 1998 end; 1999 2000symbolic procedure c!:assign(u, v, c); 2001 if flagp(u, 'fluid) then list('strglob, v, u, c!:find_literal u) . c 2002 else list('movr, u, nil, v) . c; 2003 2004symbolic procedure c!:insert_tailcall b; 2005 begin 2006 scalar why, dest, contents, fcall, res, w; 2007 why := get(b, 'c!:why); 2008 dest := get(b, 'c!:where_to); 2009 contents := get(b, 'c!:contents); 2010 while contents and not eqcar(car contents, 'call) do << 2011 w := car contents . w; 2012 contents := cdr contents >>; 2013 if null contents then return nil; 2014 fcall := car contents; 2015 contents := cdr contents; 2016 res := cadr fcall; 2017 while w do << 2018 if eqcar(car w, 'reloadenv) then w := cdr w 2019 else if eqcar(car w, 'movr) and cadddr car w = res then << 2020 res := cadr car w; 2021 w := cdr w >> 2022 else res := w := nil >>; 2023 if null res then return nil; 2024 if c!:does_return(res, why, dest) then 2025 if car cadddr fcall = c!:current_procedure then << 2026 for each p in pair(c!:current_args, caddr fcall) do 2027 contents := c!:assign(car p, cdr p, contents); 2028 put(b, 'c!:contents, contents); 2029 put(b, 'c!:why, 'goto); 2030 put(b, 'c!:where_to, list restart_label) >> 2031 else << 2032 nil_used := t; 2033 put(b, 'c!:contents, contents); 2034 put(b, 'c!:why, list('call, car cadddr fcall) . caddr fcall); 2035 put(b, 'c!:where_to, nil) >> 2036 end; 2037 2038symbolic procedure c!:does_return(res, why, where_to); 2039 if not (why = 'goto) then nil 2040 else if not atom car where_to then res = caar where_to 2041 else begin 2042 scalar contents; 2043 where_to := car where_to; 2044 contents := reverse get(where_to, 'c!:contents); 2045 why := get(where_to, 'c!:why); 2046 where_to := get(where_to, 'c!:where_to); 2047 while contents do 2048 if eqcar(car contents, 'reloadenv) then contents := cdr contents 2049 else if eqcar(car contents, 'movr) and cadddr car contents = res then << 2050 res := cadr car contents; 2051 contents := cdr contents >> 2052 else res := contents := nil; 2053 if null res then return nil 2054 else return c!:does_return(res, why, where_to) 2055 end; 2056 2057symbolic procedure c!:pushpop(op, v); 2058% for each x in v do c!:printf(" %s(%s);\n", op, x); 2059 begin 2060 scalar n, w; 2061 if null v then return nil; 2062 n := length v; 2063 while n > 0 do << 2064 w := n; 2065 if w > 6 then w := 6; 2066 n := n-w; 2067 if w = 1 then c!:printf(" %s(%s);\n", op, car v) 2068 else << 2069 c!:printf(" %s%d(%s", op, w, car v); 2070 v := cdr v; 2071 for i := 2:w do << 2072 c!:printf(",%s", car v); 2073 v := cdr v >>; 2074 c!:printf(");\n") >> >> 2075 end; 2076 2077symbolic procedure c!:optimise_flowgraph(c!:startpoint, c!:all_blocks, 2078 env, argch, args); 2079 begin 2080 scalar w, n, locs, stacks, c!:error_labels, fn_used, nil_used, nilbase_used; 2081!#if common!-lisp!-mode 2082 nilbase_used := t; % For onevalue(xxx) at least 2083!#endif 2084 for each b in c!:all_blocks do c!:insert_tailcall b; 2085 c!:startpoint := c!:branch_chain(c!:startpoint, nil); 2086 remflag(c!:all_blocks, 'c!:visited); 2087 c!:live_variable_analysis c!:all_blocks; 2088 c!:build_clash_matrix c!:all_blocks; 2089 if c!:error_labels and env then reloadenv := t; 2090 for each u in env do 2091 for each v in env do c!:clash(cdr u, cdr v); % keep all args distinct 2092 locs := c!:allocate_registers c!:registers; 2093 stacks := c!:allocate_registers c!:stacklocs; 2094 flag(stacks, 'c!:live_across_call); 2095 c!:remove_nops c!:all_blocks; 2096 c!:startpoint := c!:branch_chain(c!:startpoint, nil); % after tailcall insertion 2097 remflag(c!:all_blocks, 'c!:visited); 2098 c!:startpoint := c!:branch_chain(c!:startpoint, t); % ... AGAIN to tidy up 2099 remflag(c!:all_blocks, 'c!:visited); 2100 if does_call then nil_used := t; 2101 if nil_used then c!:printf " Lisp_Object nil = C_nil;\n" 2102 else if nilbase_used then c!:printf " nil_as_base\n"; 2103 if locs then << 2104 c!:printf(" Lisp_Object %s", car locs); 2105 for each v in cdr locs do c!:printf(", %s", v); 2106 c!:printf ";\n" >>; 2107 if fn_used then c!:printf " Lisp_Object fn;\n"; 2108 if nil_used then 2109 c!:printf(" CSL_IGNORE(nil);\n") 2110 else if nilbase_used then << 2111 c!:printf("#ifndef NILSEG_EXTERNS\n"); 2112 c!:printf(" CSL_IGNORE(nil);\n"); 2113 c!:printf("#endif\n") >>; 2114 if car argch = 0 or car argch >= 3 then 2115 c!:printf(" argcheck(nargs, %s, \q%s\q);\n", car argch, cdr argch); 2116 c!:printf("#ifdef DEBUG\n"); 2117 c!:printf(" if (check_env(env)) return aerror(\qenv for %s\q);\n", 2118 cdr argch); 2119 c!:printf("#endif\n"); 2120% I will not do a stack check if I have a leaf procedure, and I hope 2121% that this policy will speed up code a bit. 2122 if does_call then << 2123 c!:printf " if (stack >= stacklimit)\n"; 2124 c!:printf " {\n"; 2125% This is slightly clumsy code to save all args on the stack across the 2126% call to reclaim(), but it is not executed often... 2127 c!:pushpop('push, args); 2128 c!:printf " env = reclaim(env, \qstack\q, GC_STACK, 0);\n"; 2129 c!:pushpop('pop, reverse args); 2130 c!:printf " nil = C_nil;\n"; 2131 c!:printf " if (exception_pending()) return nil;\n"; 2132 c!:printf " }\n" >>; 2133 if reloadenv then c!:printf(" push(env);\n") 2134 else c!:printf(" CSL_IGNORE(env);\n"); 2135 n := 0; 2136 if stacks then << 2137 c!:printf "%</* space for vars preserved across procedure calls %<*/\n"; 2138 for each v in stacks do << 2139 put(v, 'c!:location, n); 2140 n := n+1 >>; 2141 w := n; 2142 while w >= 5 do << 2143 c!:printf " push5(nil, nil, nil, nil, nil);\n"; 2144 w := w - 5 >>; 2145 if w neq 0 then << 2146 if w = 1 then c!:printf " push(nil);\n" 2147 else << 2148 c!:printf(" push%s(nil", w); 2149 for i := 2:w do c!:printf ", nil"; 2150 c!:printf ");\n" >> >> >>; 2151 if reloadenv then << 2152 reloadenv := n; 2153 n := n + 1 >>; 2154 if env then c!:printf "%</* copy arguments values to proper place %<*/\n"; 2155 for each v in env do 2156 if flagp(cdr v, 'c!:live_across_call) then 2157 c!:printf(" stack[%s] = %s;\n", 2158 -get(get(cdr v, 'c!:chosen), 'c!:location), cdr v) 2159 else c!:printf(" %s = %s;\n", get(cdr v, 'c!:chosen), cdr v); 2160 c!:printf "%</* end of prologue %<*/\n"; 2161 c!:display_flowgraph(c!:startpoint, n, t); 2162 if c!:error_labels then << 2163 c!:printf "%</* error exit handlers %<*/\n"; 2164 for each x in c!:error_labels do << 2165 c!:printf("%s:\n", cdr x); 2166 c!:print_error_return(caar x, cadar x, caddar x) >> >>; 2167 remflag(c!:all_blocks, 'c!:visited); 2168 end; 2169 2170symbolic procedure c!:print_error_return(why, env, depth); 2171 begin 2172 if reloadenv and env then 2173 c!:printf(" env = stack[%s];\n", -reloadenv); 2174 if null why then << 2175% One could imagine generating backtrace entries here... 2176 for each v in env do 2177 c!:printf(" qvalue(elt(env, %s)) = %v; %</* %c %<*/\n", 2178 c!:find_literal car v, get(cdr v, 'c!:chosen), car v); 2179 if depth neq 0 then c!:printf(" popv(%s);\n", depth); 2180 c!:printf " return nil;\n" >> 2181 else if flagp(cadr why, 'c!:live_across_call) then << 2182 c!:printf(" { Lisp_Object res = %v;\n", cadr why); 2183 for each v in env do 2184 c!:printf(" qvalue(elt(env, %s)) = %v;\n", 2185 c!:find_literal car v, get(cdr v, 'c!:chosen)); 2186 if depth neq 0 then c!:printf(" popv(%s);\n", depth); 2187 c!:printf(" return error(1, %s, res); }\n", 2188 if eqcar(why, 'car) then "err_bad_car" 2189 else if eqcar(why, 'cdr) then "err_bad_cdr" 2190 else error(0, list(why, "unknown_error"))) >> 2191 else << 2192 for each v in env do 2193 c!:printf(" qvalue(elt(env, %s)) = %v;\n", 2194 c!:find_literal car v, get(cdr v, 'c!:chosen)); 2195 if depth neq 0 then c!:printf(" popv(%s);\n", depth); 2196 c!:printf(" return error(1, %s, %v);\n", 2197 (if eqcar(why, 'car) then "err_bad_car" 2198 else if eqcar(why, 'cdr) then "err_bad_cdr" 2199 else error(0, list(why, "unknown_error"))), 2200 cadr why) >> 2201 end; 2202 2203 2204% 2205% Now I have a series of separable sections each of which gives a special 2206% recipe that implements or optimises compilation of some specific Lisp 2207% form. 2208% 2209 2210symbolic procedure c!:cand(u, env); 2211 begin 2212 scalar w, r; 2213 w := reverse cdr u; 2214 if null w then return c!:cval(nil, env); 2215 r := list(list('t, car w)); 2216 w := cdr w; 2217 for each z in w do 2218 r := list(list('null, z), nil) . r; 2219 r := 'cond . r; 2220 return c!:cval(r, env) 2221 end; 2222%-- scalar next, done, v, r; 2223%-- v := c!:newreg(); 2224%-- done := c!:my_gensym(); 2225%-- u := cdr u; 2226%-- while cdr u do << 2227%-- next := c!:my_gensym(); 2228%-- c!:outop('movr, v, nil, c!:cval(car u, env)); 2229%-- u := cdr u; 2230%-- c!:endblock(list('ifnull, v), list(done, next)); 2231%-- c!:startblock next >>; 2232%-- c!:outop('movr, v, nil, c!:cval(car u, env)); 2233%-- c!:endblock('goto, list done); 2234%-- c!:startblock done; 2235%-- return v 2236%-- end; 2237 2238put('and, 'c!:code, function c!:cand); 2239 2240!#if common!-lisp!-mode 2241 2242symbolic procedure c!:cblock(u, env); 2243 begin 2244 scalar progret, progexit, r; 2245 progret := c!:newreg(); 2246 progexit := c!:my_gensym(); 2247 blockstack := (cadr u . progret . progexit) . blockstack; 2248 u := cddr u; 2249 for each a in u do r := c!:cval(a, env); 2250 c!:outop('movr, progret, nil, r); 2251 c!:endblock('goto, list progexit); 2252 c!:startblock progexit; 2253 blockstack := cdr blockstack; 2254 return progret 2255 end; 2256 2257 2258put('block, 'c!:code, function c!:cblock); 2259 2260!#endif 2261 2262symbolic procedure c!:ccatch(u, env); 2263 error(0, "catch"); 2264 2265put('catch, 'c!:code, function c!:ccatch); 2266 2267symbolic procedure c!:ccompile_let(u, env); 2268 error(0, "compiler-let"); 2269 2270put('compiler!-let, 'c!:code, function c!:ccompiler_let); 2271 2272symbolic procedure c!:ccond(u, env); 2273 begin 2274 scalar v, join; 2275 v := c!:newreg(); 2276 join := c!:my_gensym(); 2277 for each c in cdr u do begin 2278 scalar l1, l2; 2279 l1 := c!:my_gensym(); l2 := c!:my_gensym(); 2280 if atom cdr c then << 2281 c!:outop('movr, v, nil, c!:cval(car c, env)); 2282 c!:endblock(list('ifnull, v), list(l2, join)) >> 2283 else << 2284 c!:cjumpif(car c, env, l1, l2); 2285 c!:startblock l1; % if the condition is true 2286 c!:outop('movr, v, nil, c!:cval('progn . cdr c, env)); 2287 c!:endblock('goto, list join) >>; 2288 c!:startblock l2 end; 2289 c!:outop('movk1, v, nil, nil); 2290 c!:endblock('goto, list join); 2291 c!:startblock join; 2292 return v 2293 end; 2294 2295put('cond, 'c!:code, function c!:ccond); 2296 2297symbolic procedure c!:valid_cond x; 2298 if null x then t 2299 else if not c!:valid_list car x then nil 2300 else c!:valid_cond cdr x; 2301 2302put('cond, 'c!:valid, function c!:valid_cond); 2303 2304symbolic procedure c!:cdeclare(u, env); 2305 error(0, "declare"); 2306 2307put('declare, 'c!:code, function c!:cdeclare); 2308 2309symbolic procedure c!:cde(u, env); 2310 error(0, "de"); 2311 2312put('de, 'c!:code, function c!:cde); 2313 2314symbolic procedure c!:cdefun(u, env); 2315 error(0, "defun"); 2316 2317put('!~defun, 'c!:code, function c!:cdefun); 2318 2319symbolic procedure c!:ceval_when(u, env); 2320 error(0, "eval-when"); 2321 2322put('eval!-when, 'c!:code, function c!:ceval_when); 2323 2324symbolic procedure c!:cflet(u, env); 2325 error(0, "flet"); 2326 2327put('flet, 'c!:code, function c!:cflet); 2328 2329 2330symbolic procedure c!:cfunction(u, env); 2331 begin 2332 scalar v; 2333 u := cadr u; 2334 if not atom u then << 2335 if not eqcar(u, 'lambda) then 2336 error(0, list("lambda expression needed", u)); 2337 v := dated!-name 'lambda; 2338 pending_functions := 2339 ('de . v . cdr u) . pending_functions; 2340 u := v >>; 2341 v := c!:newreg(); 2342 c!:outop('movk, v, u, c!:find_literal u); 2343 return v; 2344 end; 2345 2346symbolic procedure c!:valid_function x; 2347 if atom x then nil 2348 else if not null cdr x then nil 2349 else if idp car x then t 2350 else if atom car x then nil 2351 else if not eqcar(car x, 'lambda) then nil 2352 else if atom cdar x then nil 2353 else c!:valid_fndef(cadar x, cddar x); 2354 2355put('function, 'c!:code, function c!:cfunction); 2356put('function, 'c!:valid, function c!:valid_function); 2357 2358symbolic procedure c!:cgo(u, env); 2359 begin 2360 scalar w, w1; 2361 w1 := proglabs; 2362 while null w and w1 do << 2363 w := assoc!*!*(cadr u, car w1); 2364 w1 := cdr w1 >>; 2365 if null w then error(0, list(u, "label not set")); 2366 c!:endblock('goto, list cadr w); 2367 return nil % value should not be used 2368 end; 2369 2370put('go, 'c!:code, function c!:cgo); 2371put('go, 'c!:valid, function c!:valid_quote); 2372 2373symbolic procedure c!:cif(u, env); 2374 begin 2375 scalar v, join, l1, l2, w; 2376 v := c!:newreg(); 2377 join := c!:my_gensym(); 2378 l1 := c!:my_gensym(); 2379 l2 := c!:my_gensym(); 2380 c!:cjumpif(car (u := cdr u), env, l1, l2); 2381 c!:startblock l1; 2382 c!:outop('movr, v, nil, c!:cval(car (u := cdr u), env)); 2383 c!:endblock('goto, list join); 2384 c!:startblock l2; 2385 u := cdr u; 2386 if u then u := car u; % permit 2-arg version... 2387 c!:outop('movr, v, nil, c!:cval(u, env)); 2388 c!:endblock('goto, list join); 2389 c!:startblock join; 2390 return v 2391 end; 2392 2393put('if, 'c!:code, function c!:cif); 2394 2395symbolic procedure c!:clabels(u, env); 2396 error(0, "labels"); 2397 2398put('labels, 'c!:code, function c!:clabels); 2399 2400symbolic procedure c!:expand!-let(vl, b); 2401 if null vl then 'progn . b 2402 else if null cdr vl then c!:expand!-let!*(vl, b) 2403 else begin scalar vars, vals; 2404 for each v in vl do 2405 if atom v then << vars := v . vars; vals := nil . vals >> 2406 else if atom cdr v then << vars := car v . vars; vals := nil . vals >> 2407 else << vars := car v . vars; vals := cadr v . vals >>; 2408% if there is any DECLARE it will be at the start of b and the code that 2409% deals with LAMBDA will cope with it. 2410 return ('lambda . vars . b) . vals 2411 end; 2412 2413symbolic procedure c!:clet(x, env); 2414 c!:cval(c!:expand!-let(cadr x, cddr x), env); 2415 2416symbolic procedure c!:valid_let x; 2417 if null x then t 2418 else if not c!:valid_cond car x then nil 2419 else c!:valid_list cdr x; 2420 2421 2422!#if common!-lisp!-mode 2423put('let, 'c!:code, function c!:clet); 2424put('let, 'c!:valid, function c!:valid_let); 2425!#else 2426put('!~let, 'c!:code, function c!:clet); 2427put('!~let, 'c!:valid, function c!:valid_let); 2428!#endif 2429 2430symbolic procedure c!:expand!-let!*(vl, b); 2431 if null vl then 'progn . b 2432 else begin scalar var, val; 2433 var := car vl; 2434 if not atom var then << 2435 val := cdr var; 2436 var := car var; 2437 if not atom val then val := car val >>; 2438 b := list list('return, c!:expand!-let!*(cdr vl, b)); 2439 if val then b := list('setq, var, val) . b; 2440 return 'prog . list var . b 2441 end; 2442 2443symbolic procedure c!:clet!*(x, env); 2444 c!:cval(c!:expand!-let!*(cadr x, cddr x), env); 2445 2446put('let!*, 'c!:code, function c!:clet!*); 2447put('let!*, 'c!:valid, function c!:valid_let); 2448 2449symbolic procedure c!:clist(u, env); 2450 if null cdr u then c!:cval(nil, env) 2451 else if null cddr u then c!:cval('ncons . cdr u, env) 2452 else if eqcar(cadr u, 'cons) then 2453 c!:cval(list('acons, cadr cadr u, caddr cadr u, 'list . cddr u), env) 2454 else if null cdddr u then c!:cval('list2 . cdr u, env) 2455 else if null cddddr u then c!:cval('list3 . cdr u, env) 2456 else if null cdr cddddr u then c!:cval('list4 . cdr u, env) 2457 else c!:cval(list('list3!*, cadr u, caddr u, 2458 cadddr u, 'list . cddddr u), env); 2459 2460put('list, 'c!:code, function c!:clist); 2461 2462symbolic procedure c!:clist!*(u, env); 2463 begin 2464 scalar v; 2465 u := reverse cdr u; 2466 v := car u; 2467 for each a in cdr u do 2468 v := list('cons, a, v); 2469 return c!:cval(v, env) 2470 end; 2471 2472put('list!*, 'c!:code, function c!:clist!*); 2473 2474symbolic procedure c!:ccons(u, env); 2475 begin 2476 scalar a1, a2; 2477 a1 := s!:improve cadr u; 2478 a2 := s!:improve caddr u; 2479 if a2 = nil or a2 = '(quote nil) or a2 = '(list) then 2480 return c!:cval(list('ncons, a1), env); 2481 if eqcar(a1, 'cons) then 2482 return c!:cval(list('acons, cadr a1, caddr a1, a2), env); 2483 if eqcar(a2, 'cons) then 2484 return c!:cval(list('list2!*, a1, cadr a2, caddr a2), env); 2485 if eqcar(a2, 'list) then 2486 return c!:cval(list('cons, a1, 2487 list('cons, cadr a2, 'list . cddr a2)), env); 2488 return c!:ccall(car u, cdr u, env) 2489 end; 2490 2491put('cons, 'c!:code, function c!:ccons); 2492 2493symbolic procedure c!:cget(u, env); 2494 begin 2495 scalar a1, a2, w, r, r1; 2496 a1 := s!:improve cadr u; 2497 a2 := s!:improve caddr u; 2498 if eqcar(a2, 'quote) and idp(w := cadr a2) and 2499 (w := symbol!-make!-fastget(w, nil)) then << 2500 r := c!:newreg(); 2501 c!:outop('fastget, r, c!:cval(a1, env), w . cadr a2); 2502 return r >> 2503 else return c!:ccall(car u, cdr u, env) 2504 end; 2505 2506put('get, 'c!:code, function c!:cget); 2507 2508symbolic procedure c!:cflag(u, env); 2509 begin 2510 scalar a1, a2, w, r, r1; 2511 a1 := s!:improve cadr u; 2512 a2 := s!:improve caddr u; 2513 if eqcar(a2, 'quote) and idp(w := cadr a2) and 2514 (w := symbol!-make!-fastget(w, nil)) then << 2515 r := c!:newreg(); 2516 c!:outop('fastflag, r, c!:cval(a1, env), w . cadr a2); 2517 return r >> 2518 else return c!:ccall(car u, cdr u, env) 2519 end; 2520 2521put('flagp, 'c!:code, function c!:cflag); 2522 2523symbolic procedure c!:cgetv(u, env); 2524 if not !*fastvector then c!:ccall(car u, cdr u, env) 2525 else c!:cval('qgetv . cdr u, env); 2526 2527put('getv, 'c!:code, function c!:cgetv); 2528!#if common!-lisp!-mode 2529put('svref, 'c!:code, function c!:cgetv); 2530!#endif 2531 2532symbolic procedure c!:cputv(u, env); 2533 if not !*fastvector then c!:ccall(car u, cdr u, env) 2534 else c!:cval('qputv . cdr u, env); 2535 2536put('putv, 'c!:code, function c!:cputv); 2537 2538symbolic procedure c!:cqputv(x, env); 2539 begin 2540 scalar rr; 2541 rr := c!:pareval(cdr x, env); 2542 c!:outop('qputv, caddr rr, car rr, cadr rr); 2543 return caddr rr 2544 end; 2545 2546put('qputv, 'c!:code, function c!:cqputv); 2547 2548symbolic procedure c!:cmacrolet(u, env); 2549 error(0, "macrolet"); 2550 2551put('macrolet, 'c!:code, function c!:cmacrolet); 2552 2553symbolic procedure c!:cmultiple_value_call(u, env); 2554 error(0, "multiple_value_call"); 2555 2556put('multiple!-value!-call, 'c!:code, function c!:cmultiple_value_call); 2557 2558symbolic procedure c!:cmultiple_value_prog1(u, env); 2559 error(0, "multiple_value_prog1"); 2560 2561put('multiple!-value!-prog1, 'c!:code, function c!:cmultiple_value_prog1); 2562 2563symbolic procedure c!:cor(u, env); 2564 begin 2565 scalar next, done, v, r; 2566 v := c!:newreg(); 2567 done := c!:my_gensym(); 2568 u := cdr u; 2569 while cdr u do << 2570 next := c!:my_gensym(); 2571 c!:outop('movr, v, nil, c!:cval(car u, env)); 2572 u := cdr u; 2573 c!:endblock(list('ifnull, v), list(next, done)); 2574 c!:startblock next >>; 2575 c!:outop('movr, v, nil, c!:cval(car u, env)); 2576 c!:endblock('goto, list done); 2577 c!:startblock done; 2578 return v 2579 end; 2580 2581put('or, 'c!:code, function c!:cor); 2582 2583symbolic procedure c!:cprog(u, env); 2584 begin 2585 scalar w, w1, bvl, local_proglabs, progret, progexit, 2586 fluids, env1, body, decs; 2587 env1 := car env; 2588 bvl := cadr u; 2589 w := s!:find_local_decs(cddr u, t); 2590 body := cdr w; 2591 localdecs := car w . localdecs; 2592% Anything DECLAREd special that is not already fluid or global 2593% gets uprated now. decs ends up a list of things that had their status 2594% changed. 2595 for each v in bvl do << 2596 if not globalp v and not fluidp v and 2597 c!:local_fluidp(v, localdecs) then << 2598 make!-special v; 2599 decs := v . decs >> >>; 2600 for each v in bvl do << 2601 if globalp v then begin scalar oo; 2602 oo := wrs nil; 2603 princ "+++++ "; prin v; 2604 princ " converted from GLOBAL to FLUID"; terpri(); 2605 wrs oo; 2606 unglobal list v; 2607 fluid list v end; 2608% Note I need to update local_decs 2609 if fluidp v then << 2610 fluids := (v . c!:newreg()) . fluids; 2611 flag(list cdar fluids, 'c!:live_across_call); % silly if not 2612 env1 := ('c!:dummy!:name . cdar fluids) . env1; 2613 c!:outop('ldrglob, cdar fluids, v, c!:find_literal v); 2614 c!:outop('nilglob, nil, v, c!:find_literal v) >> 2615 else << 2616 env1 := (v . c!:newreg()) . env1; 2617 c!:outop('movk1, cdar env1, nil, nil) >> >>; 2618 if fluids then c!:outop('fluidbind, nil, nil, fluids); 2619 env := env1 . append(fluids, cdr env); 2620 u := body; 2621 progret := c!:newreg(); 2622 progexit := c!:my_gensym(); 2623 blockstack := (nil . progret . progexit) . blockstack; 2624 for each a in u do if atom a then 2625 if atsoc(a, local_proglabs) then << 2626 if not null a then << 2627 w := wrs nil; 2628 princ "+++++ multiply defined label: "; prin a; terpri(); wrs w >> >> 2629 else local_proglabs := list(a, c!:my_gensym()) . local_proglabs; 2630 proglabs := local_proglabs . proglabs; 2631 for each a in u do 2632 if atom a then << 2633 w := cdr(assoc!*!*(a, local_proglabs)); 2634 if null cdr w then << 2635 rplacd(w, t); 2636 c!:endblock('goto, list car w); 2637 c!:startblock car w >> >> 2638 else c!:cval(a, env); 2639 c!:outop('movk1, progret, nil, nil); 2640 c!:endblock('goto, list progexit); 2641 c!:startblock progexit; 2642 for each v in fluids do 2643 c!:outop('strglob, cdr v, car v, c!:find_literal car v); 2644 blockstack := cdr blockstack; 2645 proglabs := cdr proglabs; 2646 unfluid decs; % reset effect of DECLARE 2647 localdecs := cdr localdecs; 2648 return progret 2649 end; 2650 2651put('prog, 'c!:code, function c!:cprog); 2652 2653symbolic procedure c!:valid_prog x; 2654 c!:valid_list cdr x; 2655 2656put('prog, 'c!:valid, function c!:valid_prog); 2657 2658symbolic procedure c!:cprog!*(u, env); 2659 error(0, "prog*"); 2660 2661put('prog!*, 'c!:code, function c!:cprog!*); 2662 2663symbolic procedure c!:cprog1(u, env); 2664 begin 2665 scalar g; 2666 g := c!:my_gensym(); 2667 g := list('prog, list g, 2668 list('setq, g, cadr u), 2669 'progn . cddr u, 2670 list('return, g)); 2671 return c!:cval(g, env) 2672 end; 2673 2674put('prog1, 'c!:code, function c!:cprog1); 2675 2676symbolic procedure c!:cprog2(u, env); 2677 begin 2678 scalar g; 2679 u := cdr u; 2680 g := c!:my_gensym(); 2681 g := list('prog, list g, 2682 list('setq, g, cadr u), 2683 'progn . cddr u, 2684 list('return, g)); 2685 g := list('progn, car u, g); 2686 return c!:cval(g, env) 2687 end; 2688 2689put('prog2, 'c!:code, function c!:cprog2); 2690 2691symbolic procedure c!:cprogn(u, env); 2692 begin 2693 scalar r; 2694 u := cdr u; 2695 if u = nil then u := '(nil); 2696 for each s in u do r := c!:cval(s, env); 2697 return r 2698 end; 2699 2700put('progn, 'c!:code, function c!:cprogn); 2701 2702symbolic procedure c!:cprogv(u, env); 2703 error(0, "progv"); 2704 2705put('progv, 'c!:code, function c!:cprogv); 2706 2707symbolic procedure c!:cquote(u, env); 2708 begin 2709 scalar v; 2710 u := cadr u; 2711 v := c!:newreg(); 2712 if null u or u = 't or c!:small_number u then 2713 c!:outop('movk1, v, nil, u) 2714 else c!:outop('movk, v, u, c!:find_literal u); 2715 return v; 2716 end; 2717 2718symbolic procedure c!:valid_quote x; 2719 t; 2720 2721put('quote, 'c!:code, function c!:cquote); 2722put('quote, 'c!:valid, function c!:valid_quote); 2723 2724symbolic procedure c!:creturn(u, env); 2725 begin 2726 scalar w; 2727 w := assoc!*!*(nil, blockstack); 2728 if null w then error(0, "RETURN out of context"); 2729 c!:outop('movr, cadr w, nil, c!:cval(cadr u, env)); 2730 c!:endblock('goto, list cddr w); 2731 return nil % value should not be used 2732 end; 2733 2734put('return, 'c!:code, function c!:creturn); 2735 2736!#if common!-lisp!-mode 2737 2738symbolic procedure c!:creturn_from(u, env); 2739 begin 2740 scalar w; 2741 w := assoc!*!*(cadr u, blockstack); 2742 if null w then error(0, "RETURN-FROM out of context"); 2743 c!:outop('movr, cadr w, nil, c!:cval(caddr u, env)); 2744 c!:endblock('goto, list cddr w); 2745 return nil % value should not be used 2746 end; 2747 2748!#endif 2749 2750put('return!-from, 'c!:code, function c!:creturn_from); 2751 2752symbolic procedure c!:csetq(u, env); 2753 begin 2754 scalar v, w; 2755 v := c!:cval(caddr u, env); 2756 u := cadr u; 2757 if not idp u then error(0, list(u, "bad variable in setq")) 2758 else if (w := c!:locally_bound(u, env)) then 2759 c!:outop('movr, cdr w, nil, v) 2760 else if flagp(u, 'c!:constant) then 2761 error(0, list(u, "attempt to use setq on a constant")) 2762 else c!:outop('strglob, v, u, c!:find_literal u); 2763 return v 2764 end; 2765 2766put('setq, 'c!:code, function c!:csetq); 2767put('noisy!-setq, 'c!:code, function c!:csetq); 2768 2769!#if common!-lisp!-mode 2770 2771symbolic procedure c!:ctagbody(u, env); 2772 begin 2773 scalar w, bvl, local_proglabs, res; 2774 u := cdr u; 2775 for each a in u do if atom a then 2776 if atsoc(a, local_proglabs) then << 2777 if not null a then << 2778 w := wrs nil; 2779 princ "+++++ multiply defined label: "; prin a; terpri(); wrs w >> >> 2780 else local_proglabs := list(a, c!:my_gensym()) . local_proglabs; 2781 proglabs := local_proglabs . proglabs; 2782 for each a in u do 2783 if atom a then << 2784 w := cdr(assoc!*!*(a, local_proglabs)); 2785 if null cdr w then << 2786 rplacd(w, t); 2787 c!:endblock('goto, list car w); 2788 c!:startblock car w >> >> 2789 else res := c!:cval(a, env); 2790 if null res then res := c!:cval(nil, env); 2791 proglabs := cdr proglabs; 2792 return res 2793 end; 2794 2795put('tagbody, 'c!:code, function c!:ctagbody); 2796 2797!#endif 2798 2799symbolic procedure c!:cprivate_tagbody(u, env); 2800% This sets a label for use for tail-call to self. 2801 begin 2802 u := cdr u; 2803 c!:endblock('goto, list car u); 2804 c!:startblock car u; 2805% This seems to be the proper place to capture the internal names associated 2806% with argument-vars that must be reset if a tail-call is mapped into a loop. 2807 c!:current_args := for each v in c!:current_args collect begin 2808 scalar z; 2809 z := assoc!*!*(v, car env); 2810 return if z then cdr z else v end; 2811 return c!:cval(cadr u, env) 2812 end; 2813 2814put('c!:private_tagbody, 'c!:code, function c!:cprivate_tagbody); 2815 2816symbolic procedure c!:cthe(u, env); 2817 c!:cval(caddr u, env); 2818 2819put('the, 'c!:code, function c!:cthe); 2820 2821symbolic procedure c!:cthrow(u, env); 2822 error(0, "throw"); 2823 2824put('throw, 'c!:code, function c!:cthrow); 2825 2826symbolic procedure c!:cunless(u, env); 2827 begin 2828 scalar v, join, l1, l2; 2829 v := c!:newreg(); 2830 join := c!:my_gensym(); 2831 l1 := c!:my_gensym(); 2832 l2 := c!:my_gensym(); 2833 c!:cjumpif(cadr u, env, l2, l1); 2834 c!:startblock l1; 2835 c!:outop('movr, v, nil, c!:cval('progn . cddr u, env)); 2836 c!:endblock('goto, list join); 2837 c!:startblock l2; 2838 c!:outop('movk1, v, nil, nil); 2839 c!:endblock('goto, list join); 2840 c!:startblock join; 2841 return v 2842 end; 2843 2844put('unless, 'c!:code, function c!:cunless); 2845 2846symbolic procedure c!:cunwind_protect(u, env); 2847 error(0, "unwind_protect"); 2848 2849put('unwind!-protect, 'c!:code, function c!:cunwind_protect); 2850 2851symbolic procedure c!:cwhen(u, env); 2852 begin 2853 scalar v, join, l1, l2; 2854 v := c!:newreg(); 2855 join := c!:my_gensym(); 2856 l1 := c!:my_gensym(); 2857 l2 := c!:my_gensym(); 2858 c!:cjumpif(cadr u, env, l1, l2); 2859 c!:startblock l1; 2860 c!:outop('movr, v, nil, c!:cval('progn . cddr u, env)); 2861 c!:endblock('goto, list join); 2862 c!:startblock l2; 2863 c!:outop('movk1, v, nil, nil); 2864 c!:endblock('goto, list join); 2865 c!:startblock join; 2866 return v 2867 end; 2868 2869put('when, 'c!:code, function c!:cwhen); 2870 2871% 2872% End of code to handle special forms - what comes from here on is 2873% more concerned with performance than with speed. 2874% 2875 2876!#if (not common!-lisp!-mode) 2877 2878% mapcar etc are compiled specially as a fudge to achieve an effect as 2879% if proper environment-capture was implemented for the functional 2880% argument (which I do not support at present). 2881 2882symbolic procedure c!:expand_map(fnargs); 2883 begin 2884 scalar carp, fn, fn1, args, var, avar, moveon, l1, r, s, closed; 2885 fn := car fnargs; 2886% if the value of a mapping function is not needed I demote from mapcar to 2887% mapc or from maplist to map. 2888% if context > 1 then << 2889% if fn = 'mapcar then fn := 'mapc 2890% else if fn = 'maplist then fn := 'map >>; 2891 if fn = 'mapc or fn = 'mapcar or fn = 'mapcan then carp := t; 2892 fnargs := cdr fnargs; 2893 if atom fnargs then error(0,"bad arguments to map function"); 2894 fn1 := cadr fnargs; 2895 while eqcar(fn1, 'function) or 2896 (eqcar(fn1, 'quote) and eqcar(cadr fn1, 'lambda)) do << 2897 fn1 := cadr fn1; 2898 closed := t >>; 2899% if closed is false I will insert FUNCALL since I am invoking a function 2900% stored in a variable - NB this means that the word FUNCTION becomes 2901% essential when using mapping operators - this is because I have built 2902% a 2-Lisp rather than a 1-Lisp. 2903 args := car fnargs; 2904 l1 := c!:my_gensym(); 2905 r := c!:my_gensym(); 2906 s := c!:my_gensym(); 2907 var := c!:my_gensym(); 2908 avar := var; 2909 if carp then avar := list('car, avar); 2910 if closed then fn1 := list(fn1, avar) 2911 else fn1 := list('apply1, fn1, avar); 2912 moveon := list('setq, var, list('cdr, var)); 2913 if fn = 'map or fn = 'mapc then fn := sublis( 2914 list('l1 . l1, 'var . var, 2915 'fn . fn1, 'args . args, 'moveon . moveon), 2916 '(prog (var) 2917 (setq var args) 2918 l1 (cond 2919 ((not var) (return nil))) 2920 fn 2921 moveon 2922 (go l1))) 2923 else if fn = 'maplist or fn = 'mapcar then fn := sublis( 2924 list('l1 . l1, 'var . var, 2925 'fn . fn1, 'args . args, 'moveon . moveon, 'r . r), 2926 '(prog (var r) 2927 (setq var args) 2928 l1 (cond 2929 ((not var) (return (reversip r)))) 2930 (setq r (cons fn r)) 2931 moveon 2932 (go l1))) 2933 else fn := sublis( 2934 list('l1 . l1, 'l2 . c!:my_gensym(), 'var . var, 2935 'fn . fn1, 'args . args, 'moveon . moveon, 2936 'r . c!:my_gensym(), 's . c!:my_gensym()), 2937 '(prog (var r s) 2938 (setq var args) 2939 (setq r (setq s (list nil))) 2940 l1 (cond 2941 ((not var) (return (cdr r)))) 2942 (rplacd s fn) 2943 l2 (cond 2944 ((not (atom (cdr s))) (setq s (cdr s)) (go l2))) 2945 moveon 2946 (go l1))); 2947 return fn 2948 end; 2949 2950 2951put('map, 'c!:compile_macro, function c!:expand_map); 2952put('maplist, 'c!:compile_macro, function c!:expand_map); 2953put('mapc, 'c!:compile_macro, function c!:expand_map); 2954put('mapcar, 'c!:compile_macro, function c!:expand_map); 2955put('mapcon, 'c!:compile_macro, function c!:expand_map); 2956put('mapcan, 'c!:compile_macro, function c!:expand_map); 2957 2958!#endif 2959 2960% caaar to cddddr get expanded into compositions of 2961% car, cdr which are compiled in-line 2962 2963symbolic procedure c!:expand_carcdr(x); 2964 begin 2965 scalar name; 2966 name := cdr reverse cdr explode2 car x; 2967 x := cadr x; 2968 for each v in name do 2969 x := list(if v = 'a then 'car else 'cdr, x); 2970 return x 2971 end; 2972 2973<< put('caar, 'c!:compile_macro, function c!:expand_carcdr); 2974 put('cadr, 'c!:compile_macro, function c!:expand_carcdr); 2975 put('cdar, 'c!:compile_macro, function c!:expand_carcdr); 2976 put('cddr, 'c!:compile_macro, function c!:expand_carcdr); 2977 put('caaar, 'c!:compile_macro, function c!:expand_carcdr); 2978 put('caadr, 'c!:compile_macro, function c!:expand_carcdr); 2979 put('cadar, 'c!:compile_macro, function c!:expand_carcdr); 2980 put('caddr, 'c!:compile_macro, function c!:expand_carcdr); 2981 put('cdaar, 'c!:compile_macro, function c!:expand_carcdr); 2982 put('cdadr, 'c!:compile_macro, function c!:expand_carcdr); 2983 put('cddar, 'c!:compile_macro, function c!:expand_carcdr); 2984 put('cdddr, 'c!:compile_macro, function c!:expand_carcdr); 2985 put('caaaar, 'c!:compile_macro, function c!:expand_carcdr); 2986 put('caaadr, 'c!:compile_macro, function c!:expand_carcdr); 2987 put('caadar, 'c!:compile_macro, function c!:expand_carcdr); 2988 put('caaddr, 'c!:compile_macro, function c!:expand_carcdr); 2989 put('cadaar, 'c!:compile_macro, function c!:expand_carcdr); 2990 put('cadadr, 'c!:compile_macro, function c!:expand_carcdr); 2991 put('caddar, 'c!:compile_macro, function c!:expand_carcdr); 2992 put('cadddr, 'c!:compile_macro, function c!:expand_carcdr); 2993 put('cdaaar, 'c!:compile_macro, function c!:expand_carcdr); 2994 put('cdaadr, 'c!:compile_macro, function c!:expand_carcdr); 2995 put('cdadar, 'c!:compile_macro, function c!:expand_carcdr); 2996 put('cdaddr, 'c!:compile_macro, function c!:expand_carcdr); 2997 put('cddaar, 'c!:compile_macro, function c!:expand_carcdr); 2998 put('cddadr, 'c!:compile_macro, function c!:expand_carcdr); 2999 put('cdddar, 'c!:compile_macro, function c!:expand_carcdr); 3000 put('cddddr, 'c!:compile_macro, function c!:expand_carcdr) >>; 3001 3002symbolic procedure c!:builtin_one(x, env); 3003 begin 3004 scalar r1, r2; 3005 r1 := c!:cval(cadr x, env); 3006 c!:outop(car x, r2:=c!:newreg(), cdr env, r1); 3007 return r2 3008 end; 3009 3010symbolic procedure c!:builtin_two(x, env); 3011 begin 3012 scalar a1, a2, r, rr; 3013 a1 := cadr x; 3014 a2 := caddr x; 3015 rr := c!:pareval(list(a1, a2), env); 3016 c!:outop(car x, r:=c!:newreg(), car rr, cadr rr); 3017 return r 3018 end; 3019 3020symbolic procedure c!:narg(x, env); 3021 c!:cval(expand(cdr x, get(car x, 'c!:binary_version)), env); 3022 3023for each n in 3024 '((plus plus2) 3025 (times times2) 3026 (iplus iplus2) 3027 (itimes itimes2)) do << 3028 put(car n, 'c!:binary_version, cadr n); 3029 put(car n, 'c!:code, function c!:narg) >>; 3030 3031!#if common!-lisp!-mode 3032for each n in 3033 '((!+ plus2) 3034 (!* times2)) do << 3035 put(car n, 'c!:binary_version, cadr n); 3036 put(car n, 'c!:code, function c!:narg) >>; 3037!#endif 3038 3039symbolic procedure c!:cplus2(u, env); 3040 begin 3041 scalar a, b; 3042 a := s!:improve cadr u; 3043 b := s!:improve caddr u; 3044 return if numberp a and numberp b then c!:cval(a+b, env) 3045 else if a = 0 then c!:cval(b, env) 3046 else if a = 1 then c!:cval(list('add1, b), env) 3047 else if b = 0 then c!:cval(a, env) 3048 else if b = 1 then c!:cval(list('add1, a), env) 3049 else if b = -1 then c!:cval(list('sub1, a), env) 3050 else c!:ccall(car u, cdr u, env) 3051 end; 3052 3053put('plus2, 'c!:code, function c!:cplus2); 3054 3055symbolic procedure c!:ciplus2(u, env); 3056 begin 3057 scalar a, b; 3058 a := s!:improve cadr u; 3059 b := s!:improve caddr u; 3060 return if numberp a and numberp b then c!:cval(a+b, env) 3061 else if a = 0 then c!:cval(b, env) 3062 else if a = 1 then c!:cval(list('iadd1, b), env) 3063 else if b = 0 then c!:cval(a, env) 3064 else if b = 1 then c!:cval(list('iadd1, a), env) 3065 else if b = -1 then c!:cval(list('isub1, a), env) 3066 else c!:builtin_two(u, env) 3067 end; 3068 3069put('iplus2, 'c!:code, function c!:ciplus2); 3070 3071symbolic procedure c!:cdifference(u, env); 3072 begin 3073 scalar a, b; 3074 a := s!:improve cadr u; 3075 b := s!:improve caddr u; 3076 return if numberp a and numberp b then c!:cval(a-b, env) 3077 else if a = 0 then c!:cval(list('minus, b), env) 3078 else if b = 0 then c!:cval(a, env) 3079 else if b = 1 then c!:cval(list('sub1, a), env) 3080 else if b = -1 then c!:cval(list('add1, a), env) 3081 else c!:ccall(car u, cdr u, env) 3082 end; 3083 3084put('difference, 'c!:code, function c!:cdifference); 3085 3086symbolic procedure c!:cidifference(u, env); 3087 begin 3088 scalar a, b; 3089 a := s!:improve cadr u; 3090 b := s!:improve caddr u; 3091 return if numberp a and numberp b then c!:cval(a-b, env) 3092 else if a = 0 then c!:cval(list('iminus, b), env) 3093 else if b = 0 then c!:cval(a, env) 3094 else if b = 1 then c!:cval(list('isub1, a), env) 3095 else if b = -1 then c!:cval(list('iadd1, a), env) 3096 else c!:builtin_two(u, env) 3097 end; 3098 3099put('idifference, 'c!:code, function c!:cidifference); 3100 3101symbolic procedure c!:ctimes2(u, env); 3102 begin 3103 scalar a, b; 3104 a := s!:improve cadr u; 3105 b := s!:improve caddr u; 3106 return if numberp a and numberp b then c!:cval(a*b, env) 3107 else if a = 0 or b = 0 then c!:cval(0, env) 3108 else if a = 1 then c!:cval(b, env) 3109 else if b = 1 then c!:cval(a, env) 3110 else if a = -1 then c!:cval(list('minus, b), env) 3111 else if b = -1 then c!:cval(list('minus, a), env) 3112 else c!:ccall(car u, cdr u, env) 3113 end; 3114 3115put('times2, 'c!:code, function c!:ctimes2); 3116 3117symbolic procedure c!:citimes2(u, env); 3118 begin 3119 scalar a, b; 3120 a := s!:improve cadr u; 3121 b := s!:improve caddr u; 3122 return if numberp a and numberp b then c!:cval(a*b, env) 3123 else if a = 0 or b = 0 then c!:cval(0, env) 3124 else if a = 1 then c!:cval(b, env) 3125 else if b = 1 then c!:cval(a, env) 3126 else if a = -1 then c!:cval(list('iminus, b), env) 3127 else if b = -1 then c!:cval(list('iminus, a), env) 3128 else c!:builtin_two(u, env) 3129 end; 3130 3131put('itimes2, 'c!:code, function c!:citimes2); 3132 3133symbolic procedure c!:cminus(u, env); 3134 begin 3135 scalar a, b; 3136 a := s!:improve cadr u; 3137 return if numberp a then c!:cval(-a, env) 3138 else if eqcar(a, 'minus) then c!:cval(cadr a, env) 3139 else c!:ccall(car u, cdr u, env) 3140 end; 3141 3142put('minus, 'c!:code, function c!:cminus); 3143 3144symbolic procedure c!:ceq(x, env); 3145 begin 3146 scalar a1, a2, r, rr; 3147 a1 := s!:improve cadr x; 3148 a2 := s!:improve caddr x; 3149 if a1 = nil then return c!:cval(list('null, a2), env) 3150 else if a2 = nil then return c!:cval(list('null, a1), env); 3151 rr := c!:pareval(list(a1, a2), env); 3152 c!:outop('eq, r:=c!:newreg(), car rr, cadr rr); 3153 return r 3154 end; 3155 3156put('eq, 'c!:code, function c!:ceq); 3157 3158symbolic procedure c!:cequal(x, env); 3159 begin 3160 scalar a1, a2, r, rr; 3161 a1 := s!:improve cadr x; 3162 a2 := s!:improve caddr x; 3163 if a1 = nil then return c!:cval(list('null, a2), env) 3164 else if a2 = nil then return c!:cval(list('null, a1), env); 3165 rr := c!:pareval(list(a1, a2), env); 3166 c!:outop((if c!:eqvalid a1 or c!:eqvalid a2 then 'eq else 'equal), 3167 r:=c!:newreg(), car rr, cadr rr); 3168 return r 3169 end; 3170 3171put('equal, 'c!:code, function c!:cequal); 3172 3173 3174% 3175% The next few cases are concerned with demoting functions that use 3176% equal tests into ones that use eq instead 3177 3178symbolic procedure c!:is_fixnum x; 3179 fixp x and x >= -134217728 and x <= 134217727; 3180 3181symbolic procedure c!:certainlyatom x; 3182 null x or x=t or c!:is_fixnum x or 3183 (eqcar(x, 'quote) and (symbolp cadr x or c!:is_fixnum cadr x)); 3184 3185symbolic procedure c!:atomlist1 u; 3186 atom u or 3187 ((symbolp car u or c!:is_fixnum car u) and c!:atomlist1 cdr u); 3188 3189symbolic procedure c!:atomlist x; 3190 null x or 3191 (eqcar(x, 'quote) and c!:atomlist1 cadr x) or 3192 (eqcar(x, 'list) and 3193 (null cdr x or 3194 (c!:certainlyatom cadr x and 3195 c!:atomlist ('list . cddr x)))) or 3196 (eqcar(x, 'cons) and 3197 c!:certainlyatom cadr x and 3198 c!:atomlist caddr x); 3199 3200symbolic procedure c!:atomcar x; 3201 (eqcar(x, 'cons) or eqcar(x, 'list)) and 3202 not null cdr x and 3203 c!:certainlyatom cadr x; 3204 3205symbolic procedure c!:atomkeys1 u; 3206 atom u or 3207 (not atom car u and 3208 (symbolp caar u or c!:is_fixnum caar u) and 3209 c!:atomlist1 cdr u); 3210 3211symbolic procedure c!:atomkeys x; 3212 null x or 3213 (eqcar(x, 'quote) and c!:atomkeys1 cadr x) or 3214 (eqcar(x, 'list) and 3215 (null cdr x or 3216 (c!:atomcar cadr x and 3217 c!:atomkeys ('list . cddr x)))) or 3218 (eqcar(x, 'cons) and 3219 c!:atomcar cadr x and 3220 c!:atomkeys caddr x); 3221 3222!#if (not common!-lisp!-mode) 3223 3224symbolic procedure c!:comsublis x; 3225 if c!:atomkeys cadr x then 'subla . cdr x 3226 else nil; 3227 3228put('sublis, 'c!:compile_macro, function c!:comsublis); 3229 3230symbolic procedure c!:comassoc x; 3231 if c!:certainlyatom cadr x or c!:atomkeys caddr x then 'atsoc . cdr x 3232 else nil; 3233 3234put('assoc, 'c!:compile_macro, function c!:comassoc); 3235put('assoc!*!*, 'c!:compile_macro, function c!:comassoc); 3236 3237symbolic procedure c!:commember x; 3238 if c!:certainlyatom cadr x or c!:atomlist caddr x then 'memq . cdr x 3239 else nil; 3240 3241put('member, 'c!:compile_macro, function c!:commember); 3242 3243symbolic procedure c!:comdelete x; 3244 if c!:certainlyatom cadr x or c!:atomlist caddr x then 'deleq . cdr x 3245 else nil; 3246 3247put('delete, 'c!:compile_macro, function c!:comdelete); 3248 3249!#endif 3250 3251symbolic procedure c!:ctestif(x, env, d1, d2); 3252 begin 3253 scalar l1, l2; 3254 l1 := c!:my_gensym(); 3255 l2 := c!:my_gensym(); 3256 c!:jumpif(cadr x, l1, l2); 3257 x := cddr x; 3258 c!:startblock l1; 3259 c!:jumpif(car x, d1, d2); 3260 c!:startblock l2; 3261 c!:jumpif(cadr x, d1, d2) 3262 end; 3263 3264put('if, 'c!:ctest, function c!:ctestif); 3265 3266symbolic procedure c!:ctestnull(x, env, d1, d2); 3267 c!:cjumpif(cadr x, env, d2, d1); 3268 3269put('null, 'c!:ctest, function c!:ctestnull); 3270put('not, 'c!:ctest, function c!:ctestnull); 3271 3272symbolic procedure c!:ctestatom(x, env, d1, d2); 3273 begin 3274 x := c!:cval(cadr x, env); 3275 c!:endblock(list('ifatom, x), list(d1, d2)) 3276 end; 3277 3278put('atom, 'c!:ctest, function c!:ctestatom); 3279 3280symbolic procedure c!:ctestconsp(x, env, d1, d2); 3281 begin 3282 x := c!:cval(cadr x, env); 3283 c!:endblock(list('ifatom, x), list(d2, d1)) 3284 end; 3285 3286put('consp, 'c!:ctest, function c!:ctestconsp); 3287 3288symbolic procedure c!:ctestsymbol(x, env, d1, d2); 3289 begin 3290 x := c!:cval(cadr x, env); 3291 c!:endblock(list('ifsymbol, x), list(d1, d2)) 3292 end; 3293 3294put('idp, 'c!:ctest, function c!:ctestsymbol); 3295 3296symbolic procedure c!:ctestnumberp(x, env, d1, d2); 3297 begin 3298 x := c!:cval(cadr x, env); 3299 c!:endblock(list('ifnumber, x), list(d1, d2)) 3300 end; 3301 3302put('numberp, 'c!:ctest, function c!:ctestnumberp); 3303 3304symbolic procedure c!:ctestizerop(x, env, d1, d2); 3305 begin 3306 x := c!:cval(cadr x, env); 3307 c!:endblock(list('ifizerop, x), list(d1, d2)) 3308 end; 3309 3310put('izerop, 'c!:ctest, function c!:ctestizerop); 3311 3312symbolic procedure c!:ctesteq(x, env, d1, d2); 3313 begin 3314 scalar a1, a2, r; 3315 a1 := cadr x; 3316 a2 := caddr x; 3317 if a1 = nil then return c!:cjumpif(a2, env, d2, d1) 3318 else if a2 = nil then return c!:cjumpif(a1, env, d2, d1); 3319 r := c!:pareval(list(a1, a2), env); 3320 c!:endblock('ifeq . r, list(d1, d2)) 3321 end; 3322 3323put('eq, 'c!:ctest, function c!:ctesteq); 3324 3325symbolic procedure c!:ctesteqcar(x, env, d1, d2); 3326 begin 3327 scalar a1, a2, r, d3; 3328 a1 := cadr x; 3329 a2 := caddr x; 3330 d3 := c!:my_gensym(); 3331 r := c!:pareval(list(a1, a2), env); 3332 c!:endblock(list('ifatom, car r), list(d2, d3)); 3333 c!:startblock d3; 3334 c!:outop('qcar, car r, nil, car r); 3335 c!:endblock('ifeq . r, list(d1, d2)) 3336 end; 3337 3338put('eqcar, 'c!:ctest, function c!:ctesteqcar); 3339 3340global '(least_fixnum greatest_fixnum); 3341 3342least_fixnum := -expt(2, 27); 3343greatest_fixnum := expt(2, 27) - 1; 3344 3345symbolic procedure c!:small_number x; 3346 fixp x and x >= least_fixnum and x <= greatest_fixnum; 3347 3348symbolic procedure c!:eqvalid x; 3349 if atom x then c!:small_number x 3350 else if flagp(car x, 'c!:fixnum_fn) then t 3351 else car x = 'quote and (idp cadr x or c!:small_number cadr x); 3352 3353flag('(iplus iplus2 idifference iminus itimes itimes2), 'c!:fixnum_fn); 3354 3355symbolic procedure c!:ctestequal(x, env, d1, d2); 3356 begin 3357 scalar a1, a2, r; 3358 a1 := s!:improve cadr x; 3359 a2 := s!:improve caddr x; 3360 if a1 = nil then return c!:cjumpif(a2, env, d2, d1) 3361 else if a2 = nil then return c!:cjumpif(a1, env, d2, d1); 3362 r := c!:pareval(list(a1, a2), env); 3363 c!:endblock((if c!:eqvalid a1 or c!:eqvalid a2 then 'ifeq else 'ifequal) . 3364 r, list(d1, d2)) 3365 end; 3366 3367put('equal, 'c!:ctest, function c!:ctestequal); 3368 3369symbolic procedure c!:ctestneq(x, env, d1, d2); 3370 begin 3371 scalar a1, a2, r; 3372 a1 := s!:improve cadr x; 3373 a2 := s!:improve caddr x; 3374 if a1 = nil then return c!:cjumpif(a2, env, d1, d2) 3375 else if a2 = nil then return c!:cjumpif(a1, env, d1, d2); 3376 r := c!:pareval(list(a1, a2), env); 3377 c!:endblock((if c!:eqvalid a1 or c!:eqvalid a2 then 'ifeq else 'ifequal) . 3378 r, list(d2, d1)) 3379 end; 3380 3381put('neq, 'c!:ctest, function c!:ctestneq); 3382 3383symbolic procedure c!:ctestilessp(x, env, d1, d2); 3384 begin 3385 scalar r; 3386 r := c!:pareval(list(cadr x, caddr x), env); 3387 c!:endblock('ifilessp . r, list(d1, d2)) 3388 end; 3389 3390put('ilessp, 'c!:ctest, function c!:ctestilessp); 3391 3392symbolic procedure c!:ctestigreaterp(x, env, d1, d2); 3393 begin 3394 scalar r; 3395 r := c!:pareval(list(cadr x, caddr x), env); 3396 c!:endblock('ifigreaterp . r, list(d1, d2)) 3397 end; 3398 3399put('igreaterp, 'c!:ctest, function c!:ctestigreaterp); 3400 3401symbolic procedure c!:ctestand(x, env, d1, d2); 3402 begin 3403 scalar next; 3404 for each a in cdr x do << 3405 next := c!:my_gensym(); 3406 c!:cjumpif(a, env, next, d2); 3407 c!:startblock next >>; 3408 c!:endblock('goto, list d1) 3409 end; 3410 3411put('and, 'c!:ctest, function c!:ctestand); 3412 3413symbolic procedure c!:ctestor(x, env, d1, d2); 3414 begin 3415 scalar next; 3416 for each a in cdr x do << 3417 next := c!:my_gensym(); 3418 c!:cjumpif(a, env, d1, next); 3419 c!:startblock next >>; 3420 c!:endblock('goto, list d2) 3421 end; 3422 3423put('or, 'c!:ctest, function c!:ctestor); 3424 3425% Here are some of the things that are built into the Lisp kernel 3426% and that I am happy to allow the compiler to generate direct calls to. 3427% But NOTE that if any of these were callable with eg either 1 or 2 args 3428% I would need DIFFERENT C entrypoints for each such case. To that effect 3429% I need to change this to have 3430% c!:c_entrypoint1, c!:c_entrypoint2 and c!:c_entrypointn 3431% rather than a single property name. 3432 3433fluid '(c!:c_entrypoint_list); 3434 3435null (c!:c_entrypoint_list := '( 3436 (abs c!:c_entrypoint "Labsval") 3437% (acons c!:c_entrypoint "Lacons") 3438% (add1 c!:c_entrypoint "Ladd1") 3439% (apply c!:c_entrypoint "Lapply") 3440 (apply0 c!:c_entrypoint "Lapply0") 3441 (apply1 c!:c_entrypoint "Lapply1") 3442 (apply2 c!:c_entrypoint "Lapply2") 3443 (apply3 c!:c_entrypoint "Lapply3") 3444% (ash c!:c_entrypoint "Lash") 3445 (ash1 c!:c_entrypoint "Lash1") 3446 (atan c!:c_entrypoint "Latan") 3447 (atom c!:c_entrypoint "Latom") 3448 (atsoc c!:c_entrypoint "Latsoc") 3449 (batchp c!:c_entrypoint "Lbatchp") 3450 (boundp c!:c_entrypoint "Lboundp") 3451 (bps!-putv c!:c_entrypoint "Lbpsputv") 3452 (caaaar c!:c_entrypoint "Lcaaaar") 3453 (caaadr c!:c_entrypoint "Lcaaadr") 3454 (caaar c!:c_entrypoint "Lcaaar") 3455 (caadar c!:c_entrypoint "Lcaadar") 3456 (caaddr c!:c_entrypoint "Lcaaddr") 3457 (caadr c!:c_entrypoint "Lcaadr") 3458 (caar c!:c_entrypoint "Lcaar") 3459 (cadaar c!:c_entrypoint "Lcadaar") 3460 (cadadr c!:c_entrypoint "Lcadadr") 3461 (cadar c!:c_entrypoint "Lcadar") 3462 (caddar c!:c_entrypoint "Lcaddar") 3463 (cadddr c!:c_entrypoint "Lcadddr") 3464 (caddr c!:c_entrypoint "Lcaddr") 3465 (cadr c!:c_entrypoint "Lcadr") 3466 (car c!:c_entrypoint "Lcar") 3467 (cdaaar c!:c_entrypoint "Lcdaaar") 3468 (cdaadr c!:c_entrypoint "Lcdaadr") 3469 (cdaar c!:c_entrypoint "Lcdaar") 3470 (cdadar c!:c_entrypoint "Lcdadar") 3471 (cdaddr c!:c_entrypoint "Lcdaddr") 3472 (cdadr c!:c_entrypoint "Lcdadr") 3473 (cdar c!:c_entrypoint "Lcdar") 3474 (cddaar c!:c_entrypoint "Lcddaar") 3475 (cddadr c!:c_entrypoint "Lcddadr") 3476 (cddar c!:c_entrypoint "Lcddar") 3477 (cdddar c!:c_entrypoint "Lcdddar") 3478 (cddddr c!:c_entrypoint "Lcddddr") 3479 (cdddr c!:c_entrypoint "Lcdddr") 3480 (cddr c!:c_entrypoint "Lcddr") 3481 (cdr c!:c_entrypoint "Lcdr") 3482 (char!-code c!:c_entrypoint "Lchar_code") 3483 (close c!:c_entrypoint "Lclose") 3484 (codep c!:c_entrypoint "Lcodep") 3485 (constantp c!:c_entrypoint "Lconstantp") 3486% (cons c!:c_entrypoint "Lcons") 3487 (date c!:c_entrypoint "Ldate") 3488 (deleq c!:c_entrypoint "Ldeleq") 3489% (difference c!:c_entrypoint "Ldifference2") 3490 (digit c!:c_entrypoint "Ldigitp") 3491 (eject c!:c_entrypoint "Leject") 3492 (endp c!:c_entrypoint "Lendp") 3493 (eq c!:c_entrypoint "Leq") 3494 (eqcar c!:c_entrypoint "Leqcar") 3495 (eql c!:c_entrypoint "Leql") 3496 (eqn c!:c_entrypoint "Leqn") 3497% (error c!:c_entrypoint "Lerror") 3498 (error1 c!:c_entrypoint "Lerror0") % !!! 3499% (errorset c!:c_entrypoint "Lerrorset") 3500 (evenp c!:c_entrypoint "Levenp") 3501 (evlis c!:c_entrypoint "Levlis") 3502 (explode c!:c_entrypoint "Lexplode") 3503 (explode2 c!:c_entrypoint "Lexplodec") 3504 (explodec c!:c_entrypoint "Lexplodec") 3505 (expt c!:c_entrypoint "Lexpt") 3506 (fix c!:c_entrypoint "Ltruncate") 3507 (fixp c!:c_entrypoint "Lfixp") 3508 (flag c!:c_entrypoint "Lflag") 3509 (flagp!*!* c!:c_entrypoint "Lflagp") 3510 (flagp c!:c_entrypoint "Lflagp") 3511 (flagpcar c!:c_entrypoint "Lflagpcar") 3512 (float c!:c_entrypoint "Lfloat") 3513 (floatp c!:c_entrypoint "Lfloatp") 3514 (fluidp c!:c_entrypoint "Lsymbol_specialp") 3515 (gcdn c!:c_entrypoint "Lgcd") 3516 (gctime c!:c_entrypoint "Lgctime") 3517 (gensym c!:c_entrypoint "Lgensym") 3518 (gensym1 c!:c_entrypoint "Lgensym1") 3519 (geq c!:c_entrypoint "Lgeq") 3520 (get!* c!:c_entrypoint "Lget") 3521% (get c!:c_entrypoint "Lget") 3522 (getenv c!:c_entrypoint "Lgetenv") 3523 (getv c!:c_entrypoint "Lgetv") 3524 (svref c!:c_entrypoint "Lgetv") 3525 (globalp c!:c_entrypoint "Lsymbol_globalp") 3526 (greaterp c!:c_entrypoint "Lgreaterp") 3527 (iadd1 c!:c_entrypoint "Liadd1") 3528 (idifference c!:c_entrypoint "Lidifference") 3529 (idp c!:c_entrypoint "Lsymbolp") 3530 (igreaterp c!:c_entrypoint "Ligreaterp") 3531 (ilessp c!:c_entrypoint "Lilessp") 3532 (iminus c!:c_entrypoint "Liminus") 3533 (iminusp c!:c_entrypoint "Liminusp") 3534 (indirect c!:c_entrypoint "Lindirect") 3535 (integerp c!:c_entrypoint "Lintegerp") 3536 (iplus2 c!:c_entrypoint "Liplus2") 3537 (iquotient c!:c_entrypoint "Liquotient") 3538 (iremainder c!:c_entrypoint "Liremainder") 3539 (irightshift c!:c_entrypoint "Lirightshift") 3540 (isub1 c!:c_entrypoint "Lisub1") 3541 (itimes2 c!:c_entrypoint "Litimes2") 3542% (lcm c!:c_entrypoint "Llcm") 3543 (length c!:c_entrypoint "Llength") 3544 (lengthc c!:c_entrypoint "Llengthc") 3545 (leq c!:c_entrypoint "Lleq") 3546 (lessp c!:c_entrypoint "Llessp") 3547 (linelength c!:c_entrypoint "Llinelength") 3548% (list2!* c!:c_entrypoint "Llist2star") 3549% (list2 c!:c_entrypoint "Llist2") 3550% (list3 c!:c_entrypoint "Llist3") 3551 (load!-module c!:c_entrypoint "Lload_module") 3552% (lognot c!:c_entrypoint "Llognot") 3553 (lposn c!:c_entrypoint "Llposn") 3554 (macro!-function c!:c_entrypoint "Lmacro_function") 3555 (macroexpand!-1 c!:c_entrypoint "Lmacroexpand_1") 3556 (macroexpand c!:c_entrypoint "Lmacroexpand") 3557 (make!-bps c!:c_entrypoint "Lget_bps") 3558 (make!-global c!:c_entrypoint "Lmake_global") 3559 (make!-simple!-string c!:c_entrypoint "Lsmkvect") 3560 (make!-special c!:c_entrypoint "Lmake_special") 3561 (mapstore c!:c_entrypoint "Lmapstore") 3562 (max2 c!:c_entrypoint "Lmax2") 3563 (memq c!:c_entrypoint "Lmemq") 3564 (min2 c!:c_entrypoint "Lmin2") 3565 (minus c!:c_entrypoint "Lminus") 3566 (minusp c!:c_entrypoint "Lminusp") 3567 (mkquote c!:c_entrypoint "Lmkquote") 3568 (mkvect c!:c_entrypoint "Lmkvect") 3569 (mod c!:c_entrypoint "Lmod") 3570 (modular!-difference c!:c_entrypoint "Lmodular_difference") 3571 (modular!-expt c!:c_entrypoint "Lmodular_expt") 3572 (modular!-minus c!:c_entrypoint "Lmodular_minus") 3573 (modular!-number c!:c_entrypoint "Lmodular_number") 3574 (modular!-plus c!:c_entrypoint "Lmodular_plus") 3575 (modular!-quotient c!:c_entrypoint "Lmodular_quotient") 3576 (modular!-reciprocal c!:c_entrypoint "Lmodular_reciprocal") 3577 (modular!-times c!:c_entrypoint "Lmodular_times") 3578 (nconc c!:c_entrypoint "Lnconc") 3579% (ncons c!:c_entrypoint "Lncons") 3580 (neq c!:c_entrypoint "Lneq") 3581% (next!-random!-number c!:c_entrypoint "Lnext_random") 3582 (not c!:c_entrypoint "Lnull") 3583 (null c!:c_entrypoint "Lnull") 3584 (numberp c!:c_entrypoint "Lnumberp") 3585 (oddp c!:c_entrypoint "Loddp") 3586 (onep c!:c_entrypoint "Lonep") 3587 (orderp c!:c_entrypoint "Lorderp") 3588% (ordp c!:c_entrypoint "Lorderp") 3589 (pagelength c!:c_entrypoint "Lpagelength") 3590 (pairp c!:c_entrypoint "Lconsp") 3591 (plist c!:c_entrypoint "Lplist") 3592% (plus2 c!:c_entrypoint "Lplus2") 3593 (plusp c!:c_entrypoint "Lplusp") 3594 (posn c!:c_entrypoint "Lposn") 3595 (put c!:c_entrypoint "Lputprop") 3596 (putv!-char c!:c_entrypoint "Lsputv") 3597 (putv c!:c_entrypoint "Lputv") 3598 (qcaar c!:c_entrypoint "Lcaar") 3599 (qcadr c!:c_entrypoint "Lcadr") 3600 (qcar c!:c_entrypoint "Lcar") 3601 (qcdar c!:c_entrypoint "Lcdar") 3602 (qcddr c!:c_entrypoint "Lcddr") 3603 (qcdr c!:c_entrypoint "Lcdr") 3604 (qgetv c!:c_entrypoint "Lgetv") 3605% (quotient c!:c_entrypoint "Lquotient") 3606% (random c!:c_entrypoint "Lrandom") 3607% (rational c!:c_entrypoint "Lrational") 3608 (rds c!:c_entrypoint "Lrds") 3609 (reclaim c!:c_entrypoint "Lgc") 3610% (remainder c!:c_entrypoint "Lrem") 3611 (remd c!:c_entrypoint "Lremd") 3612 (remflag c!:c_entrypoint "Lremflag") 3613 (remob c!:c_entrypoint "Lunintern") 3614 (remprop c!:c_entrypoint "Lremprop") 3615 (reverse c!:c_entrypoint "Lreverse") 3616 (reversip c!:c_entrypoint "Lnreverse") 3617 (rplaca c!:c_entrypoint "Lrplaca") 3618 (rplacd c!:c_entrypoint "Lrplacd") 3619 (schar c!:c_entrypoint "Lsgetv") 3620 (seprp c!:c_entrypoint "Lwhitespace_char_p") 3621 (set!-small!-modulus c!:c_entrypoint "Lset_small_modulus") 3622 (set c!:c_entrypoint "Lset") 3623 (smemq c!:c_entrypoint "Lsmemq") 3624 (spaces c!:c_entrypoint "Lxtab") 3625 (special!-char c!:c_entrypoint "Lspecial_char") 3626 (special!-form!-p c!:c_entrypoint "Lspecial_form_p") 3627 (spool c!:c_entrypoint "Lspool") 3628 (stop c!:c_entrypoint "Lstop") 3629 (stringp c!:c_entrypoint "Lstringp") 3630% (sub1 c!:c_entrypoint "Lsub1") 3631 (subla c!:c_entrypoint "Lsubla") 3632 (subst c!:c_entrypoint "Lsubst") 3633 (symbol!-env c!:c_entrypoint "Lsymbol_env") 3634 (symbol!-function c!:c_entrypoint "Lsymbol_function") 3635 (symbol!-name c!:c_entrypoint "Lsymbol_name") 3636 (symbol!-set!-definition c!:c_entrypoint "Lsymbol_set_definition") 3637 (symbol!-set!-env c!:c_entrypoint "Lsymbol_set_env") 3638 (symbol!-value c!:c_entrypoint "Lsymbol_value") 3639 (system c!:c_entrypoint "Lsystem") 3640 (terpri c!:c_entrypoint "Lterpri") 3641 (threevectorp c!:c_entrypoint "Lthreevectorp") 3642 (time c!:c_entrypoint "Ltime") 3643% (times2 c!:c_entrypoint "Ltimes2") 3644 (ttab c!:c_entrypoint "Lttab") 3645 (tyo c!:c_entrypoint "Ltyo") 3646 (unmake!-global c!:c_entrypoint "Lunmake_global") 3647 (unmake!-special c!:c_entrypoint "Lunmake_special") 3648 (upbv c!:c_entrypoint "Lupbv") 3649 (verbos c!:c_entrypoint "Lverbos") 3650 (wrs c!:c_entrypoint "Lwrs") 3651 (xcons c!:c_entrypoint "Lxcons") 3652 (xtab c!:c_entrypoint "Lxtab") 3653% (orderp c!:c_entrypoint "Lorderp") being retired. 3654 (zerop c!:c_entrypoint "Lzerop") 3655 3656% The following can be called without having to provide an environment 3657% or arg-count. The compiler should check the number of args being 3658% passed matches the expected number. 3659 3660 (cons c!:direct_entrypoint (2 . "cons")) 3661 (ncons c!:direct_entrypoint (1 . "ncons")) 3662 (list2 c!:direct_entrypoint (2 . "list2")) 3663 (list2!* c!:direct_entrypoint (3 . "list2star")) 3664 (acons c!:direct_entrypoint (3 . "acons")) 3665 (list3 c!:direct_entrypoint (3 . "list3")) 3666 (list3!* c!:direct_entrypoint (4 . "list3star")) 3667 (list4 c!:direct_entrypoint (4 . "list4")) 3668 (plus2 c!:direct_entrypoint (2 . "plus2")) 3669 (difference c!:direct_entrypoint (2 . "difference2")) 3670 (add1 c!:direct_entrypoint (1 . "add1")) 3671 (sub1 c!:direct_entrypoint (1 . "sub1")) 3672 (lognot c!:direct_entrypoint (1 . "lognot")) 3673 (ash c!:direct_entrypoint (2 . "ash")) 3674 (quotient c!:direct_entrypoint (2 . "quot2")) 3675 (remainder c!:direct_entrypoint (2 . "Cremainder")) 3676 (times2 c!:direct_entrypoint (2 . "times2")) 3677 (minus c!:direct_entrypoint (1 . "negate")) 3678% (rational c!:direct_entrypoint (1 . "rational")) 3679 (lessp c!:direct_predicate (2 . "lessp2")) 3680 (leq c!:direct_predicate (2 . "lesseq2")) 3681 (greaterp c!:direct_predicate (2 . "greaterp2")) 3682 (geq c!:direct_predicate (2 . "geq2")) 3683 (zerop c!:direct_predicate (1 . "zerop")) 3684 ))$ 3685 3686!#if common!-lisp!-mode 3687null (c!:c_entrypoint_list := append(c!:c_entrypoint_list, '( 3688 (!1!+ c!:c_entrypoint "Ladd1") 3689 (equal c!:c_entrypoint "Lcl_equal") 3690 (!1!- c!:c_entrypoint "Lsub1") 3691 (vectorp c!:c_entrypoint "Lvectorp"))))$ 3692!#endif 3693 3694!#if (not common!-lisp!-mode) 3695null (c!:c_entrypoint_list := append(c!:c_entrypoint_list, '( 3696 (append c!:c_entrypoint "Lappend") 3697 (assoc c!:c_entrypoint "Lassoc") 3698 (compress c!:c_entrypoint "Lcompress") 3699 (delete c!:c_entrypoint "Ldelete") 3700 (divide c!:c_entrypoint "Ldivide") 3701 (equal c!:c_entrypoint "Lequal") 3702 (intern c!:c_entrypoint "Lintern") 3703 (liter c!:c_entrypoint "Lalpha_char_p") 3704 (member c!:c_entrypoint "Lmember") 3705 (prin c!:c_entrypoint "Lprin") 3706 (prin1 c!:c_entrypoint "Lprin") 3707 (prin2 c!:c_entrypoint "Lprinc") 3708 (princ c!:c_entrypoint "Lprinc") 3709 (print c!:c_entrypoint "Lprint") 3710 (printc c!:c_entrypoint "Lprintc") 3711 (read c!:c_entrypoint "Lread") 3712 (readch c!:c_entrypoint "Lreadch") 3713 (sublis c!:c_entrypoint "Lsublis") 3714 (vectorp c!:c_entrypoint "Lsimple_vectorp") 3715 (get c!:direct_entrypoint (2 . "get")))))$ 3716!#endif 3717 3718for each x in c!:c_entrypoint_list do put(car x, cadr x, caddr x)$ 3719 3720flag( 3721 '(atom atsoc codep constantp deleq digit endp eq eqcar evenp 3722 eql fixp flagp flagpcar floatp get globalp iadd1 idifference idp 3723 igreaterp ilessp iminus iminusp indirect integerp iplus2 irightshift 3724 isub1 itimes2 liter memq minusp modular!-difference modular!-expt 3725 modular!-minus modular!-number modular!-plus modular!-times not 3726 null numberp onep pairp plusp qcaar qcadr qcar qcdar qcddr 3727 qcdr remflag remprop reversip seprp special!-form!-p stringp 3728 symbol!-env symbol!-name symbol!-value threevectorp vectorp zerop), 3729 'c!:no_errors); 3730 3731end; 3732 3733% End of ccomp.red 3734 3735