Artifact 7433316627b5f594368cd790d4195a2ac15fd084bdbec2a6d162c255fad7d848:
- Executable file
r36/cslbase/ccomp.red
— part of check-in
[f2fda60abd]
at
2011-09-02 18:13:33
on branch master
— Some historical releases purely for archival purposes
git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/trunk/historical@1375 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 117916) [annotate] [blame] [check-ins using] [more...]
% "ccomp.red" Copyright 1991-1996, Codemist Ltd % % Compiler that turns Lisp code into C in a way that fits in % with the conventions used with CSL/CCL % % A C Norman % symbolic; global '(!*fastvector !*unsafecar); flag('(fastvector unsafecar), 'switch); % % I start with some utility functions that provide something % related to a FORMAT or PRINTF facility % fluid '(C_file L_file O_file L_contents File_name); symbolic macro procedure c!:printf u; % inspired by the C printf function, but much less general. % This macro is to provide the illusion that printf can take an % arbitrary number of arguments. list('c!:printf1, cadr u, 'list . cddr u); symbolic procedure c!:printf1(fmt, args); % this is the inner works of print formatting. % the special sequences that can occur in format strings are % %s use princ (to print a name?) % %d use princ (to print a number?) % %a use prin % %t do a ttab() % %v print a variable.... magic for this compiler % \n do a terpri() % \q princ '!" to display quote marks begin scalar a, c; fmt := explode2 fmt; while fmt do << c := car fmt; fmt := cdr fmt; if c = '!\ and (car fmt = '!n or car fmt = '!N) then << terpri(); fmt := cdr fmt >> else if c = '!\ and (car fmt = '!q or car fmt = '!Q) then << princ '!"; fmt := cdr fmt >> else if c = '!% then << c := car fmt; if null args then a := 'missing_arg else a := car args; if c = '!v or c = '!V then if flagp(a, 'c!:live_across_call) then << princ "stack["; princ(-get(a, 'c!:location)); princ "]" >> else princ a else if c = '!a or c = '!A then prin a else if c = '!t or c = '!T then ttab a else princ a; if args then args := cdr args; fmt := cdr fmt >> else princ c >> end; % This establishes a default handler for each special form so that % any that I forget to treat more directly will cause a tidy error % if found in compiled code. symbolic procedure c!:cspecform(x, env); error(0, list("special form", x)); << put('and, 'c!:code, function c!:cspecform); !#if common!-lisp!-mode put('block, 'c!:code, function c!:cspecform); !#endif put('catch, 'c!:code, function c!:cspecform); put('compiler!-let, 'c!:code, function c!:cspecform); put('cond, 'c!:code, function c!:cspecform); put('declare, 'c!:code, function c!:cspecform); put('de, 'c!:code, function c!:cspecform); !#if common!-lisp!-mode put('defun, 'c!:code, function c!:cspecform); !#endif put('eval!-when, 'c!:code, function c!:cspecform); put('flet, 'c!:code, function c!:cspecform); put('function, 'c!:code, function c!:cspecform); put('go, 'c!:code, function c!:cspecform); put('if, 'c!:code, function c!:cspecform); put('labels, 'c!:code, function c!:cspecform); !#if common!-lisp!-mode put('let, 'c!:code, function c!:cspecform); !#else put('!~let, 'c!:code, function c!:cspecform); !#endif put('let!*, 'c!:code, function c!:cspecform); put('list, 'c!:code, function c!:cspecform); put('list!*, 'c!:code, function c!:cspecform); put('macrolet, 'c!:code, function c!:cspecform); put('multiple!-value!-call, 'c!:code, function c!:cspecform); put('multiple!-value!-prog1, 'c!:code, function c!:cspecform); put('or, 'c!:code, function c!:cspecform); put('prog, 'c!:code, function c!:cspecform); put('prog!*, 'c!:code, function c!:cspecform); put('prog1, 'c!:code, function c!:cspecform); put('prog2, 'c!:code, function c!:cspecform); put('progn, 'c!:code, function c!:cspecform); put('progv, 'c!:code, function c!:cspecform); put('quote, 'c!:code, function c!:cspecform); put('return, 'c!:code, function c!:cspecform); put('return!-from, 'c!:code, function c!:cspecform); put('setq, 'c!:code, function c!:cspecform); put('tagbody, 'c!:code, function c!:cspecform); put('the, 'c!:code, function c!:cspecform); put('throw, 'c!:code, function c!:cspecform); put('unless, 'c!:code, function c!:cspecform); put('unwind!-protect, 'c!:code, function c!:cspecform); put('when, 'c!:code, function c!:cspecform) >>; fluid '(current_procedure current_args current_block current_contents all_blocks registers stacklocs); fluid '(available used); available := used := nil; symbolic procedure c!:reset_gensyms(); << remflag(used, 'c!:live_across_call); remflag(used, 'c!:visited); while used do << remprop(car used, 'c!:contents); remprop(car used, 'c!:why); remprop(car used, 'c!:where_to); remprop(car used, 'c!:count); remprop(car used, 'c!:live); remprop(car used, 'c!:clash); remprop(car used, 'c!:chosen); remprop(car used, 'c!:location); if plist car used then begin scalar o; o := wrs nil; princ "+++++ "; prin car used; princ " "; prin plist car used; terpri(); wrs o end; available := car used . available; used := cdr used >> >>; !#if common!-lisp!-mode fluid '(my_gensym_counter); my_gensym_counter := 0; !#endif symbolic procedure c!:my_gensym(); begin scalar w; if available then << w := car available; available := cdr available >> !#if common!-lisp!-mode else w := compress1 ('!v . explodec (my_gensym_counter := my_gensym_counter + 1)); !#else else w := gensym1 "v"; !#endif used := w . used; if plist w then << princ "????? "; prin w; princ " => "; prin plist w; terpri() >>; return w end; symbolic procedure c!:newreg(); begin scalar r; r := c!:my_gensym(); registers := r . registers; return r end; symbolic procedure c!:startblock s; << current_block := s; current_contents := nil >>; symbolic procedure c!:outop(a,b,c,d); if current_block then current_contents := list(a,b,c,d) . current_contents; symbolic procedure c!:endblock(why, where_to); if current_block then << % Note that the operations within a block are in reversed order. put(current_block, 'c!:contents, current_contents); put(current_block, 'c!:why, why); put(current_block, 'c!:where_to, where_to); all_blocks := current_block . all_blocks; current_contents := nil; current_block := nil >>; % % Now for a general driver for compilation % symbolic procedure c!:cval_inner(x, env); begin scalar helper; % NB use the "improve" function from the regular compiler here... x := s!:improve x; % atoms and embedded lambda expressions need their own treatment. if atom x then return c!:catom(x, env) else if eqcar(car x, 'lambda) then return c!:clambda(cadar x, 'progn . cddar x, cdr x, env) % a c!:code property gives direct control over compilation else if helper := get(car x, 'c!:code) then return funcall(helper, x, env) % compiler-macros take precedence over regular macros, so that I can % make special expansions in the context of compilation. Only used if the % expansion is non-nil else if (helper := get(car x, 'c!:compile_macro)) and (helper := funcall(helper, x)) then return c!:cval(helper, env) % regular Lisp macros get expanded else if idp car x and (helper := macro!-function car x) then return c!:cval(funcall(helper, x), env) % anything not recognised as special will be turned into a % function call, but there will still be special cases, such as % calls to the current function, calls into the C-coded kernel, etc. else return c!:ccall(car x, cdr x, env) end; symbolic procedure c!:cval(x, env); begin scalar r; r := c!:cval_inner(x, env); if r and not member!*!*(r, registers) then error(0, list(r, "not a register", x)); return r end; symbolic procedure c!:clambda(bvl, body, args, env); begin scalar w, fluids, env1; env1 := car env; w := for each a in args collect c!:cval(a, env); for each v in bvl do << if globalp v then begin scalar oo; oo := wrs nil; princ "+++++ "; prin v; princ " converted from GLOBAL to FLUID"; terpri(); wrs oo; unglobal list v; fluid list v end; if fluidp v then << fluids := (v . c!:newreg()) . fluids; flag(list cdar fluids, 'c!:live_across_call); % silly if not env1 := ('c!:dummy!:name . cdar fluids) . env1; c!:outop('ldrglob, cdar fluids, v, c!:find_literal v); c!:outop('strglob, car w, v, c!:find_literal v) >> else << env1 := (v . c!:newreg()) . env1; c!:outop('movr, cdar env1, nil, car w) >>; w := cdr w >>; if fluids then c!:outop('fluidbind, nil, nil, fluids); env := env1 . append(fluids, cdr env); w := c!:cval(body, env); for each v in fluids do c!:outop('strglob, cdr v, car v, c!:find_literal car v); return w end; symbolic procedure c!:locally_bound(x, env); atsoc(x, car env); flag('(nil t), 'c!:constant); fluid '(literal_vector); symbolic procedure c!:find_literal x; begin scalar n, w; w := literal_vector; n := 0; while w and not (car w = x) do << n := n + 1; w := cdr w >>; if null w then literal_vector := append(literal_vector, list x); return n end; symbolic procedure c!:catom(x, env); begin scalar v, w; v := c!:newreg(); if idp x and (w := c!:locally_bound(x, env)) then c!:outop('movr, v, nil, cdr w) else if null x or x = 't or c!:small_number x then c!:outop('movk1, v, nil, x) else if not idp x or flagp(x, 'c!:constant) then c!:outop('movk, v, x, c!:find_literal x) else c!:outop('ldrglob, v, x, c!:find_literal x); return v end; symbolic procedure c!:cjumpif(x, env, d1, d2); begin scalar helper, r; x := s!:improve x; if atom x and (not idp x or (flagp(x, 'c!:constant) and not c!:locally_bound(x, env))) then c!:endblock('goto, list (if x then d1 else d2)) else if not atom x and (helper := get(car x, 'c!:ctest)) then return funcall(helper, x, env, d1, d2) else << r := c!:cval(x, env); c!:endblock(list('ifnull, r), list(d2, d1)) >> end; fluid '(current); symbolic procedure c!:ccall(fn, args, env); c!:ccall1(fn, args, env); fluid '(visited); symbolic procedure c!:has_calls(a, b); begin scalar visited; return c!:has_calls_1(a, b) end; symbolic procedure c!:has_calls_1(a, b); % true if there is a path from node a to node b that has a call instruction % on the way. if a = b or not atom a or memq(a, visited) then nil else begin scalar has_call; visited := a . visited; for each z in get(a, 'c!:contents) do if eqcar(z, 'call) then has_call := t; if has_call then return begin scalar visited; return c!:can_reach(a, b) end; for each d in get(a, 'c!:where_to) do if c!:has_calls_1(d, b) then has_call := t; return has_call end; symbolic procedure c!:can_reach(a, b); if a = b then t else if not atom a or memq(a, visited) then nil else << visited := a . visited; c!:any_can_reach(get(a, 'c!:where_to), b) >>; symbolic procedure c!:any_can_reach(l, b); if null l then nil else if c!:can_reach(car l, b) then t else c!:any_can_reach(cdr l, b); symbolic procedure c!:pareval(args, env); begin scalar tasks, tasks1, merge, split, r; tasks := for each a in args collect (c!:my_gensym() . c!:my_gensym()); split := c!:my_gensym(); c!:endblock('goto, list split); for each a in args do begin scalar s; % I evaluate each arg as what is (at this stage) a separate task s := car tasks; tasks := cdr tasks; c!:startblock car s; r := c!:cval(a, env) . r; c!:endblock('goto, list cdr s); % If the task did no procedure calls (or only tail calls) then it can be % executed sequentially with the other args without need for stacking % anything. Otherwise it more care will be needed. Put the hard % cases onto tasks1. !#if common!-lisp!-mode tasks1 := s . tasks1 !#else if c!:has_calls(car s, cdr s) then tasks1 := s . tasks1 else merge := s . merge !#endif end; %-- % if there are zero or one items in tasks1 then again it is easy - %-- % otherwise I flag the problem with a notionally parallel construction. %-- if tasks1 then << %-- if null cdr tasks1 then merge := car tasks1 . merge %-- else << %-- c!:startblock split; %-- printc "***** ParEval needed parallel block here..."; %-- c!:endblock('par, for each v in tasks1 collect car v); %-- split := c!:my_gensym(); %-- for each v in tasks1 do << %-- c!:startblock cdr v; %-- c!:endblock('goto, list split) >> >> >>; for each z in tasks1 do merge := z . merge; % do sequentially %-- %-- % Finally string end-to-end all the bits of sequential code I have left over. for each v in merge do << c!:startblock split; c!:endblock('goto, list car v); split := cdr v >>; c!:startblock split; return reversip r end; symbolic procedure c!:ccall1(fn, args, env); begin scalar tasks, merge, r, val; fn := list(fn, cdr env); val := c!:newreg(); if null args then c!:outop('call, val, nil, fn) else if null cdr args then c!:outop('call, val, list c!:cval(car args, env), fn) else << r := c!:pareval(args, env); c!:outop('call, val, r, fn) >>; c!:outop('reloadenv, 'env, nil, nil); return val end; fluid '(restart_label reloadenv does_call current_c_name); % % The "proper" recipe here arranges that functions that expect over 2 args use % the "va_arg" mechanism to pick up ALL their args. This would be pretty % heavy-handed, and at least on a lot of machines it does not seem to % be necessary. I will duck it for a while more at least. % fluid '(proglabs blockstack); symbolic procedure c!:cfndef(current_procedure, current_c_name, argsbody); begin scalar env, n, w, current_args, current_block, restart_label, current_contents, all_blocks, entrypoint, exitpoint, args1, registers, stacklocs, literal_vector, reloadenv, does_call, blockstack, proglabs, checksum, args, body; checksum := md60 argsbody; args := car argsbody; body := cdr argsbody; if atom body then body := nil else if atom cdr body then body := car body else body := 'progn . body; % print list(current_procedure, current_c_name, argsbody, checksum); c!:reset_gensyms(); wrs C_file; linelength 200; c!:printf("\n\n/* Code for %a */\n\n", current_procedure); c!:find_literal current_procedure; % For benefit of backtraces % % cope with fluid vars in an argument list by mapping the definition % (de f (a B C d) body) B and C fluid % onto % (de f (a x y c) (prog (B C) (setq B x) (setq C y) (return body))) % so that the fluids get bound by PROG. % current_args := args; for each v in args do if v = '!&optional or v = '!&rest then error(0, "&optional and &rest not supported by this compiler (yet)") else if globalp v then begin scalar oo; oo := wrs nil; princ "+++++ "; prin v; princ " converted from GLOBAL to FLUID"; terpri(); wrs oo; unglobal list v; fluid list v; n := (v . c!:my_gensym()) . n end else if fluidp v then n := (v . c!:my_gensym()) . n; restart_label := c!:my_gensym(); body := list('c!:private_tagbody, restart_label, body); if n then << body := list list('return, body); args := subla(n, args); for each v in n do body := list('setq, car v, cdr v) . body; body := 'prog . (for each v in reverse n collect car v) . body >>; c!:printf "static Lisp_Object "; if null args or length args >= 3 then c!:printf("MS_CDECL "); c!:printf("%s(Lisp_Object env", current_c_name); if null args or length args >= 3 then c!:printf(", int nargs"); n := t; env := nil; for each x in args do begin scalar aa; c!:printf ","; if n then << c!:printf "\n "; n := nil >> else n := t; aa := c!:my_gensym(); env := (x . aa) . env; registers := aa . registers; args1 := aa . args1; c!:printf(" Lisp_Object %s", aa) end; if null args or length args >= 3 then c!:printf(", ..."); c!:printf(")\n{\n"); c!:startblock (entrypoint := c!:my_gensym()); exitpoint := current_block; c!:endblock('goto, list list c!:cval(body, env . nil)); c!:optimise_flowgraph(entrypoint, all_blocks, env, length args . current_procedure, args1); c!:printf("}\n\n"); wrs O_file; L_contents := (current_procedure . literal_vector .checksum) . L_contents; return nil end; % c!:ccompile1 directs the compilation of a single function, and bind all the % major fluids used by the compilation process flag('(rds deflist flag fluid global remprop remflag unfluid unglobal dm carcheck C!-end), 'eval); flag('(rds), 'ignore); fluid '(!*backtrace); symbolic procedure c!:ccompilesupervisor; begin scalar u, w; top:u := errorset('(read), t, !*backtrace); if atom u then return; % failed, or maybe EOF u := car u; if u = !$eof!$ then return; % end of file if atom u then go to top % the apply('C!-end, nil) is here because C!-end has a "stat" % property and so it will mis-parse if I just write "C!-end()". Yuk. else if eqcar(u, 'C!-end) then return apply('C!-end, nil) else if eqcar(u, 'rdf) then << !#if common!-lisp!-mode w := open(u := eval cadr u, !:direction, !:input, !:if!-does!-not!-exist, nil); !#else w := open(u := eval cadr u, 'input); !#endif if w then << terpri(); princ "Reading file "; print u; w := rds w; c!:ccompilesupervisor(); princ "End of file "; print u; close rds w >> else << princ "Failed to open file "; print u >> >> else c!:ccmpout1 u; go to top end; global '(c!:char_mappings); c!:char_mappings := '( (! . !A) (!! . !B) (!# . !C) (!$ . !D) (!% . !E) (!^ . !F) (!& . !G) (!* . !H) (!( . !I) (!) . !J) (!- . !K) (!+ . !L) (!= . !M) (!\ . !N) (!| . !O) (!, . !P) (!. . !Q) (!< . !R) (!> . !S) (!: . !T) (!; . !U) (!/ . !V) (!? . !W) (!~ . !X) (!` . !Y)); symbolic procedure c!:inv_name n; begin scalar r, w; r := '(_ !C !C !"); !#if common!-lisp!-mode for each c in explode2 package!-name symbol!-package n do << if c = '_ then r := '_ . r else if alpha!-char!-p c or digit c then r := c . r else if w := atsoc(c, c!:char_mappings) then r := cdr w . r else r := '!Z . r >>; r := '!_ . '!_ . r; !#endif for each c in explode2 n do << if c = '_ then r := '_ . r !#if common!-lisp!-mode else if alpha!-char!-p c or digit c then r := c . r !#else else if liter c or digit c then r := c . r !#endif else if w := atsoc(c, c!:char_mappings) then r := cdr w . r else r := '!Z . r >>; r := '!" . r; !#if common!-lisp!-mode return compress1 reverse r !#else return compress reverse r !#endif end; fluid '(defnames pending_functions); symbolic procedure c!:ccmpout1 u; begin scalar pending_functions; pending_functions := list u; while pending_functions do << u := car pending_functions; pending_functions := cdr pending_functions; c!:ccmpout1a u >> end; symbolic procedure c!:ccmpout1a u; begin scalar w; if atom u then return else if eqcar(u, 'progn) then << for each v in cdr u do c!:ccmpout1a v; return >> else if eqcar(u, 'C!-end) then nil else if flagp(car u, 'eval) or (car u = 'setq and not atom caddr u and flagp(caaddr u, 'eval)) then errorset(u, t, !*backtrace); if eqcar(u, 'rdf) then begin !#if common!-lisp!-mode w := open(u := eval cadr u, !:direction, !:input, !:if!-does!_not!-exist, nil); !#else w := open(u := eval cadr u, 'input); !#endif if w then << princ "Reading file "; print u; w := rds w; c!:ccompilesupervisor(); princ "End of file "; print u; close rds w >> else << princ "Failed to open file "; print u >> end !#if common!-lisp!-mode else if eqcar(u, 'defun) then return c!:ccmpout1a macroexpand u !#endif else if eqcar(u, 'de) then << u := cdr u; !#if common!-lisp!-mode w := compress1 ('!" . append(explodec package!-name symbol!-package car u, '!@ . '!@ . append(explodec symbol!-name car u, append(explodec "@@Builtin", '(!"))))); w := intern w; defnames := list(car u, c!:inv_name car u, length cadr u, w) . defnames; !#else defnames := list(car u, c!:inv_name car u, length cadr u) . defnames; !#endif if posn() neq 0 then terpri(); princ "Compiling "; prin caar defnames; princ " ... "; c!:cfndef(caar defnames, cadar defnames, cdr u); !#if common!-lisp!-mode L_contents := (w . car L_contents) . cdr L_contents; !#endif terpri() >> end; fluid '(!*defn dfprint!* dfprintsave); !#if common!-lisp!-mode symbolic procedure c!:concat(a, b); compress1('!" . append(explode2 a, append(explode2 b, '(!")))); !#else symbolic procedure c!:concat(a, b); compress('!" . append(explode2 a, append(explode2 b, '(!")))); !#endif symbolic procedure c!:ccompilestart(name, !&optional, dir); begin scalar o, d, w; File_name := name; if dir then name := c!:concat(dir, c!:concat("/", name)); !#if common!-lisp!-mode C_file := open(c!:concat(name, ".c"), !:direction, !:output); !#else C_file := open(c!:concat(name, ".c"), 'output); !#endif L_file := c!:concat(name, ".lsp"); L_contents := nil; % Here I turn a date into a form like "12-Oct-1993" as expected by the % file signature mechanism that I use. This seems a pretty ugly process. o := reverse explode date(); for i := 1:5 do << d := car o . d; o := cdr o >>; d := '!- . d; o := cdddr cdddr cddddr o; w := o; o := cdddr o; d := caddr o . cadr o . car o . d; !#if common!-lisp!-mode d := compress1('!" . cadr w . car w . '!- . d); !#else d := compress('!" . cadr w . car w . '!- . d); !#endif O_file := wrs C_file; defnames := nil; c!:printf("\n/* %s.c%tMachine generated C code */\n\n", name, 25); c!:printf("/* Signature: 00000000 %s */\n\n", d); % c!:printf "#include <stdio.h>\n"; Included by "machine.h" % c!:printf "#include <stdlib.h>\n"; c!:printf "#include <stdarg.h>\n"; c!:printf "#include <string.h>\n"; % c!:printf "#include <time.h>\n"; c!:printf "#include <ctype.h>\n\n"; c!:printf "#include \qmachine.h\q\n"; c!:printf "#include \qtags.h\q\n"; c!:printf "#include \qcslerror.h\q\n"; c!:printf "#include \qexterns.h\q\n"; c!:printf "#include \qarith.h\q\n"; c!:printf "#include \qentries.h\q\n\n\n"; wrs O_file; return nil end; symbolic procedure C!-end; begin scalar checksum, c1, c2, c3; wrs C_file; c!:printf("\n\nsetup_type const %s_setup[] =\n{\n", File_name); defnames := reverse defnames; while defnames do begin scalar name, nargs, f1, f2, cast, fn; !#if common!-lisp!-mode name := cadddr car defnames; !#else name := caar defnames; !#endif f1 := cadar defnames; nargs := caddar defnames; cast := "(n_args *)"; if nargs = 1 then << f2 := '!t!o!o_!m!a!n!y_1; cast := ""; fn := '!w!r!o!n!g_!n!o_1 >> else if nargs = 2 then << f2 := f1; f1 := '!t!o!o_!f!e!w_2; cast := ""; fn := '!w!r!o!n!g_!n!o_2 >> else << fn := f1; f1 := '!w!r!o!n!g_!n!o_!n!a; f2 := '!w!r!o!n!g_!n!o_!n!b >>; c!:printf(" {\q%s\q,%t%s,%t%s,%t%s%s},\n", name, 32, f1, 48, f2, 63, cast, fn); defnames := cdr defnames end; c3 := checksum := md60 L_contents; c1 := remainder(c3, 10000000); c3 := c3 / 10000000; c2 := remainder(c3, 10000000); c3 := c3 / 10000000; checksum := list!-to!-string append(explodec c3, '! . append(explodec c2, '! . explodec c1)); c!:printf(" {NULL, (one_args *)%a, (two_args *)%a, 0}\n};\n\n", list!-to!-string explodec File_name, checksum); c!:printf "/* end of generated code */\n"; close C_file; !#if common!-lisp!-mode L_file := open(L_file, !:direction, !:output); !#else L_file := open(L_file, 'output); !#endif wrs L_file; linelength 72; terpri(); !#if common!-lisp!-mode princ ";;; "; !#else princ "% "; !#endif princ File_name; princ ".lsp"; ttab 20; princ "Machine generated Lisp"; % princ " "; princ date(); terpri(); terpri(); !#if common!-lisp!-mode princ "(in-package lisp)"; terpri(); terpri(); princ "(c::install "; !#else princ "(c!:install "; !#endif princ '!"; princ File_name; princ '!"; princ " "; princ checksum; printc ")"; terpri(); for each x in reverse L_contents do << !#if common!-lisp!-mode princ "(c::install '"; prin car x; princ " '"; x := cdr x; !#else princ "(c!:install '"; !#endif prin car x; princ " '"; prin cadr x; !#if (not common!-lisp!-mode) princ " "; prin cddr x; !#endif princ ")"; terpri(); terpri() >>; terpri(); !#if common!-lisp!-mode princ ";;; End of generated Lisp code"; !#else princ "% End of generated Lisp code"; !#endif terpri(); terpri(); L_contents := nil; wrs O_file; close L_file; !*defn := nil; dfprint!* := dfprintsave end; put('C!-end, 'stat, 'endstat); symbolic procedure C!-compile u; begin terpri(); princ "C!-COMPILE "; prin u; princ ": IN files; or type in expressions"; terpri(); princ "When all done, execute C!-END;"; terpri(); verbos nil; c!:ccompilestart car u; dfprintsave := dfprint!*; dfprint!* := 'c!:ccmpout1; !*defn := t; if getd 'begin then return nil; c!:ccompilesupervisor(); end; put('C!-compile, 'stat, 'rlis); % % Global treatment of a flow-graph... % symbolic procedure c!:print_opcode(s, depth); begin scalar op, r1, r2, r3, helper; op := car s; r1 := cadr s; r2 := caddr s; r3 := cadddr s; helper := get(op, 'c!:opcode_printer); if helper then funcall(helper, op, r1, r2, r3, depth) else << prin s; terpri() >> end; symbolic procedure c!:print_exit_condition(why, where_to, depth); begin scalar helper, lab1, drop1, lab2, drop2, negate; % An exit condition is one of % goto (lab) % goto ((return-register)) % (ifnull v) (lab1 lab2) ) etc, where v is a register and % (ifatom v) (lab1 lab2) ) lab1, lab2 are labels for true & false % (ifeq v1 v2) (lab1 lab2) ) and various predicates are supported % ((call fn) a1 a2) () tail-call to given function % if why = 'goto then << where_to := car where_to; if atom where_to then << c!:printf(" goto %s;\n", where_to); c!:display_flowgraph(where_to, depth, t) >> else << c!:printf " "; c!:pgoto(where_to, depth) >>; return nil >> else if eqcar(car why, 'call) then return begin scalar args, locs, g, w; if w := get(cadar why, 'c!:direct_entrypoint) then << for each a in cdr why do if flagp(a, 'c!:live_across_call) then << if null g then c!:printf " {\n"; g := c!:my_gensym(); c!:printf(" Lisp_Object %s = %v;\n", g, a); args := g . args >> else args := a . args; if depth neq 0 then << if g then c!:printf " "; c!:printf(" popv(%s);\n", depth) >>; if g then c!:printf " "; !#if common!-lisp!-mode c!:printf(" { Lisp_Object retVal = %s(", cdr w); !#else c!:printf(" return %s(", cdr w); !#endif args := reversip args; if args then << c!:printf("%v", car args); for each a in cdr args do c!:printf(", %v", a) >>; c!:printf(");\n"); !#if common!-lisp!-mode if g then c!:printf " "; c!:printf(" errexit();\n"); if g then c!:printf " "; c!:printf(" return onevalue(retVal); }\n"); !#endif if g then c!:printf " }\n" >> else if w := get(cadar why, 'c!:c_entrypoint) then << for each a in cdr why do if flagp(a, 'c!:live_across_call) then << if null g then c!:printf " {\n"; g := c!:my_gensym(); c!:printf(" Lisp_Object %s = %v;\n", g, a); args := g . args >> else args := a . args; if depth neq 0 then c!:printf(" popv(%s);\n", depth); c!:printf(" return %s(nil", w); if null args or length args >= 3 then c!:printf(", %s", length args); for each a in reversip args do c!:printf(", %v", a); c!:printf(");\n"); if g then c!:printf " }\n" >> else begin scalar nargs; nargs := length cdr why; c!:printf " {\n"; for each a in cdr why do if flagp(a, 'c!:live_across_call) then << g := c!:my_gensym(); c!:printf(" Lisp_Object %s = %v;\n", g, a); args := g . args >> else args := a . args; if depth neq 0 then c!:printf(" popv(%s);\n", depth); c!:printf(" fn = elt(env, %s); /* %a */\n", c!:find_literal cadar why, cadar why); if nargs = 1 then c!:printf(" return (*qfn1(fn))(qenv(fn)") else if nargs = 2 then c!:printf(" return (*qfn2(fn))(qenv(fn)") else c!:printf(" return (*qfnn(fn))(qenv(fn), %s", nargs); for each a in reversip args do c!:printf(", %s", a); c!:printf(");\n }\n") end; return nil end; lab1 := car where_to; drop1 := atom lab1 and not flagp(lab1, 'c!:visited); lab2 := cadr where_to; drop2 := atom lab2 and not flagp(drop2, 'c!:visited); if drop2 and get(lab2, 'c!:count) = 1 then << where_to := list(lab2, lab1); drop1 := t >> else if drop1 then negate := t; helper := get(car why, 'c!:exit_helper); if null helper then error(0, list("Bad exit condition", why)); c!:printf(" if ("); if negate then << c!:printf("!("); funcall(helper, cdr why, depth); c!:printf(")") >> else funcall(helper, cdr why, depth); c!:printf(") "); if not drop1 then << c!:pgoto(car where_to, depth); c!:printf(" else ") >>; c!:pgoto(cadr where_to, depth); if atom car where_to then c!:display_flowgraph(car where_to, depth, drop1); if atom cadr where_to then c!:display_flowgraph(cadr where_to, depth, nil) end; symbolic procedure c!:pmovr(op, r1, r2, r3, depth); c!:printf(" %v = %v;\n", r1, r3); put('movr, 'c!:opcode_printer, function c!:pmovr); symbolic procedure c!:pmovk(op, r1, r2, r3, depth); c!:printf(" %v = elt(env, %s); /* %a */\n", r1, r3, r2); put('movk, 'c!:opcode_printer, function c!:pmovk); symbolic procedure c!:pmovk1(op, r1, r2, r3, depth); if null r3 then c!:printf(" %v = nil;\n", r1) else if r3 = 't then c!:printf(" %v = lisp_true;\n", r1) else c!:printf(" %v = (Lisp_Object)%s; /* %a */\n", r1, 16*r3+1, r3); put('movk1, 'c!:opcode_printer, function c!:pmovk1); symbolic procedure c!:preloadenv(op, r1, r2, r3, depth); % will not be encountered unless reloadenv variable has been set up. c!:printf(" env = stack[%s];\n", -reloadenv); put('reloadenv, 'c!:opcode_printer, function c!:preloadenv); symbolic procedure c!:pldrglob(op, r1, r2, r3, depth); c!:printf(" %v = qvalue(elt(env, %s)); /* %a */\n", r1, r3, r2); put('ldrglob, 'c!:opcode_printer, function c!:pldrglob); symbolic procedure c!:pstrglob(op, r1, r2, r3, depth); c!:printf(" qvalue(elt(env, %s)) = %v; /* %a */\n", r3, r1, r2); put('strglob, 'c!:opcode_printer, function c!:pstrglob); symbolic procedure c!:pnilglob(op, r1, r2, r3, depth); c!:printf(" qvalue(elt(env, %s)) = nil; /* %a */\n", r3, r2); put('nilglob, 'c!:opcode_printer, function c!:pnilglob); symbolic procedure c!:pnull(op, r1, r2, r3, depth); c!:printf(" %v = (%v == nil ? lisp_true : nil);\n", r1, r3); put('null, 'c!:opcode_printer, function c!:pnull); put('not, 'c!:opcode_printer, function c!:pnull); flag('(null not), 'c!:uses_nil); symbolic procedure c!:pfastget(op, r1, r2, r3, depth); << c!:printf(" if (!symbolp(%v)) %v = nil;\n", r2, r1); c!:printf(" else { %v = qfastgets(%v);\n", r1, r2); c!:printf(" if (%v != nil) { %v = elt(%v, %s); /* %s */\n", r1, r1, r1, car r3, cdr r3); c!:printf("#ifdef RECORD_GET\n"); c!:printf(" if (%v != SPID_NOPROP)\n", r1); c!:printf(" record_get(elt(fastget_names, %s), 1);\n", car r3); c!:printf(" else record_get(elt(fastget_names, %s), 0),\n", car r3); c!:printf(" %v = nil; }\n", r1); c!:printf(" else record_get(elt(fastget_names, %s), 0); }\n", car r3); c!:printf("#else\n"); c!:printf(" if (%v == SPID_NOPROP) %v = nil; }}\n", r1, r1); c!:printf("#endif\n"); >>; put('fastget, 'c!:opcode_printer, function c!:pfastget); flag('(fastget), 'c!:uses_nil); symbolic procedure c!:pfastflag(op, r1, r2, r3, depth); << c!:printf(" if (!symbolp(%v)) %v = nil;\n", r2, r1); c!:printf(" else { %v = qfastgets(%v);\n", r1, r2); c!:printf(" if (%v != nil) { %v = elt(%v, %s); /* %s */\n", r1, r1, r1, car r3, cdr r3); c!:printf("#ifdef RECORD_GET\n"); c!:printf(" if (%v == SPID_NOPROP)\n", r1); c!:printf(" record_get(elt(fastget_names, %s), 0),\n", car r3); c!:printf(" %v = nil;\n", r1); c!:printf(" else record_get(elt(fastget_names, %s), 1),\n", car r3); c!:printf(" %v = lisp_true; }\n", r1); c!:printf(" else record_get(elt(fastget_names, %s), 0); }\n", car r3); c!:printf("#else\n"); c!:printf(" if (%v == SPID_NOPROP) %v = nil; else %v = lisp_true; }}\n", r1, r1, r1); c!:printf("#endif\n"); >>; put('fastflag, 'c!:opcode_printer, function c!:pfastflag); flag('(fastflag), 'c!:uses_nil); symbolic procedure c!:pcar(op, r1, r2, r3, depth); begin if not !*unsafecar then << c!:printf(" if (!car_legal(%v)) ", r3); c!:pgoto(c!:find_error_label(list('car, r3), r2, depth), depth) >>; c!:printf(" %v = qcar(%v);\n", r1, r3) end; put('car, 'c!:opcode_printer, function c!:pcar); symbolic procedure c!:pcdr(op, r1, r2, r3, depth); begin if not !*unsafecar then << c!:printf(" if (!car_legal(%v)) ", r3); c!:pgoto(c!:find_error_label(list('cdr, r3), r2, depth), depth) >>; c!:printf(" %v = qcdr(%v);\n", r1, r3) end; put('cdr, 'c!:opcode_printer, function c!:pcdr); symbolic procedure c!:pqcar(op, r1, r2, r3, depth); c!:printf(" %v = qcar(%v);\n", r1, r3); put('qcar, 'c!:opcode_printer, function c!:pqcar); symbolic procedure c!:pqcdr(op, r1, r2, r3, depth); c!:printf(" %v = qcdr(%v);\n", r1, r3); put('qcdr, 'c!:opcode_printer, function c!:pqcdr); symbolic procedure c!:patom(op, r1, r2, r3, depth); c!:printf(" %v = (!consp(%v) ? lisp_true : nil);\n", r1, r3); put('atom, 'c!:opcode_printer, function c!:patom); symbolic procedure c!:pnumberp(op, r1, r2, r3, depth); c!:printf(" %v = (is_number(%v) ? lisp_true : nil);\n", r1, r3); put('numberp, 'c!:opcode_printer, function c!:pnumberp); symbolic procedure c!:pfixp(op, r1, r2, r3, depth); c!:printf(" %v = integerp(%v);\n", r1, r3); put('fixp, 'c!:opcode_printer, function c!:pfixp); symbolic procedure c!:piminusp(op, r1, r2, r3, depth); c!:printf(" %v = ((int32)(%v) < 0 ? lisp_true : nil);\n", r1, r3); put('iminusp, 'c!:opcode_printer, function c!:piminusp); symbolic procedure c!:pilessp(op, r1, r2, r3, depth); c!:printf(" %v = ((int32)%v < (int32)%v) ? lisp_true : nil;\n", r1, r2, r3); put('ilessp, 'c!:opcode_printer, function c!:pilessp); symbolic procedure c!:pigreaterp(op, r1, r2, r3, depth); c!:printf(" %v = ((int32)%v > (int32)%v) ? lisp_true : nil;\n", r1, r2, r3); put('igreaterp, 'c!:opcode_printer, function c!:pigreaterp); symbolic procedure c!:piminus(op, r1, r2, r3, depth); c!:printf(" %v = (Lisp_Object)(2-((int32)(%v)));\n", r1, r3); put('iminus, 'c!:opcode_printer, function c!:piminus); symbolic procedure c!:piadd1(op, r1, r2, r3, depth); c!:printf(" %v = (Lisp_Object)((int32)(%v) + 0x10);\n", r1, r3); put('iadd1, 'c!:opcode_printer, function c!:piadd1); symbolic procedure c!:pisub1(op, r1, r2, r3, depth); c!:printf(" %v = (Lisp_Object)((int32)(%v) - 0x10);\n", r1, r3); put('isub1, 'c!:opcode_printer, function c!:pisub1); symbolic procedure c!:piplus2(op, r1, r2, r3, depth); c!:printf(" %v = (Lisp_Object)((int32)%v + (int32)%v - TAG_FIXNUM);\n", r1, r2, r3); put('iplus2, 'c!:opcode_printer, function c!:piplus2); symbolic procedure c!:pidifference(op, r1, r2, r3, depth); c!:printf(" %v = (Lisp_Object)((int32)%v - (int32)%v + TAG_FIXNUM);\n", r1, r2, r3); put('idifference, 'c!:opcode_printer, function c!:pidifference); symbolic procedure c!:pitimes2(op, r1, r2, r3, depth); c!:printf(" %v = fixnum_of_int(int_of_fixnum(%v) * int_of_fixnum(%v));\n", r1, r2, r3); put('itimes2, 'c!:opcode_printer, function c!:pitimes2); symbolic procedure c!:pmodular_plus(op, r1, r2, r3, depth); << c!:printf(" { int32 w = int_of_fixnum(%v) + int_of_fixnum(%v);\n", r2, r3); c!:printf(" if (w >= current_modulus) w -= current_modulus;\n"); c!:printf(" %v = fixnum_of_int(w);\n", r1); c!:printf(" }\n") >>; put('modular!-plus, 'c!:opcode_printer, function c!:pmodular_plus); symbolic procedure c!:pmodular_difference(op, r1, r2, r3, depth); << c!:printf(" { int32 w = int_of_fixnum(%v) - int_of_fixnum(%v);\n", r2, r3); c!:printf(" if (w < 0) w += current_modulus;\n"); c!:printf(" %v = fixnum_of_int(w);\n", r1); c!:printf(" }\n") >>; put('modular!-difference, 'c!:opcode_printer, function c!:pmodular_difference); symbolic procedure c!:pmodular_minus(op, r1, r2, r3, depth); << c!:printf(" { int32 w = int_of_fixnum(%v);\n", r3); c!:printf(" if (w != 0) w = current_modulus - w;\n"); c!:printf(" %v = fixnum_of_int(w);\n", r1); c!:printf(" }\n") >>; put('modular!-minus, 'c!:opcode_printer, function c!:pmodular_minus); !#if (not common!-lisp!-mode) symbolic procedure c!:passoc(op, r1, r2, r3, depth); c!:printf(" %v = Lassoc(nil, %v, %v);\n", r1, r2, r3); put('assoc, 'c!:opcode_printer, function c!:passoc); flag('(assoc), 'c!:uses_nil); !#endif symbolic procedure c!:patsoc(op, r1, r2, r3, depth); c!:printf(" %v = Latsoc(nil, %v, %v);\n", r1, r2, r3); put('atsoc, 'c!:opcode_printer, function c!:patsoc); flag('(atsoc), 'c!:uses_nil); !#if (not common!-lisp!-mode) symbolic procedure c!:pmember(op, r1, r2, r3, depth); c!:printf(" %v = Lmember(nil, %v, %v);\n", r1, r2, r3); put('member, 'c!:opcode_printer, function c!:pmember); flag('(member), 'c!:uses_nil); !#endif symbolic procedure c!:pmemq(op, r1, r2, r3, depth); c!:printf(" %v = Lmemq(nil, %v, %v);\n", r1, r2, r3); put('memq, 'c!:opcode_printer, function c!:pmemq); flag('(memq), 'c!:uses_nil); !#if common!-lisp!-mode symbolic procedure c!:pget(op, r1, r2, r3, depth); c!:printf(" %v = get(%v, %v, nil);\n", r1, r2, r3); flag('(get), 'c!:uses_nil); !#else symbolic procedure c!:pget(op, r1, r2, r3, depth); c!:printf(" %v = get(%v, %v);\n", r1, r2, r3); !#endif put('get, 'c!:opcode_printer, function c!:pget); symbolic procedure c!:pqgetv(op, r1, r2, r3, depth); << c!:printf(" %v = *(Lisp_Object *)((char *)%v + (4L-TAG_VECTOR) +", r1, r2); c!:printf(" ((int32)%v>>2));\n", r3) >>; put('qgetv, 'c!:opcode_printer, function c!:pqgetv); symbolic procedure c!:pqputv(op, r1, r2, r3, depth); << c!:printf(" *(Lisp_Object *)((char *)%v + (4L-TAG_VECTOR) +", r2); c!:printf(" ((int32)%v>>2)) = %v;\n", r3, r1) >>; put('qputv, 'c!:opcode_printer, function c!:pqputv); symbolic procedure c!:peq(op, r1, r2, r3, depth); c!:printf(" %v = (%v == %v ? lisp_true : nil);\n", r1, r2, r3); put('eq, 'c!:opcode_printer, function c!:peq); flag('(eq), 'c!:uses_nil); !#if common!-lisp!-mode symbolic procedure c!:pequal(op, r1, r2, r3, depth); c!:printf(" %v = (cl_equal(%v, %v) ? lisp_true : nil);\n", r1, r2, r3, r2, r3); !#else symbolic procedure c!:pequal(op, r1, r2, r3, depth); c!:printf(" %v = (equal(%v, %v) ? lisp_true : nil);\n", r1, r2, r3, r2, r3); !#endif put('equal, 'c!:opcode_printer, function c!:pequal); flag('(equal), 'c!:uses_nil); symbolic procedure c!:pfluidbind(op, r1, r2, r3, depth); nil; put('fluidbind, 'c!:opcode_printer, function c!:pfluidbind); symbolic procedure c!:pcall(op, r1, r2, r3, depth); begin % r3 is (name <fluids to unbind on error>) scalar w, boolfn; if w := get(car r3, 'c!:direct_entrypoint) then << c!:printf(" %v = %s(", r1, cdr w); if r2 then << c!:printf("%v", car r2); for each a in cdr r2 do c!:printf(", %v", a) >>; c!:printf(");\n") >> else if w := get(car r3, 'c!:direct_predicate) then << boolfn := t; c!:printf(" %v = (Lisp_Object)%s(", r1, cdr w); if r2 then << c!:printf("%v", car r2); for each a in cdr r2 do c!:printf(", %v", a) >>; c!:printf(");\n") >> else if car r3 = current_procedure then << c!:printf(" %v = %s(env", r1, current_c_name); if null r2 or length r2 >= 3 then c!:printf(", %s", length r2); for each a in r2 do c!:printf(", %v", a); c!:printf(");\n") >> else if w := get(car r3, 'c!:c_entrypoint) then << c!:printf(" %v = %s(nil", r1, w); if null r2 or length r2 >= 3 then c!:printf(", %s", length r2); for each a in r2 do c!:printf(", %v", a); c!:printf(");\n") >> else begin scalar nargs; nargs := length r2; c!:printf(" fn = elt(env, %s); /* %a */\n", c!:find_literal car r3, car r3); if nargs = 1 then c!:printf(" %v = (*qfn1(fn))(qenv(fn)", r1) else if nargs = 2 then c!:printf(" %v = (*qfn2(fn))(qenv(fn)", r1) else c!:printf(" %v = (*qfnn(fn))(qenv(fn), %s", r1, nargs); for each a in r2 do c!:printf(", %v", a); c!:printf(");\n") end; if not flagp(car r3, 'c!:no_errors) then << if null cadr r3 and depth = 0 then c!:printf(" errexit();\n") else << c!:printf(" nil = C_nil;\n"); c!:printf(" if (exception_pending()) "); c!:pgoto(c!:find_error_label(nil, cadr r3, depth) , depth) >> >>; if boolfn then c!:printf(" %v = %v ? lisp_true : nil;\n", r1, r1); end; put('call, 'c!:opcode_printer, function c!:pcall); symbolic procedure c!:pgoto(lab, depth); begin if atom lab then return c!:printf("goto %s;\n", lab); lab := get(car lab, 'c!:chosen); if zerop depth then c!:printf("return onevalue(%v);\n", lab) else if flagp(lab, 'c!:live_across_call) then c!:printf("{ Lisp_Object res = %v; popv(%s); return onevalue(res); }\n", lab, depth) else c!:printf("{ popv(%s); return onevalue(%v); }\n", depth, lab) end; symbolic procedure c!:pifnull(s, depth); c!:printf("%v == nil", car s); put('ifnull, 'c!:exit_helper, function c!:pifnull); symbolic procedure c!:pifatom(s, depth); c!:printf("!consp(%v)", car s); put('ifatom, 'c!:exit_helper, function c!:pifatom); symbolic procedure c!:pifsymbol(s, depth); c!:printf("symbolp(%v)", car s); put('ifsymbol, 'c!:exit_helper, function c!:pifsymbol); symbolic procedure c!:pifnumber(s, depth); c!:printf("is_number(%v)", car s); put('ifnumber, 'c!:exit_helper, function c!:pifnumber); symbolic procedure c!:pifizerop(s, depth); c!:printf("(%v) == 1", car s); put('ifizerop, 'c!:exit_helper, function c!:pifizerop); symbolic procedure c!:pifeq(s, depth); c!:printf("%v == %v", car s, cadr s); put('ifeq, 'c!:exit_helper, function c!:pifeq); !#if common!-lisp!-mode symbolic procedure c!:pifequal(s, depth); c!:printf("cl_equal(%v, %v)", car s, cadr s, car s, cadr s); !#else symbolic procedure c!:pifequal(s, depth); c!:printf("equal(%v, %v)", car s, cadr s, car s, cadr s); !#endif put('ifequal, 'c!:exit_helper, function c!:pifequal); symbolic procedure c!:pifilessp(s, depth); c!:printf("((int32)(%v)) < ((int32)(%v))", car s, cadr s); put('ifilessp, 'c!:exit_helper, function c!:pifilessp); symbolic procedure c!:pifigreaterp(s, depth); c!:printf("((int32)(%v)) > ((int32)(%v))", car s, cadr s); put('ifigreaterp, 'c!:exit_helper, function c!:pifigreaterp); symbolic procedure c!:display_flowgraph(s, depth, dropping_through); if not atom s then << c!:printf " "; c!:pgoto(s, depth) >> else if not flagp(s, 'c!:visited) then begin scalar why, where_to; flag(list s, 'c!:visited); if not dropping_through or not (get(s, 'c!:count) = 1) then c!:printf("\n%s:\n", s); for each k in reverse get(s, 'c!:contents) do c!:print_opcode(k, depth); why := get(s, 'c!:why); where_to := get(s, 'c!:where_to); if why = 'goto and (not atom car where_to or (not flagp(car where_to, 'c!:visited) and get(car where_to, 'c!:count) = 1)) then c!:display_flowgraph(car where_to, depth, t) else c!:print_exit_condition(why, where_to, depth); end; fluid '(startpoint); symbolic procedure c!:branch_chain(s, count); begin scalar contents, why, where_to, n; % do nothing to blocks already visted or return blocks. if not atom s then return s else if flagp(s, 'c!:visited) then << n := get(s, 'c!:count); if null n then n := 1 else n := n + 1; put(s, 'c!:count, n); return s >>; flag(list s, 'c!:visited); contents := get(s, 'c!:contents); why := get(s, 'c!:why); where_to := for each z in get(s, 'c!:where_to) collect c!:branch_chain(z, count); % Turn movr a,b; return a; into return b; while contents and eqcar(car contents, 'movr) and why = 'goto and not atom car where_to and caar where_to = cadr car contents do << where_to := list list cadddr car contents; contents := cdr contents >>; put(s, 'c!:contents, contents); put(s, 'c!:where_to, where_to); % discard empty blocks if null contents and why = 'goto then << remflag(list s, 'c!:visited); return car where_to >>; if count then << n := get(s, 'c!:count); if null n then n := 1 else n := n + 1; put(s, 'c!:count, n) >>; return s end; symbolic procedure c!:one_operand op; << flag(list op, 'c!:set_r1); flag(list op, 'c!:read_r3); put(op, 'c!:code, function c!:builtin_one) >>; symbolic procedure c!:two_operands op; << flag(list op, 'c!:set_r1); flag(list op, 'c!:read_r2); flag(list op, 'c!:read_r3); put(op, 'c!:code, function c!:builtin_two) >>; for each n in '(car cdr qcar qcdr null not atom numberp fixp iminusp iminus iadd1 isub1 modular!-minus) do c!:one_operand n; !#if common!-lisp!-mode for each n in '(eq equal atsoc memq iplus2 idifference itimes2 ilessp igreaterp qgetv get modular!-plus modular!-difference ) do c!:two_operands n; !#else for each n in '(eq equal atsoc memq iplus2 idifference assoc member itimes2 ilessp igreaterp qgetv get modular!-plus modular!-difference ) do c!:two_operands n; !#endif flag('(movr movk movk1 ldrglob call reloadenv fastget fastflag), 'c!:set_r1); flag('(strglob qputv), 'c!:read_r1); flag('(qputv fastget fastflag), 'c!:read_r2); flag('(movr qputv), 'c!:read_r3); flag('(ldrglob strglob nilglob movk call), 'c!:read_env); % special opcodes: % call fluidbind fluid '(fn_used nil_used nilbase_used); symbolic procedure c!:live_variable_analysis all_blocks; begin scalar changed, z; repeat << changed := nil; for each b in all_blocks do begin scalar w, live; for each x in get(b, 'c!:where_to) do if atom x then live := union(live, get(x, 'c!:live)) else live := union(live, x); w := get(b, 'c!:why); if not atom w then << if eqcar(w, 'ifnull) or eqcar(w, 'ifequal) then nil_used := t; live := union(live, cdr w); if eqcar(car w, 'call) and (flagp(cadar w, 'c!:direct_predicate) or (flagp(cadar w, 'c!:c_entrypoint) and not flagp(cadar w, 'c!:direct_entrypoint))) then nil_used := t; if eqcar(car w, 'call) and not (cadar w = current_procedure) and not get(cadar w, 'c!:direct_entrypoint) and not get(cadar w, 'c!:c_entrypoint) then << fn_used := t; live := union('(env), live) >> >>; for each s in get(b, 'c!:contents) do begin % backwards over contents scalar op, r1, r2, r3; op := car s; r1 := cadr s; r2 := caddr s; r3 := cadddr s; if op = 'movk1 then << if r3 = nil then nil_used := t else if r3 = 't then nilbase_used := t >> else if atom op and flagp(op, 'c!:uses_nil) then nil_used := t; if flagp(op, 'c!:set_r1) then !#if common!-lisp!-mode if memq(r1, live) then live := remove(r1, live) !#else if memq(r1, live) then live := delete(r1, live) !#endif else if op = 'call then nil % Always needed else op := 'nop; if flagp(op, 'c!:read_r1) then live := union(live, list r1); if flagp(op, 'c!:read_r2) then live := union(live, list r2); if flagp(op, 'c!:read_r3) then live := union(live, list r3); if op = 'call then << if not flagp(car r3, 'c!:no_errors) or flagp(car r3, 'c!:c_entrypoint) or get(car r3, 'c!:direct_predicate) then nil_used := t; does_call := t; if not eqcar(r3, current_procedure) and not get(car r3, 'c!:direct_entrypoint) and not get(car r3, 'c!:c_entrypoint) then fn_used := t; if not flagp(car r3, 'c!:no_errors) then flag(live, 'c!:live_across_call); live := union(live, r2) >>; if flagp(op, 'c!:read_env) then live := union(live, '(env)) end; !#if common!-lisp!-mode live := append(live, nil); % because CL sort is destructive! !#endif live := sort(live, function orderp); if not (live = get(b, 'c!:live)) then << put(b, 'c!:live, live); changed := t >> end >> until not changed; z := registers; registers := stacklocs := nil; for each r in z do if flagp(r, 'c!:live_across_call) then stacklocs := r . stacklocs else registers := r . registers end; symbolic procedure c!:insert1(a, b); if memq(a, b) then b else a . b; symbolic procedure c!:clash(a, b); if flagp(a, 'c!:live_across_call) = flagp(b, 'c!:live_across_call) then << put(a, 'c!:clash, c!:insert1(b, get(a, 'c!:clash))); put(b, 'c!:clash, c!:insert1(a, get(b, 'c!:clash))) >>; symbolic procedure c!:build_clash_matrix all_blocks; begin for each b in all_blocks do begin scalar live, w; for each x in get(b, 'c!:where_to) do if atom x then live := union(live, get(x, 'c!:live)) else live := union(live, x); w := get(b, 'c!:why); if not atom w then << live := union(live, cdr w); if eqcar(car w, 'call) and not get(cadar w, 'c!:direct_entrypoint) and not get(cadar w, 'c!:c_entrypoint) then live := union('(env), live) >>; for each s in get(b, 'c!:contents) do begin scalar op, r1, r2, r3; op := car s; r1 := cadr s; r2 := caddr s; r3 := cadddr s; if flagp(op, 'c!:set_r1) then if memq(r1, live) then << !#if common!-lisp!-mode live := remove(r1, live); !#else live := delete(r1, live); !#endif if op = 'reloadenv then reloadenv := t; for each v in live do c!:clash(r1, v) >> else if op = 'call then nil else << op := 'nop; rplacd(s, car s . cdr s); % Leaves original instrn visible rplaca(s, op) >>; if flagp(op, 'c!:read_r1) then live := union(live, list r1); if flagp(op, 'c!:read_r2) then live := union(live, list r2); if flagp(op, 'c!:read_r3) then live := union(live, list r3); % Maybe CALL should be a little more selective about need for "env"? if op = 'call then live := union(live, r2); if flagp(op, 'c!:read_env) then live := union(live, '(env)) end end; % The next few lines are for debugging... %%- c!:printf "Scratch registers:\n"; %%- for each r in registers do %%- c!:printf("%s clashes: %s\n", r, get(r, 'c!:clash)); %%- c!:printf "Stack items:\n"; %%- for each r in stacklocs do %%- c!:printf("%s clashes: %s\n", r, get(r, 'c!:clash)); return nil end; symbolic procedure c!:allocate_registers rl; begin scalar schedule, neighbours, allocation; neighbours := 0; while rl do begin scalar w, x; w := rl; while w and length (x := get(car w, 'c!:clash)) > neighbours do w := cdr w; if w then << schedule := car w . schedule; rl := deleq(car w, rl); for each r in x do put(r, 'c!:clash, deleq(car w, get(r, 'c!:clash))) >> else neighbours := neighbours + 1 end; for each r in schedule do begin scalar poss; poss := allocation; for each x in get(r, 'c!:clash) do poss := deleq(get(x, 'c!:chosen), poss); if null poss then << poss := c!:my_gensym(); allocation := append(allocation, list poss) >> else poss := car poss; % c!:printf("/* Allocate %s to %s, to miss %s */\n", % r, poss, get(r, 'c!:clash)); put(r, 'c!:chosen, poss) end; return allocation end; symbolic procedure c!:remove_nops all_blocks; % Remove no-operation instructions, and map registers to reflect allocation for each b in all_blocks do begin scalar r; for each s in get(b, 'c!:contents) do if not eqcar(s, 'nop) then begin scalar op, r1, r2, r3; op := car s; r1 := cadr s; r2 := caddr s; r3 := cadddr s; if flagp(op, 'c!:set_r1) or flagp(op, 'c!:read_r1) then r1 := get(r1, 'c!:chosen); if flagp(op, 'c!:read_r2) then r2 := get(r2, 'c!:chosen); if flagp(op, 'c!:read_r3) then r3 := get(r3, 'c!:chosen); if op = 'call then r2 := for each v in r2 collect get(v, 'c!:chosen); if not (op = 'movr and r1 = r3) then r := list(op, r1, r2, r3) . r end; put(b, 'c!:contents, reversip r); r := get(b, 'c!:why); if not atom r then put(b, 'c!:why, car r . for each v in cdr r collect get(v, 'c!:chosen)) end; fluid '(error_labels); symbolic procedure c!:find_error_label(why, env, depth); begin scalar w, z; z := list(why, env, depth); w := assoc!*!*(z, error_labels); if null w then << w := z . c!:my_gensym(); error_labels := w . error_labels >>; return cdr w end; symbolic procedure c!:assign(u, v, c); if flagp(u, 'fluid) then list('strglob, v, u, c!:find_literal u) . c else list('movr, u, nil, v) . c; symbolic procedure c!:insert_tailcall b; begin scalar why, dest, contents, fcall, res, w; why := get(b, 'c!:why); dest := get(b, 'c!:where_to); contents := get(b, 'c!:contents); while contents and not eqcar(car contents, 'call) do << w := car contents . w; contents := cdr contents >>; if null contents then return nil; fcall := car contents; contents := cdr contents; res := cadr fcall; while w do << if eqcar(car w, 'reloadenv) then w := cdr w else if eqcar(car w, 'movr) and cadddr car w = res then << res := cadr car w; w := cdr w >> else res := w := nil >>; if null res then return nil; if c!:does_return(res, why, dest) then if car cadddr fcall = current_procedure then << for each p in pair(current_args, caddr fcall) do contents := c!:assign(car p, cdr p, contents); put(b, 'c!:contents, contents); put(b, 'c!:why, 'goto); put(b, 'c!:where_to, list restart_label) >> else << nil_used := t; put(b, 'c!:contents, contents); put(b, 'c!:why, list('call, car cadddr fcall) . caddr fcall); put(b, 'c!:where_to, nil) >> end; symbolic procedure c!:does_return(res, why, where_to); if not (why = 'goto) then nil else if not atom car where_to then res = caar where_to else begin scalar contents; where_to := car where_to; contents := reverse get(where_to, 'c!:contents); why := get(where_to, 'c!:why); where_to := get(where_to, 'c!:where_to); while contents do if eqcar(car contents, 'reloadenv) then contents := cdr contents else if eqcar(car contents, 'movr) and cadddr car contents = res then << res := cadr car contents; contents := cdr contents >> else res := contents := nil; if null res then return nil else return c!:does_return(res, why, where_to) end; symbolic procedure c!:pushpop(op, v); % for each x in v do c!:printf(" %s(%s);\n", op, x); begin scalar n, w; if null v then return nil; n := length v; if n = 1 then return c!:printf(" %s(%s);\n", op, car v); while n > 0 do << w := n; if w > 6 then w := 6; n := n-w; c!:printf(" %s%d(%s", op, w, car v); v := cdr v; for i := 2:w do << c!:printf(",%s", car v); v := cdr v >>; c!:printf(");\n") >> end; symbolic procedure c!:optimise_flowgraph(startpoint, all_blocks, env, argch, args); begin scalar w, n, locs, stacks, error_labels, fn_used, nil_used, nilbase_used; !#if common!-lisp!-mode nilbase_used := t; % For onevalue(xxx) at least !#endif for each b in all_blocks do c!:insert_tailcall b; startpoint := c!:branch_chain(startpoint, nil); remflag(all_blocks, 'c!:visited); c!:live_variable_analysis all_blocks; c!:build_clash_matrix all_blocks; if error_labels and env then reloadenv := t; for each u in env do for each v in env do c!:clash(cdr u, cdr v); % keep all args distinct locs := c!:allocate_registers registers; stacks := c!:allocate_registers stacklocs; flag(stacks, 'c!:live_across_call); c!:remove_nops all_blocks; startpoint := c!:branch_chain(startpoint, nil); % after tailcall insertion remflag(all_blocks, 'c!:visited); startpoint := c!:branch_chain(startpoint, t); % ... AGAIN to tidy up remflag(all_blocks, 'c!:visited); if does_call then nil_used := t; if nil_used then c!:printf " Lisp_Object nil = C_nil;\n" else if nilbase_used then c!:printf " nil_as_base\n"; if locs then << c!:printf(" Lisp_Object %s", car locs); for each v in cdr locs do c!:printf(", %s", v); c!:printf ";\n" >>; if fn_used then c!:printf " Lisp_Object fn;\n"; if car argch = 0 or car argch >= 3 then c!:printf(" argcheck(nargs, %s, \q%s\q);\n", car argch, cdr argch); % I will not do a stack check if I have a leaf procedure, and I hope % that this policy will speed up code a bit. if does_call then << c!:printf " if (stack >= stacklimit)\n"; c!:printf " {\n"; % This is slightly clumsy code to save all args on the stack across the % call to reclaim(), but it is not executed often... c!:pushpop('push, args); c!:printf " env = reclaim(env, \qstack\q, GC_STACK, 0);\n"; c!:pushpop('pop, reverse args); c!:printf " nil = C_nil;\n"; c!:printf " if (exception_pending()) return nil;\n"; c!:printf " }\n" >>; if reloadenv then c!:printf(" push(env);\n") else c!:printf(" CSL_IGNORE(env);\n"); n := 0; if stacks then << c!:printf "/* space for vars preserved across procedure calls */\n"; for each v in stacks do << put(v, 'c!:location, n); n := n+1 >>; w := n; while w >= 5 do << c!:printf " push5(nil, nil, nil, nil, nil);\n"; w := w - 5 >>; if w neq 0 then << if w = 1 then c!:printf " push(nil);\n" else << c!:printf(" push%s(nil", w); for i := 2:w do c!:printf ", nil"; c!:printf ");\n" >> >> >>; if reloadenv then << reloadenv := n; n := n + 1 >>; if env then c!:printf "/* copy arguments values to proper place */\n"; for each v in env do if flagp(cdr v, 'c!:live_across_call) then c!:printf(" stack[%s] = %s;\n", -get(get(cdr v, 'c!:chosen), 'c!:location), cdr v) else c!:printf(" %s = %s;\n", get(cdr v, 'c!:chosen), cdr v); c!:printf "/* end of prologue */\n"; c!:display_flowgraph(startpoint, n, t); if error_labels then << c!:printf "/* error exit handlers */\n"; for each x in error_labels do << c!:printf("%s:\n", cdr x); c!:print_error_return(caar x, cadar x, caddar x) >> >>; remflag(all_blocks, 'c!:visited); end; symbolic procedure c!:print_error_return(why, env, depth); begin if reloadenv and env then c!:printf(" env = stack[%s];\n", -reloadenv); if null why then << % One could imagine generating backtrace entries here... for each v in env do c!:printf(" qvalue(elt(env, %s)) = %v; /* %a */\n", c!:find_literal car v, get(cdr v, 'c!:chosen), car v); if depth neq 0 then c!:printf(" popv(%s);\n", depth); c!:printf " return nil;\n" >> else if flagp(cadr why, 'c!:live_across_call) then << c!:printf(" { Lisp_Object res = %v;\n", cadr why); for each v in env do c!:printf(" qvalue(elt(env, %s)) = %v;\n", c!:find_literal car v, get(cdr v, 'c!:chosen)); if depth neq 0 then c!:printf(" popv(%s);\n", depth); c!:printf(" return error(1, %s, res); }\n", if eqcar(why, 'car) then "err_bad_car" else if eqcar(why, 'cdr) then "err_bad_cdr" else error(0, list(why, "unknown_error"))) >> else << for each v in env do c!:printf(" qvalue(elt(env, %s)) = %v;\n", c!:find_literal car v, get(cdr v, 'c!:chosen)); if depth neq 0 then c!:printf(" popv(%s);\n", depth); c!:printf(" return error(1, %s, %v);\n", (if eqcar(why, 'car) then "err_bad_car" else if eqcar(why, 'cdr) then "err_bad_cdr" else error(0, list(why, "unknown_error"))), cadr why) >> end; % % Now I have a series of separable sections each of which gives a special % recipe that implements or optimises compilation of some specific Lisp % form. % symbolic procedure c!:cand(u, env); begin scalar w, r; w := reverse cdr u; if null w then return c!:cval(nil, env); r := list(list('t, car w)); w := cdr w; for each z in w do r := list(list('null, z), nil) . r; r := 'cond . r; return c!:cval(r, env) end; %-- scalar next, done, v, r; %-- v := c!:newreg(); %-- done := c!:my_gensym(); %-- u := cdr u; %-- while cdr u do << %-- next := c!:my_gensym(); %-- c!:outop('movr, v, nil, c!:cval(car u, env)); %-- u := cdr u; %-- c!:endblock(list('ifnull, v), list(done, next)); %-- c!:startblock next >>; %-- c!:outop('movr, v, nil, c!:cval(car u, env)); %-- c!:endblock('goto, list done); %-- c!:startblock done; %-- return v %-- end; put('and, 'c!:code, function c!:cand); !#if common!-lisp!-mode symbolic procedure c!:cblock(u, env); begin scalar progret, progexit, r; progret := c!:newreg(); progexit := c!:my_gensym(); blockstack := (cadr u . progret . progexit) . blockstack; u := cddr u; for each a in u do r := c!:cval(a, env); c!:outop('movr, progret, nil, r); c!:endblock('goto, list progexit); c!:startblock progexit; blockstack := cdr blockstack; return progret end; put('block, 'c!:code, function c!:cblock); !#endif symbolic procedure c!:ccatch(u, env); error(0, "catch"); put('catch, 'c!:code, function c!:ccatch); symbolic procedure c!:ccompile_let(u, env); error(0, "compiler-let"); put('compiler!-let, 'c!:code, function c!:ccompiler_let); symbolic procedure c!:ccond(u, env); begin scalar v, join; v := c!:newreg(); join := c!:my_gensym(); for each c in cdr u do begin scalar l1, l2; l1 := c!:my_gensym(); l2 := c!:my_gensym(); if atom cdr c then << c!:outop('movr, v, nil, c!:cval(car c, env)); c!:endblock(list('ifnull, v), list(l2, join)) >> else << c!:cjumpif(car c, env, l1, l2); c!:startblock l1; % if the condition is true c!:outop('movr, v, nil, c!:cval('progn . cdr c, env)); c!:endblock('goto, list join) >>; c!:startblock l2 end; c!:outop('movk1, v, nil, nil); c!:endblock('goto, list join); c!:startblock join; return v end; put('cond, 'c!:code, function c!:ccond); symbolic procedure c!:cdeclare(u, env); error(0, "declare"); put('declare, 'c!:code, function c!:cdeclare); symbolic procedure c!:cde(u, env); error(0, "de"); put('de, 'c!:code, function c!:cde); symbolic procedure c!:cdefun(u, env); error(0, "defun"); put('!~defun, 'c!:code, function c!:cdefun); symbolic procedure c!:ceval_when(u, env); error(0, "eval-when"); put('eval!-when, 'c!:code, function c!:ceval_when); symbolic procedure c!:cflet(u, env); error(0, "flet"); put('flet, 'c!:code, function c!:cflet); symbolic procedure c!:cfunction(u, env); begin scalar v; u := cadr u; if not atom u then << if not eqcar(u, 'lambda) then error(0, list("lambda expression needed", u)); v := dated!-name 'lambda; pending_functions := ('de . v . cdr u) . pending_functions; u := v >>; v := c!:newreg(); c!:outop('movk, v, u, c!:find_literal u); return v; end; put('function, 'c!:code, function c!:cfunction); symbolic procedure c!:cgo(u, env); begin scalar w, w1; w1 := proglabs; while null w and w1 do << w := assoc!*!*(cadr u, car w1); w1 := cdr w1 >>; if null w then error(0, list(u, "label not set")); c!:endblock('goto, list cadr w); return nil % value should not be used end; put('go, 'c!:code, function c!:cgo); symbolic procedure c!:cif(u, env); begin scalar v, join, l1, l2; v := c!:newreg(); join := c!:my_gensym(); l1 := c!:my_gensym(); l2 := c!:my_gensym(); c!:cjumpif(cadr u, env, l1, l2); c!:startblock l1; c!:outop('movr, v, nil, c!:cval(car (u := cddr u), env)); c!:endblock('goto, list join); c!:startblock l2; c!:outop('movr, v, nil, c!:cval(cadr u, env)); c!:endblock('goto, list join); c!:startblock join; return v end; put('if, 'c!:code, function c!:cif); symbolic procedure c!:clabels(u, env); error(0, "labels"); put('labels, 'c!:code, function c!:clabels); symbolic procedure c!:expand!-let(vl, b); if null vl then 'progn . b else if null cdr vl then c!:expand!-let!*(vl, b) else begin scalar vars, vals; for each v in vl do if atom v then << vars := v . vars; vals := nil . vals >> else if atom cdr v then << vars := car v . vars; vals := nil . vals >> else << vars := car v . vars; vals := cadr v . vals >>; return ('lambda . vars . b) . vals end; symbolic procedure c!:clet(x, env); c!:cval(c!:expand!-let(cadr x, cddr x), env); !#if common!-lisp!-mode put('let, 'c!:code, function c!:clet); !#else put('!~let, 'c!:code, function c!:clet); !#endif symbolic procedure c!:expand!-let!*(vl, b); if null vl then 'progn . b else begin scalar var, val; var := car vl; if not atom var then << val := cdr var; var := car var; if not atom val then val := car val >>; b := list list('return, c!:expand!-let!*(cdr vl, b)); if val then b := list('setq, var, val) . b; return 'prog . list var . b end; symbolic procedure c!:clet!*(x, env); c!:cval(c!:expand!-let!*(cadr x, cddr x), env); put('let!*, 'c!:code, function c!:clet!*); symbolic procedure c!:clist(u, env); if null cdr u then c!:cval(nil, env) else if null cddr u then c!:cval('ncons . cdr u, env) else if eqcar(cadr u, 'cons) then c!:cval(list('acons, cadr cadr u, caddr cadr u, 'list . cddr u), env) else if null cdddr u then c!:cval('list2 . cdr u, env) else c!:cval(list('list2!*, cadr u, caddr u, 'list . cdddr u), env); put('list, 'c!:code, function c!:clist); symbolic procedure c!:clist!*(u, env); begin scalar v; u := reverse cdr u; v := car u; for each a in cdr u do v := list('cons, a, v); return c!:cval(v, env) end; put('list!*, 'c!:code, function c!:clist!*); symbolic procedure c!:ccons(u, env); begin scalar a1, a2; a1 := s!:improve cadr u; a2 := s!:improve caddr u; if a2 = nil or a2 = '(quote nil) or a2 = '(list) then return c!:cval(list('ncons, a1), env); if eqcar(a1, 'cons) then return c!:cval(list('acons, cadr a1, caddr a1, a2), env); if eqcar(a2, 'cons) then return c!:cval(list('list2!*, a1, cadr a2, caddr a2), env); if eqcar(a2, 'list) then return c!:cval(list('cons, a1, list('cons, cadr a2, 'list . cddr a2)), env); return c!:ccall(car u, cdr u, env) end; put('cons, 'c!:code, function c!:ccons); symbolic procedure c!:cget(u, env); begin scalar a1, a2, w, r, r1; a1 := s!:improve cadr u; a2 := s!:improve caddr u; if eqcar(a2, 'quote) and idp(w := cadr a2) and (w := symbol!-make!-fastget(w, nil)) then << r := c!:newreg(); c!:outop('fastget, r, c!:cval(a1, env), w . cadr a2); return r >> else return c!:ccall(car u, cdr u, env) end; put('get, 'c!:code, function c!:cget); symbolic procedure c!:cflag(u, env); begin scalar a1, a2, w, r, r1; a1 := s!:improve cadr u; a2 := s!:improve caddr u; if eqcar(a2, 'quote) and idp(w := cadr a2) and (w := symbol!-make!-fastget(w, nil)) then << r := c!:newreg(); c!:outop('fastflag, r, c!:cval(a1, env), w . cadr a2); return r >> else return c!:ccall(car u, cdr u, env) end; put('flagp, 'c!:code, function c!:cflag); symbolic procedure c!:cgetv(u, env); if not !*fastvector then c!:ccall(car u, cdr u, env) else c!:cval('qgetv . cdr u, env); put('getv, 'c!:code, function c!:cgetv); !#if common!-lisp!-mode put('svref, 'c!:code, function c!:cgetv); !#endif symbolic procedure c!:cputv(u, env); if not !*fastvector then c!:ccall(car u, cdr u, env) else c!:cval('qputv . cdr u, env); put('putv, 'c!:code, function c!:cputv); symbolic procedure c!:cqputv(x, env); begin scalar rr; rr := c!:pareval(cdr x, env); c!:outop('qputv, caddr rr, car rr, cadr rr); return caddr rr end; put('qputv, 'c!:code, function c!:cqputv); symbolic procedure c!:cmacrolet(u, env); error(0, "macrolet"); put('macrolet, 'c!:code, function c!:cmacrolet); symbolic procedure c!:cmultiple_value_call(u, env); error(0, "multiple_value_call"); put('multiple!-value!-call, 'c!:code, function c!:cmultiple_value_call); symbolic procedure c!:cmultiple_value_prog1(u, env); error(0, "multiple_value_prog1"); put('multiple!-value!-prog1, 'c!:code, function c!:cmultiple_value_prog1); symbolic procedure c!:cor(u, env); begin scalar next, done, v, r; v := c!:newreg(); done := c!:my_gensym(); u := cdr u; while cdr u do << next := c!:my_gensym(); c!:outop('movr, v, nil, c!:cval(car u, env)); u := cdr u; c!:endblock(list('ifnull, v), list(next, done)); c!:startblock next >>; c!:outop('movr, v, nil, c!:cval(car u, env)); c!:endblock('goto, list done); c!:startblock done; return v end; put('or, 'c!:code, function c!:cor); symbolic procedure c!:cprog(u, env); begin scalar w, w1, bvl, local_proglabs, progret, progexit, fluids, env1; env1 := car env; bvl := cadr u; for each v in bvl do if globalp v then error(0, list(v, "attempt to bind a global")) else if fluidp v then << fluids := (v . c!:newreg()) . fluids; flag(list cdar fluids, 'c!:live_across_call); % silly if not env1 := ('c!:dummy!:name . cdar fluids) . env1; c!:outop('ldrglob, cdar fluids, v, c!:find_literal v); c!:outop('nilglob, nil, v, c!:find_literal v) >> else << env1 := (v . c!:newreg()) . env1; c!:outop('movk1, cdar env1, nil, nil) >>; if fluids then c!:outop('fluidbind, nil, nil, fluids); env := env1 . append(fluids, cdr env); u := cddr u; progret := c!:newreg(); progexit := c!:my_gensym(); blockstack := (nil . progret . progexit) . blockstack; for each a in u do if atom a then if atsoc(a, local_proglabs) then << if not null a then << w := wrs nil; princ "+++++ multiply defined label: "; prin a; terpri(); wrs w >> >> else local_proglabs := list(a, c!:my_gensym()) . local_proglabs; proglabs := local_proglabs . proglabs; for each a in u do if atom a then << w := cdr(assoc!*!*(a, local_proglabs)); if null cdr w then << rplacd(w, t); c!:endblock('goto, list car w); c!:startblock car w >> >> else c!:cval(a, env); c!:outop('movk1, progret, nil, nil); c!:endblock('goto, list progexit); c!:startblock progexit; for each v in fluids do c!:outop('strglob, cdr v, car v, c!:find_literal car v); blockstack := cdr blockstack; proglabs := cdr proglabs; return progret end; put('prog, 'c!:code, function c!:cprog); symbolic procedure c!:cprog!*(u, env); error(0, "prog*"); put('prog!*, 'c!:code, function c!:cprog!*); symbolic procedure c!:cprog1(u, env); begin scalar g; g := c!:my_gensym(); g := list('prog, list g, list('setq, g, cadr u), 'progn . cddr u, list('return, g)); return c!:cval(g, env) end; put('prog1, 'c!:code, function c!:cprog1); symbolic procedure c!:cprog2(u, env); begin scalar g; u := cdr u; g := c!:my_gensym(); g := list('prog, list g, list('setq, g, cadr u), 'progn . cddr u, list('return, g)); g := list('progn, car u, g); return c!:cval(g, env) end; put('prog2, 'c!:code, function c!:cprog2); symbolic procedure c!:cprogn(u, env); begin scalar r; u := cdr u; if u = nil then u := '(nil); for each s in u do r := c!:cval(s, env); return r end; put('progn, 'c!:code, function c!:cprogn); symbolic procedure c!:cprogv(u, env); error(0, "progv"); put('progv, 'c!:code, function c!:cprogv); symbolic procedure c!:cquote(u, env); begin scalar v; u := cadr u; v := c!:newreg(); if null u or u = 't or c!:small_number u then c!:outop('movk1, v, nil, u) else c!:outop('movk, v, u, c!:find_literal u); return v; end; put('quote, 'c!:code, function c!:cquote); symbolic procedure c!:creturn(u, env); begin scalar w; w := assoc!*!*(nil, blockstack); if null w then error "RETURN out of context"; c!:outop('movr, cadr w, nil, c!:cval(cadr u, env)); c!:endblock('goto, list cddr w); return nil % value should not be used end; put('return, 'c!:code, function c!:creturn); !#if common!-lisp!-mode symbolic procedure c!:creturn_from(u, env); begin scalar w; w := assoc!*!*(cadr u, blockstack); if null w then error "RETURN-FROM out of context"; c!:outop('movr, cadr w, nil, c!:cval(caddr u, env)); c!:endblock('goto, list cddr w); return nil % value should not be used end; !#endif put('return!-from, 'c!:code, function c!:creturn_from); symbolic procedure c!:csetq(u, env); begin scalar v, w; v := c!:cval(caddr u, env); u := cadr u; if not idp u then error(0, list(u, "bad variable in setq")) else if (w := c!:locally_bound(u, env)) then c!:outop('movr, cdr w, nil, v) else if flagp(u, 'c!:constant) then error(0, list(u, "attempt to use setq on a constant")) else c!:outop('strglob, v, u, c!:find_literal u); return v end; put('setq, 'c!:code, function c!:csetq); put('noisy!-setq, 'c!:code, function c!:csetq); !#if common!-lisp!-mode symbolic procedure c!:ctagbody(u, env); begin scalar w, bvl, local_proglabs, res; u := cdr u; for each a in u do if atom a then if atsoc(a, local_proglabs) then << if not null a then << w := wrs nil; princ "+++++ multiply defined label: "; prin a; terpri(); wrs w >> >> else local_proglabs := list(a, c!:my_gensym()) . local_proglabs; proglabs := local_proglabs . proglabs; for each a in u do if atom a then << w := cdr(assoc!*!*(a, local_proglabs)); if null cdr w then << rplacd(w, t); c!:endblock('goto, list car w); c!:startblock car w >> >> else res := c!:cval(a, env); if null res then res := c!:cval(nil, env); proglabs := cdr proglabs; return res end; put('tagbody, 'c!:code, function c!:ctagbody); !#endif symbolic procedure c!:cprivate_tagbody(u, env); % This sets a label for use for tail-call to self. begin u := cdr u; c!:endblock('goto, list car u); c!:startblock car u; % This seems to be the proper place to capture the internal names associated % with argument-vars that must be reset if a tail-call is mapped into a loop. current_args := for each v in current_args collect begin scalar z; z := assoc!*!*(v, car env); return if z then cdr z else v end; return c!:cval(cadr u, env) end; put('c!:private_tagbody, 'c!:code, function c!:cprivate_tagbody); symbolic procedure c!:cthe(u, env); c!:cval(caddr u, env); put('the, 'c!:code, function c!:cthe); symbolic procedure c!:cthrow(u, env); error(0, "throw"); put('throw, 'c!:code, function c!:cthrow); symbolic procedure c!:cunless(u, env); begin scalar v, join, l1, l2; v := c!:newreg(); join := c!:my_gensym(); l1 := c!:my_gensym(); l2 := c!:my_gensym(); c!:cjumpif(cadr u, env, l2, l1); c!:startblock l1; c!:outop('movr, v, nil, c!:cval('progn . cddr u, env)); c!:endblock('goto, list join); c!:startblock l2; c!:outop('movk1, v, nil, nil); c!:endblock('goto, list join); c!:startblock join; return v end; put('unless, 'c!:code, function c!:cunless); symbolic procedure c!:cunwind_protect(u, env); error(0, "unwind_protect"); put('unwind!-protect, 'c!:code, function c!:cunwind_protect); symbolic procedure c!:cwhen(u, env); begin scalar v, join, l1, l2; v := c!:newreg(); join := c!:my_gensym(); l1 := c!:my_gensym(); l2 := c!:my_gensym(); c!:cjumpif(cadr u, env, l1, l2); c!:startblock l1; c!:outop('movr, v, nil, c!:cval('progn . cddr u, env)); c!:endblock('goto, list join); c!:startblock l2; c!:outop('movk1, v, nil, nil); c!:endblock('goto, list join); c!:startblock join; return v end; put('when, 'c!:code, function c!:cwhen); % % End of code to handle special forms - what comes from here on is % more concerned with performance than with speed. % !#if (not common!-lisp!-mode) % mapcar etc are compiled specially as a fudge to achieve an effect as % if proper environment-capture was implemented for the functional % argument (which I do not support at present). symbolic procedure c!:expand_map(fnargs); begin scalar carp, fn, fn1, args, var, avar, moveon, l1, r, s, closed; fn := car fnargs; % if the value of a mapping function is not needed I demote from mapcar to % mapc or from maplist to map. % if context > 1 then << % if fn = 'mapcar then fn := 'mapc % else if fn = 'maplist then fn := 'map >>; if fn = 'mapc or fn = 'mapcar or fn = 'mapcan then carp := t; fnargs := cdr fnargs; if atom fnargs then error(0,"bad arguments to map function"); fn1 := cadr fnargs; while eqcar(fn1, 'function) or (eqcar(fn1, 'quote) and eqcar(cadr fn1, 'lambda)) do << fn1 := cadr fn1; closed := t >>; % if closed is false I will insert FUNCALL since I am invoking a function % stored in a variable - NB this means that the word FUNCTION becomes % essential when using mapping operators - this is because I have built % a 2-Lisp rather than a 1-Lisp. args := car fnargs; l1 := c!:my_gensym(); r := c!:my_gensym(); s := c!:my_gensym(); var := c!:my_gensym(); avar := var; if carp then avar := list('car, avar); if closed then fn1 := list(fn1, avar) else fn1 := list('apply1, fn1, avar); moveon := list('setq, var, list('cdr, var)); if fn = 'map or fn = 'mapc then fn := sublis( list('l1 . l1, 'var . var, 'fn . fn1, 'args . args, 'moveon . moveon), '(prog (var) (setq var args) l1 (cond ((not var) (return nil))) fn moveon (go l1))) else if fn = 'maplist or fn = 'mapcar then fn := sublis( list('l1 . l1, 'var . var, 'fn . fn1, 'args . args, 'moveon . moveon, 'r . r), '(prog (var r) (setq var args) l1 (cond ((not var) (return (reversip r)))) (setq r (cons fn r)) moveon (go l1))) else fn := sublis( list('l1 . l1, 'l2 . c!:my_gensym(), 'var . var, 'fn . fn1, 'args . args, 'moveon . moveon, 'r . c!:my_gensym(), 's . c!:my_gensym()), '(prog (var r s) (setq var args) (setq r (setq s (list nil))) l1 (cond ((not var) (return (cdr r)))) (rplacd s fn) l2 (cond ((not (atom (cdr s))) (setq s (cdr s)) (go l2))) moveon (go l1))); return fn end; put('map, 'c!:compile_macro, function c!:expand_map); put('maplist, 'c!:compile_macro, function c!:expand_map); put('mapc, 'c!:compile_macro, function c!:expand_map); put('mapcar, 'c!:compile_macro, function c!:expand_map); put('mapcon, 'c!:compile_macro, function c!:expand_map); put('mapcan, 'c!:compile_macro, function c!:expand_map); !#endif % caaar to cddddr get expanded into compositions of % car, cdr which are compiled in-line symbolic procedure c!:expand_carcdr(x); begin scalar name; name := cdr reverse cdr explode2 car x; x := cadr x; for each v in name do x := list(if v = 'a then 'car else 'cdr, x); return x end; << put('caar, 'c!:compile_macro, function c!:expand_carcdr); put('cadr, 'c!:compile_macro, function c!:expand_carcdr); put('cdar, 'c!:compile_macro, function c!:expand_carcdr); put('cddr, 'c!:compile_macro, function c!:expand_carcdr); put('caaar, 'c!:compile_macro, function c!:expand_carcdr); put('caadr, 'c!:compile_macro, function c!:expand_carcdr); put('cadar, 'c!:compile_macro, function c!:expand_carcdr); put('caddr, 'c!:compile_macro, function c!:expand_carcdr); put('cdaar, 'c!:compile_macro, function c!:expand_carcdr); put('cdadr, 'c!:compile_macro, function c!:expand_carcdr); put('cddar, 'c!:compile_macro, function c!:expand_carcdr); put('cdddr, 'c!:compile_macro, function c!:expand_carcdr); put('caaaar, 'c!:compile_macro, function c!:expand_carcdr); put('caaadr, 'c!:compile_macro, function c!:expand_carcdr); put('caadar, 'c!:compile_macro, function c!:expand_carcdr); put('caaddr, 'c!:compile_macro, function c!:expand_carcdr); put('cadaar, 'c!:compile_macro, function c!:expand_carcdr); put('cadadr, 'c!:compile_macro, function c!:expand_carcdr); put('caddar, 'c!:compile_macro, function c!:expand_carcdr); put('cadddr, 'c!:compile_macro, function c!:expand_carcdr); put('cdaaar, 'c!:compile_macro, function c!:expand_carcdr); put('cdaadr, 'c!:compile_macro, function c!:expand_carcdr); put('cdadar, 'c!:compile_macro, function c!:expand_carcdr); put('cdaddr, 'c!:compile_macro, function c!:expand_carcdr); put('cddaar, 'c!:compile_macro, function c!:expand_carcdr); put('cddadr, 'c!:compile_macro, function c!:expand_carcdr); put('cdddar, 'c!:compile_macro, function c!:expand_carcdr); put('cddddr, 'c!:compile_macro, function c!:expand_carcdr) >>; symbolic procedure c!:builtin_one(x, env); begin scalar r1, r2; r1 := c!:cval(cadr x, env); c!:outop(car x, r2:=c!:newreg(), cdr env, r1); return r2 end; symbolic procedure c!:builtin_two(x, env); begin scalar a1, a2, r, rr; a1 := cadr x; a2 := caddr x; rr := c!:pareval(list(a1, a2), env); c!:outop(car x, r:=c!:newreg(), car rr, cadr rr); return r end; symbolic procedure c!:narg(x, env); c!:cval(expand(cdr x, get(car x, 'c!:binary_version)), env); for each n in '((plus plus2) (times times2) (iplus iplus2) (itimes itimes2)) do << put(car n, 'c!:binary_version, cadr n); put(car n, 'c!:code, function c!:narg) >>; !#if common!-lisp!-mode for each n in '((!+ plus2) (!* times2)) do << put(car n, 'c!:binary_version, cadr n); put(car n, 'c!:code, function c!:narg) >>; !#endif symbolic procedure c!:cplus2(u, env); begin scalar a, b; a := s!:improve cadr u; b := s!:improve caddr u; return if numberp a and numberp b then c!:cval(a+b, env) else if a = 0 then c!:cval(b, env) else if a = 1 then c!:cval(list('add1, b), env) else if b = 0 then c!:cval(a, env) else if b = 1 then c!:cval(list('add1, a), env) else if b = -1 then c!:cval(list('sub1, a), env) else c!:ccall(car u, cdr u, env) end; put('plus2, 'c!:code, function c!:cplus2); symbolic procedure c!:ciplus2(u, env); begin scalar a, b; a := s!:improve cadr u; b := s!:improve caddr u; return if numberp a and numberp b then c!:cval(a+b, env) else if a = 0 then c!:cval(b, env) else if a = 1 then c!:cval(list('iadd1, b), env) else if b = 0 then c!:cval(a, env) else if b = 1 then c!:cval(list('iadd1, a), env) else if b = -1 then c!:cval(list('isub1, a), env) else c!:builtin_two(u, env) end; put('iplus2, 'c!:code, function c!:ciplus2); symbolic procedure c!:cdifference(u, env); begin scalar a, b; a := s!:improve cadr u; b := s!:improve caddr u; return if numberp a and numberp b then c!:cval(a-b, env) else if a = 0 then c!:cval(list('minus, b), env) else if b = 0 then c!:cval(a, env) else if b = 1 then c!:cval(list('sub1, a), env) else if b = -1 then c!:cval(list('add1, a), env) else c!:ccall(car u, cdr u, env) end; put('difference, 'c!:code, function c!:cdifference); symbolic procedure c!:cidifference(u, env); begin scalar a, b; a := s!:improve cadr u; b := s!:improve caddr u; return if numberp a and numberp b then c!:cval(a-b, env) else if a = 0 then c!:cval(list('iminus, b), env) else if b = 0 then c!:cval(a, env) else if b = 1 then c!:cval(list('isub1, a), env) else if b = -1 then c!:cval(list('iadd1, a), env) else c!:builtin_two(u, env) end; put('idifference, 'c!:code, function c!:cidifference); symbolic procedure c!:ctimes2(u, env); begin scalar a, b; a := s!:improve cadr u; b := s!:improve caddr u; return if numberp a and numberp b then c!:cval(a*b, env) else if a = 0 or b = 0 then c!:cval(0, env) else if a = 1 then c!:cval(b, env) else if b = 1 then c!:cval(a, env) else if a = -1 then c!:cval(list('minus, b), env) else if b = -1 then c!:cval(list('minus, a), env) else c!:ccall(car u, cdr u, env) end; put('times2, 'c!:code, function c!:ctimes2); symbolic procedure c!:citimes2(u, env); begin scalar a, b; a := s!:improve cadr u; b := s!:improve caddr u; return if numberp a and numberp b then c!:cval(a*b, env) else if a = 0 or b = 0 then c!:cval(0, env) else if a = 1 then c!:cval(b, env) else if b = 1 then c!:cval(a, env) else if a = -1 then c!:cval(list('iminus, b), env) else if b = -1 then c!:cval(list('iminus, a), env) else c!:builtin_two(u, env) end; put('itimes2, 'c!:code, function c!:citimes2); symbolic procedure c!:cminus(u, env); begin scalar a, b; a := s!:improve cadr u; return if numberp a then c!:cval(-a, env) else if eqcar(a, 'minus) then c!:cval(cadr a, env) else c!:ccall(car u, cdr u, env) end; put('minus, 'c!:code, function c!:cminus); symbolic procedure c!:ceq(x, env); begin scalar a1, a2, r, rr; a1 := s!:improve cadr x; a2 := s!:improve caddr x; if a1 = nil then return c!:cval(list('null, a2), env) else if a2 = nil then return c!:cval(list('null, a1), env); rr := c!:pareval(list(a1, a2), env); c!:outop('eq, r:=c!:newreg(), car rr, cadr rr); return r end; put('eq, 'c!:code, function c!:ceq); symbolic procedure c!:cequal(x, env); begin scalar a1, a2, r, rr; a1 := s!:improve cadr x; a2 := s!:improve caddr x; if a1 = nil then return c!:cval(list('null, a2), env) else if a2 = nil then return c!:cval(list('null, a1), env); rr := c!:pareval(list(a1, a2), env); c!:outop((if c!:eqvalid a1 or c!:eqvalid a2 then 'eq else 'equal), r:=c!:newreg(), car rr, cadr rr); return r end; put('equal, 'c!:code, function c!:cequal); % % The next few cases are concerned with demoting functions that use % equal tests into ones that use eq instead symbolic procedure c!:is_fixnum x; fixp x and x >= -134217728 and x <= 134217727; symbolic procedure c!:certainlyatom x; null x or x=t or c!:is_fixnum x or (eqcar(x, 'quote) and (symbolp cadr x or c!:is_fixnum cadr x)); symbolic procedure c!:atomlist1 u; atom u or ((symbolp car u or c!:is_fixnum car u) and c!:atomlist1 cdr u); symbolic procedure c!:atomlist x; null x or (eqcar(x, 'quote) and c!:atomlist1 cadr x) or (eqcar(x, 'list) and (null cdr x or (c!:certainlyatom cadr x and c!:atomlist ('list . cddr x)))) or (eqcar(x, 'cons) and c!:certainlyatom cadr x and c!:atomlist caddr x); symbolic procedure c!:atomcar x; (eqcar(x, 'cons) or eqcar(x, 'list)) and not null cdr x and c!:certainlyatom cadr x; symbolic procedure c!:atomkeys1 u; atom u or (not atom car u and (symbolp caar u or c!:is_fixnum caar u) and c!:atomlist1 cdr u); symbolic procedure c!:atomkeys x; null x or (eqcar(x, 'quote) and c!:atomkeys1 cadr x) or (eqcar(x, 'list) and (null cdr x or (c!:atomcar cadr x and c!:atomkeys ('list . cddr x)))) or (eqcar(x, 'cons) and c!:atomcar cadr x and c!:atomkeys caddr x); !#if (not common!-lisp!-mode) symbolic procedure c!:comsublis x; if c!:atomkeys cadr x then 'subla . cdr x else nil; put('sublis, 'c!:compile_macro, function c!:comsublis); symbolic procedure c!:comassoc x; if c!:certainlyatom cadr x or c!:atomkeys caddr x then 'atsoc . cdr x else nil; put('assoc, 'c!:compile_macro, function c!:comassoc); put('assoc!*!*, 'c!:compile_macro, function c!:comassoc); symbolic procedure c!:commember x; if c!:certainlyatom cadr x or c!:atomlist caddr x then 'memq . cdr x else nil; put('member, 'c!:compile_macro, function c!:commember); symbolic procedure c!:comdelete x; if c!:certainlyatom cadr x or c!:atomlist caddr x then 'deleq . cdr x else nil; put('delete, 'c!:compile_macro, function c!:comdelete); !#endif symbolic procedure c!:ctestif(x, env, d1, d2); begin scalar l1, l2; l1 := c!:my_gensym(); l2 := c!:my_gensym(); c!:jumpif(cadr x, l1, l2); x := cddr x; c!:startblock l1; c!:jumpif(car x, d1, d2); c!:startblock l2; c!:jumpif(cadr x, d1, d2) end; put('if, 'c!:ctest, function c!:ctestif); symbolic procedure c!:ctestnull(x, env, d1, d2); c!:cjumpif(cadr x, env, d2, d1); put('null, 'c!:ctest, function c!:ctestnull); put('not, 'c!:ctest, function c!:ctestnull); symbolic procedure c!:ctestatom(x, env, d1, d2); begin x := c!:cval(cadr x, env); c!:endblock(list('ifatom, x), list(d1, d2)) end; put('atom, 'c!:ctest, function c!:ctestatom); symbolic procedure c!:ctestconsp(x, env, d1, d2); begin x := c!:cval(cadr x, env); c!:endblock(list('ifatom, x), list(d2, d1)) end; put('consp, 'c!:ctest, function c!:ctestconsp); symbolic procedure c!:ctestsymbol(x, env, d1, d2); begin x := c!:cval(cadr x, env); c!:endblock(list('ifsymbol, x), list(d1, d2)) end; put('idp, 'c!:ctest, function c!:ctestsymbol); symbolic procedure c!:ctestnumberp(x, env, d1, d2); begin x := c!:cval(cadr x, env); c!:endblock(list('ifnumber, x), list(d1, d2)) end; put('numberp, 'c!:ctest, function c!:ctestnumberp); symbolic procedure c!:ctestizerop(x, env, d1, d2); begin x := c!:cval(cadr x, env); c!:endblock(list('ifizerop, x), list(d1, d2)) end; put('izerop, 'c!:ctest, function c!:ctestizerop); symbolic procedure c!:ctesteq(x, env, d1, d2); begin scalar a1, a2, r; a1 := cadr x; a2 := caddr x; if a1 = nil then return c!:cjumpif(a2, env, d2, d1) else if a2 = nil then return c!:cjumpif(a1, env, d2, d1); r := c!:pareval(list(a1, a2), env); c!:endblock('ifeq . r, list(d1, d2)) end; put('eq, 'c!:ctest, function c!:ctesteq); symbolic procedure c!:ctesteqcar(x, env, d1, d2); begin scalar a1, a2, r, d3; a1 := cadr x; a2 := caddr x; d3 := c!:my_gensym(); r := c!:pareval(list(a1, a2), env); c!:endblock(list('ifatom, car r), list(d2, d3)); c!:startblock d3; c!:outop('qcar, car r, nil, car r); c!:endblock('ifeq . r, list(d1, d2)) end; put('eqcar, 'c!:ctest, function c!:ctesteqcar); global '(least_fixnum greatest_fixnum); least_fixnum := -expt(2, 27); greatest_fixnum := expt(2, 27) - 1; symbolic procedure c!:small_number x; fixp x and x >= least_fixnum and x <= greatest_fixnum; symbolic procedure c!:eqvalid x; if atom x then c!:small_number x else if flagp(car x, 'c!:fixnum_fn) then t else car x = 'quote and (idp cadr x or c!:small_number cadr x); flag('(iplus iplus2 idifference iminus itimes itimes2), 'c!:fixnum_fn); symbolic procedure c!:ctestequal(x, env, d1, d2); begin scalar a1, a2, r; a1 := s!:improve cadr x; a2 := s!:improve caddr x; if a1 = nil then return c!:cjumpif(a2, env, d2, d1) else if a2 = nil then return c!:cjumpif(a1, env, d2, d1); r := c!:pareval(list(a1, a2), env); c!:endblock((if c!:eqvalid a1 or c!:eqvalid a2 then 'ifeq else 'ifequal) . r, list(d1, d2)) end; put('equal, 'c!:ctest, function c!:ctestequal); symbolic procedure c!:ctestilessp(x, env, d1, d2); begin scalar r; r := c!:pareval(list(cadr x, caddr x), env); c!:endblock('ifilessp . r, list(d1, d2)) end; put('ilessp, 'c!:ctest, function c!:ctestilessp); symbolic procedure c!:ctestigreaterp(x, env, d1, d2); begin scalar r; r := c!:pareval(list(cadr x, caddr x), env); c!:endblock('ifigreaterp . r, list(d1, d2)) end; put('igreaterp, 'c!:ctest, function c!:ctestigreaterp); symbolic procedure c!:ctestand(x, env, d1, d2); begin scalar next; for each a in cdr x do << next := c!:my_gensym(); c!:cjumpif(a, env, next, d2); c!:startblock next >>; c!:endblock('goto, list d1) end; put('and, 'c!:ctest, function c!:ctestand); symbolic procedure c!:ctestor(x, env, d1, d2); begin scalar next; for each a in cdr x do << next := c!:my_gensym(); c!:cjumpif(a, env, d1, next); c!:startblock next >>; c!:endblock('goto, list d2) end; put('or, 'c!:ctest, function c!:ctestor); % Here are some of the things that are built into the Lisp kernel % and that I am happy to allow the compiler to generate direct calls to. << put('abs, 'c!:c_entrypoint, "Labsval"); % put('acons, 'c!:c_entrypoint, "Lacons"); % put('add1, 'c!:c_entrypoint, "Ladd1"); !#if common!-lisp!-mode put('!1!+, 'c!:c_entrypoint, "Ladd1"); !#endif !#if (not common!-lisp!-mode) put('append, 'c!:c_entrypoint, "Lappend"); !#endif % put('apply, 'c!:c_entrypoint, "Lapply"); put('apply0, 'c!:c_entrypoint, "Lapply0"); put('apply1, 'c!:c_entrypoint, "Lapply1"); put('apply2, 'c!:c_entrypoint, "Lapply2"); put('apply3, 'c!:c_entrypoint, "Lapply3"); % put('ash, 'c!:c_entrypoint, "Lash"); put('ash1, 'c!:c_entrypoint, "Lash1"); !#if (not common!-lisp!-mode) put('assoc, 'c!:c_entrypoint, "Lassoc"); !#endif put('atan, 'c!:c_entrypoint, "Latan"); put('atom, 'c!:c_entrypoint, "Latom"); put('atsoc, 'c!:c_entrypoint, "Latsoc"); put('batchp, 'c!:c_entrypoint, "Lbatchp"); put('boundp, 'c!:c_entrypoint, "Lboundp"); put('bps!-putv, 'c!:c_entrypoint, "Lbpsputv"); put('caaaar, 'c!:c_entrypoint, "Lcaaaar"); put('caaadr, 'c!:c_entrypoint, "Lcaaadr"); put('caaar, 'c!:c_entrypoint, "Lcaaar"); put('caadar, 'c!:c_entrypoint, "Lcaadar"); put('caaddr, 'c!:c_entrypoint, "Lcaaddr"); put('caadr, 'c!:c_entrypoint, "Lcaadr"); put('caar, 'c!:c_entrypoint, "Lcaar"); put('cadaar, 'c!:c_entrypoint, "Lcadaar"); put('cadadr, 'c!:c_entrypoint, "Lcadadr"); put('cadar, 'c!:c_entrypoint, "Lcadar"); put('caddar, 'c!:c_entrypoint, "Lcaddar"); put('cadddr, 'c!:c_entrypoint, "Lcadddr"); put('caddr, 'c!:c_entrypoint, "Lcaddr"); put('cadr, 'c!:c_entrypoint, "Lcadr"); put('car, 'c!:c_entrypoint, "Lcar"); put('cdaaar, 'c!:c_entrypoint, "Lcdaaar"); put('cdaadr, 'c!:c_entrypoint, "Lcdaadr"); put('cdaar, 'c!:c_entrypoint, "Lcdaar"); put('cdadar, 'c!:c_entrypoint, "Lcdadar"); put('cdaddr, 'c!:c_entrypoint, "Lcdaddr"); put('cdadr, 'c!:c_entrypoint, "Lcdadr"); put('cdar, 'c!:c_entrypoint, "Lcdar"); put('cddaar, 'c!:c_entrypoint, "Lcddaar"); put('cddadr, 'c!:c_entrypoint, "Lcddadr"); put('cddar, 'c!:c_entrypoint, "Lcddar"); put('cdddar, 'c!:c_entrypoint, "Lcdddar"); put('cddddr, 'c!:c_entrypoint, "Lcddddr"); put('cdddr, 'c!:c_entrypoint, "Lcdddr"); put('cddr, 'c!:c_entrypoint, "Lcddr"); put('cdr, 'c!:c_entrypoint, "Lcdr"); put('char!-code, 'c!:c_entrypoint, "Lchar_code"); put('close, 'c!:c_entrypoint, "Lclose"); put('code!-char, 'c!:c_entrypoint, "Lcode_char"); put('codep, 'c!:c_entrypoint, "Lcodep"); !#if (not common!-lisp!-mode) put('compress, 'c!:c_entrypoint, "Lcompress"); !#endif put('constantp, 'c!:c_entrypoint, "Lconstantp"); % put('cons, 'c!:c_entrypoint, "Lcons"); put('date, 'c!:c_entrypoint, "Ldate"); put('deleq, 'c!:c_entrypoint, "Ldeleq"); !#if (not common!-lisp!-mode) put('delete, 'c!:c_entrypoint, "Ldelete"); !#endif % put('difference, 'c!:c_entrypoint, "Ldifference2"); put('digit, 'c!:c_entrypoint, "Ldigitp"); !#if (not common!-lisp!-mode) put('divide, 'c!:c_entrypoint, "Ldivide"); !#endif put('eject, 'c!:c_entrypoint, "Leject"); put('endp, 'c!:c_entrypoint, "Lendp"); put('eq, 'c!:c_entrypoint, "Leq"); put('eqcar, 'c!:c_entrypoint, "Leqcar"); put('eql, 'c!:c_entrypoint, "Leql"); put('eqn, 'c!:c_entrypoint, "Leqn"); !#if common!-lisp!-mode put('equal, 'c!:c_entrypoint, "Lcl_equal"); !#else put('equal, 'c!:c_entrypoint, "Lequal"); !#endif put('error, 'c!:c_entrypoint, "Lerror"); put('error1, 'c!:c_entrypoint, "Lerror1"); % put('errorset, 'c!:c_entrypoint, "Lerrorset"); put('evenp, 'c!:c_entrypoint, "Levenp"); put('evlis, 'c!:c_entrypoint, "Levlis"); put('explode, 'c!:c_entrypoint, "Lexplode"); put('explode2, 'c!:c_entrypoint, "Lexplodec"); put('explodec, 'c!:c_entrypoint, "Lexplodec"); put('expt, 'c!:c_entrypoint, "Lexpt"); put('fasldef, 'c!:c_entrypoint, "Lfasldef"); put('faslstart, 'c!:c_entrypoint, "Lfaslstart"); put('faslwrite, 'c!:c_entrypoint, "Lfaslwrite"); put('fix, 'c!:c_entrypoint, "Ltruncate"); put('fixp, 'c!:c_entrypoint, "Lfixp"); put('flag, 'c!:c_entrypoint, "Lflag"); put('flagp!*!*, 'c!:c_entrypoint, "Lflagp"); put('flagp, 'c!:c_entrypoint, "Lflagp"); put('flagpcar, 'c!:c_entrypoint, "Lflagpcar"); put('float, 'c!:c_entrypoint, "Lfloat"); put('floatp, 'c!:c_entrypoint, "Lfloatp"); put('fluidp, 'c!:c_entrypoint, "Lsymbol_specialp"); put('gcdn, 'c!:c_entrypoint, "Lgcd"); put('gctime, 'c!:c_entrypoint, "Lgctime"); put('gensym, 'c!:c_entrypoint, "Lgensym"); put('gensym1, 'c!:c_entrypoint, "Lgensym1"); put('geq, 'c!:c_entrypoint, "Lgeq"); put('get!*, 'c!:c_entrypoint, "Lget"); % put('get, 'c!:c_entrypoint, "Lget"); put('getenv, 'c!:c_entrypoint, "Lgetenv"); put('getv, 'c!:c_entrypoint, "Lgetv"); !#if common!-lisp!-mode put('svref, 'c!:c_entrypoint, "Lgetv"); !#endif put('globalp, 'c!:c_entrypoint, "Lsymbol_globalp"); put('greaterp, 'c!:c_entrypoint, "Lgreaterp"); put('iadd1, 'c!:c_entrypoint, "Liadd1"); put('idifference, 'c!:c_entrypoint, "Lidifference"); put('idp, 'c!:c_entrypoint, "Lsymbolp"); put('igreaterp, 'c!:c_entrypoint, "Ligreaterp"); put('ilessp, 'c!:c_entrypoint, "Lilessp"); put('iminus, 'c!:c_entrypoint, "Liminus"); put('iminusp, 'c!:c_entrypoint, "Liminusp"); put('indirect, 'c!:c_entrypoint, "Lindirect"); put('integerp, 'c!:c_entrypoint, "Lintegerp"); !#if (not common!-lisp!-mode) put('intern, 'c!:c_entrypoint, "Lintern"); !#endif put('iplus2, 'c!:c_entrypoint, "Liplus2"); put('iquotient, 'c!:c_entrypoint, "Liquotient"); put('iremainder, 'c!:c_entrypoint, "Liremainder"); put('irightshift, 'c!:c_entrypoint, "Lirightshift"); put('isub1, 'c!:c_entrypoint, "Lisub1"); put('itimes2, 'c!:c_entrypoint, "Litimes2"); % put('lcm, 'c!:c_entrypoint, "Llcm"); put('length, 'c!:c_entrypoint, "Llength"); put('lengthc, 'c!:c_entrypoint, "Llengthc"); put('leq, 'c!:c_entrypoint, "Lleq"); put('lessp, 'c!:c_entrypoint, "Llessp"); put('linelength, 'c!:c_entrypoint, "Llinelength"); % put('list2!*, 'c!:c_entrypoint, "Llist2star"); % put('list2, 'c!:c_entrypoint, "Llist2"); % put('list3, 'c!:c_entrypoint, "Llist3"); !#if (not common!-lisp!-mode) put('liter, 'c!:c_entrypoint, "Lalpha_char_p"); !#endif put('load!-module, 'c!:c_entrypoint, "Lload_module"); % put('lognot, 'c!:c_entrypoint, "Llognot"); put('lposn, 'c!:c_entrypoint, "Llposn"); put('macro!-function, 'c!:c_entrypoint, "Lmacro_function"); put('macroexpand!-1, 'c!:c_entrypoint, "Lmacroexpand_1"); put('macroexpand, 'c!:c_entrypoint, "Lmacroexpand"); put('make!-bps, 'c!:c_entrypoint, "Lget_bps"); put('make!-global, 'c!:c_entrypoint, "Lmake_global"); put('make!-simple!-string, 'c!:c_entrypoint, "Lsmkvect"); put('make!-special, 'c!:c_entrypoint, "Lmake_special"); put('mapstore, 'c!:c_entrypoint, "Lmapstore"); put('max2, 'c!:c_entrypoint, "Lmax2"); !#if (not common!-lisp!-mode) put('member, 'c!:c_entrypoint, "Lmember"); !#endif put('memq, 'c!:c_entrypoint, "Lmemq"); put('min2, 'c!:c_entrypoint, "Lmin2"); put('minus, 'c!:c_entrypoint, "Lminus"); put('minusp, 'c!:c_entrypoint, "Lminusp"); put('mkquote, 'c!:c_entrypoint, "Lmkquote"); put('mkvect, 'c!:c_entrypoint, "Lmkvect"); put('mod, 'c!:c_entrypoint, "Lmod"); put('modular!-difference, 'c!:c_entrypoint, "Lmodular_difference"); put('modular!-expt, 'c!:c_entrypoint, "Lmodular_expt"); put('modular!-minus, 'c!:c_entrypoint, "Lmodular_minus"); put('modular!-number, 'c!:c_entrypoint, "Lmodular_number"); put('modular!-plus, 'c!:c_entrypoint, "Lmodular_plus"); put('modular!-quotient, 'c!:c_entrypoint, "Lmodular_quotient"); put('modular!-reciprocal, 'c!:c_entrypoint, "Lmodular_reciprocal"); put('modular!-times, 'c!:c_entrypoint, "Lmodular_times"); put('nconc, 'c!:c_entrypoint, "Lnconc"); % put('ncons, 'c!:c_entrypoint, "Lncons"); put('neq, 'c!:c_entrypoint, "Lneq"); % put('next!-random!-number, 'c!:c_entrypoint, "Lnext_random"); put('not, 'c!:c_entrypoint, "Lnull"); put('null, 'c!:c_entrypoint, "Lnull"); put('numberp, 'c!:c_entrypoint, "Lnumberp"); put('oddp, 'c!:c_entrypoint, "Loddp"); put('onep, 'c!:c_entrypoint, "Lonep"); put('orderp, 'c!:c_entrypoint, "Lorderp"); % put('ordp, 'c!:c_entrypoint, "Lorderp"); put('pagelength, 'c!:c_entrypoint, "Lpagelength"); put('pairp, 'c!:c_entrypoint, "Lconsp"); put('plist, 'c!:c_entrypoint, "Lplist"); % put('plus2, 'c!:c_entrypoint, "Lplus2"); put('plusp, 'c!:c_entrypoint, "Lplusp"); put('posn, 'c!:c_entrypoint, "Lposn"); !#if (not common!-lisp!-mode) put('prin, 'c!:c_entrypoint, "Lprin"); put('prin1, 'c!:c_entrypoint, "Lprin"); put('prin2, 'c!:c_entrypoint, "Lprinc"); put('princ, 'c!:c_entrypoint, "Lprinc"); put('print, 'c!:c_entrypoint, "Lprint"); put('printc, 'c!:c_entrypoint, "Lprintc"); !#endif put('put, 'c!:c_entrypoint, "Lputprop"); put('putv!-char, 'c!:c_entrypoint, "Lsputv"); put('putv, 'c!:c_entrypoint, "Lputv"); put('qcaar, 'c!:c_entrypoint, "Lcaar"); put('qcadr, 'c!:c_entrypoint, "Lcadr"); put('qcar, 'c!:c_entrypoint, "Lcar"); put('qcdar, 'c!:c_entrypoint, "Lcdar"); put('qcddr, 'c!:c_entrypoint, "Lcddr"); put('qcdr, 'c!:c_entrypoint, "Lcdr"); put('qgetv, 'c!:c_entrypoint, "Lgetv"); % put('quotient, 'c!:c_entrypoint, "Lquotient"); % put('random, 'c!:c_entrypoint, "Lrandom"); % put('rational, 'c!:c_entrypoint, "Lrational"); put('rdf, 'c!:c_entrypoint, "Lrdf"); put('rds, 'c!:c_entrypoint, "Lrds"); !#if (not common!-lisp!-mode) put('read, 'c!:c_entrypoint, "Lread"); put('readch, 'c!:c_entrypoint, "Lreadch"); !#endif put('reclaim, 'c!:c_entrypoint, "Lgc"); % put('remainder, 'c!:c_entrypoint, "Lrem"); put('remd, 'c!:c_entrypoint, "Lremd"); put('remflag, 'c!:c_entrypoint, "Lremflag"); put('remob, 'c!:c_entrypoint, "Lunintern"); put('remprop, 'c!:c_entrypoint, "Lremprop"); put('representation, 'c!:c_entrypoint, "Lrepresentation"); put('reverse, 'c!:c_entrypoint, "Lreverse"); put('reversip, 'c!:c_entrypoint, "Lnreverse"); put('rplaca, 'c!:c_entrypoint, "Lrplaca"); put('rplacd, 'c!:c_entrypoint, "Lrplacd"); put('schar, 'c!:c_entrypoint, "Lsgetv"); put('seprp, 'c!:c_entrypoint, "Lwhitespace_char_p"); put('set!-small!-modulus, 'c!:c_entrypoint, "Lset_small_modulus"); put('set, 'c!:c_entrypoint, "Lset"); put('smemq, 'c!:c_entrypoint, "Lsmemq"); put('spaces, 'c!:c_entrypoint, "Lxtab"); put('special!-char, 'c!:c_entrypoint, "Lspecial_char"); put('special!-form!-p, 'c!:c_entrypoint, "Lspecial_form_p"); put('spool, 'c!:c_entrypoint, "Lspool"); put('stop, 'c!:c_entrypoint, "Lstop"); put('stringp, 'c!:c_entrypoint, "Lstringp"); % put('sub1, 'c!:c_entrypoint, "Lsub1"); !#if common!-lisp!-mode put('!1!-, 'c!:c_entrypoint, "Lsub1"); !#endif put('subla, 'c!:c_entrypoint, "Lsubla"); !#if (not common!-lisp!-mode) put('sublis, 'c!:c_entrypoint, "Lsublis"); !#endif put('subst, 'c!:c_entrypoint, "Lsubst"); put('symbol!-env, 'c!:c_entrypoint, "Lsymbol_env"); put('symbol!-function, 'c!:c_entrypoint, "Lsymbol_function"); put('symbol!-name, 'c!:c_entrypoint, "Lsymbol_name"); put('symbol!-set!-definition, 'c!:c_entrypoint, "Lsymbol_set_definition"); put('symbol!-set!-env, 'c!:c_entrypoint, "Lsymbol_set_env"); put('symbol!-value, 'c!:c_entrypoint, "Lsymbol_value"); put('system, 'c!:c_entrypoint, "Lsystem"); put('terpri, 'c!:c_entrypoint, "Lterpri"); put('threevectorp, 'c!:c_entrypoint, "Lthreevectorp"); put('time, 'c!:c_entrypoint, "Ltime"); % put('times2, 'c!:c_entrypoint, "Ltimes2"); put('ttab, 'c!:c_entrypoint, "Lttab"); put('tyo, 'c!:c_entrypoint, "Ltyo"); put('unmake!-global, 'c!:c_entrypoint, "Lunmake_global"); put('unmake!-special, 'c!:c_entrypoint, "Lunmake_special"); put('upbv, 'c!:c_entrypoint, "Lupbv"); !#if common!-lisp!-mode put('vectorp, 'c!:c_entrypoint, "Lvectorp"); !#else put('vectorp, 'c!:c_entrypoint, "Lsimple_vectorp"); !#endif put('verbos, 'c!:c_entrypoint, "Lverbos"); put('wrs, 'c!:c_entrypoint, "Lwrs"); put('xcons, 'c!:c_entrypoint, "Lxcons"); put('xtab, 'c!:c_entrypoint, "Lxtab"); % put('orderp, 'c!:c_entrypoint, "Lorderp"); being retired. put('zerop, 'c!:c_entrypoint, "Lzerop"); % The following can be called without having to provide an environment % or arg-count. The compiler should check the number of args being % passed matches the expected number. put('cons, 'c!:direct_entrypoint, 2 . "cons"); put('ncons, 'c!:direct_entrypoint, 1 . "ncons"); put('list2, 'c!:direct_entrypoint, 2 . "list2"); put('list2!*, 'c!:direct_entrypoint, 3 . "list2star"); put('acons, 'c!:direct_entrypoint, 3 . "acons"); put('list3, 'c!:direct_entrypoint, 3 . "list3"); put('plus2, 'c!:direct_entrypoint, 2 . "plus2"); put('difference, 'c!:direct_entrypoint, 2 . "difference2"); put('add1, 'c!:direct_entrypoint, 1 . "add1"); put('sub1, 'c!:direct_entrypoint, 1 . "sub1"); !#if (not common!-lisp!-mode) put('get, 'c!:direct_entrypoint, 2 . "get"); !#endif put('lognot, 'c!:direct_entrypoint, 1 . "lognot"); put('ash, 'c!:direct_entrypoint, 2 . "ash"); put('quotient, 'c!:direct_entrypoint, 2 . "quot2"); put('remainder, 'c!:direct_entrypoint, 2 . "Cremainder"); put('times2, 'c!:direct_entrypoint, 2 . "times2"); put('minus, 'c!:direct_entrypoint, 1 . "negate"); put('rational, 'c!:direct_entrypoint, 1 . "rational"); put('lessp, 'c!:direct_predicate, 2 . "lessp2"); put('leq, 'c!:direct_predicate, 2 . "lesseq2"); put('greaterp, 'c!:direct_predicate, 2 . "greaterp2"); put('geq, 'c!:direct_predicate, 2 . "geq2"); put('zerop, 'c!:direct_predicate, 1 . "zerop"); "C entrypoints established" >>; flag( '(atom atsoc codep constantp deleq digit endp eq eqcar evenp eql fixp flagp flagpcar floatp get globalp iadd1 idifference idp igreaterp ilessp iminus iminusp indirect integerp iplus2 irightshift isub1 itimes2 liter memq minusp modular!-difference modular!-expt modular!-minus modular!-number modular!-plus modular!-times not null numberp onep pairp plusp qcaar qcadr qcar qcdar qcddr qcdr remflag remprop reversip seprp special!-form!-p stringp symbol!-env symbol!-name symbol!-value threevectorp vectorp zerop), 'c!:no_errors); end; % End of ccomp.red