#| -*-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
(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)
#| -*-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
(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)
(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)))
(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)
(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)))))))))
(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)
#| -*-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
(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")
#| -*-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
;; 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))
#| -*-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
(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
#| -*-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
(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
#| -*-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
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)
#| -*-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
(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)
(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))
#| -*-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
(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)
#| -*-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
(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)
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 '())))
(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
(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)
'()
#| -*-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
(RUNTIME LOAD)
;; Syntax
(RUNTIME PARSER)
- (RUNTIME NUMBER-UNPARSER) (RUNTIME UNPARSER)
+ (RUNTIME UNPARSER)
(RUNTIME SYNTAXER)
(RUNTIME MACROS)
(RUNTIME SYSTEM-MACROS)
#| -*-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
;;;; Number Parser
;;; package: (runtime number-parser)
-
-(declare (usual-integrations))
\f
-;;; 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?))))))))))
\f
-(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))))))
-\f
-(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))))
-\f
-(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))))
\f
-(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))))))))
+\f
+(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)))))))))))
\f
-(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
#| -*-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
(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.
(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")))))\f
;;;; Lists/Vectors
(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)))
#| -*-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
(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)
#| -*-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
;;; package: (runtime random-number)
(declare (usual-integrations))
-\f
+
(define seed)
(define a)
(define m)
(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
#| -*-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
(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)))
#| -*-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
(initialization (initialize-package!)))
(define-package (runtime number)
- (files "narith")
+ (files "arith" "dragon4")
(parent ())
(export ()
*
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
integer-divide
integer-divide-quotient
integer-divide-remainder
- integer-expt
integer-floor
integer-round
integer-truncate
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")
(export ()
string->number))
-(define-package (runtime number-unparser)
- (files "numunp")
- (parent ())
- (export ()
- number->string)
- (initialization (initialize-package!)))
(define-package (runtime options)
(files "option")
(parent ())
#| -*-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
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"))))
#| -*-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
&+
&-
&/
- &ATAN
-1+
1+
ASCII->CHAR
- CEILING
CELL?
CHAR->ASCII
CHAR->INTEGER
CHAR-UPCASE
COMPILED-CODE-ADDRESS->BLOCK
COMPILED-CODE-ADDRESS->OFFSET
- COS
EQ?
- EXP
- FLOOR
INTEGER->CHAR
- LOG
MAKE-CHAR
MAKE-NON-POINTER-OBJECT
NEGATIVE?
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?
))))
\f
;;;; Sequence
#| -*-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
(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)
'()
(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))
#| -*-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
(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))
#| -*-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
(- (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)
#| -*-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
(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)
(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)
(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)
(begin (*unparse-datum (compiled-closure->entry entry))
(*unparse-char #\Space)))
(*unparse-datum entry)))))
-
+\f
;;;; Miscellaneous
(define (unparse/environment environment)
(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 ()
#| -*-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
(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)))
#| -*-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
'()))
(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!)
#| -*-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
(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
"\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
#| -*-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
(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)
(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)))
(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)
(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)))))))))
(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)
#| -*-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
(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)
(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))
#| -*-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
(RUNTIME LOAD)
;; Syntax
(RUNTIME PARSER)
- (RUNTIME NUMBER-UNPARSER) (RUNTIME UNPARSER)
+ (RUNTIME UNPARSER)
(RUNTIME SYNTAXER)
(RUNTIME MACROS)
(RUNTIME SYSTEM-MACROS)
#| -*-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
(initialization (initialize-package!)))
(define-package (runtime number)
- (files "narith")
+ (files "arith" "dragon4")
(parent ())
(export ()
*
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
integer-divide
integer-divide-quotient
integer-divide-remainder
- integer-expt
integer-floor
integer-round
integer-truncate
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")
(export ()
string->number))
-(define-package (runtime number-unparser)
- (files "numunp")
- (parent ())
- (export ()
- number->string)
- (initialization (initialize-package!)))
(define-package (runtime options)
(files "option")
(parent ())
projects / mit-scheme.git / commitdiff