Artifact 276836cb8b08d916641136cc26616e4a1d5f95c9da51fef249108271f317786b:

• Executable file r36/src/entry.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: 7897) [annotate] [blame] [check-ins using] [more...]

module entry;   % Entry points for self-loading modules.

% Author: Anthony C. Hearn.

% Using a modified version of the defautoload function of Eric Benson
% and Martin L. Griss.

% Extended for algebraic operators and values by Herbert Melenk.

fluid '(varstack!*);

if getd 'create!-package then create!-package('(entry),'(build));

symbolic procedure safe!-putd(name,type,body);
   % So that stubs will not clobber REAL entries preloaded.
   if getd name then lprim list("Autoload stub for",name,"not defined")
    else putd(name,type,body);

smacro procedure mkfunction u; list('function,u);

symbolic macro procedure defautoload u;
% (defautoload name), (defautoload name loadname),
% (defautoload name loadname fntype), or
% (defautoload name loadname fntype numargs)
% Default is 1 Arg EXPR in module of same name.
  begin scalar name,numargs,loadname,fntype;
    u := cdr u;
    name := car u;
    u := cdr u;
    if u then <<loadname := car u; u :=cdr u>> else loadname := name;
    if eqcar(name, 'quote) then name := cadr name;
    if atom loadname then loadname := list loadname
     else if car loadname eq 'quote then loadname := cadr loadname;
    if u then <<fntype := car u; u := cdr u>> else fntype := 'expr;
    if u then numargs := car u else numargs := 1;
    u := if numargs=0 then nil
          else if numargs=1 then '(x1)
          else if numargs=2 then '(x1 x2)
          else if numargs=3 then '(x1 x2 x3)
          else if numargs=4 then '(x1 x2 x3 x4)
          else error(99,list(numargs,"too large in DEFAUTOLOAD"));
    name := mkquote name;
    return
       list('progn,
            list('put,name,mkquote 'number!-of!-args,numargs),
            list('safe!-putd,
                 name,
                 mkquote fntype,
                 mkfunction
                    list('lambda, u,
                         'progn .
                             aconc(for each j in loadname
                                      collect
                                         list('load!-package,mkquote j),
                                   list('lispapply,name,'list . u)))))
  end;

% Autoload support for algebraic operators and values.
%
%    defautoload_operator(opname,package);
%    defautoload_value(varname,package);
%

symbolic macro procedure defautoload_operator u;
  begin scalar name,package;
    name := cadr u; package := caddr u;
    return subla(list('name.name,'package.package),
     '(progn
        (flag '(name) 'full)
        (put 'name 'simpfn
          '(lambda(x)(autoload_operator!* 'name 'package x)))))
  end;

symbolic procedure autoload_operator!*(o,p,x);
   begin scalar varstack!*;
     remflag(list o,'full);
     remprop(o,'simpfn);
     load!-package p;
     return simp x;
   end;

symbolic macro procedure defautoload_value u;
  begin scalar name,package;
    u:=cdr u; name := car u; u:=cdr u; package := car u;
    return subla(list('name.name,'package.package),
     '(progn
        (put 'name 'avalue
          '(autoload_value!* name package))))
  end;

symbolic procedure autoload_value!*(u,v);
   begin scalar name,p,x,varstack!*;
     x:=get(u,'avalue);
     name := cadr x; p := caddr x;
     remprop(name,'avalue);
     load!-package p;
     return reval1(name,v);
   end;

put('autoload_value!*,'evfn,'autoload_value!*);

comment Actual Entry Point Definitions;

% Compiler and LAP entry points.

defautoload(compile,compiler);

if 'csl memq lispsystem!* then defautoload(faslout,compiler)
 else defautoload(lap,compiler);


% Cross-reference module entry points.

remd 'crefon;  % don't use PSL version

put('cref,'simpfg,'((t (crefon)) (nil (crefoff))));

defautoload(crefon,rcref,expr,0);


% Input editor entry points.

defautoload cedit;

defautoload(display,cedit);

put('display,'stat,'rlis);

defautoload(editdef,cedit);

put('editdef,'stat,'rlis);


% Factorizer module entry points.

switch trfac, trallfac;

remprop('factor,'stat);

defautoload(ezgcdf,ezgcd,expr,2);

defautoload(factorize!-primitive!-polynomial,factor);

defautoload(pfactor,factor,expr,2);

defautoload(simpnprimitive,factor);

put('nprimitive,'simpfn,'simpnprimitive);

put('factor,'stat,'rlis);


% FASL module entry points.

flag('(faslout),'opfn);

flag('(faslout),'noval);


% High energy physics module entry points.

remprop('index,'stat); remprop('mass,'stat);

remprop('mshell,'stat); remprop('vecdim,'stat);

remprop('vector,'stat);

defautoload(index,hephys);

defautoload(mass,hephys);

defautoload(mshell,hephys);

defautoload(vecdim,hephys);

defautoload(vector,hephys);

put('index,'stat,'rlis);

put('mshell,'stat,'rlis);

put('mass,'stat,'rlis);

put('vecdim,'stat,'rlis);

put('vector,'stat,'rlis);

flagop nospur;


% Integrator module entry points.

fluid '(!*trint);

switch trint;

defautoload(simpint,int);

put('int,'simpfn,'simpint);

put('algint,'simpfg,'((t (load!-package 'algint))));


% Matrix module entry points.

switch cramer;

put('cramer,'simpfg,
    '((t (put 'mat 'lnrsolvefn 'clnrsolve)
     (put 'mat 'inversefn 'matinv))
      (nil (put 'mat 'lnrsolvefn 'lnrsolve)
       (put 'mat 'inversefn 'matinverse))));

defautoload(detq,'(matrix)); % Used by high energy physics package.

defautoload(matp,'(matrix));

defautoload(matrix,'(matrix));

put('matrix,'stat,'rlis);

flag('(mat),'struct);

put('mat,'formfn,'formmat);

defautoload(formmat,'(matrix),expr,3);

defautoload(generateident,'(matrix));

defautoload(lnrsolve,'(matrix),expr,2);

defautoload(simpresultant,'(matrix));

defautoload(resultant,'(matrix),expr,3);

put('resultant,'simpfn,'simpresultant);

defautoload(nullspace!-eval,matrix);

put('nullspace,'psopfn,'nullspace!-eval);


% Prettyprint module entry point (built into CSL).

if null('csl memq lispsystem!*) then defautoload(prettyprint,pretty);

% Print module entry point.

% defautoload(horner,scope);

% global '(!*horner);

% switch horner;


% Rprint module entry point.

defautoload rprint;


% SOLVE module entry points.

defautoload(solveeval,solve);

defautoload(solve0,solve,expr,2);

% defautoload(solvelnrsys,solve,expr,2);      % Used by matrix routines.

% defautoload(!*sf2ex,solve,expr,2);   % Used by matrix routines.

put('solve,'psopfn,'solveeval);

switch allbranch,arbvars,fullroots,multiplicities,nonlnr,solvesingular;
%      varopt;

put('arbint,'simpfn,'simpiden);

% Since the following three switches are set on in the solve module,
% they must first load that module if they are initially turned off.

put('nonlnr,'simpfg,'((nil (load!-package 'solve))));

put('allbranch,'simpfg,'((nil (load!-package 'solve))));

put('solvesingular,'simpfg,'((nil (load!-package 'solve))));


% Root finding package entry points.

defautoload roots;

defautoload(gfnewt,roots);

defautoload(gfroot,roots);

defautoload(root_val,roots);

defautoload(roots_at_prec,roots);

defautoload(firstroot,roots);

defautoload(rlrootno,roots2);

defautoload(realroots,roots2);

defautoload(isolater,roots2);

defautoload(nearestroot,roots2);

defautoload(sturm0,roots2);

defautoload(multroot1,roots2);

symbolic for each n in '(roots rlrootno realroots isolater firstroot
 nearestroot gfnewt gfroot root_val roots_at_prec)
   do put(n,'psopfn,n);

put('sturm,'psopfn,'sturm0);

switch trroot,rootmsg;

put('multroot,'psopfn,'multroot1);

switch fullprecision,compxroots;

% Limits entry points.

for each c in '(limit limit!+ limit!-) do
   <<put(c,'simpfn,'simplimit);
     put(c,'number!-of!-args,3);
     flag({c},'full)>>;

defautoload(simplimit,misc);

% Partial fractions entry point.

defautoload(pf,misc,expr,2);

symbolic operator pf;


% Sum entry points.

defautoload(simp!-sum,misc);

put('sum,'simpfn,'simp!-sum);

defautoload(simp!-prod,misc);

put('prod,'simpfn,'simp!-prod);


% Debug module entry points.

% if not(systemname!* eq 'ibm) then defautoload(embfn,debug,expr,3);


% Specfn entry points.

defautoload_operator(lambert_w,specbess);

endmodule;

end;