From: Chris Hanson Date: Thu, 26 Oct 1989 06:50:33 +0000 (+0000) Subject: * All-new arithmetic and number I/O conforms with R4RS. X-Git-Tag: 20090517-FFI~11741 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=b60c5bf26e4f27c5726ab54f3f7f2722b485ea47;p=mit-scheme.git * All-new arithmetic and number I/O conforms with R4RS. * The variable (access flonum-unparser-hook (->environment '(runtime number))) accepts two arguments (the flonum and the radix), and returns either the string representation or #f. * `*unparser-radix*' is recognized only when it is one of (2 8 10 16), and it affects only exact rationals. Inexact numbers and non-rational complex numbers are always printed in base 10. The radix prefix is suppressed in base 10, or in the other bases when the number's absolute value is less than the radix. * Written representation of compiled entries changed to show the "block number". * `pp' no longer accepts hash numbers as arguments; use #@ if you want that effect (you will need to type '#@ for scode objects). * `trace'/`break' output changed to show arguments more clearly. --- diff --git a/v7/src/runtime/advice.scm b/v7/src/runtime/advice.scm index 915a1ac1b..573d59e41 100644 --- a/v7/src/runtime/advice.scm +++ b/v7/src/runtime/advice.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/advice.scm,v 14.3 1988/12/30 06:41:58 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/advice.scm,v 14.4 1989/10/26 06:45:49 cph Exp $ -Copyright (c) 1988 Massachusetts Institute of Technology +Copyright (c) 1988, 1989 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -323,26 +323,44 @@ MIT in each case. |# (define (trace-display procedure arguments #!optional result) (newline) - (let ((width (- (output-port/x-size (current-output-port)) 3))) - (let ((output - (with-output-to-truncated-string - width - (lambda () - (if (default-object? result) - (write-string "[Entering ") - (begin (write-string "[") - (write result) - (write-string " <== "))) - (write-string "<") - (write procedure) - (for-each (lambda (arg) (write-char #\Space) (write arg)) - arguments))))) - (if (car output) ; Too long? - (begin - (write-string (substring (cdr output) 0 (- width 5))) - (write-string " ... ")) - (write-string (cdr output))))) - (write-string ">]")) + (let ((width (-1+ (max 40 (output-port/x-size (current-output-port))))) + (write-truncated + (lambda (object width) + (let ((output + (with-output-to-truncated-string width + (lambda () + (write object))))) + (if (car output) + (substring-fill! (cdr output) (- width 3) width #\.)) + (write-string (cdr output)))))) + (if (default-object? result) + (write-string "[Entering ") + (begin + (write-string "[") + (write-truncated result (- width 2)) + (newline) + (write-string " <== "))) + (write-truncated procedure (- width 11)) + (newline) + (let ((write-args + (lambda (arguments) + (let loop ((prefix " Args: ") (arguments arguments)) + (write-string prefix) + (write-truncated (car arguments) (- width 11)) + (if (not (null? (cdr arguments))) + (begin + (newline) + (loop " " (cdr arguments)))))))) + (cond ((null? arguments) + (write-string "]")) + ((<= (length arguments) 10) + (write-args arguments) + (write-string "]")) + (else + (write-args (list-head arguments 10)) + (newline) + (write-string " ...]")))))) + (define primitive-trace-entry) (define primitive-trace-exit) (define primitive-trace-both) diff --git a/v7/src/runtime/conpar.scm b/v7/src/runtime/conpar.scm index 653c0a763..0304596bb 100644 --- a/v7/src/runtime/conpar.scm +++ b/v7/src/runtime/conpar.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/conpar.scm,v 14.9 1989/10/10 11:38:30 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/conpar.scm,v 14.10 1989/10/26 06:45:54 cph Exp $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -169,7 +169,7 @@ MIT in each case. |# (element-stream/head stream)))) (let ((length (let ((length (stack-frame-type/length type))) - (if (integer? length) + (if (exact-nonnegative-integer? length) length (length stream (parser-state/n-elements state)))))) ((stack-frame-type/parser type) @@ -316,7 +316,7 @@ MIT in each case. |# (element-stream/head stream))) (length (let ((length (stack-frame-type/length type))) - (if (integer? length) + (if (exact-nonnegative-integer? length) length (length stream offset)))) (ltail (stream-tail* stream length))) @@ -641,7 +641,7 @@ MIT in each case. |# (write-string " ") (write-string name) (write-string " = ") - (write-string (number->string value '(HEUR (RADIX X)))))) + (write-string (number->string value 16)))) (define (hardware-trap-frame/print-registers frame) (guarantee-hardware-trap-frame frame) @@ -653,7 +653,8 @@ MIT in each case. |# (let loop ((i 0)) (if (< i nregs) (begin - (print-register block (+ 2 i) + (print-register block + (+ 2 i) (string-append "register " (number->string i))) (loop (1+ i))))))))) @@ -701,7 +702,8 @@ MIT in each case. |# (write-string (number->string (stack-frame/ref frame hardware-trap/pc-info2-index) - '(HEUR (RADIX X)))) (newline) + 16)) + (newline) (write-string "within ") (let ((block (stack-frame/ref frame hardware-trap/pc-info1-index))) (write block) diff --git a/v7/src/runtime/debug.scm b/v7/src/runtime/debug.scm index 4001026aa..9fd814db5 100644 --- a/v7/src/runtime/debug.scm +++ b/v7/src/runtime/debug.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/debug.scm,v 14.15 1989/08/07 07:36:30 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/debug.scm,v 14.16 1989/10/26 06:45:59 cph Exp $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -417,8 +417,8 @@ MIT in each case. |# (number->string (-1+ limit)) " inclusive)") ""))))) - (cond ((not (and (integer? expression) - (not (negative? expression)))) (debugger-failure prompt " must be nonnegative integer") + (cond ((not (exact-nonnegative-integer? expression)) + (debugger-failure prompt " must be nonnegative integer") (loop)) ((and limit (>= expression limit)) (debugger-failure prompt " too large") diff --git a/v7/src/runtime/equals.scm b/v7/src/runtime/equals.scm index cb392b1b1..acd433f82 100644 --- a/v7/src/runtime/equals.scm +++ b/v7/src/runtime/equals.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/equals.scm,v 14.1 1988/06/13 11:44:04 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/equals.scm,v 14.2 1989/10/26 06:46:03 cph Rel $ -Copyright (c) 1988 Massachusetts Institute of Technology +Copyright (c) 1988, 1989 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -41,36 +41,33 @@ MIT in each case. |# ;; EQV? is officially supposed to work on booleans, characters, and ;; numbers specially, but it turns out that EQ? does the right thing ;; for everything but numbers, so we take advantage of that. - (if (eq? x y) - true + (or (eq? x y) (and (object-type? (object-type x) y) - (or (and (or (object-type? (ucode-type big-fixnum) y) - (object-type? (ucode-type big-flonum) y)) - (= x y)) + (if (number? y) + (and (= x y) + (boolean=? (exact? x) (exact? y))) (and (object-type? (ucode-type vector) y) (zero? (vector-length x)) (zero? (vector-length y))))))) (define (equal? x y) - (if (eq? x y) - true + (or (eq? x y) (and (object-type? (object-type x) y) - (cond ((or (object-type? (ucode-type big-fixnum) y) - (object-type? (ucode-type big-flonum) y)) - (= x y)) + (cond ((number? y) + (and (= x y) + (boolean=? (exact? x) (exact? y)))) ((object-type? (ucode-type list) y) (and (equal? (car x) (car y)) (equal? (cdr x) (cdr y)))) ((object-type? (ucode-type vector) y) (let ((size (vector-length x))) - (define (loop index) - (if (= index size) - true - (and (equal? (vector-ref x index) - (vector-ref y index)) - (loop (1+ index))))) (and (= size (vector-length y)) - (loop 0)))) ((object-type? (ucode-type cell) y) + (let loop ((index 0)) + (or (= index size) + (and (equal? (vector-ref x index) + (vector-ref y index)) + (loop (1+ index)))))))) + ((object-type? (ucode-type cell) y) (equal? (cell-contents x) (cell-contents y))) ((object-type? (ucode-type character-string) y) (string=? x y)) diff --git a/v7/src/runtime/gcnote.scm b/v7/src/runtime/gcnote.scm index 96787642a..c1360cd13 100644 --- a/v7/src/runtime/gcnote.scm +++ b/v7/src/runtime/gcnote.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/gcnote.scm,v 14.5 1989/08/15 13:19:47 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/gcnote.scm,v 14.6 1989/10/26 06:46:11 cph Rel $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -103,8 +103,10 @@ MIT in each case. |# (number->string (internal-time/ticks->seconds delta-time)) " (" (number->string - (round (* (/ delta-time - (- (gc-statistic/this-gc-end statistic) - (gc-statistic/last-gc-end statistic))) - 100))) "%) free: " + (round->exact + (* (/ delta-time + (- (gc-statistic/this-gc-end statistic) + (gc-statistic/last-gc-end statistic))) + 100))) + "%) free: " (number->string (gc-statistic/heap-left statistic))))) \ No newline at end of file diff --git a/v7/src/runtime/gensym.scm b/v7/src/runtime/gensym.scm index d0d2bfd7c..74498c2cf 100644 --- a/v7/src/runtime/gensym.scm +++ b/v7/src/runtime/gensym.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/gensym.scm,v 14.1 1988/06/13 11:45:28 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/gensym.scm,v 14.2 1989/10/26 06:46:15 cph Exp $ -Copyright (c) 1988 Massachusetts Institute of Technology +Copyright (c) 1988, 1989 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -41,8 +41,8 @@ MIT in each case. |# (if (not (default-object? argument)) (cond ((symbol? argument) (set! name-prefix (symbol->string argument))) - ((and (integer? argument) - (not (negative? argument))) (set! name-counter argument)) + ((exact-nonnegative-integer? argument) + (set! name-counter argument)) (else (error "GENERATE-UNINTERNED-SYMBOL: Bad argument" argument)))) (string->uninterned-symbol diff --git a/v7/src/runtime/histry.scm b/v7/src/runtime/histry.scm index 47182c977..445498e6d 100644 --- a/v7/src/runtime/histry.scm +++ b/v7/src/runtime/histry.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/histry.scm,v 14.1 1988/06/13 11:45:51 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/histry.scm,v 14.2 1989/10/26 06:46:19 cph Exp $ -Copyright (c) 1988 Massachusetts Institute of Technology +Copyright (c) 1988, 1989 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -117,9 +117,10 @@ MIT in each case. |# head (make-reduction false false (reduction-loop (-1+ n)))))) (make-vertebra head '() '()))))) - (if (not (and (integer? depth) (positive? depth))) + (if (not (and (exact-integer? depth) (positive? depth))) (error "CREATE-HISTORY: invalid depth" depth)) - (if (not (and (integer? width) (positive? width))) (error "CREATE-HISTORY: invalid width" width)) + (if (not (and (exact-integer? width) (positive? width))) + (error "CREATE-HISTORY: invalid width" width)) (let ((head (new-vertebra))) (let subproblem-loop ((n (-1+ depth)) (previous head)) (if (zero? n) diff --git a/v7/src/runtime/infutl.scm b/v7/src/runtime/infutl.scm index d8a7ce294..387c76927 100644 --- a/v7/src/runtime/infutl.scm +++ b/v7/src/runtime/infutl.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/infutl.scm,v 1.13 1989/10/03 22:55:38 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/infutl.scm,v 1.14 1989/10/26 06:46:23 cph Exp $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -78,8 +78,7 @@ MIT in each case. |# (vector-ref binf 0)))))) ((and (pair? descriptor) (string? (car descriptor)) - (integer? (cdr descriptor)) - (not (negative? (cdr descriptor)))) + (exact-nonnegative-integer? (cdr descriptor))) (let ((binf (read-binf-file (car descriptor)))) (and binf (vector? binf) @@ -158,11 +157,15 @@ MIT in each case. |# (let loop ((info (compiled-code-block/debugging-info (compiled-entry/block entry)))) - (cond ((string? info) info) - ((not (pair? info)) false) - ((string? (car info)) (car info)) + (cond ((string? info) (values info false)) + ((not (pair? info)) (values false false)) ((dbg-info? (car info)) (loop (cdr info))) - (else false)))) + ((string? (car info)) + (values (car info) + (and (exact-nonnegative-integer? (cdr info)) + (cdr info)))) + (else (values false false))))) + (define (dbg-labels/find-offset labels offset) (vector-binary-search labels < dbg-label/offset offset)) diff --git a/v7/src/runtime/input.scm b/v7/src/runtime/input.scm index d5ae5f4c1..d729f55f6 100644 --- a/v7/src/runtime/input.scm +++ b/v7/src/runtime/input.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/input.scm,v 14.4 1989/03/06 19:57:44 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/input.scm,v 14.5 1989/10/26 06:46:27 cph Exp $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -250,8 +250,10 @@ MIT in each case. |# (if (default-object? interval) 0 (begin - (if (not (and (integer? interval) (>= interval 0))) - (error "Bad interval" interval)) interval)))) + (if (not (exact-nonnegative-integer? interval)) + (error "interval must be exact nonnegative integer" + interval)) + interval)))) (input-port/char-ready? port interval))) (define (peek-char #!optional port) diff --git a/v7/src/runtime/list.scm b/v7/src/runtime/list.scm index d30d068aa..292cdd13b 100644 --- a/v7/src/runtime/list.scm +++ b/v7/src/runtime/list.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/list.scm,v 14.9 1989/09/20 15:05:47 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/list.scm,v 14.10 1989/10/26 06:46:31 cph Exp $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -52,8 +52,8 @@ MIT in each case. |# (cdr rest-elements)))))) (define (make-list length #!optional value) - (if (not (and (integer? length) (not (negative? length)))) - (error "MAKE-LIST: length must be nonnegative integer" length)) + (if (not (exact-nonnegative-integer? length)) + (error "length must be exact nonnegative integer" length)) (let ((value (if (default-object? value) '() value))) (let loop ((n length) (result '())) (if (zero? n) @@ -69,8 +69,8 @@ MIT in each case. |# items) (define (make-circular-list length #!optional value) - (if (not (and (integer? length) (not (negative? length)))) - (error "MAKE-CIRCULAR-LIST: length must be nonnegative integer" length)) + (if (not (exact-nonnegative-integer? length)) + (error "length must be exact nonnegative integer" length)) (if (positive? length) (let ((value (if (default-object? value) '() value))) (let ((last (cons value '()))) @@ -89,8 +89,8 @@ MIT in each case. |# (car tail))) (define (list-tail list index) - (if (not (and (integer? index) (not (negative? index)))) - (error "LIST-TAIL: index must be nonnegative integer" index)) + (if (not (exact-nonnegative-integer? index)) + (error "index must be exact nonnegative integer" index)) (let loop ((list list) (index index)) (if (zero? index) list @@ -100,8 +100,8 @@ MIT in each case. |# (loop (cdr list) (-1+ index)))))) (define (list-head list index) - (if (not (and (integer? index) (not (negative? index)))) - (error "LIST-HEAD: index must be nonnegative integer" index)) + (if (not (exact-nonnegative-integer? index)) + (error "index must be exact nonnegative integer" index)) (let loop ((list list) (index index)) (if (zero? index) '() diff --git a/v7/src/runtime/make.scm b/v7/src/runtime/make.scm index 6e09bf945..f245925fa 100644 --- a/v7/src/runtime/make.scm +++ b/v7/src/runtime/make.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/make.scm,v 14.18 1989/08/18 19:14:46 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/make.scm,v 14.19 1989/10/26 06:46:35 cph Exp $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -320,7 +320,7 @@ MIT in each case. |# (RUNTIME LOAD) ;; Syntax (RUNTIME PARSER) - (RUNTIME NUMBER-UNPARSER) (RUNTIME UNPARSER) + (RUNTIME UNPARSER) (RUNTIME SYNTAXER) (RUNTIME MACROS) (RUNTIME SYSTEM-MACROS) diff --git a/v7/src/runtime/numpar.scm b/v7/src/runtime/numpar.scm index 5d6ca569b..8c0a61a5c 100644 --- a/v7/src/runtime/numpar.scm +++ b/v7/src/runtime/numpar.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/numpar.scm,v 14.2 1988/07/09 02:24:02 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/numpar.scm,v 14.3 1989/10/26 06:50:33 cph Exp $ -Copyright (c) 1988 Massachusetts Institute of Technology +Copyright (c) 1989 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -34,238 +34,261 @@ MIT in each case. |# ;;;; Number Parser ;;; package: (runtime number-parser) - -(declare (usual-integrations)) -;;; These are not supported right now. - -(define-integrable (->exact number) number) -(define-integrable (->inexact number) number) -(define-integrable (->long-flonum number) number) -(define-integrable (->short-flonum number) number) - -(define *radix*) +(define (string->number string #!optional radix-default) + (let ((radix-default + (if (default-object? radix-default) + 10 + (begin + (if (not (memv radix-default '(2 8 10 16))) + (bad-range 'STRING->NUMBER radix-default)) + radix-default)))) + (with-values (lambda () (parse-prefix (string->list string))) + (lambda (chars radix-prefix exactness) + ((if (eq? exactness 'INEXACT) + exact->inexact + identity-procedure) + (let ((radix (or radix-prefix radix-default))) + (with-values (lambda () (parse-sign chars)) + (lambda (chars real-sign) + (if (and real-sign (imaginary-suffix? chars)) + (make-rectangular 0 real-sign) + (with-values (lambda () (parse-unsigned-real chars radix)) + (lambda (chars real inexact?) + (let ((real + (combine-sign real-sign + real + exactness + inexact?))) + (cond ((or (null? chars) (not real)) + real) + ((and real-sign (imaginary-suffix? chars)) + (make-rectangular 0 real)) + ((char=? #\@ (car chars)) + (with-values + (lambda () + (parse-signed-real (cdr chars) + radix + exactness)) + (lambda (chars angle) + (and angle + (null? chars) + (make-polar real angle))))) + (else + (parse-imaginary-tail chars + radix + exactness + real))))))))))))))) -(define (string->number string #!optional exactness radix) - ((cond ((or (default-object? exactness) (not exactness)) identity-procedure) - ((eq? exactness 'E) ->exact) - ((eq? exactness 'I) ->inexact) - (else (error "Illegal exactness argument" exactness))) - (fluid-let ((*radix* - (cond ((default-object? radix) 10) - ((memv radix '(2 8 10 16)) radix) - ((eq? radix 'B) 2) - ((eq? radix 'O) 8) - ((eq? radix 'D) 10) - ((eq? radix 'X) 16) - (else (error "Illegal radix argument" radix))))) - (parse-number (string->list string))))) - -(define (parse-number chars) - (parse-real chars - (lambda (chars real) - (if (null? chars) - real - (case (car chars) - ((#\+ #\-) - (parse-real chars - (lambda (chars* real*) - (and (not (null? chars*)) - (null? (cdr chars*)) - (or (char-ci=? (car chars*) #\i) - (char-ci=? (car chars*) #\j)) - (make-rectangular real real*))))) - ((#\@) - (parse-real (cdr chars) - (lambda (chars real*) - (and (null? chars) - (make-polar real real*))))) - (else false)))))) +(define (parse-imaginary-tail chars radix exactness real) + (with-values (lambda () (parse-sign chars)) + (lambda (chars sign) + (and sign + (if (imaginary-suffix? chars) + (make-rectangular real sign) + (with-values (lambda () (parse-unsigned-real chars radix)) + (lambda (chars imag inexact?) + (and imag + (imaginary-suffix? chars) + (make-rectangular + real + (combine-sign sign imag exactness inexact?)))))))))) -(define (parse-real chars receiver) - (and (not (null? chars)) - (case (car chars) - ((#\+) - (parse-unsigned-real (cdr chars) - receiver)) - ((#\-) - (parse-unsigned-real (cdr chars) - (lambda (chars real) - (receiver chars (- real))))) - (else - (parse-unsigned-real chars - receiver))))) +(define (parse-prefix chars) + (parse-1-prefix chars + (lambda (chars radix) + (parse-1-prefix chars + (lambda (chars radix) + chars radix + (values '() false false)) + (lambda (chars exactness) + (values chars radix exactness)) + (lambda (chars) + (values chars radix false)))) + (lambda (chars exactness) + (parse-1-prefix chars + (lambda (chars radix) + (values chars radix exactness)) + (lambda (chars exactness) + chars exactness + (values '() false false)) + (lambda (chars) + (values chars false exactness)))) + (lambda (chars) + (values chars false false)))) -(define (parse-unsigned-real chars receiver) - (parse-prefix chars false false false - (lambda (chars radix exactness precision) - (let ((finish - (lambda () - (parse-body chars - (lambda (chars real) - (parse-suffix chars - (lambda (chars exponent) - (receiver chars - ((case exactness - ((#F) identity-procedure) - ((#\e) ->exact) - ((#\i) ->inexact)) - ((case precision - ((#F) identity-procedure) - ((#\s) ->short-flonum) - ((#\l) ->long-flonum)) - (if exponent - (* real (expt 10 exponent)) - real))))))))))) - (if radix - (fluid-let ((*radix* - (cdr (assv radix - '((#\b . 2) - (#\o . 8) - (#\d . 10) - (#\x . 16)))))) - (finish)) - (finish)))))) - -(define (parse-prefix chars radix exactness precision receiver) - (and (not (null? chars)) - (if (char=? (car chars) #\#) - (and (pair? (cdr chars)) - (let ((type (char-downcase (cadr chars))) - (rest (cddr chars))) - (let ((specify-prefix-type - (lambda (old) - (if old - (error "Respecification of prefix type" type) - type)))) - (case type - ((#\b #\o #\d #\x) - (parse-prefix rest - (specify-prefix-type radix) - exactness - precision - receiver)) - ((#\i #\e) - (parse-prefix rest - radix - (specify-prefix-type exactness) - precision - receiver)) - ((#\s #\l) - (parse-prefix rest - radix - exactness - (specify-prefix-type precision) - receiver)) - (else (error "Unknown prefix type" type)))))) - (receiver chars radix exactness precision)))) - -(define (parse-suffix chars receiver) +(define (parse-1-prefix chars if-radix if-exactness if-neither) (if (and (not (null? chars)) - (char-ci=? (car chars) #\e)) - (parse-signed-suffix (cdr chars) receiver) - (receiver chars false))) + (char=? (car chars) #\#) + (not (null? (cdr chars)))) + (let ((char (cadr chars)) + (chars* (cddr chars))) + (cond ((char-ci=? #\i char) (if-exactness chars* 'INEXACT)) + ((char-ci=? #\e char) (if-exactness chars* 'EXACT)) + ((char-ci=? #\b char) (if-radix chars* 2)) + ((char-ci=? #\o char) (if-radix chars* 8)) + ((char-ci=? #\d char) (if-radix chars* 10)) + ((char-ci=? #\x char) (if-radix chars* 16)) + (else (if-neither chars)))) + (if-neither chars))) -(define (parse-signed-suffix chars receiver) +(define (imaginary-suffix? chars) (and (not (null? chars)) - (case (car chars) - ((#\+) - (parse-unsigned-suffix (cdr chars) - receiver)) - ((#\-) - (parse-unsigned-suffix (cdr chars) - (lambda (chars exponent) - (receiver chars (and exponent (- exponent)))))) - (else - (parse-unsigned-suffix chars - receiver))))) - -(define (parse-unsigned-suffix chars receiver) - (define (parse-digit chars value if-digit) - (let ((digit (char->digit (car chars) 10))) - (if digit - (if-digit (cdr chars) digit) - (receiver chars value)))) - - (define (loop chars value) - (if (null? chars) - (receiver chars value) - (parse-digit chars value - (lambda (chars digit) - (loop chars (+ digit (* value 10))))))) - - (and (not (null? chars)) - (parse-digit chars false - loop))) + (null? (cdr chars)) + (or (char-ci=? (car chars) #\i) + (char-ci=? (car chars) #\j)))) -(define (parse-body chars receiver) - (and (not (null? chars)) - (if (char=? (car chars) #\.) - (require-digit (cdr chars) - (lambda (chars digit) - (parse-fraction chars digit 1 - receiver))) - (parse-integer chars - (lambda (chars integer) - (if (null? chars) - (receiver chars integer) - (case (car chars) - ((#\/) - (parse-integer (cdr chars) - (lambda (chars denominator) - (receiver chars (/ integer denominator))))) - ((#\.) - (parse-fraction (cdr chars) 0 0 - (lambda (chars fraction) - (receiver chars (+ integer fraction))))) - (else - (receiver chars integer))))))))) +(define (parse-signed-real chars radix exactness) + (with-values (lambda () (parse-sign chars)) + (lambda (chars sign) + (with-values (lambda () (parse-unsigned-real chars radix)) + (lambda (chars real inexact?) + (values chars (combine-sign sign real exactness inexact?))))))) -(define (parse-integer chars receiver) - (define (loop chars integer) - (parse-digit/sharp chars - (lambda (chars count) - (receiver chars (->inexact (* integer (expt *radix* count))))) - (lambda (chars digit) - (loop chars (+ digit (* integer *radix*)))) - (lambda (chars) - (receiver chars integer)))) - (require-digit chars loop)) +(define (parse-unsigned-real chars radix) + (with-values (lambda () (parse-integer chars radix)) + (lambda (chars* numerator inexact?) + (cond ((not numerator) + (if (= radix 10) + (parse-decimal chars) + (values chars false false))) + ((and (not (null? chars*)) + (char=? #\/ (car chars*))) + (with-values (lambda () (parse-integer (cdr chars*) radix)) + (lambda (chars* denominator inexact?*) + (if denominator + (values chars* + (/ numerator denominator) + (or inexact? inexact?*)) + (values chars false false))))) + (else + (values chars* numerator inexact?)))))) -(define (parse-fraction chars integer place-value receiver) - (define (loop chars integer place-value) - (parse-digit/sharp chars - (lambda (chars count) - count - (finish chars (->inexact integer) place-value)) - (lambda (chars digit) - (loop chars - (+ digit (* integer *radix*)) - (1+ place-value))) - (lambda (chars) - (finish chars integer place-value)))) +(define (parse-integer chars radix) + (if (or (null? chars) + (not (char->digit (car chars) radix))) + (values chars false false) + (let loop ((chars* (cdr chars)) (n (char->digit (car chars) radix))) + (if (null? chars*) + (values chars* n false) + (let ((digit (char->digit (car chars*) radix))) + (cond (digit + (loop (cdr chars*) (+ (* n radix) digit))) + ((char=? (car chars*) #\.) + (values chars false false)) + ((char=? (car chars*) #\#) + (let loop ((chars* (cdr chars*)) (n (* n radix))) + (cond ((null? chars*) + (values chars* n true)) + ((char=? (car chars*) #\#) + (loop (cdr chars*) (* n radix))) + ((char=? (car chars*) #\.) + (values chars false false)) + (else + (values chars* n true))))) + (else + (values chars* n false)))))))) + +(define (parse-decimal chars) + (let ((handle-suffix + (lambda (chars x inexact?) + (with-values (lambda () (parse-suffix chars)) + (lambda (chars exponent) + (if exponent + (values chars (* x (expt 10 exponent)) true) + (values chars x inexact?))))))) + (cond ((null? chars) + (values chars false false)) + ((char=? #\. (car chars)) + (let ((chars* (cdr chars))) + (if (and (not (null? chars*)) + (char->digit (car chars*) 10)) + (with-values (lambda () (parse-decimal-fraction chars*)) + (lambda (chars x) + (handle-suffix chars x true))) + (values chars false false)))) + ((char->digit (car chars) 10) + (with-values (lambda () (parse-decimal-integer chars)) + handle-suffix)) + (else + (values chars false false))))) - (define (finish chars integer place-value) - (receiver chars (/ integer (expt *radix* place-value)))) +(define (parse-decimal-integer chars) + (let loop ((chars* (cdr chars)) (n (char->digit (car chars) 10))) + (if (null? chars*) + (values '() n false) + (let ((digit (char->digit (car chars*) 10))) + (if digit + (loop (cdr chars*) (+ (* n 10) digit)) + (cond ((char=? #\. (car chars*)) + (with-values + (lambda () (parse-decimal-fraction (cdr chars*))) + (lambda (chars* fraction) + (values chars* (+ n fraction) true)))) + ((char=? #\# (car chars*)) + (let loop ((chars* (cdr chars*)) (n (* n 10))) + (cond ((null? chars*) + (values '() n true)) + ((char=? #\# (car chars*)) + (loop (cdr chars*) (* n 10))) + ((char=? #\. (car chars*)) + (let loop ((chars* (cdr chars*))) + (if (and (not (null? chars*)) + (char=? #\# (car chars*))) + (loop (cdr chars*)) + (values chars* n true)))) + (else + (values chars* n true))))) + (else + (values chars* n false)))))))) - (loop chars integer place-value)) +(define (parse-decimal-fraction chars) + (let loop ((chars chars) (f 0) (exponent 0)) + (let ((done + (lambda (chars) + (values chars (* f (expt 10 exponent)))))) + (if (null? chars) + (done '()) + (let ((digit (char->digit (car chars) 10))) + (if digit + (loop (cdr chars) (+ (* f 10) digit) (-1+ exponent)) + (let loop ((chars chars)) + (cond ((not (char=? #\# (car chars))) (done chars)) + ((null? (cdr chars)) (done '())) + (else (loop (cdr chars))))))))))) -(define (require-digit chars receiver) - (and (not (null? chars)) - (let ((digit (char->digit (car chars) *radix*))) - (and digit - (receiver (cdr chars) digit))))) +(define (parse-suffix chars) + (if (and (not (null? chars)) + (or (char-ci=? #\e (car chars)) + (char-ci=? #\s (car chars)) + (char-ci=? #\f (car chars)) + (char-ci=? #\d (car chars)) + (char-ci=? #\l (car chars)))) + (with-values (lambda () (parse-sign (cdr chars))) + (lambda (chars* sign) + (let ((digit + (and (not (null? chars*)) + (char->digit (car chars*) 10)))) + (if digit + (let loop ((chars* (cdr chars*)) (n digit)) + (let ((digit + (and (not (null? chars*)) + (char->digit (car chars*) 10)))) + (if digit + (loop (cdr chars*) (+ (* n 10) digit)) + (values chars* (if (eqv? -1 sign) (- n) n))))) + (values chars false))))) + (values chars false))) + +(define (parse-sign chars) + (cond ((null? chars) (values chars false)) + ((char=? (car chars) #\+) (values (cdr chars) 1)) + ((char=? (car chars) #\-) (values (cdr chars) -1)) + (else (values chars false)))) -(define (parse-digit/sharp chars if-sharp if-digit otherwise) - (cond ((null? chars) (otherwise chars)) - ((char=? (car chars) #\#) - (let count-sharps ((chars (cdr chars)) (count 1)) - (if (and (not (null? chars)) - (char=? (car chars) #\#)) - (count-sharps (cdr chars) (1+ count)) - (if-sharp chars count)))) - (else - (let ((digit (char->digit (car chars) *radix*))) - (if digit - (if-digit (cdr chars) digit) - (otherwise chars)))))) \ No newline at end of file +(define (combine-sign sign real exactness inexact?) + (let ((real (if (and real (eqv? -1 sign)) (- real) real))) + (if (and inexact? + (not (eq? exactness 'EXACT))) + (exact->inexact real) + real))) \ No newline at end of file diff --git a/v7/src/runtime/parse.scm b/v7/src/runtime/parse.scm index a380567fa..1de139ebf 100644 --- a/v7/src/runtime/parse.scm +++ b/v7/src/runtime/parse.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/parse.scm,v 14.8 1989/08/16 01:06:14 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/parse.scm,v 14.9 1989/10/26 06:46:39 cph Exp $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -264,8 +264,9 @@ MIT in each case. |# (or (parse-number string) (intern-string! string))) -(define-integrable (parse-number string) - (string->number string false *parser-radix*)) +(define (parse-number string) + (string->number string + (if (memv *parser-radix* '(2 8 10 16)) *parser-radix* 10))) (define (intern-string! string) ;; Special version of `intern' to reduce consing and increase speed. @@ -287,7 +288,7 @@ MIT in each case. |# (let ((string (read-atom))) (unsigned-integer->bit-string (string-length string) - (or (string->number string false 2) + (or (string->number string 2) (error "READ: bad syntax for bit-string"))))) ;;;; Lists/Vectors @@ -482,7 +483,8 @@ MIT in each case. |# (define (parse-object/unhash) (discard-char) (let ((number (parse-object/dispatch))) - (if (not (integer? number)) (parse-error "Invalid unhash syntax" number)) + (if (not (exact-nonnegative-integer? number)) + (parse-error "Invalid unhash syntax" number)) (let ((object (object-unhash number))) ;; This knows that 0 is the hash of #f. (if (and (false? object) (not (zero? number))) diff --git a/v7/src/runtime/pp.scm b/v7/src/runtime/pp.scm index 974ccc5cb..b185f66d2 100644 --- a/v7/src/runtime/pp.scm +++ b/v7/src/runtime/pp.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/pp.scm,v 14.8 1989/08/15 13:20:02 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/pp.scm,v 14.9 1989/10/26 06:46:43 cph Exp $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -61,12 +61,8 @@ MIT in each case. |# (define *forced-x-size* false) (define (pp object #!optional port . rest) - (let ((object - (or (and (integer? object) - (not (negative? object)) - (unhash object)) - object)) - (port (if (default-object? port) (current-output-port) port))) (let ((pretty-print + (let ((port (if (default-object? port) (current-output-port) port))) + (let ((pretty-print (lambda (object) (apply pretty-print object port rest)))) (newline port) (if (named-structure? object) diff --git a/v7/src/runtime/random.scm b/v7/src/runtime/random.scm index f97caa6a3..7feefb409 100644 --- a/v7/src/runtime/random.scm +++ b/v7/src/runtime/random.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/random.scm,v 14.2 1988/06/13 11:50:32 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/random.scm,v 14.3 1989/10/26 06:46:47 cph Rel $ -Copyright (c) 1988 Massachusetts Institute of Technology +Copyright (c) 1988, 1989 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -36,7 +36,7 @@ MIT in each case. |# ;;; package: (runtime random-number) (declare (usual-integrations)) - + (define seed) (define a) (define m) @@ -45,20 +45,18 @@ MIT in each case. |# (define (initialize-package!) (set! seed 1) (set! a (+ (* 3141 1000 1000) (* 592 1000) 621)) - (set! m (integer-expt 2 63)) - (set! c 1)) + (set! m (expt 2 63)) + (set! c 1) + unspecific) (define (random k) - (if (not (integer? k)) - (error "RANDOM is valid only for integers" k)) - (if (not (and (positive? k) (<= k m))) - (error "RANDOM is valid only for integers from 1 to" m)) + (if (not (and (exact-integer? k) (<= 1 k m))) + (error "RANDOM is valid only for exact integers from 1 to" m)) (set! seed (remainder (+ (* a seed) c) m)) (quotient (* seed k) m)) (define (randomize k) - (if (not (integer? k)) - (error "RANDOMIZE is valid only for integers" k)) - (if (not (and (positive? k) (<= k m))) - (error "RANDOMIZE is valid only for integers from 1 to" m)) - (set! seed k)) \ No newline at end of file + (if (not (and (exact-integer? k) (<= 1 k m))) + (error "RANDOMIZE is valid only for exact integers from 1 to" m)) + (set! seed k) + unspecific) \ No newline at end of file diff --git a/v7/src/runtime/rep.scm b/v7/src/runtime/rep.scm index 035ff0dbe..0b97c207b 100644 --- a/v7/src/runtime/rep.scm +++ b/v7/src/runtime/rep.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/rep.scm,v 14.12 1989/08/15 13:20:07 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/rep.scm,v 14.13 1989/10/26 06:46:50 cph Exp $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -445,8 +445,8 @@ MIT in each case. |# (set-repl-history/elements! history (cdr elements)))))) (define (repl-history/read history n) - (if (not (and (integer? n) - (not (negative? n)) (< n (repl-history/size history)))) + (if (not (and (exact-nonnegative-integer? n) + (< n (repl-history/size history)))) (error "REPL-HISTORY/READ: Bad argument" n)) (list-ref (repl-history/elements history) (- (-1+ (repl-history/size history)) n))) diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg index a2e42f530..7c668c3be 100644 --- a/v7/src/runtime/runtime.pkg +++ b/v7/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/runtime.pkg,v 14.52 1989/09/24 15:44:23 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/runtime.pkg,v 14.53 1989/10/26 06:46:55 cph Exp $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -945,7 +945,7 @@ MIT in each case. |# (initialization (initialize-package!))) (define-package (runtime number) - (files "narith") + (files "arith" "dragon4") (parent ()) (export () * @@ -965,14 +965,19 @@ MIT in each case. |# asin atan ceiling + ceiling->exact complex? conjugate cos even? exact->inexact + exact-integer? + exact-nonnegative-integer? + exact-rational? exact? exp expt floor + floor->exact gcd imag-part inexact->exact @@ -981,7 +986,6 @@ MIT in each case. |# integer-divide integer-divide-quotient integer-divide-remainder - integer-expt integer-floor integer-round integer-truncate @@ -995,20 +999,30 @@ MIT in each case. |# min modulo negative? + number->string number? + numerator odd? positive? quotient rational? + rationalize + rationalize->exact real-part real? remainder round + round->exact + simplest-exact-rational + simplest-rational sin sqrt tan truncate + truncate->exact zero?) + (export (runtime number-parser) + bad-range) (initialization (initialize-package!))) (define-package (runtime number-parser) (files "numpar") @@ -1016,12 +1030,6 @@ MIT in each case. |# (export () string->number)) -(define-package (runtime number-unparser) - (files "numunp") - (parent ()) - (export () - number->string) - (initialization (initialize-package!))) (define-package (runtime options) (files "option") (parent ()) diff --git a/v7/src/runtime/runtime.sf b/v7/src/runtime/runtime.sf index 15d4bda24..cafdc94d0 100644 --- a/v7/src/runtime/runtime.sf +++ b/v7/src/runtime/runtime.sf @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/runtime.sf,v 14.3 1989/08/03 23:16:30 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/runtime.sf,v 14.4 1989/10/26 06:47:00 cph Exp $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -32,8 +32,9 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. |# -(sf/set-default-syntax-table! syntax-table/system-internal) -(sf-directory ".") +(fluid-let ((sf/default-syntax-table syntax-table/system-internal)) + (sf-directory ".")) + ;; Guarantee that the package modeller is loaded. (if (not (name->package '(CROSS-REFERENCE))) (with-working-directory-pathname "../cref" (lambda () (load "make")))) diff --git a/v7/src/runtime/scomb.scm b/v7/src/runtime/scomb.scm index b259227b7..e51120616 100644 --- a/v7/src/runtime/scomb.scm +++ b/v7/src/runtime/scomb.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/scomb.scm,v 14.3 1989/04/15 01:22:51 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/scomb.scm,v 14.4 1989/10/26 06:47:03 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -45,11 +45,9 @@ MIT in each case. |# &+ &- &/ - &ATAN -1+ 1+ ASCII->CHAR - CEILING CELL? CHAR->ASCII CHAR->INTEGER @@ -60,12 +58,8 @@ MIT in each case. |# CHAR-UPCASE COMPILED-CODE-ADDRESS->BLOCK COMPILED-CODE-ADDRESS->OFFSET - COS EQ? - EXP - FLOOR INTEGER->CHAR - LOG MAKE-CHAR MAKE-NON-POINTER-OBJECT NEGATIVE? @@ -75,14 +69,11 @@ MIT in each case. |# PAIR? POSITIVE? PRIMITIVE-PROCEDURE-ARITY - ROUND - SIN - SQRT ;; STRING->SYMBOL is a special case. Strings have can ;; be side-effected, but it is useful to be able to ;; constant fold this primitive anyway. STRING->SYMBOL - TRUNCATE ZERO? + ZERO? )))) ;;;; Sequence diff --git a/v7/src/runtime/stream.scm b/v7/src/runtime/stream.scm index 4f65015ea..a807799e1 100644 --- a/v7/src/runtime/stream.scm +++ b/v7/src/runtime/stream.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/stream.scm,v 14.5 1989/09/20 15:06:47 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/stream.scm,v 14.6 1989/10/26 06:47:07 cph Rel $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -78,8 +78,8 @@ MIT in each case. |# (stream-car tail))) (define (stream-head stream index) - (if (not (and (integer? index) (not (negative? index)))) - (error "STREAM-HEAD: index must be nonnegative integer" index)) + (if (not (exact-nonnegative-integer? index)) + (error "index must be exact nonnegative integer" index)) (let loop ((stream stream) (index index)) (if (zero? index) '() @@ -89,8 +89,9 @@ MIT in each case. |# (cons (stream-car stream) (loop (stream-cdr stream) (-1+ index))))))) (define (stream-tail stream index) - (if (not (and (integer? index) (not (negative? index)))) - (error "STREAM-TAIL: index must be nonnegative integer" index)) (let loop ((stream stream) (index index)) + (if (not (exact-nonnegative-integer? index)) + (error "index must be exact nonnegative integer" index)) + (let loop ((stream stream) (index index)) (if (zero? index) stream (begin (if (not (stream-pair? stream)) diff --git a/v7/src/runtime/system.scm b/v7/src/runtime/system.scm index 9d23f4b62..725cf3a02 100644 --- a/v7/src/runtime/system.scm +++ b/v7/src/runtime/system.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/system.scm,v 14.6 1989/08/07 07:37:02 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/system.scm,v 14.7 1989/10/26 06:47:10 cph Rel $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -76,7 +76,8 @@ MIT in each case. |# (define (version->string version) (cond ((string? version) version) - ((integer? version) (number->string version)) ((null? version) "") + ((exact-nonnegative-integer? version) (number->string version)) + ((null? version) "") ((list? version) (let loop ((version version)) (if (null? (cdr version)) diff --git a/v7/src/runtime/uerror.scm b/v7/src/runtime/uerror.scm index 4ca93f247..e0609c311 100644 --- a/v7/src/runtime/uerror.scm +++ b/v7/src/runtime/uerror.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/uerror.scm,v 14.9 1989/08/04 02:42:32 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/uerror.scm,v 14.10 1989/10/26 06:47:14 cph Exp $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -129,7 +129,8 @@ MIT in each case. |# (- (stack-frame/length frame) 4)) (define (internal-apply-frame/select frame selector) - (if (integer? selector) (internal-apply-frame/operand frame selector) + (if (exact-nonnegative-integer? selector) + (internal-apply-frame/operand frame selector) (selector frame))) (define ((internal-apply-frame/operator-filter . operators) frame) diff --git a/v7/src/runtime/unpars.scm b/v7/src/runtime/unpars.scm index 2dd5eef93..6a6d1a7ef 100644 --- a/v7/src/runtime/unpars.scm +++ b/v7/src/runtime/unpars.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unpars.scm,v 14.13 1989/08/09 11:08:39 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unpars.scm,v 14.14 1989/10/26 06:47:18 cph Exp $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -85,6 +85,7 @@ MIT in each case. |# (NULL ,unparse/null) (PRIMITIVE ,unparse/primitive-procedure) (PROCEDURE ,unparse/compound-procedure) + (RATNUM ,unparse/number) (RETURN-ADDRESS ,unparse/return-address) (STRING ,unparse/string) (TRUE ,unparse/true) @@ -194,7 +195,8 @@ MIT in each case. |# (define-integrable (*unparse-datum object) (*unparse-hex (object-datum object))) -(define-integrable (*unparse-hex number) +(define (*unparse-hex number) + (*unparse-string "#x") (*unparse-string (number->string number 16))) (define-integrable (*unparse-hash object) @@ -490,19 +492,21 @@ MIT in each case. |# (if closure? 'COMPILED-CLOSURE type) entry (lambda () - (let ((unparse-name - (lambda () - (*unparse-object - (let ((filename (compiled-entry/filename entry))) - (if filename - (list 'FILE (pathname-name (->pathname filename))) - '())))))) - (if (eq? type 'COMPILED-PROCEDURE) - (let ((name (compiled-procedure/name entry))) - (if name - (*unparse-string name) - (unparse-name))) - (unparse-name))) + (let ((name (compiled-procedure/name entry))) (with-values (lambda () (compiled-entry/filename entry)) + (lambda (filename block-number) + (*unparse-char #\() + (if name + (*unparse-string name)) + (if filename + (begin + (if name + (*unparse-char #\Space)) + (*unparse-object (pathname-name (->pathname filename))) + (if block-number + (begin + (*unparse-char #\Space) + (*unparse-hex block-number))))) + (*unparse-char #\))))) (*unparse-char #\Space) (*unparse-hex (compiled-entry/offset entry)) (*unparse-char #\Space) @@ -510,7 +514,7 @@ MIT in each case. |# (begin (*unparse-datum (compiled-closure->entry entry)) (*unparse-char #\Space))) (*unparse-datum entry))))) - + ;;;; Miscellaneous (define (unparse/environment environment) @@ -523,7 +527,24 @@ MIT in each case. |# (lambda () (*unparse-object (variable-name variable))))) (define (unparse/number object) - (*unparse-string (number->string object *unparser-radix*))) + (*unparse-string + (number->string + object + (let ((prefix + (lambda (prefix limit radix) + (if (exact-rational? object) + (begin + (if (not (and (exact-integer? object) + (< (abs object) limit))) + (*unparse-string prefix)) + radix) + 10)))) + (case *unparser-radix* + ((2) (prefix "#b" 2 2)) + ((8) (prefix "#o" 8 8)) + ((16) (prefix "#x" 10 16)) + (else 10)))))) + (define (unparse/future future) (*unparse-with-brackets 'FUTURE false (lambda () diff --git a/v7/src/runtime/unxprm.scm b/v7/src/runtime/unxprm.scm index 7bc108ba7..ec15d1c56 100644 --- a/v7/src/runtime/unxprm.scm +++ b/v7/src/runtime/unxprm.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unxprm.scm,v 1.4 1989/04/25 01:04:43 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unxprm.scm,v 1.5 1989/10/26 06:47:23 cph Exp $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -131,7 +131,8 @@ MIT in each case. |# (let ((pathname (pathname->absolute-pathname (->pathname filename)))) (if (let ((version (pathname-version pathname))) (or (not version) - (integer? version))) pathname + (exact-integer? version))) + pathname (or (pathname->input-truename pathname) (pathname-new-version pathname false))))))) (let ((result ((ucode-primitive file-touch) filename))) diff --git a/v7/src/runtime/version.scm b/v7/src/runtime/version.scm index 773966086..2756a422b 100644 --- a/v7/src/runtime/version.scm +++ b/v7/src/runtime/version.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/version.scm,v 14.61 1989/10/03 22:56:03 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/version.scm,v 14.62 1989/10/26 06:47:30 cph Exp $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -45,7 +45,7 @@ MIT in each case. |# '())) (add-system! microcode-system) (add-event-receiver! event:after-restore snarf-microcode-version!) - (add-identification! "Runtime" 14 61)) + (add-identification! "Runtime" 14 62)) (define microcode-system) (define (snarf-microcode-version!) diff --git a/v7/src/runtime/x11graph.scm b/v7/src/runtime/x11graph.scm index 0df3c64fb..6f8455815 100644 --- a/v7/src/runtime/x11graph.scm +++ b/v7/src/runtime/x11graph.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/x11graph.scm,v 1.3 1989/06/27 10:16:02 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/x11graph.scm,v 1.4 1989/10/26 06:47:37 cph Exp $ Copyright (c) 1989 Massachusetts Institute of Technology @@ -165,9 +165,12 @@ MIT in each case. |# (vector-ref limits 3)))) (define (operation/set-line-style xw line-style) - (cond ((zero? line-style) + (cond ((not (and (exact-nonnegative-integer? line-style) + (< line-style 8))) + (error "Illegal line style" line-style)) + ((zero? line-style) (x-graphics-set-line-style xw 0)) - ((and (integer? line-style) (<= 1 line-style 7)) + (else (x-graphics-set-line-style xw 2) (x-graphics-set-dashes xw @@ -179,6 +182,4 @@ MIT in each case. |# "\013\005" "\014\001\002\001" "\011\001\002\001\002\001") - (-1+ line-style)))) - (else - (error "Illegal line style" line-style)))) \ No newline at end of file + (-1+ line-style)))))) \ No newline at end of file diff --git a/v8/src/runtime/conpar.scm b/v8/src/runtime/conpar.scm index 6680b3f02..06fb0ebac 100644 --- a/v8/src/runtime/conpar.scm +++ b/v8/src/runtime/conpar.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/conpar.scm,v 14.9 1989/10/10 11:38:30 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/conpar.scm,v 14.10 1989/10/26 06:45:54 cph Exp $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -169,7 +169,7 @@ MIT in each case. |# (element-stream/head stream)))) (let ((length (let ((length (stack-frame-type/length type))) - (if (integer? length) + (if (exact-nonnegative-integer? length) length (length stream (parser-state/n-elements state)))))) ((stack-frame-type/parser type) @@ -316,7 +316,7 @@ MIT in each case. |# (element-stream/head stream))) (length (let ((length (stack-frame-type/length type))) - (if (integer? length) + (if (exact-nonnegative-integer? length) length (length stream offset)))) (ltail (stream-tail* stream length))) @@ -641,7 +641,7 @@ MIT in each case. |# (write-string " ") (write-string name) (write-string " = ") - (write-string (number->string value '(HEUR (RADIX X)))))) + (write-string (number->string value 16)))) (define (hardware-trap-frame/print-registers frame) (guarantee-hardware-trap-frame frame) @@ -653,7 +653,8 @@ MIT in each case. |# (let loop ((i 0)) (if (< i nregs) (begin - (print-register block (+ 2 i) + (print-register block + (+ 2 i) (string-append "register " (number->string i))) (loop (1+ i))))))))) @@ -701,7 +702,8 @@ MIT in each case. |# (write-string (number->string (stack-frame/ref frame hardware-trap/pc-info2-index) - '(HEUR (RADIX X)))) (newline) + 16)) + (newline) (write-string "within ") (let ((block (stack-frame/ref frame hardware-trap/pc-info1-index))) (write block) diff --git a/v8/src/runtime/infutl.scm b/v8/src/runtime/infutl.scm index b8cdb6975..f743772f3 100644 --- a/v8/src/runtime/infutl.scm +++ b/v8/src/runtime/infutl.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/infutl.scm,v 1.13 1989/10/03 22:55:38 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/infutl.scm,v 1.14 1989/10/26 06:46:23 cph Exp $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -78,8 +78,7 @@ MIT in each case. |# (vector-ref binf 0)))))) ((and (pair? descriptor) (string? (car descriptor)) - (integer? (cdr descriptor)) - (not (negative? (cdr descriptor)))) + (exact-nonnegative-integer? (cdr descriptor))) (let ((binf (read-binf-file (car descriptor)))) (and binf (vector? binf) @@ -158,11 +157,15 @@ MIT in each case. |# (let loop ((info (compiled-code-block/debugging-info (compiled-entry/block entry)))) - (cond ((string? info) info) - ((not (pair? info)) false) - ((string? (car info)) (car info)) + (cond ((string? info) (values info false)) + ((not (pair? info)) (values false false)) ((dbg-info? (car info)) (loop (cdr info))) - (else false)))) + ((string? (car info)) + (values (car info) + (and (exact-nonnegative-integer? (cdr info)) + (cdr info)))) + (else (values false false))))) + (define (dbg-labels/find-offset labels offset) (vector-binary-search labels < dbg-label/offset offset)) diff --git a/v8/src/runtime/make.scm b/v8/src/runtime/make.scm index 4c77e2d23..609764cbc 100644 --- a/v8/src/runtime/make.scm +++ b/v8/src/runtime/make.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/make.scm,v 14.18 1989/08/18 19:14:46 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/make.scm,v 14.19 1989/10/26 06:46:35 cph Exp $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -320,7 +320,7 @@ MIT in each case. |# (RUNTIME LOAD) ;; Syntax (RUNTIME PARSER) - (RUNTIME NUMBER-UNPARSER) (RUNTIME UNPARSER) + (RUNTIME UNPARSER) (RUNTIME SYNTAXER) (RUNTIME MACROS) (RUNTIME SYSTEM-MACROS) diff --git a/v8/src/runtime/runtime.pkg b/v8/src/runtime/runtime.pkg index 029531e3a..21ac63c34 100644 --- a/v8/src/runtime/runtime.pkg +++ b/v8/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/runtime.pkg,v 14.52 1989/09/24 15:44:23 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/runtime.pkg,v 14.53 1989/10/26 06:46:55 cph Exp $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -945,7 +945,7 @@ MIT in each case. |# (initialization (initialize-package!))) (define-package (runtime number) - (files "narith") + (files "arith" "dragon4") (parent ()) (export () * @@ -965,14 +965,19 @@ MIT in each case. |# asin atan ceiling + ceiling->exact complex? conjugate cos even? exact->inexact + exact-integer? + exact-nonnegative-integer? + exact-rational? exact? exp expt floor + floor->exact gcd imag-part inexact->exact @@ -981,7 +986,6 @@ MIT in each case. |# integer-divide integer-divide-quotient integer-divide-remainder - integer-expt integer-floor integer-round integer-truncate @@ -995,20 +999,30 @@ MIT in each case. |# min modulo negative? + number->string number? + numerator odd? positive? quotient rational? + rationalize + rationalize->exact real-part real? remainder round + round->exact + simplest-exact-rational + simplest-rational sin sqrt tan truncate + truncate->exact zero?) + (export (runtime number-parser) + bad-range) (initialization (initialize-package!))) (define-package (runtime number-parser) (files "numpar") @@ -1016,12 +1030,6 @@ MIT in each case. |# (export () string->number)) -(define-package (runtime number-unparser) - (files "numunp") - (parent ()) - (export () - number->string) - (initialization (initialize-package!))) (define-package (runtime options) (files "option") (parent ())