785 lines
20 KiB
Plaintext
785 lines
20 KiB
Plaintext
;;; LISP9 Derived Syntax and Functions
|
|
;;; Nils M Holm, 2018,2019
|
|
;;; In the public domain
|
|
;;;
|
|
;;; If your country does not have a concept like the public
|
|
;;; domain, the Creative Common Zero (CC0) licence applies,
|
|
;;; see https://creativecommons.org/publicdomain/zero/1.0/
|
|
|
|
nil t
|
|
|
|
(defun (cons x y) (cons x y))
|
|
(defun (car x) (car x))
|
|
(defun (cdr x) (cdr x))
|
|
|
|
(defun (caar x) (caar x))
|
|
(defun (cadr x) (cadr x))
|
|
(defun (cdar x) (cdar x))
|
|
(defun (cddr x) (cddr x))
|
|
|
|
(defun (caaar x) (car (caar x)))
|
|
(defun (caadr x) (car (cadr x)))
|
|
(defun (cadar x) (car (cdar x)))
|
|
(defun (caddr x) (car (cddr x)))
|
|
(defun (cdaar x) (cdr (caar x)))
|
|
(defun (cdadr x) (cdr (cadr x)))
|
|
(defun (cddar x) (cdr (cdar x)))
|
|
(defun (cdddr x) (cdr (cddr x)))
|
|
|
|
(defun (list . x) x)
|
|
(defun (vector . x) (listvec x))
|
|
(defun (string . x) (liststr x))
|
|
|
|
(defun (rever a)
|
|
(reconc a nil))
|
|
|
|
(defun (nrever a)
|
|
(nreconc a nil))
|
|
|
|
(defmac (cond . cs)
|
|
(if (null cs)
|
|
nil
|
|
(if (eq 'else (caar cs))
|
|
(cons 'prog (cdar cs))
|
|
(list 'if (caar cs)
|
|
(cons 'prog (cdar cs))
|
|
(cons 'cond (cdr cs))))))
|
|
|
|
(defmac (and . xs)
|
|
(cond ((null xs) 't)
|
|
((null (cdr xs)) (car xs))
|
|
(else (list 'if (car xs)
|
|
(cons 'and (cdr xs))
|
|
nil))))
|
|
|
|
(defmac (qquote x)
|
|
(cond ((vectorp x)
|
|
(list 'listvec
|
|
(list 'qquote (veclist x))))
|
|
((not (pair x))
|
|
(list 'quote x))
|
|
((eq 'unquote (car x))
|
|
(cadr x))
|
|
((and (pair (car x))
|
|
(eq 'unquote (caar x)))
|
|
(list 'cons (cadar x)
|
|
(list 'qquote (cdr x))))
|
|
((and (pair (car x))
|
|
(eq 'splice (caar x)))
|
|
(list 'conc (cadar x)
|
|
(list 'qquote (cdr x))))
|
|
(else
|
|
(list 'cons (list 'qquote (car x))
|
|
(list 'qquote (cdr x))))))
|
|
|
|
(defmac (let bs x . xs)
|
|
((lambda (split)
|
|
(setq split
|
|
(lambda (bs vs as)
|
|
(if (null bs)
|
|
(list vs as)
|
|
(split (cdr bs)
|
|
(cons (caar bs) vs)
|
|
(cons (cadar bs) as)))))
|
|
(apply (lambda (vs as)
|
|
@((lambda ,vs ,x . ,xs) . ,as))
|
|
(split bs nil nil)))
|
|
nil))
|
|
|
|
(defun (mapcar f a . b)
|
|
(if (null b)
|
|
(let ((m1 nil))
|
|
(setq m1 (lambda (a)
|
|
(if (null a)
|
|
nil
|
|
(cons (f (car a))
|
|
(m1 (cdr a))))))
|
|
(m1 a))
|
|
(let ((m2 nil))
|
|
(setq m2 (lambda (a b)
|
|
(if (null a)
|
|
nil
|
|
(cons (f (car a) (car b))
|
|
(m2 (cdr a) (cdr b))))))
|
|
(m2 a (car b)))))
|
|
|
|
(defmac (labels bs x . xs)
|
|
(let ((vs (mapcar car bs))
|
|
(as (mapcar cadr bs)))
|
|
(let ((ns (mapcar (lambda (v) (list v nil)) vs))
|
|
(is (mapcar (lambda (v a) (list 'setq v a)) vs as)))
|
|
@(let ,ns ,@is ,x . ,xs))))
|
|
|
|
(defmac (or . xs)
|
|
(cond ((null xs) nil)
|
|
((null (cdr xs)) (car xs))
|
|
(else @(if* ,(car xs)
|
|
(or . ,(cdr xs))))))
|
|
|
|
(defmac (cond . cs)
|
|
(cond ((null cs) nil)
|
|
((null (cdar cs))
|
|
@(if* ,(caar cs)
|
|
(cond . ,(cdr cs))))
|
|
((eq '=> (cadar cs))
|
|
(let ((g (gensym)))
|
|
@(let ((,g ,(caar cs)))
|
|
(if ,g (,(caddr (car cs)) ,g)
|
|
(cond . ,(cdr cs))))))
|
|
((eq 'else (caar cs))
|
|
@(prog . ,(cdar cs)))
|
|
((null (cdr cs))
|
|
@(if ,(caar cs)
|
|
(prog . ,(cdar cs))))
|
|
(else
|
|
@(if ,(caar cs)
|
|
(prog . ,(cdar cs))
|
|
(cond . ,(cdr cs))))))
|
|
|
|
(defmac (case x . cs)
|
|
(defun (cases x cs)
|
|
(cond ((null cs) nil)
|
|
((eq 'else (caar cs))
|
|
@(prog . ,(cdar cs)))
|
|
(else
|
|
@(if (memv ,x ',(caar cs))
|
|
(prog . ,(cdar cs))
|
|
,(cases x (cdr cs))))))
|
|
(let ((g (gensym)))
|
|
@(let ((,g ,x))
|
|
,(cases g cs))))
|
|
|
|
(defmac (let* bs x . xs)
|
|
(if (null bs)
|
|
@(let () ,x . ,xs)
|
|
@(let (,(car bs))
|
|
(let* ,(cdr bs) ,x . ,xs))))
|
|
|
|
(defmac (let x0 x . xs)
|
|
(if (symbolp x0)
|
|
(let ((vs (mapcar car x))
|
|
(as (mapcar cadr x)))
|
|
@((labels ((,x0 (lambda ,vs . ,xs)))
|
|
,x0) . ,as))
|
|
(let ((vs (mapcar car x0))
|
|
(as (mapcar cadr x0)))
|
|
@((lambda ,vs ,x . ,xs) . ,as))))
|
|
|
|
(defmac (with bs x . xs)
|
|
(let* ((vs (mapcar car bs))
|
|
(gs (mapcar (lambda (x) (gensym)) bs))
|
|
(as (mapcar cadr bs))
|
|
(set (mapcar (lambda (v a) @(setq ,v ,a)) vs as))
|
|
(res (mapcar (lambda (v g) @(setq ,v ,g)) vs gs))
|
|
(val (gensym)))
|
|
@((lambda ,gs
|
|
(unwind
|
|
(lambda () (prog . ,res))
|
|
(lambda ()
|
|
,@set
|
|
,x . ,xs))) . ,vs)))
|
|
|
|
(defmac (do bs tst . xs)
|
|
(let ((fn (gensym))
|
|
(vs (mapcar car bs))
|
|
(as (mapcar cadr bs))
|
|
(ss (mapcar cddr bs)))
|
|
(let ((ss (mapcar (lambda (s v)
|
|
(if (null s) v (car s)))
|
|
ss vs)))
|
|
@(labels
|
|
((,fn (lambda ,vs
|
|
(if ,(car tst)
|
|
(prog . ,(cdr tst))
|
|
(prog ,@xs (,fn . ,ss))))))
|
|
(,fn . ,as)))))
|
|
|
|
(defun (fold f b a)
|
|
(defun (fl a r)
|
|
(if (null a)
|
|
r
|
|
(fl (cdr a)
|
|
(f r (car a)))))
|
|
(fl a b))
|
|
|
|
(defun (foldr f b a)
|
|
(defun (fr a r)
|
|
(if (null a)
|
|
r
|
|
(fr (cdr a)
|
|
(f (car a) r))))
|
|
(fr (rever a) b))
|
|
|
|
(defun (filter p a)
|
|
(defun (fi a r)
|
|
(cond ((null a) (nrever r))
|
|
((p (car a))
|
|
(fi (cdr a) (cons (car a) r)))
|
|
(else
|
|
(fi (cdr a) r))))
|
|
(fi a nil))
|
|
|
|
(defun (memq x a)
|
|
(cond ((null a) nil)
|
|
((eq x (car a)) a)
|
|
(else (memq x (cdr a)))))
|
|
|
|
(defun (mapcar f a . as)
|
|
(defun (map f x)
|
|
(if (null x)
|
|
nil
|
|
(cons (f (car x))
|
|
(map f (cdr x)))))
|
|
(defun (car* x) (map car x))
|
|
(defun (cdr* x) (map cdr x))
|
|
(defun (nil* x) (memq nil x))
|
|
(defun (mapcar* as r)
|
|
(if (nil* as)
|
|
(nrever r)
|
|
(mapcar* (cdr* as)
|
|
(cons (apply f (car* as))
|
|
r))))
|
|
(mapcar* (cons a as) nil))
|
|
|
|
(defun (foreach f a . as)
|
|
(apply mapcar f a as)
|
|
nil)
|
|
|
|
(defun (length ls)
|
|
(defun (len a n)
|
|
(cond ((null a) n)
|
|
((pair a) (len (cdr a) (+ 1 n)))
|
|
(else (error "length: improper list" ls))))
|
|
(len ls 0))
|
|
|
|
(defun (nth-tail n a)
|
|
(if (= 0 n)
|
|
a
|
|
(nth-tail (- n 1) (cdr a))))
|
|
|
|
(defun (nth n a) (car (nth-tail n a)))
|
|
|
|
(defun (listp x)
|
|
(defun (acyclicp x y)
|
|
(cond ((eq x y) nil)
|
|
((null x))
|
|
((pair x)
|
|
(or (null (cdr x))
|
|
(and (pair (cdr x))
|
|
(acyclicp (cddr x) (cdr y)))))
|
|
(else nil)))
|
|
(or (null x)
|
|
(and (pair x)
|
|
(acyclicp (cdr x) x))))
|
|
|
|
(defun (caaaar x) (caar (caar x)))
|
|
(defun (caaadr x) (caar (cadr x)))
|
|
(defun (caadar x) (caar (cdar x)))
|
|
(defun (caaddr x) (caar (cddr x)))
|
|
(defun (cadaar x) (cadr (caar x)))
|
|
(defun (cadadr x) (cadr (cadr x)))
|
|
(defun (caddar x) (cadr (cdar x)))
|
|
(defun (cadddr x) (cadr (cddr x)))
|
|
(defun (cdaaar x) (cdar (caar x)))
|
|
(defun (cdaadr x) (cdar (cadr x)))
|
|
(defun (cdadar x) (cdar (cdar x)))
|
|
(defun (cdaddr x) (cdar (cddr x)))
|
|
(defun (cddaar x) (cddr (caar x)))
|
|
(defun (cddadr x) (cddr (cadr x)))
|
|
(defun (cdddar x) (cddr (cdar x)))
|
|
(defun (cddddr x) (cddr (cddr x)))
|
|
|
|
(defun (eqv a b)
|
|
(cond ((eq a b))
|
|
((and (fixp a)
|
|
(fixp b)
|
|
(= a b)))
|
|
((and (charp a)
|
|
(charp b)
|
|
(c= a b)))
|
|
(else nil)))
|
|
|
|
(defun (equal a b)
|
|
(defun (equvec a b)
|
|
(and (= (vsize a) (vsize b))
|
|
(let loop ((i (- (vsize a) 1)))
|
|
(cond ((< i 0))
|
|
((equal (vref a i) (vref b i))
|
|
(loop (- i 1)))
|
|
(else nil)))))
|
|
(cond ((eq a b))
|
|
((and (pair a)
|
|
(pair b)
|
|
(equal (car a) (car b))
|
|
(equal (cdr a) (cdr b))))
|
|
((and (stringp a)
|
|
(stringp b)
|
|
(s= a b)))
|
|
((and (vectorp a)
|
|
(vectorp b)
|
|
(equvec a b)))
|
|
(else (eqv a b))))
|
|
|
|
(defun (memv x a)
|
|
(cond ((null a) nil)
|
|
((eqv x (car a)) a)
|
|
(else (memv x (cdr a)))))
|
|
|
|
(defun (member x a)
|
|
(cond ((null a) nil)
|
|
((equal x (car a)) a)
|
|
(else (member x (cdr a)))))
|
|
|
|
(defun (assq x a)
|
|
(cond ((null a) nil)
|
|
((eq x (caar a)) (car a))
|
|
(else (assq x (cdr a)))))
|
|
|
|
(defun (assv x a)
|
|
(cond ((null a) nil)
|
|
((eqv x (caar a)) (car a))
|
|
(else (assv x (cdr a)))))
|
|
|
|
(defun (asss x a)
|
|
(cond ((null a) nil)
|
|
((s= x (caar a)) (car a))
|
|
(else (s= x (cdr a)))))
|
|
|
|
(defun (assoc x a)
|
|
(cond ((null a) nil)
|
|
((equal x (caar a)) (car a))
|
|
(else (assoc x (cdr a)))))
|
|
|
|
(defmac (andb x y . z) @(bitop 1 ,x ,y . ,z))
|
|
(defmac (xorb x y . z) @(bitop 6 ,x ,y . ,z))
|
|
(defmac (orb x y . z) @(bitop 7 ,x ,y . ,z))
|
|
(defmac (norb x y . z) @(bitop 8 ,x ,y . ,z))
|
|
(defmac (eqvb x y . z) @(bitop 9 ,x ,y . ,z))
|
|
(defmac (notb x) @(bitop 12 ,x 0))
|
|
(defmac (nandb x y . z) @(bitop 14 ,x ,y . ,z))
|
|
(defmac (shlb x y . z) @(bitop 16 ,x ,y . ,z))
|
|
(defmac (shrb x y . z) @(bitop 17 ,x ,y . ,z))
|
|
(defmac (asrb x y . z) @(bitop 18 ,x ,y . ,z))
|
|
|
|
(defun (andb x y . z) (apply bitop 1 x y z))
|
|
(defun (xorb x y . z) (apply bitop 6 x y z))
|
|
(defun (orb x y . z) (apply bitop 7 x y z))
|
|
(defun (norb x y . z) (apply bitop 8 x y z))
|
|
(defun (eqvb x y . z) (apply bitop 9 x y z))
|
|
(defun (notb x) (bitop 12 x 0))
|
|
(defun (nandb x y . z) (apply bitop 14 x y z))
|
|
(defun (shlb x y . z) (apply bitop 16 x y z))
|
|
(defun (asrb x y . z) (apply bitop 17 x y z))
|
|
|
|
(defun (evenp x) (= 0 (rem x 2)))
|
|
|
|
(defun (oddp x) (not (evenp x)))
|
|
|
|
(defun (gcd x y)
|
|
(defun (gcd x y)
|
|
(cond ((= 0 x) y)
|
|
((= 0 y) x)
|
|
((< x y) (gcd x (rem y x)))
|
|
(else (gcd y (rem x y)))))
|
|
(gcd (abs x) (abs y)))
|
|
|
|
(defun (lcm x y)
|
|
(let ((cd (gcd x y)))
|
|
(abs (* cd (div x cd) (div y cd)))))
|
|
|
|
(defun (expt x y)
|
|
(defun (square x) (* x x))
|
|
(defun (expt2 x y)
|
|
(cond ((= 0 y) 1)
|
|
((evenp y) (square (expt2 x (div y 2))))
|
|
(else (* x (square (expt2 x (div y 2)))))))
|
|
(defun (nexpt y r)
|
|
(cond ((= 0 y) r)
|
|
(else (nexpt (- y 1) (* r x)))))
|
|
(if (> y 20)
|
|
(expt2 x y)
|
|
(nexpt y 1)))
|
|
|
|
(defun (mod x y)
|
|
(let ((r (rem x y)))
|
|
(cond ((= 0 r) 0)
|
|
((eq (< x 0) (< y 0)) r)
|
|
(else (+ y r)))))
|
|
|
|
(defun (scopy s)
|
|
(substr s 0 (ssize s)))
|
|
|
|
(defun (terpri . p)
|
|
(if (and (pair p)
|
|
(pair (cdr p)))
|
|
(error "terpri: too many arguments"))
|
|
(apply writec #\nl p))
|
|
|
|
(defun (print . xs)
|
|
(cond ((null xs) (princ "\n"))
|
|
((null (cdr xs))
|
|
(princ (car xs))
|
|
(princ "\n"))
|
|
(else
|
|
(prin (car xs))
|
|
(writec #\sp)
|
|
(apply print (cdr xs)))))
|
|
|
|
(defun (printc . xs)
|
|
(cond ((null xs) (princ "\n"))
|
|
((null (cdr xs))
|
|
(princ (car xs))
|
|
(princ "\n"))
|
|
(else
|
|
(princ (car xs))
|
|
(writec #\sp)
|
|
(apply printc (cdr xs)))))
|
|
|
|
(defun (readln . p)
|
|
(let loop ((c (apply readc p))
|
|
(a nil))
|
|
(cond ((eofp c)
|
|
(if (null a)
|
|
c
|
|
(liststr (nrever a))))
|
|
((c= #\nl c)
|
|
(liststr (nrever a)))
|
|
(else
|
|
(loop (apply readc p)
|
|
(cons c a))))))
|
|
|
|
(defun (with-infile s f)
|
|
(let ((oi (inport))
|
|
(i (open-infile s)))
|
|
(unwind
|
|
(lambda ()
|
|
(set-inport oi)
|
|
(close-port i))
|
|
(lambda ()
|
|
(set-inport i)
|
|
(f)))))
|
|
|
|
(defun (with-outfile s f)
|
|
(let ((oo (outport))
|
|
(o (open-outfile s)))
|
|
(unwind
|
|
(lambda ()
|
|
(set-outport oo)
|
|
(close-port o))
|
|
(lambda ()
|
|
(set-outport o)
|
|
(f)))))
|
|
|
|
(defun (with-inport s f)
|
|
(let ((i (open-infile s)))
|
|
(unwind
|
|
(lambda ()
|
|
(close-port i))
|
|
(lambda ()
|
|
(f i)))))
|
|
|
|
(defun (with-outport s f)
|
|
(let ((o (open-outfile s)))
|
|
(unwind
|
|
(lambda ()
|
|
(close-port o))
|
|
(lambda ()
|
|
(f o)))))
|
|
|
|
(def *unwind* nil)
|
|
|
|
(defun (catch x)
|
|
(let ((r (catch*
|
|
(lambda (c)
|
|
(setq *unwind* (cons c *unwind*))
|
|
(x c)))))
|
|
(setq *unwind* (cdr *unwind*))
|
|
r))
|
|
|
|
(defun (throw c v)
|
|
(let loop ()
|
|
(cond ((null *unwind*)
|
|
(throw* c v))
|
|
((funp (car *unwind*))
|
|
(let ((w (car *unwind*)))
|
|
(setq *unwind* (cdr *unwind*))
|
|
(w)
|
|
(loop)))
|
|
((eq c (car *unwind*))
|
|
(throw* c v))
|
|
(else
|
|
(setq *unwind* (cdr *unwind*))
|
|
(loop)))))
|
|
|
|
(defun (unwind u f)
|
|
(setq *unwind* (cons u *unwind*))
|
|
(let ((v (f)) (w nil))
|
|
(setq w (car *unwind*))
|
|
(setq *unwind* (cdr *unwind*))
|
|
(w)
|
|
v))
|
|
|
|
(defmac (catch-errors v x . xs)
|
|
(let ((g (gensym))
|
|
(r (gensym))
|
|
(et (gensym))
|
|
(ev (gensym)))
|
|
@(let ((,et *Errtag*)
|
|
(,ev *Errval*))
|
|
(let ((,r (catch*
|
|
(lambda (,g)
|
|
(setq *Errval*
|
|
,(if (null v) g (car v)))
|
|
(setq *Errtag* ,g)
|
|
,x . ,xs))))
|
|
(setq *Errtag* ,et)
|
|
(setq *Errval* ,ev)
|
|
,r))))
|
|
|
|
(defun (save)
|
|
(if *imagefile*
|
|
(dump-image *imagefile*)
|
|
(error "save: no image loaded, use \"dump-image\"")))
|
|
|
|
(defun (cmdline) (cmdline))
|
|
(defun (errport) (errport))
|
|
(defun (inport) (inport))
|
|
(defun (outport) (outport))
|
|
(defun (gc) (gc))
|
|
(defun (gensym) (gensym))
|
|
(defun (obtab) (obtab))
|
|
(defun (quit) (quit))
|
|
(defun (symtab) (symtab))
|
|
|
|
(defun (abs x) (abs x))
|
|
(defun (alphac x) (alphac x))
|
|
(defun (atom x) (atom x))
|
|
(defun (catch* x) (catch* x))
|
|
(defun (char x) (char x))
|
|
(defun (charp x) (charp x))
|
|
(defun (charval x) (charval x))
|
|
(defun (close-port x) (close-port x))
|
|
(defun (ctagp x) (ctagp x))
|
|
(defun (constp x) (constp x))
|
|
(defun (delete x) (delete x))
|
|
(defun (downcase x) (downcase x))
|
|
(defun (dump-image x) (dump-image x))
|
|
(defun (eofp x) (eofp x))
|
|
(defun (existsp x) (existsp x))
|
|
(defun (fixp x) (fixp x))
|
|
(defun (flush x) (flush x))
|
|
(defun (format x) (format x))
|
|
(defun (funp x) (funp x))
|
|
(defun (inportp x) (inportp x))
|
|
(defun (liststr x) (liststr x))
|
|
(defun (listvec x) (listvec x))
|
|
(defun (load x) (load x))
|
|
(defun (lowerc x) (lowerc x))
|
|
(defun (mx x) (mx x))
|
|
(defun (mx1 x) (mx1 x))
|
|
(defun (not x) (not x))
|
|
(defun (null x) (null x))
|
|
(defun (numeric x) (numeric x))
|
|
(defun (open-infile x) (open-infile x))
|
|
(defun (outportp x) (outportp x))
|
|
(defun (pair x) (pair x))
|
|
(defun (set-inport x) (set-inport x))
|
|
(defun (set-outport x) (set-outport x))
|
|
(defun (ssize x) (ssize x))
|
|
(defun (stringp x) (stringp x))
|
|
(defun (strlist x) (strlist x))
|
|
(defun (symbol x) (symbol x))
|
|
(defun (symbolp x) (symbolp x))
|
|
(defun (symname x) (symname x))
|
|
(defun (syscmd x) (syscmd x))
|
|
(defun (untag x) (untag x))
|
|
(defun (upcase x) (upcase x))
|
|
(defun (upperc x) (upperc x))
|
|
(defun (veclist x) (veclist x))
|
|
(defun (vectorp x) (vectorp x))
|
|
(defun (vsize x) (vsize x))
|
|
(defun (whitec x) (whitec x))
|
|
|
|
(defun (div x y) (div x y))
|
|
(defun (eq x y) (eq x y))
|
|
(defun (nreconc x y) (nreconc x y))
|
|
(defun (rem x y) (rem x y))
|
|
(defun (reconc x y) (reconc x y))
|
|
(defun (reanme x y) (rename x y))
|
|
(defun (setcar x y) (setcar x y))
|
|
(defun (setcdr x y) (setcdr x y))
|
|
(defun (sfill x y) (sfill x y))
|
|
(defun (sref x y) (sref x y))
|
|
(defun (throw* x y) (throw* x y))
|
|
(defun (vfill x y) (vfill x y))
|
|
(defun (vref x y) (vref x y))
|
|
|
|
(defun (+ . x) (fold (lambda (x y) (+ x y)) 0 x))
|
|
(defun (* . x) (fold (lambda (x y) (* x y)) 1 x))
|
|
(defun (conc . x) (fold (lambda (x y) (conc x y)) nil x))
|
|
(defun (nconc . x) (fold (lambda (x y) (nconc x y)) nil x))
|
|
(defun (sconc . x) (fold (lambda (x y) (sconc x y)) "" x))
|
|
(defun (vconc . x) (fold (lambda (x y) (vconc x y)) #() x))
|
|
|
|
(defun (peekc . x)
|
|
(cond ((null x)
|
|
(peekc))
|
|
((null (cdr x))
|
|
(peekc (car x)))
|
|
(else
|
|
(error "peekc: too many arguments"))))
|
|
|
|
(defun (read . x)
|
|
(cond ((null x)
|
|
(read))
|
|
((null (cdr x))
|
|
(read (car x)))
|
|
(else
|
|
(error "read: too many arguments"))))
|
|
|
|
(defun (readc . x)
|
|
(cond ((null x)
|
|
(readc))
|
|
((null (cdr x))
|
|
(readc (car x)))
|
|
(else
|
|
(error "readc: too many arguments"))))
|
|
|
|
(defun (bitop op x y . z)
|
|
(fold (lambda (x y) (bitop op x y))
|
|
x
|
|
(cons y z)))
|
|
|
|
(defun (- x . y)
|
|
(if (null y)
|
|
(- x)
|
|
(fold (lambda (x y) (- x y)) x y)))
|
|
|
|
(defun (max x . y)
|
|
(if (null y)
|
|
x
|
|
(fold (lambda (x y) (max x y)) x y)))
|
|
|
|
(defun (min x . y)
|
|
(if (null y)
|
|
x
|
|
(fold (lambda (x y) (min x y)) x y)))
|
|
|
|
(defun (error x . y)
|
|
(cond ((null y)
|
|
(error x))
|
|
((null (cdr y))
|
|
(error x (car y)))
|
|
(else
|
|
(error "error: too many arguments"))))
|
|
|
|
(defun (mkstr x . y)
|
|
(cond ((null y)
|
|
(mkstr x))
|
|
((null (cdr y))
|
|
(mkstr x (car y)))
|
|
(else
|
|
(error "mkstr: too many arguments"))))
|
|
|
|
(defun (mkvec x . y)
|
|
(cond ((null y)
|
|
(mkvec x))
|
|
((null (cdr y))
|
|
(mkvec x (car y)))
|
|
(else
|
|
(error "mkstr: too many arguments"))))
|
|
|
|
(defun (numstr x . y)
|
|
(cond ((null y)
|
|
(numstr x))
|
|
((null (cdr y))
|
|
(numstr x (car y)))
|
|
(else
|
|
(error "numstr: too many arguments"))))
|
|
|
|
(defun (strnum x . y)
|
|
(cond ((null y)
|
|
(strnum x))
|
|
((null (cdr y))
|
|
(strnum x (car y)))
|
|
(else
|
|
(error "strnum: too many arguments"))))
|
|
|
|
(defun (open-outfile x . y)
|
|
(cond ((null y)
|
|
(open-outfile x))
|
|
((null (cdr y))
|
|
(open-outfile x (car y)))
|
|
(else
|
|
(error "open-outfile: too many arguments"))))
|
|
|
|
(defun (prin x . y)
|
|
(cond ((null y)
|
|
(prin x))
|
|
((null (cdr y))
|
|
(prin x (car y)))
|
|
(else
|
|
(error "prin: too many arguments"))))
|
|
|
|
(defun (princ x . y)
|
|
(cond ((null y)
|
|
(princ x))
|
|
((null (cdr y))
|
|
(princ x (car y)))
|
|
(else
|
|
(error "princ: too many arguments"))))
|
|
|
|
(defun (writec x . y)
|
|
(cond ((null y)
|
|
(writec x))
|
|
((null (cdr y))
|
|
(writec x (car y)))
|
|
(else
|
|
(error "writec: too many arguments"))))
|
|
|
|
(defun (%compare op a)
|
|
(let loop ((a a))
|
|
(cond ((null (cdr a)))
|
|
((op (car a) (cadr a))
|
|
(loop (cdr a)))
|
|
(else nil))))
|
|
|
|
(defun (< x . y) (%compare (lambda (x y) (< x y)) (cons x y)))
|
|
(defun (<= x . y) (%compare (lambda (x y) (<= x y)) (cons x y)))
|
|
(defun (= x . y) (%compare (lambda (x y) (= x y)) (cons x y)))
|
|
(defun (> x . y) (%compare (lambda (x y) (> x y)) (cons x y)))
|
|
(defun (>= x . y) (%compare (lambda (x y) (>= x y)) (cons x y)))
|
|
(defun (c< x . y) (%compare (lambda (x y) (c< x y)) (cons x y)))
|
|
(defun (c<= x . y) (%compare (lambda (x y) (c<= x y)) (cons x y)))
|
|
(defun (c= x . y) (%compare (lambda (x y) (c= x y)) (cons x y)))
|
|
(defun (c> x . y) (%compare (lambda (x y) (c> x y)) (cons x y)))
|
|
(defun (c>= x . y) (%compare (lambda (x y) (c>= x y)) (cons x y)))
|
|
(defun (s< x . y) (%compare (lambda (x y) (s< x y)) (cons x y)))
|
|
(defun (s<= x . y) (%compare (lambda (x y) (s<= x y)) (cons x y)))
|
|
(defun (s= x . y) (%compare (lambda (x y) (s= x y)) (cons x y)))
|
|
(defun (s> x . y) (%compare (lambda (x y) (s> x y)) (cons x y)))
|
|
(defun (s>= x . y) (%compare (lambda (x y) (s>= x y)) (cons x y)))
|
|
(defun (si< x . y) (%compare (lambda (x y) (si< x y)) (cons x y)))
|
|
(defun (si<= x . y) (%compare (lambda (x y) (si<= x y)) (cons x y)))
|
|
(defun (si= x . y) (%compare (lambda (x y) (si= x y)) (cons x y)))
|
|
(defun (si> x . y) (%compare (lambda (x y) (si> x y)) (cons x y)))
|
|
(defun (si>= x . y) (%compare (lambda (x y) (si>= x y)) (cons x y)))
|
|
|
|
(defun (sset x y z) (sset x y z))
|
|
(defun (substr x y z) (substr x y z))
|
|
(defun (subvec x y z) (subvec x y z))
|
|
(defun (vset x y z) (vset x y z))
|
|
|
|
(defun (apply f . as)
|
|
(let loop ((as as)
|
|
(a nil))
|
|
(cond ((null as)
|
|
(error "apply: too few arguments"))
|
|
((null (cdr as))
|
|
(if (pair (car as))
|
|
(apply f (conc (nrever a) (car as)))
|
|
(error "apply: expected list" (car as))))
|
|
(else
|
|
(loop (cdr as)
|
|
(cons (car as) a))))))
|