allowing logand, logior, logxor to accept any number of arguments

adding negative?, positive?, zero?, even?, odd?, for-each
adding *linefeed*, terpri
This commit is contained in:
JeffBezanson 2009-03-12 02:47:34 +00:00
parent d81e6c2d57
commit bfa30fb095
6 changed files with 134 additions and 53 deletions

View File

@ -490,26 +490,6 @@ size_t cvalue_arraylen(value_t v)
return cv_len(cv)/(cv_class(cv)->elsz);
}
static value_t cvalue_relocate(value_t v)
{
size_t nw;
cvalue_t *cv = (cvalue_t*)ptr(v);
cvalue_t *nv;
value_t ncv;
nw = cv_nwords(cv);
nv = (cvalue_t*)alloc_words(nw);
memcpy(nv, cv, nw*sizeof(value_t));
if (isinlined(cv))
nv->data = &nv->_space[0];
ncv = tagptr(nv, TAG_CVALUE);
fltype_t *t = cv_class(cv);
if (t->vtable != NULL && t->vtable->relocate != NULL)
t->vtable->relocate(v, ncv);
forward(v, ncv);
return ncv;
}
static size_t cvalue_struct_offs(value_t type, value_t field, int computeTotal,
int *palign)
{
@ -664,6 +644,26 @@ value_t cvalue_typeof(value_t *args, u_int32_t nargs)
return cv_type((cvalue_t*)ptr(args[0]));
}
value_t cvalue_relocate(value_t v)
{
size_t nw;
cvalue_t *cv = (cvalue_t*)ptr(v);
cvalue_t *nv;
value_t ncv;
nw = cv_nwords(cv);
nv = (cvalue_t*)alloc_words(nw);
memcpy(nv, cv, nw*sizeof(value_t));
if (isinlined(cv))
nv->data = &nv->_space[0];
ncv = tagptr(nv, TAG_CVALUE);
fltype_t *t = cv_class(cv);
if (t->vtable != NULL && t->vtable->relocate != NULL)
t->vtable->relocate(v, ncv);
forward(v, ncv);
return ncv;
}
value_t cvalue_copy(value_t v)
{
assert(iscvalue(v));

View File

@ -10,7 +10,7 @@
it uses a Scheme-style evaluation rule where any expression may appear in
head position as long as it evaluates to a function.
it uses Scheme-style varargs (dotted formal argument lists)
lambdas can have only 1 body expression; use (progn ...) for multiple
lambdas can have only 1 body expression; use (begin ...) for multiple
expressions. this is due to the closure representation
(lambda args body . env)
@ -29,6 +29,7 @@
* constructor notation for nicely printing arbitrary values
* strings
* hash tables
* I/O streams
by Jeff Bezanson (C) 2009
Distributed under the BSD License
@ -894,7 +895,7 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
}
v = *pv;
break;
case F_PROGN:
case F_BEGIN:
// return last arg
pv = &Stack[saveSP];
if (iscons(*pv)) {
@ -1153,25 +1154,52 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
v = fl_bitwise_not(Stack[SP-1]);
break;
case F_BAND:
argcount("logand", nargs, 2);
if (bothfixnums(Stack[SP-1], Stack[SP-2]))
v = Stack[SP-1] & Stack[SP-2];
else
v = fl_bitwise_op(Stack[SP-2], Stack[SP-1], 0, "&");
if (nargs == 0)
v = fixnum(-1);
else {
v = Stack[SP-nargs];
while (nargs > 1) {
e = Stack[SP-nargs+1];
if (bothfixnums(v, e))
v = v & e;
else
v = fl_bitwise_op(v, e, 0, "&");
nargs--;
Stack[SP-nargs] = v;
}
}
break;
case F_BOR:
argcount("logior", nargs, 2);
if (bothfixnums(Stack[SP-1], Stack[SP-2]))
v = Stack[SP-1] | Stack[SP-2];
else
v = fl_bitwise_op(Stack[SP-2], Stack[SP-1], 1, "!");
if (nargs == 0)
v = fixnum(0);
else {
v = Stack[SP-nargs];
while (nargs > 1) {
e = Stack[SP-nargs+1];
if (bothfixnums(v, e))
v = v | e;
else
v = fl_bitwise_op(v, e, 1, "!");
nargs--;
Stack[SP-nargs] = v;
}
}
break;
case F_BXOR:
argcount("logxor", nargs, 2);
if (bothfixnums(Stack[SP-1], Stack[SP-2]))
v = fixnum(numval(Stack[SP-1]) ^ numval(Stack[SP-2]));
else
v = fl_bitwise_op(Stack[SP-2], Stack[SP-1], 2, "$");
if (nargs == 0)
v = fixnum(0);
else {
v = Stack[SP-nargs];
while (nargs > 1) {
e = Stack[SP-nargs+1];
if (bothfixnums(v, e))
v = fixnum(numval(v) ^ numval(e));
else
v = fl_bitwise_op(v, e, 2, "$");
nargs--;
Stack[SP-nargs] = v;
}
}
break;
case F_ASH:
argcount("ash", nargs, 2);

View File

@ -102,7 +102,7 @@ extern uint32_t SP;
enum {
// special forms
F_QUOTE=0, F_COND, F_IF, F_AND, F_OR, F_WHILE, F_LAMBDA,
F_TRYCATCH, F_SPECIAL_APPLY, F_SETQ, F_PROGN,
F_TRYCATCH, F_SPECIAL_APPLY, F_SETQ, F_BEGIN,
// functions
F_EQ, F_EQV, F_EQUAL, F_ATOM, F_NOT, F_NULL, F_BOOLEANP, F_SYMBOLP,
@ -116,7 +116,7 @@ enum {
F_TRUE, F_FALSE, F_NIL,
N_BUILTINS,
};
#define isspecial(v) (uintval(v) <= (unsigned int)F_PROGN)
#define isspecial(v) (uintval(v) <= (unsigned int)F_BEGIN)
extern value_t NIL, FL_T, FL_F;

39
femtolisp/rule30.lsp Normal file
View File

@ -0,0 +1,39 @@
; -*- scheme -*-
(define (rule30-step b)
(let ((L (ash b -1))
(R (ash b 1)))
(let ((~b (lognot b))
(~L (lognot L))
(~R (lognot R)))
(logior (logand L ~b ~R)
(logand ~L b R)
(logand ~L b ~R)
(logand ~L ~b R)))))
(define (nestlist f zero n)
(if (<= n 0) ()
(cons zero (nestlist f (f zero) (- n 1)))))
(define (make-string k ch)
(cond ((<= k 0) "")
((= k 1) (string ch))
((= k 2) (string ch ch))
((odd? k) (string ch (make-string (- k 1) ch)))
(else (let ((half (make-string (/ k 2) ch)))
(string half half)))))
(define (pad0 s n) (string (make-string (- n (length s)) "0") s))
(define (bin-draw s)
(string.map (lambda (c) (case c
(#\1 #\#)
(#\0 #\ )
(else c)))
s))
(for-each (lambda (n)
(begin
(princ (bin-draw (pad0 (number->string n 2) 63)))
(terpri)))
(nestlist rule30-step (uint64 0x0000000080000000) 32))

View File

@ -195,6 +195,11 @@
(define (> a b) (< b a))
(define (<= a b) (not (< b a)))
(define (>= a b) (not (< a b)))
(define (negative? x) (< x 0))
(define (zero? x) (= x 0))
(define (positive? x) (> x 0))
(define (even? x) (= (logand x 1) 0))
(define (odd? x) (not (even? x)))
(define (1+ n) (+ n 1))
(define (1- n) (- n 1))
(define (mod x y) (- x (* (/ x y) y)))
@ -467,6 +472,12 @@
(define (iota n) (map-int identity n))
(define ι iota)
(define (for-each f l)
(when (pair? l)
(begin (f (car l))
(for-each f (cdr l))))
#t)
(define (error . args) (raise (cons 'error args)))
(define-macro (throw tag value) `(raise (list 'thrown-value ,tag ,value)))
@ -485,6 +496,14 @@
(lambda (,e) (begin ,finally (raise ,e))))
,finally)))
(if (or (eq? *os-name* 'win32)
(eq? *os-name* 'win64)
(eq? *os-name* 'windows))
(begin (define *directory-separator* "\\")
(define *linefeed* "\r\n"))
(begin (define *directory-separator* "/")
(define *linefeed* "\n")))
(define-macro (assert expr) `(if ,expr #t (raise '(assert-failed ,expr))))
(define-macro (time expr)
@ -494,8 +513,9 @@
,expr
(princ "Elapsed time: " (- (time.now) ,t0) " seconds\n")))))
(define (terpri) (princ *linefeed*))
(define (display x) (princ x) #t)
(define (println . args) (prog1 (apply print args) (princ "\n")))
(define (println . args) (prog1 (apply print args) (terpri)))
(define (vu8 . elts) (apply array (cons 'uint8 elts)))
@ -598,12 +618,12 @@
(set! that V)
#t))))
(define (reploop)
(when (trycatch (and (prompt) (princ "\n"))
(when (trycatch (and (prompt) (terpri))
print-exception)
(begin (princ "\n")
(begin (terpri)
(reploop))))
(reploop)
(princ "\n"))
(terpri))
(define (print-exception e)
(cond ((and (pair? e)
@ -641,7 +661,7 @@
(else (io.princ *stderr* "*** Unhandled exception: ")
(io.print *stderr* e)))
(io.princ *stderr* "\n")
(io.princ *stderr* *linefeed*)
#t)
(define (__script fname)
@ -649,12 +669,6 @@
(lambda (e) (begin (print-exception e)
(exit 1)))))
(if (or (eq? *os-name* 'win32)
(eq? *os-name* 'win64)
(eq? *os-name* 'windows))
(define *directory-separator* "\\")
(define *directory-separator* "/"))
(define (__start . argv)
; reload this file with our new definition of load
(load (string *install-dir* *directory-separator* "system.lsp"))

View File

@ -848,10 +848,10 @@ IOStream API
*princ
*file
iostream - (stream[ cvalue-as-bytestream])
*memstream
*buffer
fifo
socket
*io.eof
*io.eof?
*io.flush
*io.close
*io.discardbuffer
@ -950,7 +950,7 @@ consolidated todo list as of 8/30:
* finalizers in gc
* hashtable
* generic aref/aset
- expose io stream object
* expose io stream object
* new toplevel
* make raising a memory error non-consing