1 /* xlsubr - xlisp builtin function support routines */
2 /* Copyright (c) 1985, by David Michael Betz
3 All Rights Reserved
4 Permission is granted for unrestricted non-commercial use */
5
6 /* CHANGE LOG
7 * --------------------------------------------------------------------
8 * 28Apr03 dm eliminate some compiler warnings
9 */
10
11 #include "string.h"
12 #include "xlisp.h"
13
14 /* external variables */
15 extern LVAL k_test,k_tnot,s_eql;
16
17 /* xlsubr - define a builtin function */
xlsubr(const char * sname,int type,LVAL (* fcn)(void),int offset)18 LVAL xlsubr(const char *sname, int type, LVAL (*fcn)(void), int offset)
19 {
20 LVAL sym;
21 sym = xlenter(sname);
22 setfunction(sym,cvsubr(fcn,type,offset));
23 return (sym);
24 }
25
26 /* xlgetkeyarg - get a keyword argument */
xlgetkeyarg(LVAL key,LVAL * pval)27 int xlgetkeyarg(LVAL key, LVAL *pval)
28 {
29 LVAL *argv=xlargv;
30 int argc=xlargc;
31 for (argv = xlargv, argc = xlargc; (argc -= 2) >= 0; argv += 2) {
32 if (*argv == key) {
33 *pval = *++argv;
34 return (TRUE);
35 }
36 }
37 return (FALSE);
38 }
39
40 /* xlgkfixnum - get a fixnum keyword argument */
xlgkfixnum(LVAL key,LVAL * pval)41 int xlgkfixnum(LVAL key, LVAL *pval)
42 {
43 if (xlgetkeyarg(key,pval)) {
44 if (!fixp(*pval))
45 xlbadtype(*pval);
46 return (TRUE);
47 }
48 return (FALSE);
49 }
50
51 /* xltest - get the :test or :test-not keyword argument */
xltest(LVAL * pfcn,int * ptresult)52 void xltest(LVAL *pfcn, int *ptresult)
53 {
54 if (xlgetkeyarg(k_test,pfcn)) /* :test */
55 *ptresult = TRUE;
56 else if (xlgetkeyarg(k_tnot,pfcn)) /* :test-not */
57 *ptresult = FALSE;
58 else {
59 *pfcn = getfunction(s_eql);
60 *ptresult = TRUE;
61 }
62 }
63
64 /* xlgetfile - get a file or stream */
xlgetfile(void)65 LVAL xlgetfile(void)
66 {
67 LVAL arg;
68
69 /* get a file or stream (cons) or nil */
70 if ((arg = xlgetarg())) {
71 if (streamp(arg)) {
72 if (getfile(arg) == NULL)
73 xlfail("file not open");
74 }
75 else if (!ustreamp(arg))
76 xlerror("bad argument type",arg);
77 }
78 return (arg);
79 }
80
81 /* xlgetfname - get a filename */
xlgetfname(void)82 LVAL xlgetfname(void)
83 {
84 LVAL name;
85
86 /* get the next argument */
87 name = xlgetarg();
88
89 /* get the filename string */
90 if (symbolp(name))
91 name = getpname(name);
92 else if (!stringp(name))
93 xlerror("bad argument type",name);
94
95 /* return the name */
96 return (name);
97 }
98
99 /* needsextension - check if a filename needs an extension */
needsextension(const char * name)100 int needsextension(const char *name)
101 {
102 const char *p;
103
104 /* check for an extension */
105 for (p = &name[strlen(name)]; --p >= &name[0]; )
106 if (*p == '.')
107 return (FALSE);
108 else if (!islower(*p) && !isupper(*p) && !isdigit(*p))
109 return (TRUE);
110
111 /* no extension found */
112 return (TRUE);
113 }
114
115 /* the next three functions must be declared as LVAL because they
116 * are used in LVAL expressions, but they do not return anything
117 * warning 4035 is "no return value"
118 */
119 /* #pragma warning(disable: 4035) */
120
121 /* xlbadtype - report a "bad argument type" error */
xlbadtype(LVAL arg)122 LVAL xlbadtype(LVAL arg)
123 {
124 xlerror("bad argument type",arg);
125 return NIL; /* never happens */
126 }
127
128 /* xltoofew - report a "too few arguments" error */
xltoofew(void)129 LVAL xltoofew(void)
130 {
131 xlfail("too few arguments");
132 return NIL; /* never happens */
133 }
134
135 /* xltoomany - report a "too many arguments" error */
xltoomany(void)136 LVAL xltoomany(void)
137 {
138 xlfail("too many arguments");
139 return NIL; /* never happens */
140 }
141
142 /* eq - internal eq function */
eq(LVAL arg1,LVAL arg2)143 int eq(LVAL arg1, LVAL arg2)
144 {
145 return (arg1 == arg2);
146 }
147
148 /* eql - internal eql function */
eql(LVAL arg1,LVAL arg2)149 int eql(LVAL arg1, LVAL arg2)
150 {
151 /* compare the arguments */
152 if (arg1 == arg2)
153 return (TRUE);
154 else if (arg1) {
155 switch (ntype(arg1)) {
156 case FIXNUM:
157 return (fixp(arg2) ? getfixnum(arg1)==getfixnum(arg2) : FALSE);
158 case FLONUM:
159 return (floatp(arg2) ? getflonum(arg1)==getflonum(arg2) : FALSE);
160 default:
161 return (FALSE);
162 }
163 }
164 else
165 return (FALSE);
166 }
167
168 /* lval_equal - internal equal function */
lval_equal(LVAL arg1,LVAL arg2)169 int lval_equal(LVAL arg1, LVAL arg2)
170 {
171 /* compare the arguments */
172 if (arg1 == arg2)
173 return (TRUE);
174 else if (arg1) {
175 switch (ntype(arg1)) {
176 case FIXNUM:
177 return (fixp(arg2) ? getfixnum(arg1)==getfixnum(arg2) : FALSE);
178 case FLONUM:
179 return (floatp(arg2) ? getflonum(arg1)==getflonum(arg2) : FALSE);
180 case STRING:
181 return (stringp(arg2) ? strcmp((char *) getstring(arg1),
182 (char *) getstring(arg2)) == 0 : FALSE);
183 case CONS:
184 return (consp(arg2) ? lval_equal(car(arg1),car(arg2))
185 && lval_equal(cdr(arg1),cdr(arg2)) : FALSE);
186 default:
187 return (FALSE);
188 }
189 }
190 else
191 return (FALSE);
192 }
193