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
parent
d81e6c2d57
commit
bfa30fb095
|
|
@ -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));
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
@ -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"))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue