~ chicken-core (chicken-5) 957a745b7dbf5ecef26471cf539794c36dc8f997
commit 957a745b7dbf5ecef26471cf539794c36dc8f997
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Sun Jan 25 21:53:08 2015 +0100
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Sun Jan 25 21:53:08 2015 +0100
core.scm: mini-srfi-1
diff --git a/core.scm b/core.scm
index 56310cca..c5fd0040 100644
--- a/core.scm
+++ b/core.scm
@@ -580,7 +580,7 @@
((symbol? (car x))
(let ((ln (or (get-line x) outer-ln)))
(emit-syntax-trace-info x #f)
- (unless (proper-list? x)
+ (unless (list? x)
(if ln
(##sys#syntax-error/context (sprintf "(~a) - malformed expression" ln) x)
(##sys#syntax-error/context "malformed expression" x)))
@@ -656,7 +656,7 @@
(apply ##sys#require ids)
(##sys#hash-table-update!
file-requirements 'dynamic/syntax
- (cut lset-union eq? <> ids)
+ (cut lset-union <> ids)
(lambda () ids) )
'(##core#undefined) ) )
@@ -1249,8 +1249,8 @@
(cons (cons raw-c-name name) callback-names))
(quit-compiling "name `~S' of external definition is not a valid C identifier"
raw-c-name) )
- (when (or (not (proper-list? vars))
- (not (proper-list? atypes))
+ (when (or (not (list? vars))
+ (not (list? atypes))
(not (= (length vars) (length atypes))) )
(syntax-error
"non-matching or invalid argument list to foreign callback-wrapper"
@@ -1348,7 +1348,7 @@
(cons name (alist-cons x2 ln (if old (cdr old) '()))) ) )
x2) ) ) ] ) ) ) )
- ((not (proper-list? x))
+ ((not (list? x))
(##sys#syntax-error/context "malformed expression" x) )
((constant? (car x))
@@ -1415,7 +1415,7 @@
(when (pair? us)
(##sys#hash-table-update!
file-requirements 'static
- (cut lset-union eq? us <>)
+ (cut lset-union us <>)
(lambda () us))
(let ((units (map (lambda (u) (string->c-identifier (stringify u))) us)))
(set! used-units (append used-units units)) ) ) ) )
@@ -1440,8 +1440,8 @@
(set! extended-bindings default-extended-bindings) ]
[else
(let ([syms (stripa (cdr spec))])
- (set! standard-bindings (lset-intersection eq? syms default-standard-bindings))
- (set! extended-bindings (lset-intersection eq? syms default-extended-bindings)) ) ] ) )
+ (set! standard-bindings (lset-intersection syms default-standard-bindings))
+ (set! extended-bindings (lset-intersection syms default-extended-bindings)) ) ] ) )
((number-type)
(check-decl spec 1 1)
(set! number-type (strip (cadr spec))))
@@ -1491,13 +1491,13 @@
(if (null? (cddr spec))
(set! standard-bindings '())
(set! standard-bindings
- (lset-difference eq? default-standard-bindings
+ (lset-difference default-standard-bindings
(stripa (cddr spec))))) ]
[(extended-bindings)
(if (null? (cddr spec))
(set! extended-bindings '())
(set! extended-bindings
- (lset-difference eq? default-extended-bindings
+ (lset-difference default-extended-bindings
(stripa (cddr spec))) )) ]
[(inline)
(if (null? (cddr spec))
@@ -1511,8 +1511,8 @@
(set! extended-bindings '()) ]
[else
(let ([syms (stripa (cddr spec))])
- (set! standard-bindings (lset-difference eq? default-standard-bindings syms))
- (set! extended-bindings (lset-difference eq? default-extended-bindings syms)) ) ] ) ]
+ (set! standard-bindings (lset-difference default-standard-bindings syms))
+ (set! extended-bindings (lset-difference default-extended-bindings syms)) ) ] ) ]
((inline-global)
(set! enable-inline-files #t)
(when (pair? (cddr spec))
@@ -1755,7 +1755,7 @@
(walk (car xs))
(loop (cdr xs)) ) ) )
(define (walk x)
- (cond ((not-pair? x))
+ (cond ((not (pair? x)))
((symbol? (car x))
(let* ((name (car x))
(old (or (##sys#hash-table-ref ##sys#line-number-database name) '())) )
@@ -2296,12 +2296,12 @@
(define (test sym item) (db-get db sym item))
(define (register-customizable! var id)
- (set! customizable (lset-adjoin eq? customizable var))
+ (set! customizable (lset-adjoin customizable var))
(db-put! db id 'customizable #t) )
(define (register-direct-call! id)
(set! direct-calls (add1 direct-calls))
- (set! direct-call-ids (lset-adjoin eq? direct-call-ids id)) )
+ (set! direct-call-ids (lset-adjoin direct-call-ids id)) )
;; Gather free-variable information:
;; (and: - register direct calls
@@ -2325,7 +2325,7 @@
(when (pair? (cdr params)) (bomb "let-node has invalid format" params))
(let ((c (gather (first subs) here locals))
(var (first params)))
- (append c (delete var (gather (second subs) here (cons var locals)) eq?))))
+ (append c (delete var (gather (second subs) here (cons var locals))))))
((set!)
(let ((var (first params))
@@ -2363,7 +2363,7 @@
(and refs sites
(= (length refs) (length sites))
(test varname 'value)
- (proper-list? llist) ) ] )
+ (list? llist) ) ] )
(when (and name
(not (llist-match? llist (cdr subs))))
(quit-compiling
@@ -2384,10 +2384,10 @@
(lambda (vars argc rest)
(let ((id (if here (first params) 'toplevel)))
(fluid-let ((lexicals (append locals lexicals)))
- (let ((c (delete-duplicates (gather (first subs) id vars) eq?)))
+ (let ((c (delete-duplicates (gather (first subs) id vars))))
(db-put! db id 'closure-size (length c))
(db-put! db id 'captured-variables c)
- (lset-difference eq? c locals vars)))))))
+ (lset-difference c locals vars)))))))
(else (concatenate (map (lambda (n) (gather n here locals)) subs)) ) ) ))
@@ -2469,14 +2469,16 @@
(fourth params) )
(list (let ((body (transform (car subs) cvar capturedvars)))
(if (pair? boxedvars)
- (fold-right
- (lambda (alias val body)
- (make-node 'let (list alias) (list val body)))
- body
- (unzip1 boxedaliases)
- (map (lambda (a)
- (make-node '##core#box '() (list (varnode (cdr a)))))
- boxedaliases) )
+ (let loop ((aliases (unzip1 boxedaliases))
+ (values
+ (map (lambda (a)
+ (make-node '##core#box '() (list (varnode (cdr a)))))
+ boxedaliases) ))
+ (if (null? aliases)
+ body
+ (make-node 'let (list (car aliases))
+ (list (car values)
+ (loop (cdr aliases) (cdr values))))))
body) ) ) )
(let ((cvars (map (lambda (v) (ref-var (varnode v) here closure))
capturedvars) ) )
@@ -2782,7 +2784,7 @@
((##core#call)
(let ((len (length (cdr subs))))
- (set! signatures (lset-adjoin = signatures len))
+ (set! signatures (lset-adjoin signatures len))
(when (and (>= (length params) 3) (eq? here (third params)))
(set! looping (add1 looping)) )
(make-node class params (mapwalk subs e e-count here boxes)) ) )
Trap