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 */
|
