From 0c6956c9c9f674a6c511eecf1747276751b7d3a9 Mon Sep 17 00:00:00 2001 From: Alexander Rosenberg Date: Tue, 8 Sep 2026 10:42:42 -0700 Subject: [PATCH] Fix soome stuff --- lisp/kernel.gl | 139 +++++++++++++++++++++++++++++++++++++++++++----- src/lisp_math.c | 6 ++- src/lisp_math.h | 1 + src/macro.c | 5 +- src/memory.c | 2 +- 5 files changed, 134 insertions(+), 19 deletions(-) diff --git a/lisp/kernel.gl b/lisp/kernel.gl index fdcd3f1..c5d1d7c 100644 --- a/lisp/kernel.gl +++ b/lisp/kernel.gl @@ -1,23 +1,26 @@ ;; -*- mode: lisp-data -*- ;; Defining macros and functions -(fset 'defmacro (cons 'macro - (lambda (name lambda-list &rest body) - "Define NAME to be a macro." - (declare (name defmacro)) - (list 'fset (list 'quote name) - (list 'cons - (quote 'macro) - (list* 'lambda lambda-list - (list 'declare (list 'name name)) - body)))))) +(fset 'defmacro + (cons 'macro + (lambda (name lambda-list &rest body) + "Define NAME to be a macro." + (declare (name defmacro)) + (list 'fset (list 'quote name) + (list 'cons + (quote 'macro) + (list 'lambda lambda-list + (list 'declare (list 'name name)) + (list* 'block name + body))))))) (defmacro defun (name lambda-list &rest body) "Define NAME to be a function." (list 'fset (list 'quote name) - (list* 'lambda lambda-list - (list 'declare (list 'name name)) - body))) + (list 'lambda lambda-list + (list 'declare (list 'name name)) + (list* 'block name + body)))) ;; List indicies (defun first (list) @@ -101,6 +104,16 @@ Spec is of the form (VARIABLE LIST &optional RETURN-FORM)." (dolist (elt list list) (funcall function elt))) +;; Functional functions +(defun identity (x) + "Return X." + x) + +(defun complement (f) + "Return the complement function of F, that is (not (f))." + (lambda (&rest r) + (not (apply f r)))) + ;; Some other functions (defun terpri (&optional print-char-fun) "Print a newline to PRINT-CHAR-FUN, then flush it." @@ -108,9 +121,107 @@ Spec is of the form (VARIABLE LIST &optional RETURN-FORM)." (funcall fun ?\n) (funcall fun nil))) +(defun prin1ln (datum &optional print-char-fun) + "`prin1' DATUM to PRINT-CHAR-FUN, then do a `terpri'." + (prin1 datum print-char-fun) + (terpri print-char-fun)) + (defun princln (datum &optional print-char-fun) "`princ' DATUM to PRINT-CHAR-FUN, then do a `terpri'." (princ datum print-char-fun) (terpri print-char-fun)) -(princln (append '(1 2) '(3 4))) +;; Cond +(defun internal-expand-single-cond (cond) + (if (cdr cond) + (let ((res (list 'if (car cond) + (list* 'progn (cdr cond))))) + (cons res res)) + (let* ((res-var (make-symbol "res")) + (if-stmt (list 'if res-var res-var))) + (cons (list 'let (list (list res-var (car cond))) + if-stmt) + if-stmt)))) + +(defmacro cond (&rest conds) + (let (out last-if) + (dolist (cond conds) + (let ((res (internal-expand-single-cond cond))) + (if (not out) + (setq out (car res) + last-if (cdr res)) + (rplacd (last last-if) (list (car res))) + (setq last-if (cdr res))))) + out)) + +;; Type predicates +(defmacro define-type-predicate (name args &rest body) + (cond + ((eq args 'alias) + (let ((var (make-symbol "var"))) + (list 'put (list 'quote name) ''type-predicate + (list 'lambda (list var) (list 'typep var (cons 'quote body)))))) + ((and (symbolp args) (null body)) + (list 'put (list 'quote name) ''type-predicate (list 'quote args))) + (t + (list 'put (list 'quote name) ''type-predicate + (list 'lambda args + (list 'declare (list 'name name)) + (list* 'block name + body)))))) + +(defun typep (obj type) + (let* ((name (if (consp type) + (car type) + type)) + (pred (get name 'type-predicate)) + (args (and (consp type) (cdr type)))) + (unless pred + (throw 'type-error)) + (apply pred obj args))) + +(define-type-predicate t (obj) t) +(define-type-predicate any alias t) +(define-type-predicate or (obj &rest preds) + (dolist (pred preds) + (let ((res (typep obj pred))) + (when res + (return-from or res)))) + nil) +(define-type-predicate and (obj &rest preds) + (let (res) + (dolist (pred preds) + (unless (setq res (typep obj pred)) + (return-from and nil))) + res)) +(define-type-predicate pred (obj pred) + (funcall pred obj)) +(define-type-predicate null null) +(define-type-predicate string stringp) +(define-type-predicate symbol symbolp) +(define-type-predicate cons consp) +(define-type-predicate list listp) +(define-type-predicate integer (obj &opt min max) + (and (integerp obj) + (or (not min) (>= obj min)) + (or (not max) (<= obj max)))) +(define-type-predicate fixnum fixnump) +(define-type-predicate bignum bignump) +(define-type-predicate byte alias (integer -128 127)) +(define-type-predicate signed-byte alias byte) +(define-type-predicate unsigned-byte alias (integer 0 255)) +(define-type-predicate float (obj &opt min max) + (and (floatp obj) + (or (not min) (>= obj min)) + (or (not max) (<= obj max)))) +(define-type-predicate vector vectorp) +(define-type-predicate function functionp) +(define-type-predicate callable callablep) +(define-type-predicate hash-table hash-table-p) +(define-type-predicate user-pointer user-pointer-p) +(define-type-predicate record recordp) +(define-type-predicate number (obj &opt min max) + (typep obj (list 'or (list 'float min max) + (list 'integer min max)))) + +(princln (typep [] '(or vector list))) diff --git a/src/lisp_math.c b/src/lisp_math.c index 6a54cc2..68f05e4 100644 --- a/src/lisp_math.c +++ b/src/lisp_math.c @@ -54,10 +54,14 @@ DEFUN(fixnump, "fixnump", (LispVal * val), "(val)", "") { return FIXNUMP(val) ? Qt : Qnil; } -DEFUN(integerp, "integerp", (LispVal * val), "(val)", "") { +DEFUN(bignump, "bignump", (LispVal * val), "(val)", "") { return LISP_GMP_P(val) ? Qt : Qnil; } +DEFUN(integerp, "integerp", (LispVal * val), "(val)", "") { + return LISP_GMP_P(val) || FIXNUMP(val) ? Qt : Qnil; +} + DEFUN(floatp, "floatp", (LispVal * val), "(val)", "") { return LISP_FLOAT_P(val) ? Qt : Qnil; } diff --git a/src/lisp_math.h b/src/lisp_math.h index 7f62757..d9dac8e 100644 --- a/src/lisp_math.h +++ b/src/lisp_math.h @@ -32,6 +32,7 @@ LispVal *parse_gmp(const char *str, int base); LispVal *parse_number(const char *str, int base); DECLARE_FUNCTION(fixnump, (LispVal * val)); +DECLARE_FUNCTION(bignump, (LispVal * val)); DECLARE_FUNCTION(integerp, (LispVal * val)); DECLARE_FUNCTION(floatp, (LispVal * val)); DECLARE_FUNCTION(numberp, (LispVal * val)); diff --git a/src/macro.c b/src/macro.c index 799caed..f5e5bac 100644 --- a/src/macro.c +++ b/src/macro.c @@ -151,9 +151,8 @@ static LispVal *macroexpand_special_form(LispVal *fobj, LispVal *form, if (!CONSP(XCDR(form)) || !LISTP(XCDR(XCDR(form)))) { return form; } - return CONS( - FIRST(form), - CONS(SECOND(form), Fmacroexpand_all(THIRD(form), lexical_macros))); + return LIST(FIRST(form), SECOND(form), + Fmacroexpand_all(THIRD(form), lexical_macros)); } else if (IS(declare)) { return form; } diff --git a/src/memory.c b/src/memory.c index bee3fee..7add983 100644 --- a/src/memory.c +++ b/src/memory.c @@ -6,7 +6,7 @@ void *lisp_realloc(void *oldptr, size_t size) { if (!size) { - assert(oldptr != NULL); + assert(oldptr == NULL); return NULL; } else { void *newptr = realloc(oldptr, size);