share/macro/fexpr.mac

   1 /*      A Macsyma ``FEXPR'' Definer             KMP     May, 1980       */
   2 /*                                                                      */
   3 /*      DEF(fname(spec1,spec2,...),definition);                         */
   4 /*       where some specs may be quoted with ' and the last may have    */
   5 /*       an optional [...] around it will define a normal macsyma       */
   6 /*       function called fname_AUX and a macro named fname where the    */
   7 /*       macro will have the calling conventions given by the specs.    */
   8 /*                                                                      */
   9 /*       eg:                                                            */
  10 /*                                                                      */
  11 /*              DEF(F(X,'Y),X+Y);                                       */
  12 /*                                                                      */
  13 /*              =>      F     is a macro which behaves like a function  */
  14 /*                            that gets only its first arg evaluated    */
  15 /*                      F_AUX is a function of two args and adds them   */
  16 /*                            so should be used with APPLY, MAP, etc    */
  17 /*                                                                      */
  18
  19 def(fninfo,body)::=
  20  block([bvl,              /* arglist of the main function               */
  21         name,             /* main function name                         */
  22         auxname,          /* aux function name                          */
  23         vars:[],          /* list of var names used by main fun         */
  24         varsets,          /* list of vars for buildq setup in macro def */
  25         qinfo:[],         /* list of which args need quoting            */
  26         lexpr:false,      /* flag saying if this was a lexpr            */
  27         piece],           /* make piece local to this function          */
  28
  29   bvl:args(fninfo),                          /* bvl is original arglist */
  30                                              /*                         */
  31   if atom(part(fninfo,0))                    /* allow two syntaxes      */
  32      then ( name:piece,                      /*  only one name means    */
  33             auxname:concat(piece,"_aux"))    /*   to gensym other name  */
  34      else ( name:part(piece,1),              /*  if two names were given*/
  35             auxname:part(piece,2) ),         /*   then use 2nd as aux   */
  36                                              /*                         */
  37   map( lambda([x],                           /* ** check each var in bvl*/
  38          if atom(x)                          /* if atomic,              */
  39             then ( qinfo:cons(false,qinfo),  /*   then remember no quote*/
  40                    vars:cons(x,vars) )       /*   and add to vars       */
  41     else if part(x,0) = "'"                  /* if quoted,              */
  42             then ( qinfo:cons(true,qinfo),   /*   then remember to quote*/
  43                    vars:cons(part(x,1),vars))/*   and add to vars       */
  44     else if part(x,0) = "["                  /* else if a list,         */
  45             then ( lexpr:true,               /*   then this is a lexpr  */
  46                    x:part(x,1),              /*   look at first element */
  47          if atom(x)                          /*   if an atom,           */
  48             then ( qinfo:cons(false,qinfo),  /*     say not to quote it */
  49                    vars:cons(x,vars) )       /*     and add to vars     */
  50             else (                           /*   else,                 */
  51              if part(x,0) = "'"              /*    if quoted,           */
  52               then                           /*     then,               */
  53                 (qinfo:cons(true,qinfo),     /*      save quote info    */
  54                   vars:cons(part(x,1),vars)) /*      and add to vars    */
  55               else                           /*    else loser blew it   */
  56                 (error("illegal form in bvl -def"))))
  57             else ( error ("illegal form in bvl -def"))),
  58         bvl),                                /* (map across bvl)        */
  59                                              /* what a long function    */
  60                                              /*  this is getting to be  */
  61
  62   bvl     : vars,                            /* make bvl same as vars   */
  63   genlist : vars,
  64   varsets : vars,
  65
  66   /* hack things to add brackets, etc if a lexpr */
  67
  68   if lexpr then
  69      (bvl:cons([part(bvl,1)],rest(bvl)),
  70       if qinfo[1]=true then
  71          (qinfo:cons(false,rest(qinfo)),
  72           varsets:cons(buildq([v:genlist[1]],
  73                               v:map(lambda([x],funmake("'",[x])),v)),
  74                        rest(varsets))),
  75       genlist:cons(funmake('splice,[part(genlist,1)]),rest(genlist))),
  76
  77   /* make genlist have vars quoted as appropriate */
  78
  79   genlist:map(lambda([x,y], if x then funmake("'",[y]) else y),
  80               qinfo,
  81               genlist),
  82
  83   /* the whole world is backward at this point  */
  84
  85   qinfo  : reverse(qinfo),                   /* reverse quote info      */
  86   bvl    : reverse(bvl),                     /* reverse bvl             */
  87   vars   : reverse(vars),                    /* reverse main vars       */
  88   genlist: reverse(genlist),                 /* reverse genlist         */
  89
  90   /* now cons up the solution and we're all set */
  91
  92   buildq([name,auxname,vars,genlist,body,bvl,varsets],
  93          (name(splice(bvl))::=               /* main def recalls aux    */
  94               buildq([splice(varsets)],auxname(splice(genlist))),
  95           auxname(splice(bvl)):= body,       /* aux definition          */
  96           ['name, 'auxname])))$              /* return names of funs    */
  97