diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/builtins.c | 91 | ||||
| -rw-r--r-- | src/builtins.h | 6 | ||||
| -rw-r--r-- | src/interp.c | 6 | ||||
| -rw-r--r-- | src/prelude.c | 2 | ||||
| -rw-r--r-- | src/prelude.lisp | 94 |
5 files changed, 195 insertions, 4 deletions
diff --git a/src/builtins.c b/src/builtins.c index 591dc97..e39dfa4 100644 --- a/src/builtins.c +++ b/src/builtins.c @@ -7,6 +7,14 @@ #include <float.h> #include <math.h> +SExpRef builtin_functionp(Interp *interp, SExpRef args) { + if (LENGTH(args) != 1) { + return new_error(interp, "function?: args num error.\n"); + } + return new_boolean(interp, VALTYPE(CAR(args)) == kFuncSExp + || VALTYPE(CAR(args)) == kUserFuncSExp); +} + SExpRef builtin_setnth(Interp *interp, SExpRef args) { if (LENGTH(args) != 3) { return new_error(interp, "set-nth: args num error.\n"); @@ -114,11 +122,11 @@ SExpRef builtin_nconc(Interp *interp, SExpRef args) { SExpRef builtin_logand(Interp *interp, SExpRef args) { if (LENGTH(args) < 1) { - return new_error(interp, "nconc: args num error.\n"); + return new_error(interp, "logand: args num error.\n"); } for (SExpRef l = args; !NILP(l); l = CDR(l)) { if (VALTYPE(CAR(l)) != kIntegerSExp) { - return new_error(interp, "append: type error.\n"); + return new_error(interp, "logand: type error.\n"); } } uint64_t res = 0xffffffffffffffffULL; @@ -128,6 +136,83 @@ SExpRef builtin_logand(Interp *interp, SExpRef args) { return new_integer(interp, res); } +SExpRef builtin_logior(Interp *interp, SExpRef args) { + if (LENGTH(args) < 1) { + return new_error(interp, "logior: args num error.\n"); + } + for (SExpRef l = args; !NILP(l); l = CDR(l)) { + if (VALTYPE(CAR(l)) != kIntegerSExp) { + return new_error(interp, "logior: type error.\n"); + } + } + uint64_t res = 0; + for (SExpRef l = args; !NILP(l); l = CDR(l)) { + res = res | (REF(CAR(l))->integer); + } + return new_integer(interp, res); +} + +SExpRef builtin_logxor(Interp *interp, SExpRef args) { + if (LENGTH(args) < 1) { + return new_error(interp, "logxor: args num error.\n"); + } + for (SExpRef l = args; !NILP(l); l = CDR(l)) { + if (VALTYPE(CAR(l)) != kIntegerSExp) { + return new_error(interp, "logxor: type error.\n"); + } + } + uint64_t res = 0; + for (SExpRef l = args; !NILP(l); l = CDR(l)) { + res = res ^ (REF(CAR(l))->integer); + } + return new_integer(interp, res); +} + +SExpRef builtin_lognot(Interp *interp, SExpRef args) { + if (LENGTH(args) != 1) { + return new_error(interp, "lognot: args num error.\n"); + } + SExpRef x = CAR(args); + if (VALTYPE(x) != kIntegerSExp) { + return new_error(interp, "lognot: type error.\n"); + } + uint64_t res = 0; + res = ~(REF(x)->integer); + return new_integer(interp, res); +} + +SExpRef builtin_lsh(Interp *interp, SExpRef args) { + if (LENGTH(args) != 2) { + return new_error(interp, "lsh: args num error.\n"); + } + SExpRef x = CAR(args), n = CADR(args); + if (VALTYPE(x) != kIntegerSExp) { + return new_error(interp, "lsh: type error.\n"); + } + if (VALTYPE(n) != kIntegerSExp) { + return new_error(interp, "lsh: type error.\n"); + } + uint64_t res = 0; + res = (REF(x)->integer) << (REF(n)->integer); + return new_integer(interp, res); +} + +SExpRef builtin_ash(Interp *interp, SExpRef args) { + if (LENGTH(args) != 2) { + return new_error(interp, "ash: args num error.\n"); + } + SExpRef x = CAR(args), n = CADR(args); + if (VALTYPE(x) != kIntegerSExp) { + return new_error(interp, "ash: type error.\n"); + } + if (VALTYPE(n) != kIntegerSExp) { + return new_error(interp, "ash: type error.\n"); + } + int64_t res = 0; + res = (REF(x)->integer) >> (REF(n)->integer); + return new_integer(interp, res); +} + SExpRef builtin_charp(Interp *interp, SExpRef args) { if (LENGTH(args) != 1) return new_error(interp, "char?: arg num error.\n"); return new_boolean(interp, VALTYPE(CAR(args)) == kCharSExp); @@ -263,7 +348,7 @@ SExpRef builtin_numberp(Interp *interp, SExpRef args) { SExpRef builtin_integerp(Interp *interp, SExpRef args) { if (LENGTH(args) != 1) return new_error(interp, "integer?: arg num error.\n"); - return new_boolean(interp, REF(CAR(args))->type == kNilSExp); + return new_boolean(interp, REF(CAR(args))->type == kIntegerSExp); } SExpRef builtin_floatp(Interp *interp, SExpRef args) { diff --git a/src/builtins.h b/src/builtins.h index 0d3c5cc..1a8e927 100644 --- a/src/builtins.h +++ b/src/builtins.h @@ -3,6 +3,12 @@ #include "interp.h" +SExpRef builtin_logior(Interp *interp, SExpRef args); +SExpRef builtin_logxor(Interp *interp, SExpRef args); +SExpRef builtin_lognot(Interp *interp, SExpRef args); +SExpRef builtin_lsh(Interp *interp, SExpRef args); +SExpRef builtin_ash(Interp *interp, SExpRef args); +SExpRef builtin_functionp(Interp *interp, SExpRef args); SExpRef builtin_setnth(Interp *interp, SExpRef args); SExpRef builtin_setnthcdr(Interp *interp, SExpRef args); SExpRef builtin_foldl(Interp *interp, SExpRef args); diff --git a/src/interp.c b/src/interp.c index e6e9f2a..8b5c15f 100644 --- a/src/interp.c +++ b/src/interp.c @@ -123,6 +123,7 @@ void Interp_init(Interp *self) { Interp_add_primitive(self, "assert-error", primitive_assert_error); Interp_add_primitive(self, "load", primitive_load); + Interp_add_userfunc(self, "function?", builtin_functionp); Interp_add_userfunc(self, "map", builtin_map); Interp_add_userfunc(self, "filter", builtin_filter); Interp_add_userfunc(self, "remove", builtin_remove); @@ -221,6 +222,11 @@ void Interp_init(Interp *self) { Interp_add_userfunc(self, "append", builtin_append); Interp_add_userfunc(self, "nconc", builtin_nconc); Interp_add_userfunc(self, "logand", builtin_logand); + Interp_add_userfunc(self, "logior", builtin_logior); + Interp_add_userfunc(self, "logxor", builtin_logxor); + Interp_add_userfunc(self, "lognot", builtin_lognot); + Interp_add_userfunc(self, "lsh", builtin_lsh); + Interp_add_userfunc(self, "ash", builtin_ash); Interp_add_userfunc(self, "_gcstat", builtin_gcstat); Interp_add_userfunc(self, "_alwaysgc", builtin_alwaysgc); diff --git a/src/prelude.c b/src/prelude.c index e827718..679b418 100644 --- a/src/prelude.c +++ b/src/prelude.c @@ -1,6 +1,6 @@ #include "prelude.h" -const char *bamboo_lisp_prelude = "(defvar nil \'())\n\n(defvar pi 3.1415926)\n(defvar e 2.718281828)\n\n(defmacro incq (i)\n `(setq ,i (+ ,i 1)))\n\n(defmacro decq (i)\n `(setq ,i (- ,i 1)))\n\n(defun zero? (x) (= x 0))\n(defun plus? (x) (> x 0))\n(defun minus? (x) (< x 0))\n\n(defmacro when (pred . body)\n `(if ,pred\n (progn ,@body)\n nil))\n\n(defmacro unless (pred . body)\n `(if ,pred\n nil\n (progn ,@body)))\n\n(defun caar (x) (car (car x)))\n(defun cadr (x) (car (cdr x)))\n(defun cddr (x) (cdr (cdr x)))\n(defun cdar (x) (cdr (car x)))\n\n(defun caaar (x) (car (caar x)))\n(defun cadar (x) (car (cdar x)))\n(defun cddar (x) (cdr (cdar x)))\n(defun cdaar (x) (cdr (caar x)))\n(defun caadr (x) (car (cadr x)))\n(defun caddr (x) (car (cddr x)))\n(defun cdddr (x) (cdr (cddr x)))\n(defun cdadr (x) (cdr (cadr x)))\n"; +const char *bamboo_lisp_prelude = "(defvar nil \'())\n\n(defvar pi 3.1415926)\n(defvar e 2.718281828)\n\n(defmacro incq (i)\n `(setq ,i (+ ,i 1)))\n\n(defmacro decq (i)\n `(setq ,i (- ,i 1)))\n\n(defun zero? (x) (= x 0))\n(defun plus? (x) (> x 0))\n(defun minus? (x) (< x 0))\n\n(defmacro when (pred . body)\n `(if ,pred\n (progn ,@body)\n nil))\n\n(defmacro unless (pred . body)\n `(if ,pred\n nil\n (progn ,@body)))\n\n(defun take (n lst)\n (unless (integer? n)\n (error \"take: type error.\"))\n (unless (list? lst)\n (error \"take: type error.\"))\n (let ((i 0)\n (newlst nil))\n (while (and (< i n)\n (not (null? lst)))\n (setq newlst (cons (car lst) newlst))\n (setq lst (cdr lst))\n (incq i))\n (nreverse newlst)))\n\n(defun drop (n lst)\n (unless (integer? n)\n (error \"drop type error.\"))\n (unless (list? lst)\n (error \"drop: type error.\"))\n (let ((i 0))\n (while (and (< i n)\n (not (null? lst)))\n (setq lst (cdr lst))\n (incq i))\n lst))\n\n(defun take-while (pred lst)\n (unless (function? pred)\n (error \"take-while: type error.\"))\n (unless (list? lst)\n (error \"take-while: type error.\"))\n (let ((newlst nil))\n (while (and (not (null? lst))\n (funcall pred (car lst)))\n (setq newlst (cons (car lst) newlst))\n (setq lst (cdr lst)))\n (nreverse newlst)))\n\n(defun drop-while (pred lst)\n (unless (function? pred)\n (error \"drop-while: type error.\"))\n (unless (list? lst)\n (error \"drop-while: type error.\"))\n (while (and (not (null? lst))\n (funcall pred (car lst)))\n (setq lst (cdr lst)))\n lst)\n\n(defun sublist (start end lst)\n (unless (integer? start)\n (error \"sublist: type error.\"))\n (unless (integer? end)\n (error \"sublist: type error.\"))\n (unless (< start end)\n (error \"sublist: start must less than end.\"))\n (unless (list? lst)\n (error \"sublist: type error.\"))\n (drop start (take end lst)))\n\n(defun find (x lst)\n (unless (list? lst)\n (error \"find: type error.\"))\n (while (not (null? lst))\n (when (equal? x (car lst))\n (return lst))\n (setq lst (cdr lst)))\n nil)\n\n(defun contains? (x lst)\n (unless (list? lst)\n (error \"contains?: type error.\"))\n (while (not (null? lst))\n (when (equal? x (car lst))\n (return #t))\n (setq lst (cdr lst)))\n #f)\n\n(defun caar (x) (car (car x)))\n(defun cadr (x) (car (cdr x)))\n(defun cddr (x) (cdr (cdr x)))\n(defun cdar (x) (cdr (car x)))\n\n(defun caaar (x) (car (caar x)))\n(defun cadar (x) (car (cdar x)))\n(defun cddar (x) (cdr (cdar x)))\n(defun cdaar (x) (cdr (caar x)))\n(defun caadr (x) (car (cadr x)))\n(defun caddr (x) (car (cddr x)))\n(defun cdddr (x) (cdr (cddr x)))\n(defun cdadr (x) (cdr (cadr x)))\n\n(defun caaaar (x) (car (caaar x)))\n(defun cadaar (x) (car (cdaar x)))\n(defun cddaar (x) (cdr (cdaar x)))\n(defun cdaaar (x) (cdr (caaar x)))\n(defun caadar (x) (car (cadar x)))\n(defun caddar (x) (car (cddar x)))\n(defun cdddar (x) (cdr (cddar x)))\n(defun cdadar (x) (cdr (cadar x)))\n(defun caaadr (x) (car (caadr x)))\n(defun cadadr (x) (car (cdadr x)))\n(defun cddadr (x) (cdr (cdadr x)))\n(defun cdaadr (x) (cdr (caadr x)))\n(defun caaddr (x) (car (caddr x)))\n(defun cadddr (x) (car (cdddr x)))\n(defun cddddr (x) (cdr (cdddr x)))\n(defun cdaddr (x) (cdr (caddr x)))\n"; diff --git a/src/prelude.lisp b/src/prelude.lisp index b102e1b..a1be068 100644 --- a/src/prelude.lisp +++ b/src/prelude.lisp @@ -23,6 +23,83 @@ nil (progn ,@body))) +(defun take (n lst) + (unless (integer? n) + (error "take: type error.")) + (unless (list? lst) + (error "take: type error.")) + (let ((i 0) + (newlst nil)) + (while (and (< i n) + (not (null? lst))) + (setq newlst (cons (car lst) newlst)) + (setq lst (cdr lst)) + (incq i)) + (nreverse newlst))) + +(defun drop (n lst) + (unless (integer? n) + (error "drop type error.")) + (unless (list? lst) + (error "drop: type error.")) + (let ((i 0)) + (while (and (< i n) + (not (null? lst))) + (setq lst (cdr lst)) + (incq i)) + lst)) + +(defun take-while (pred lst) + (unless (function? pred) + (error "take-while: type error.")) + (unless (list? lst) + (error "take-while: type error.")) + (let ((newlst nil)) + (while (and (not (null? lst)) + (funcall pred (car lst))) + (setq newlst (cons (car lst) newlst)) + (setq lst (cdr lst))) + (nreverse newlst))) + +(defun drop-while (pred lst) + (unless (function? pred) + (error "drop-while: type error.")) + (unless (list? lst) + (error "drop-while: type error.")) + (while (and (not (null? lst)) + (funcall pred (car lst))) + (setq lst (cdr lst))) + lst) + +(defun sublist (start end lst) + (unless (integer? start) + (error "sublist: type error.")) + (unless (integer? end) + (error "sublist: type error.")) + (unless (< start end) + (error "sublist: start must less than end.")) + (unless (list? lst) + (error "sublist: type error.")) + (drop start (take end lst))) + +(defun find (x lst) + (unless (list? lst) + (error "find: type error.")) + (while (not (null? lst)) + (when (equal? x (car lst)) + (return lst)) + (setq lst (cdr lst))) + nil) + +(defun contains? (x lst) + (unless (list? lst) + (error "contains?: type error.")) + (while (not (null? lst)) + (when (equal? x (car lst)) + (return #t)) + (setq lst (cdr lst))) + #f) + (defun caar (x) (car (car x))) (defun cadr (x) (car (cdr x))) (defun cddr (x) (cdr (cdr x))) @@ -36,3 +113,20 @@ (defun caddr (x) (car (cddr x))) (defun cdddr (x) (cdr (cddr x))) (defun cdadr (x) (cdr (cadr x))) + +(defun caaaar (x) (car (caaar x))) +(defun cadaar (x) (car (cdaar x))) +(defun cddaar (x) (cdr (cdaar x))) +(defun cdaaar (x) (cdr (caaar x))) +(defun caadar (x) (car (cadar x))) +(defun caddar (x) (car (cddar x))) +(defun cdddar (x) (cdr (cddar x))) +(defun cdadar (x) (cdr (cadar x))) +(defun caaadr (x) (car (caadr x))) +(defun cadadr (x) (car (cdadr x))) +(defun cddadr (x) (cdr (cdadr x))) +(defun cdaadr (x) (cdr (caadr x))) +(defun caaddr (x) (car (caddr x))) +(defun cadddr (x) (car (cdddr x))) +(defun cddddr (x) (cdr (cdddr x))) +(defun cdaddr (x) (cdr (caddr x))) |