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