From c4bf82842c370acb6deedc6196ee572583fdea3a Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 20 May 2012 18:44:25 +0900 Subject: [PATCH] updates for changes from results of the fifth ballot --- lib/init-7.scm | 8 ++--- lib/scheme/base.sld | 14 ++++---- lib/scheme/char/normalization.sld | 2 ++ lib/scheme/division.sld | 2 ++ lib/scheme/extras.scm | 56 +++++++++++++++++++++++++++---- lib/scheme/lazy.sld | 4 +-- opcodes.c | 2 +- 7 files changed, 68 insertions(+), 20 deletions(-) diff --git a/lib/init-7.scm b/lib/init-7.scm index 1f1ad157..3fe5cc52 100644 --- a/lib/init-7.scm +++ b/lib/init-7.scm @@ -290,15 +290,15 @@ ,(map (lambda (x) (list (car x) (cadr x))) (cadr expr)) ,wrap))))) -(define-syntax lazy +(define-syntax delay-force (er-macro-transformer (lambda (expr rename compare) - `(,(rename 'make-promise) #f (,(rename 'lambda) () ,(cadr expr)))))) + `(,(rename 'promise) #f (,(rename 'lambda) () ,(cadr expr)))))) (define-syntax delay (er-macro-transformer (lambda (expr rename compare) - `(,(rename 'lazy) (,(rename 'make-promise) #t ,(cadr expr)))))) + `(,(rename 'delay-force) (,(rename 'promise) #t ,(cadr expr)))))) (define-syntax define-auxiliary-syntax (er-macro-transformer @@ -899,7 +899,7 @@ (auto-force ) (else - (define (make-promise done? proc) + (define (promise done? proc) (list (cons done? proc))) (define (promise-done? x) (car (car x))) (define (promise-value x) (cdr (car x))) diff --git a/lib/scheme/base.sld b/lib/scheme/base.sld index 37771445..964fb2ec 100644 --- a/lib/scheme/base.sld +++ b/lib/scheme/base.sld @@ -12,8 +12,8 @@ (srfi 9) (srfi 11) (srfi 39)) (export * + - ... / < <= = => > >= _ abs and append apply assoc assq assv begin - binary-port? boolean? bytevector-copy bytevector-copy! - bytevector-copy-partial bytevector-copy-partial! bytevector-length + binary-port? boolean? boolean=? bytevector-copy bytevector-copy! + bytevector-copy-partial bytevector-length bytevector-u8-ref bytevector-u8-set! bytevector? caar cadr call-with-current-continuation call-with-port call-with-values call/cc car case cdr cdar cddr ceiling char->integer @@ -23,9 +23,9 @@ define-record-type define-syntax define-values denominator do dynamic-wind else eof-object? eq? equal? eqv? error error-object-irritants error-object-message error-object? even? - exact->inexact exact-integer-sqrt exact-integer? exact? expt floor + exact exact-integer-sqrt exact-integer? exact? expt floor flush-output-port for-each gcd get-output-bytevector get-output-string - guard if import inexact->exact inexact? input-port? integer->char + guard if import inexact inexact? input-port? integer->char integer? lambda lcm length let let* let*-values let-syntax let-values letrec letrec* letrec-syntax list list->string list->vector list-copy list-ref list-set! list-tail list? make-bytevector make-list @@ -40,11 +40,11 @@ string->number string->symbol string->utf8 string->vector string-append string-copy string-fill! string-for-each string-length string-map string-ref string-set! string<=? string=? - string>? string? substring symbol->string symbol? syntax-error + string>? string? substring symbol->string symbol? symbol=? syntax-error syntax-rules textual-port? truncate u8-ready? unless unquote unquote-splicing utf8->string values vector vector->list vector->string - vector-copy vector-fill! vector-for-each vector-length vector-map - vector-ref vector-set! vector? when with-exception-handler + vector-copy vector-copy! vector-fill! vector-for-each vector-length + vector-map vector-ref vector-set! vector? when with-exception-handler write-bytevector write-char write-partial-bytevector write-u8 zero?) (include "define-values.scm" "extras.scm" diff --git a/lib/scheme/char/normalization.sld b/lib/scheme/char/normalization.sld index cbec89a9..1d05723a 100644 --- a/lib/scheme/char/normalization.sld +++ b/lib/scheme/char/normalization.sld @@ -1,3 +1,5 @@ +;; This library is deprecated, occurring in early R7RS drafts before +;; being removed. (define-library (scheme char normalization) (import (rename (scheme) diff --git a/lib/scheme/division.sld b/lib/scheme/division.sld index 738f714a..799dcdef 100644 --- a/lib/scheme/division.sld +++ b/lib/scheme/division.sld @@ -1,3 +1,5 @@ +;; This library is deprecated, occurring in early R7RS drafts before +;; being removed. (define-library (scheme division) (import (scheme)) diff --git a/lib/scheme/extras.scm b/lib/scheme/extras.scm index aebe40b4..b657e307 100644 --- a/lib/scheme/extras.scm +++ b/lib/scheme/extras.scm @@ -1,4 +1,10 @@ +(define exact inexact->exact) +(define inexact exact->inexact) + +(define (boolean=? x y) (eq? x y)) +(define (symbol=? x y) (eq? x y)) + (define call/cc call-with-current-continuation) ;; Adapted from Bawden's algorithm. @@ -19,6 +25,8 @@ (sr (- x e) (+ x e) return)) x)) +(define (square x) (* x x)) + (define flush-output-port flush-output) (define (close-port port) @@ -98,6 +106,13 @@ (do ((i 0 (+ i 1))) ((>= i len) res) (vector-set! res i (vector-ref vec i))))) +(define (vector-copy! to at from . o) + (let ((start (if (pair? o) (car o) 0)) + (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (vector-length from)))) + (do ((i at (+ i 1)) (j start (+ i 1))) + ((>= j end)) + (vector-set! to i (vector-ref from j))))) + (define (vector->string vec) (list->string (vector->list vec))) @@ -109,12 +124,41 @@ (bytevector-copy! bv res) res)) -(define (bytevector-copy! from to) - (bytevector-copy-partial! from 0 (bytevector-length from) to 0)) +(define (bytevector-copy! to at from . o) + (let ((start (if (pair? o) (car o) 0)) + (end (if (and (pair? o) (pair? (cdr o))) + (cadr o) + (bytevector-length from)))) + (do ((i at (+ i 1)) (j start (+ i 1))) + ((>= j end)) + (bytevector-u8-set! to i (bytevector-u8-ref from j))))) (define bytevector-copy-partial subbytes) -(define (bytevector-copy-partial! from start end to at) - (do ((i start (+ i 1))) - ((= i end)) - (bytevector-u8-set! to (+ (- i start) at) (bytevector-u8-ref from i)))) +;; Never use this! +(define (string-copy! to at from . o) + (let ((start (if (pair? o) (car o) 0)) + (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length from)))) + (do ((i at (+ i 1)) (j start (+ i 1))) + ((>= j end)) + (string-set! to i (string-ref from j))))) + +(define truncate-quotient quotient) +(define truncate-remainder remainder) +(define (truncate/ n m) + (values (truncate-quotient n m) (truncate-remainder n m))) + +(cond-expand + (ratios + (define (floor-quotient n m) + (floor (/ n m)))) + (else + (define (floor-quotient n m) + (let ((res (floor (/ n m)))) + (if (and (exact? n) (exact? m)) + (exact res) + res))))) +(define (floor-remainder n m) + (- n (* m (floor-quotient n m)))) +(define (floor/ n m) + (values (floor-quotient n m) (floor-remainder n m))) diff --git a/lib/scheme/lazy.sld b/lib/scheme/lazy.sld index c724b3f1..68af4d57 100644 --- a/lib/scheme/lazy.sld +++ b/lib/scheme/lazy.sld @@ -1,5 +1,5 @@ (define-library (scheme lazy) (import (scheme)) - (export delay force lazy eager) - (begin (define (eager x) (delay x)))) + (export delay force delay-force make-promise) + (begin (define (make-promise x) (delay x)))) diff --git a/opcodes.c b/opcodes.c index dd534919..e7d012c5 100644 --- a/opcodes.c +++ b/opcodes.c @@ -242,7 +242,7 @@ _FN0(SEXP_VOID, "print-vm-profile", 0, sexp_print_vm_profile), #endif #if SEXP_USE_AUTO_FORCE _OP(SEXP_OPC_GENERIC, SEXP_OP_FORCE, 1, 0, _I(SEXP_OBJECT), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "force", 0, NULL), -_FN2(_I(SEXP_PROMISE), _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), "make-promise", 0, sexp_make_promise), +_FN2(_I(SEXP_PROMISE), _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), "promise", 0, sexp_make_promise), #endif };