Skip to content

Commit f4cd15c

Browse files
add (defun (setf foo) (val arg) ...) support
ref: http://forum.ulisp.com/t/defun-setf-foo-val-arg/1401?u=dragoncoder047
1 parent 08598e3 commit f4cd15c

File tree

1 file changed

+34
-4
lines changed

1 file changed

+34
-4
lines changed

ulisp.hpp

Lines changed: 34 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -184,7 +184,7 @@ typedef int (*gfun_t)();
184184
typedef void (*pfun_t)(char);
185185

186186
enum builtins: builtin_t { NIL, TEE, NOTHING, OPTIONAL, INITIALELEMENT, ELEMENTTYPE, BIT, AMPREST, LAMBDA, MACRO, LET, LETSTAR,
187-
CLOSURE, PSTAR, QUOTE, BACKQUOTE, UNQUOTE, UNQUOTE_SPLICING, CONS, APPEND, DEFUN, DEFVAR, DEFMACRO, CAR, FIRST, CDR, REST, NTH, AREF, STRINGFN, PINMODE, DIGITALWRITE,
187+
CLOSURE, PSTAR, QUOTE, BACKQUOTE, UNQUOTE, UNQUOTE_SPLICING, CONS, APPEND, DEFUN, SETF, DEFVAR, DEFMACRO, CAR, FIRST, CDR, REST, NTH, AREF, STRINGFN, PINMODE, DIGITALWRITE,
188188
ANALOGREAD, REGISTER, FORMAT,
189189
};
190190

@@ -2162,16 +2162,31 @@ object* sp_or (object* args, object* env) {
21622162
return nil;
21632163
}
21642164

2165+
// Need to do manual search because findvalue() uses eq() but we need equal() for this.
2166+
object* find_setf_func (object* whatenv, object* funcname) {
2167+
object* what = cons(bsymbol(SETF), cons(funcname, nil));
2168+
for (object* z = whatenv; z != nil; z = cdr(z)) {
2169+
object* pair = car(z);
2170+
if (equal(what, car(pair))) return pair;
2171+
}
2172+
return nil;
2173+
}
2174+
21652175
/*
21662176
(defun name (parameters) form*)
21672177
Defines a function.
21682178
*/
21692179
object* sp_defun (object* args, object* env) {
21702180
(void) env;
21712181
object* var = first(args);
2172-
if (!symbolp(var)) error(notasymbol, var);
2182+
if (!symbolp(var)) {
2183+
// Check for (setf foo) forms
2184+
if (consp(var) && listlength(var) == 2 && eq(first(var), bsymbol(SETF))) /* do nothing */;
2185+
else error(notasymbol, var);
2186+
}
21732187
object* val = cons(bsymbol(LAMBDA), cdr(args));
21742188
object* pair = value(var->name, GlobalEnv);
2189+
if (consp(var) && !pair) pair = find_setf_func(GlobalEnv, second(var));
21752190
if (pair != NULL) cdr(pair) = val;
21762191
else push(cons(var, val), GlobalEnv);
21772192
return var;
@@ -2384,12 +2399,27 @@ object* sp_decf (object* args, object* env) {
23842399
object* sp_setf (object* args, object* env) {
23852400
int bit;
23862401
object* arg = nil;
2402+
object* placeform = nil;
2403+
object** loc;
23872404
while (args != NULL) {
23882405
if (cdr(args) == NULL) error2(oddargs);
2389-
object** loc = place(first(args), env, &bit);
2406+
placeform = first(args);
2407+
// Check for special defsetf forms first before calling place()
2408+
if (consp(placeform)) {
2409+
object* funcname = first(placeform);
2410+
object* userdef = find_setf_func(env, funcname);
2411+
if (!userdef) userdef = find_setf_func(GlobalEnv, funcname);
2412+
if (userdef) {
2413+
// usercode should be a lambda
2414+
arg = eval(cons(cdr(userdef), cons(second(args), rest(placeform))), env);
2415+
goto next;
2416+
}
2417+
}
23902418
arg = eval(second(args), env);
2419+
loc = place(placeform, env, &bit);
23912420
if (bit == -1) *loc = arg;
23922421
else *loc = number((checkinteger(*loc) & ~(1<<bit)) | checkbitvalue(arg)<<bit);
2422+
next:
23932423
args = cddr(args);
23942424
}
23952425
return arg;
@@ -6451,6 +6481,7 @@ const tbl_entry_t BuiltinTable[] PROGMEM = {
64516481
{ string57, fn_cons, MINMAX(FUNCTIONS, 2, 2), doc57 },
64526482
{ string92, fn_append, MINMAX(FUNCTIONS, 0, UNLIMITED), doc92 },
64536483
{ string14, sp_defun, MINMAX(SPECIAL_FORMS, 2, UNLIMITED), doc14 },
6484+
{ string36, sp_setf, MINMAX(SPECIAL_FORMS, 2, UNLIMITED), doc36 },
64546485
{ string15, sp_defvar, MINMAX(SPECIAL_FORMS, 1, 3), doc15 },
64556486
{ stringdefmacro, sp_defmacro, MINMAX(SPECIAL_FORMS, 2, UNLIMITED), docdefmacro },
64566487
{ string16, fn_car, MINMAX(FUNCTIONS, 1, 1), doc16 },
@@ -6473,7 +6504,6 @@ const tbl_entry_t BuiltinTable[] PROGMEM = {
64736504
{ string33, sp_pop, MINMAX(SPECIAL_FORMS, 1, 1), doc33 },
64746505
{ string34, sp_incf, MINMAX(SPECIAL_FORMS, 1, 2), doc34 },
64756506
{ string35, sp_decf, MINMAX(SPECIAL_FORMS, 1, 2), doc35 },
6476-
{ string36, sp_setf, MINMAX(SPECIAL_FORMS, 2, UNLIMITED), doc36 },
64776507
{ string37, sp_dolist, MINMAX(SPECIAL_FORMS, 1, UNLIMITED), doc37 },
64786508
{ string38, sp_dotimes, MINMAX(SPECIAL_FORMS, 1, UNLIMITED), doc38 },
64796509
{ string39, sp_trace, MINMAX(SPECIAL_FORMS, 0, 1), doc39 },

0 commit comments

Comments
 (0)
pFad - Phonifier reborn

Pfad - The Proxy pFad of © 2024 Garber Painting. All rights reserved.

Note: This service is not intended for secure transactions such as banking, social media, email, or purchasing. Use at your own risk. We assume no liability whatsoever for broken pages.


Alternative Proxies:

Alternative Proxy

pFad Proxy

pFad v3 Proxy

pFad v4 Proxy