suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge pull request #45 from michaellenaghan/master

Browse Source 
Fix two typos and three minor inconsistencies.
original commit: 19a80e849b1b0f9451b205cd96411c44036cdba6
This commit is contained in:
Andy Keep 2016-05-12 20:08:55 -04:00
commit 0c5d46d1b2
4 changed files with 48 additions and 48 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

38
c/scheme.c
View File

@ -1,12 +1,12 @@
/* scheme.c /* scheme.c
* Copyright 1984-2016 Cisco Systems, Inc. * Copyright 1984-2016 Cisco Systems, Inc.
* *
* Licensed under the Apache License, Version 2.0 (the "License"); * Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License. * you may not use this file except in compliance with the License.
* You may obtain a copy of the License at * You may obtain a copy of the License at
* *
* http://www.apache.org/licenses/LICENSE-2.0 * http://www.apache.org/licenses/LICENSE-2.0
* *
* Unless required by applicable law or agreed to in writing, software * Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS, * distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
@ -275,7 +275,7 @@ static void idiot_checks() {
oops = 1; oops = 1;
} }
} }
if (sizeof(bucket_pointer_list) != sizeof(bucket_list)) { if (sizeof(bucket_pointer_list) != sizeof(bucket_list)) {
/* gc repurposes bucket_lists for bucket_pointer lists, so they'd better have the same size */ /* gc repurposes bucket_lists for bucket_pointer lists, so they'd better have the same size */
fprintf(stderr, "bucket_pointer_list and bucket_list have different sizes\n"); fprintf(stderr, "bucket_pointer_list and bucket_list have different sizes\n");
@ -370,7 +370,7 @@ void S_generic_invoke(tc, code) ptr tc; ptr code; {
} }
__except(GetExceptionCode() == EXCEPTION_ACCESS_VIOLATION ? __except(GetExceptionCode() == EXCEPTION_ACCESS_VIOLATION ?
EXCEPTION_EXECUTE_HANDLER : EXCEPTION_CONTINUE_SEARCH) EXCEPTION_EXECUTE_HANDLER : EXCEPTION_CONTINUE_SEARCH)
{ {
if (S_pants_down) if (S_pants_down)
S_error_abort("nonrecoverable invalid memory reference"); S_error_abort("nonrecoverable invalid memory reference");
else else
@ -545,7 +545,7 @@ static IBOOL find_boot(name, ext, errorp) const char *name, *ext; IBOOL errorp;
if (S_fixedpathp(name)) { if (S_fixedpathp(name)) {
if (strlen(name) >= PATH_MAX) { if (strlen(name) >= PATH_MAX) {
fprintf(stderr, "boot-file path is to long %s\n", name); fprintf(stderr, "boot-file path is too long %s\n", name);
S_abnormal_exit(); S_abnormal_exit();
} }
@ -566,10 +566,10 @@ static IBOOL find_boot(name, ext, errorp) const char *name, *ext; IBOOL errorp;
if (gzgetc(file) != fasl_type_header || if (gzgetc(file) != fasl_type_header ||
gzgetc(file) != 0 || gzgetc(file) != 0 ||
gzgetc(file) != 0 || gzgetc(file) != 0 ||
gzgetc(file) != 0 || gzgetc(file) != 0 ||
gzgetc(file) != 'c' || gzgetc(file) != 'c' ||
gzgetc(file) != 'h' || gzgetc(file) != 'h' ||
gzgetc(file) != 'e' || gzgetc(file) != 'e' ||
gzgetc(file) != 'z') { gzgetc(file) != 'z') {
fprintf(stderr, "malformed fasl-object header in %s\n", path); fprintf(stderr, "malformed fasl-object header in %s\n", path);
S_abnormal_exit(); S_abnormal_exit();
@ -632,23 +632,23 @@ static IBOOL find_boot(name, ext, errorp) const char *name, *ext; IBOOL errorp;
if (gzgetc(file) != fasl_type_header || if (gzgetc(file) != fasl_type_header ||
gzgetc(file) != 0 || gzgetc(file) != 0 ||
gzgetc(file) != 0 || gzgetc(file) != 0 ||
gzgetc(file) != 0 || gzgetc(file) != 0 ||
gzgetc(file) != 'c' || gzgetc(file) != 'c' ||
gzgetc(file) != 'h' || gzgetc(file) != 'h' ||
gzgetc(file) != 'e' || gzgetc(file) != 'e' ||
gzgetc(file) != 'z') { gzgetc(file) != 'z') {
if (verbose) fprintf(stderr, "malformed fasl-object header in %s\n", path); if (verbose) fprintf(stderr, "malformed fasl-object header in %s\n", path);
gzclose(file); gzclose(file);
continue; continue;
} }
/* check version */ /* check version */
if (zget_uptr(file, &n) != 0) { if (zget_uptr(file, &n) != 0) {
if (verbose) fprintf(stderr, "unexpected end of file on %s\n", path); if (verbose) fprintf(stderr, "unexpected end of file on %s\n", path);
gzclose(file); gzclose(file);
continue; continue;
} }
if (n != scheme_version) { if (n != scheme_version) {
if (verbose) { if (verbose) {
fprintf(stderr, "%s is for Version %s; ", path, S_format_scheme_version(n)); fprintf(stderr, "%s is for Version %s; ", path, S_format_scheme_version(n));
@ -658,14 +658,14 @@ static IBOOL find_boot(name, ext, errorp) const char *name, *ext; IBOOL errorp;
gzclose(file); gzclose(file);
continue; continue;
} }
/* check machine type */ /* check machine type */
if (zget_uptr(file, &n) != 0) { if (zget_uptr(file, &n) != 0) {
if (verbose) fprintf(stderr, "unexpected end of file on %s\n", path); if (verbose) fprintf(stderr, "unexpected end of file on %s\n", path);
gzclose(file); gzclose(file);
continue; continue;
} }
if (n != machine_type) { if (n != machine_type) {
if (verbose) if (verbose)
fprintf(stderr, "%s is for machine-type %s; need machine-type %s\n", path, fprintf(stderr, "%s is for machine-type %s; need machine-type %s\n", path,
@ -1181,7 +1181,7 @@ extern void Sscheme_deinit() {
p = S_symbol_value(S_intern((const unsigned char *)"$close-files")); p = S_symbol_value(S_intern((const unsigned char *)"$close-files"));
S_initframe(tc, 0); S_initframe(tc, 0);
boot_call(tc, p, 0); boot_call(tc, p, 0);
S_errors_to_console = 1; S_errors_to_console = 1;
current_state = DEINITIALIZED; current_state = DEINITIALIZED;
} }

8
configure vendored
View File

@ -2,13 +2,13 @@
# configure # configure
# Copyright 1984-2016 Cisco Systems, Inc. # Copyright 1984-2016 Cisco Systems, Inc.
# #
# Licensed under the Apache License, Version 2.0 (the "License"); # Licensed under the Apache License, Version 2.0 (the "License");
# you may not use this file except in compliance with the License. # you may not use this file except in compliance with the License.
# You may obtain a copy of the License at # You may obtain a copy of the License at
# #
# http://www.apache.org/licenses/LICENSE-2.0 # http://www.apache.org/licenses/LICENSE-2.0
# #
# Unless required by applicable law or agreed to in writing, software # Unless required by applicable law or agreed to in writing, software
# distributed under the License is distributed on an "AS IS" BASIS, # distributed under the License is distributed on an "AS IS" BASIS,
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. # WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
@ -245,7 +245,7 @@ if [ "$help" = "yes" ]; then
echo " --threads specify threaded version ($threads)" echo " --threads specify threaded version ($threads)"
echo " --32|--64 specify 32/64-bit version ($bits)" echo " --32|--64 specify 32/64-bit version ($bits)"
echo " --installprefix=<pathname> final installation root ($installprefix)" echo " --installprefix=<pathname> final installation root ($installprefix)"
echo " --installbin=<pathname> lib directory ($installbin)" echo " --installbin=<pathname> bin directory ($installbin)"
echo " --installlib=<pathname> lib directory ($installlib)" echo " --installlib=<pathname> lib directory ($installlib)"
echo " --installman=<pathname> manpage directory ($installman)" echo " --installman=<pathname> manpage directory ($installman)"
echo " --temproot=<pathname> staging root ($temproot)" echo " --temproot=<pathname> staging root ($temproot)"

22
s/io.ss
View File

@ -1,13 +1,13 @@
"io.ss" "io.ss"
;;; io.ss ;;; io.ss
;;; Copyright 1984-2016 Cisco Systems, Inc. ;;; Copyright 1984-2016 Cisco Systems, Inc.
;;; ;;;
;;; Licensed under the Apache License, Version 2.0 (the "License"); ;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License. ;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at ;;; You may obtain a copy of the License at
;;; ;;;
;;; http://www.apache.org/licenses/LICENSE-2.0 ;;; http://www.apache.org/licenses/LICENSE-2.0
;;; ;;;
;;; Unless required by applicable law or agreed to in writing, software ;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS, ;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
@ -2282,12 +2282,12 @@ implementation notes:
(nongenerative) (nongenerative)
(opaque #t) (opaque #t)
(fields decode-desc encode-desc)) (fields decode-desc encode-desc))
(define $iconv-open (foreign-procedure "(cs)s_iconv_open" (string string) ptr)) (define $iconv-open (foreign-procedure "(cs)s_iconv_open" (string string) ptr))
(define $iconv-close (foreign-procedure "(cs)s_iconv_close" (uptr) void)) (define $iconv-close (foreign-procedure "(cs)s_iconv_close" (uptr) void))
(define $iconv-from-string (foreign-procedure "(cs)s_iconv_from_string" (uptr ptr uptr uptr ptr uptr uptr) ptr)) (define $iconv-from-string (foreign-procedure "(cs)s_iconv_from_string" (uptr ptr uptr uptr ptr uptr uptr) ptr))
(define $iconv-to-string (foreign-procedure "(cs)s_iconv_to_string" (uptr ptr uptr uptr ptr uptr uptr) ptr)) (define $iconv-to-string (foreign-procedure "(cs)s_iconv_to_string" (uptr ptr uptr uptr ptr uptr uptr) ptr))
(define iconv-decode (define iconv-decode
(let () (let ()
(define (err who tp info i iend bv) (define (err who tp info i iend bv)
@ -2388,7 +2388,7 @@ implementation notes:
[else (err who tp info i iend bv)])] [else (err who tp info i iend bv)])]
[(fx= n 0) (return 0 i iend info)] [(fx= n 0) (return 0 i iend info)]
[else (loop j 0 (fx+ iend n))])))]))]))))))) [else (loop j 0 (fx+ iend n))])))]))])))))))
(define iconv-encode (define iconv-encode
(let () (let ()
(define (return ans o info) (define (return ans o info)
@ -2459,12 +2459,12 @@ implementation notes:
(if (fx= newo o) (if (fx= newo o)
(return (fx- j start) o info) (return (fx- j start) o info)
(loop j newo)))]))]))))))) (loop j newo)))]))])))))))
(define iconv-close (define iconv-close
(lambda (info) (lambda (info)
(cond [(iconv-info-decode-desc info) => $iconv-close]) (cond [(iconv-info-decode-desc info) => $iconv-close])
(cond [(iconv-info-encode-desc info) => $iconv-close]))) (cond [(iconv-info-encode-desc info) => $iconv-close])))
(set-who! iconv-codec (set-who! iconv-codec
(lambda (code) (lambda (code)
(unless (string? code) ($oops who "~s is not a string" code)) (unless (string? code) ($oops who "~s is not a string" code))
@ -2525,7 +2525,7 @@ implementation notes:
($make-transcoder codec eol-style handling-mode)]))) ($make-transcoder codec eol-style handling-mode)])))
(set-who! transcoder? (lambda (x) ($transcoder? x))) (set-who! transcoder? (lambda (x) ($transcoder? x)))
(let ([transcoder (make-transcoder (utf-8-codec))]) (let ([transcoder (make-transcoder (utf-8-codec))])
(set-who! native-transcoder (lambda () transcoder)) (set-who! native-transcoder (lambda () transcoder))
(set-who! current-transcoder (set-who! current-transcoder
@ -3768,7 +3768,7 @@ implementation notes:
(unless (and (input-port? binary-input-port) (binary-port? binary-input-port)) (unless (and (input-port? binary-input-port) (binary-port? binary-input-port))
($oops who "~s is not a binary input port" binary-input-port)) ($oops who "~s is not a binary input port" binary-input-port))
(unless (and (fixnum? count) (fx>= count 0)) (unless (and (fixnum? count) (fx>= count 0))
($oops who "~s is not a non-negative fixnum" count)) ($oops who "~s is not a nonnegative fixnum" count))
(let ([buffer-size (file-buffer-size)]) (let ([buffer-size (file-buffer-size)])
(if (not ($fxu< buffer-size count)) (if (not ($fxu< buffer-size count))
(let ([bv (make-bytevector count)]) (let ([bv (make-bytevector count)])
@ -3933,7 +3933,7 @@ implementation notes:
(unless (and (input-port? textual-input-port) (textual-port? textual-input-port)) (unless (and (input-port? textual-input-port) (textual-port? textual-input-port))
($oops who "~s is not a textual input port" textual-input-port)) ($oops who "~s is not a textual input port" textual-input-port))
(unless (and (fixnum? count) (fx>= count 0)) (unless (and (fixnum? count) (fx>= count 0))
($oops who "~s is not a non-negative fixnum" count)) ($oops who "~s is not a nonnegative fixnum" count))
(let ([buffer-size (file-buffer-size)]) (let ([buffer-size (file-buffer-size)])
(if (not ($fxu< buffer-size count)) (if (not ($fxu< buffer-size count))
(let ([st (make-string count)]) (let ([st (make-string count)])

28
s/print.ss
View File

@ -1,13 +1,13 @@
"print.ss" "print.ss"
;;; print.ss ;;; print.ss
;;; Copyright 1984-2016 Cisco Systems, Inc. ;;; Copyright 1984-2016 Cisco Systems, Inc.
;;; ;;;
;;; Licensed under the Apache License, Version 2.0 (the "License"); ;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License. ;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at ;;; You may obtain a copy of the License at
;;; ;;;
;;; http://www.apache.org/licenses/LICENSE-2.0 ;;; http://www.apache.org/licenses/LICENSE-2.0
;;; ;;;
;;; Unless required by applicable law or agreed to in writing, software ;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS, ;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
@ -97,7 +97,7 @@
(lambda (x) (lambda (x)
(if ($immediate? x) (if ($immediate? x)
(eq? x black-hole) (eq? x black-hole)
(and (and
($object-in-heap? x) ($object-in-heap? x)
(or (pair? x) (or (pair? x)
(vector? x) (vector? x)
@ -422,13 +422,13 @@ floating point returns with (1 0 -1 ...).
(fixup k (* r scale) s m- (and m+ (ash m- 1)) ruf))] (fixup k (* r scale) s m- (and m+ (ash m- 1)) ruf))]
[else [else
(fixup k r s m- m+ ruf)])))) (fixup k r s m- m+ ruf)]))))
(define fixup (define fixup
(lambda (k r s m- m+ ruf) (lambda (k r s m- m+ ruf)
(if ((if ruf >= >) (+ r (or m+ m-)) s) (if ((if ruf >= >) (+ r (or m+ m-)) s)
(cutoffadjust0 (fx+ k 1) r (* s ob) m- m+ ruf) (cutoffadjust0 (fx+ k 1) r (* s ob) m- m+ ruf)
(cutoffadjust0 k r s m- m+ ruf)))) (cutoffadjust0 k r s m- m+ ruf))))
(define cutoffadjust0 (define cutoffadjust0
(lambda (k r s m- m+ ruf) (lambda (k r s m- m+ ruf)
(case cutoffmode (case cutoffmode
@ -437,7 +437,7 @@ floating point returns with (1 0 -1 ...).
(cutoffadjust k r s m- m+ ruf (fx- initialcutoffplace k))] (cutoffadjust k r s m- m+ ruf (fx- initialcutoffplace k))]
[(relative) [(relative)
(when (fx>= initialcutoffplace 0) (when (fx>= initialcutoffplace 0)
($oops '$flonum->digits "non-negative relative cutoffplace ~s" ($oops '$flonum->digits "nonnegative relative cutoffplace ~s"
initialcutoffplace)) initialcutoffplace))
(cutoffadjust k r s m- m+ ruf initialcutoffplace)] (cutoffadjust k r s m- m+ ruf initialcutoffplace)]
[else [else
@ -476,7 +476,7 @@ floating point returns with (1 0 -1 ...).
(lambda (k r s m- m+ ruf cop) (lambda (k r s m- m+ ruf cop)
(let ([k (fx- k 1)]) (let ([k (fx- k 1)])
(cons k (generate k r s m- m+ ruf cop))))) (cons k (generate k r s m- m+ ruf cop)))))
(define generate (define generate
(lambda (k r s m- m+ ruf cop) (lambda (k r s m- m+ ruf cop)
(let* ([rob (* r ob)] (let* ([rob (* r ob)]
@ -501,7 +501,7 @@ floating point returns with (1 0 -1 ...).
(if (fx= d u) (if (fx= d u)
(generate1 k (+ r (or m+ m-)) s cop) (generate1 k (+ r (or m+ m-)) s cop)
(generate1 k (- (+ r (or m+ m-)) s) s cop)))])))))) (generate1 k (- (+ r (or m+ m-)) s) s cop)))]))))))
; delta may be zero, in which case all digits are significant, ; delta may be zero, in which case all digits are significant,
; even if we've been asked for 1,000,000 of them. This is due to ; even if we've been asked for 1,000,000 of them. This is due to
; our definition of (in)significant: "a digit is insignificant when ; our definition of (in)significant: "a digit is insignificant when
@ -510,7 +510,7 @@ floating point returns with (1 0 -1 ...).
; words, a digit is insignificant if incrementing the preceding ; words, a digit is insignificant if incrementing the preceding
; digit does not cause the number to fall outside the rounding ; digit does not cause the number to fall outside the rounding
; range of v." For 1e23, which falls exactly midway between two ; range of v." For 1e23, which falls exactly midway between two
; fp numbers and reads as the next one down due to "unbiasd rounding", ; fp numbers and reads as the next one down due to "unbiasd rounding",
; if we add even a single 1 digit way down, we're pushed to the next ; if we add even a single 1 digit way down, we're pushed to the next
; higher (when read). For example: ; higher (when read). For example:
; 100000000000000000000000.000000000000000000000000000000000000001 ; 100000000000000000000000.000000000000000000000000000000000000001
@ -941,7 +941,7 @@ floating point returns with (1 0 -1 ...).
(lambda (x r d? p) (lambda (x r d? p)
(unless (or (fx= r 10) d?) (wrradix r p)) (unless (or (fx= r 10) d?) (wrradix r p))
(wrbigits (if (< x 0) (begin (write-char #\- p) (- x)) x) r p))) (wrbigits (if (< x 0) (begin (write-char #\- p) (- x)) x) r p)))
(define wrfixnum (define wrfixnum
(lambda (x r d? p) (lambda (x r d? p)
(unless (or (fx= r 10) d?) (wrradix r p)) (unless (or (fx= r 10) d?) (wrradix r p))
@ -970,7 +970,7 @@ floating point returns with (1 0 -1 ...).
(let ([u (car s)]) (let ([u (car s)])
(when (or (fx>= u 0) (fx>= e 0)) (when (or (fx>= u 0) (fx>= e 0))
(loop u (cdr s) (fx- e 1))))))) (loop u (cdr s) (fx- e 1)))))))
(define free-format-exponential (define free-format-exponential
(lambda (e s r p) (lambda (e s r p)
(write-char (flonum-digit->char (car s)) p) (write-char (flonum-digit->char (car s)) p)
@ -1167,7 +1167,7 @@ floating point returns with (1 0 -1 ...).
(wr x (print-radix) lev len #f env p)))) (wr x (print-radix) lev len #f env p))))
(set-who! write (set-who! write
(case-lambda (case-lambda
[(x p) [(x p)
(unless (and (output-port? p) (textual-port? p)) (unless (and (output-port? p) (textual-port? p))
($oops 'write "~s is not a textual output port" p)) ($oops 'write "~s is not a textual output port" p))
@ -1187,7 +1187,7 @@ floating point returns with (1 0 -1 ...).
(wr x (print-radix) #f #f #t #f p)) (wr x (print-radix) #f #f #t #f p))
(set-who! display (set-who! display
(case-lambda (case-lambda
[(x p) [(x p)
(unless (and (output-port? p) (textual-port? p)) (unless (and (output-port? p) (textual-port? p))
($oops 'display "~s is not a textual output port" p)) ($oops 'display "~s is not a textual output port" p))