From: Chris Hanson Date: Thu, 13 Feb 2003 05:07:46 +0000 (+0000) Subject: Eliminate definitions embedded inside LET-SYNTAX, since they depend on X-Git-Tag: 20090517-FFI~2033 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=fe9ceb1ae96662141088b5c701ebd93c2fb63281;p=mit-scheme.git Eliminate definitions embedded inside LET-SYNTAX, since they depend on an incorrect implementation of LET-SYNTAX. --- diff --git a/v7/src/6001/arith.scm b/v7/src/6001/arith.scm index f4d440dcb..2efedaf35 100644 --- a/v7/src/6001/arith.scm +++ b/v7/src/6001/arith.scm @@ -1,8 +1,9 @@ #| -*-Scheme-*- -$Id: arith.scm,v 1.11 2002/11/20 19:45:46 cph Exp $ +$Id: arith.scm,v 1.12 2003/02/13 05:07:46 cph Exp $ -Copyright (c) 1989-1999, 2001, 2002 Massachusetts Institute of Technology +Copyright 1989,1991,1992,1993,1995,2001 Massachusetts Institute of Technology +Copyright 2002,2003 Massachusetts Institute of Technology This file is part of MIT Scheme. @@ -46,57 +47,57 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. (if (not (int:integer? object)) (error:wrong-type-argument object "number" procedure))) -(let-syntax - ((define-standard-unary - (sc-macro-transformer - (lambda (form environment) - `(DEFINE (,(list-ref form 1) X) - (IF (FLONUM? X) - (,(close-syntax (list-ref form 2) environment) X) - (,(close-syntax (list-ref form 3) environment) X))))))) - (define-standard-unary rational? (lambda (x) x true) int:integer?) - (define-standard-unary integer? flo:integer? int:integer?) - (define-standard-unary exact? (lambda (x) x false) - (lambda (x) - (guarantee-integer x 'EXACT?) - true)) - (define-standard-unary zero? flo:zero? int:zero?) - (define-standard-unary negative? flo:negative? int:negative?) - (define-standard-unary positive? flo:positive? int:positive?) - (define-standard-unary abs flo:abs int:abs) - (define-standard-unary floor flo:floor (lambda (x) x)) - (define-standard-unary ceiling flo:ceiling (lambda (x) x)) - (define-standard-unary truncate flo:truncate (lambda (x) x)) - (define-standard-unary round flo:round (lambda (x) x)) - (define-standard-unary exact->inexact (lambda (x) x) int:->flonum) - (define-standard-unary inexact->exact - (lambda (x) - (if (not (flo:integer? x)) - (error:bad-range-argument x 'INEXACT->EXACT)) - (flo:truncate->exact x)) - (lambda (x) - (guarantee-integer x 'INEXACT->EXACT) - x))) +(define-syntax define-standard-unary + (sc-macro-transformer + (lambda (form environment) + `(DEFINE (,(list-ref form 1) X) + (IF (FLONUM? X) + (,(close-syntax (list-ref form 2) environment) X) + (,(close-syntax (list-ref form 3) environment) X)))))) + +(define-standard-unary rational? (lambda (x) x true) int:integer?) +(define-standard-unary integer? flo:integer? int:integer?) +(define-standard-unary exact? (lambda (x) x false) + (lambda (x) + (guarantee-integer x 'EXACT?) + true)) +(define-standard-unary zero? flo:zero? int:zero?) +(define-standard-unary negative? flo:negative? int:negative?) +(define-standard-unary positive? flo:positive? int:positive?) +(define-standard-unary abs flo:abs int:abs) +(define-standard-unary floor flo:floor (lambda (x) x)) +(define-standard-unary ceiling flo:ceiling (lambda (x) x)) +(define-standard-unary truncate flo:truncate (lambda (x) x)) +(define-standard-unary round flo:round (lambda (x) x)) +(define-standard-unary exact->inexact (lambda (x) x) int:->flonum) +(define-standard-unary inexact->exact + (lambda (x) + (if (not (flo:integer? x)) + (error:bad-range-argument x 'INEXACT->EXACT)) + (flo:truncate->exact x)) + (lambda (x) + (guarantee-integer x 'INEXACT->EXACT) + x)) -(let-syntax - ((define-standard-binary - (sc-macro-transformer - (lambda (form environment) - (let ((flo:op (close-syntax (list-ref form 2) environment)) - (int:op (close-syntax (list-ref form 3) environment))) - `(DEFINE (,(list-ref form 1) X Y) - (IF (FLONUM? X) - (IF (FLONUM? Y) - (,flo:op X Y) - (,flo:op X (INT:->FLONUM Y))) - (IF (FLONUM? Y) - (,flo:op (INT:->FLONUM X) Y) - (,int:op X Y))))))))) - (define-standard-binary real:+ flo:+ int:+) - (define-standard-binary real:- flo:- int:-) - (define-standard-binary rationalize - flo:rationalize - int:rationalize)) +(define-syntax define-standard-binary + (sc-macro-transformer + (lambda (form environment) + (let ((flo:op (close-syntax (list-ref form 2) environment)) + (int:op (close-syntax (list-ref form 3) environment))) + `(DEFINE (,(list-ref form 1) X Y) + (IF (FLONUM? X) + (IF (FLONUM? Y) + (,flo:op X Y) + (,flo:op X (INT:->FLONUM Y))) + (IF (FLONUM? Y) + (,flo:op (INT:->FLONUM X) Y) + (,int:op X Y)))))))) + +(define-standard-binary real:+ flo:+ int:+) +(define-standard-binary real:- flo:- int:-) +(define-standard-binary rationalize + flo:rationalize + int:rationalize) (define (int:rationalize q e) (int:simplest-rational (int:- q e) (int:+ q e))) @@ -188,30 +189,30 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. (define (even? n) (int:even? (if (flonum? n) (flo:->integer n) n))) -(let-syntax - ((define-integer-binary - (sc-macro-transformer - (lambda (form environment) - (let ((operator (close-syntax (list-ref form 3) environment)) - (flo->int - (lambda (n) - `(IF (FLO:INTEGER? ,n) - (FLO:->INTEGER ,n) - (ERROR:WRONG-TYPE-ARGUMENT ,n "integer" - ',(list-ref form 2)))))) - `(DEFINE (,(list-ref form 1) N M) - (IF (FLONUM? N) - (INT:->FLONUM - (,operator ,(flo->int 'N) - (IF (FLONUM? M) (FLO:->INTEGER M) M))) - (IF (FLONUM? M) - (INT:->FLONUM (,operator N ,(flo->int 'M))) - (,operator N M))))))))) - (define-integer-binary quotient quotient int:quotient) - (define-integer-binary remainder remainder int:remainder) - (define-integer-binary modulo modulo int:modulo) - (define-integer-binary real:gcd gcd int:gcd) - (define-integer-binary real:lcm lcm int:lcm)) +(define-syntax define-integer-binary + (sc-macro-transformer + (lambda (form environment) + (let ((operator (close-syntax (list-ref form 3) environment)) + (flo->int + (lambda (n) + `(IF (FLO:INTEGER? ,n) + (FLO:->INTEGER ,n) + (ERROR:WRONG-TYPE-ARGUMENT ,n "integer" + ',(list-ref form 2)))))) + `(DEFINE (,(list-ref form 1) N M) + (IF (FLONUM? N) + (INT:->FLONUM + (,operator ,(flo->int 'N) + (IF (FLONUM? M) (FLO:->INTEGER M) M))) + (IF (FLONUM? M) + (INT:->FLONUM (,operator N ,(flo->int 'M))) + (,operator N M)))))))) + +(define-integer-binary quotient quotient int:quotient) +(define-integer-binary remainder remainder int:remainder) +(define-integer-binary modulo modulo int:modulo) +(define-integer-binary real:gcd gcd int:gcd) +(define-integer-binary real:lcm lcm int:lcm) (define (numerator q) (if (flonum? q) @@ -227,23 +228,23 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. (guarantee-integer q 'DENOMINATOR) 1))) -(let-syntax - ((define-transcendental-unary - (sc-macro-transformer - (lambda (form environment) - `(DEFINE (,(list-ref form 1) X) - (IF (,(close-syntax (list-ref form 2) environment) X) - ,(close-syntax (list-ref form 3) environment) - (,(close-syntax (list-ref form 4) environment) - (REAL:->FLONUM X)))))))) - (define-transcendental-unary exp real:exact0= 1 flo:exp) - (define-transcendental-unary log real:exact1= 0 flo:log) - (define-transcendental-unary sin real:exact0= 0 flo:sin) - (define-transcendental-unary cos real:exact0= 1 flo:cos) - (define-transcendental-unary tan real:exact0= 0 flo:tan) - (define-transcendental-unary asin real:exact0= 0 flo:asin) - (define-transcendental-unary acos real:exact1= 0 flo:acos) - (define-transcendental-unary real:atan real:exact0= 0 flo:atan)) +(define-syntax define-transcendental-unary + (sc-macro-transformer + (lambda (form environment) + `(DEFINE (,(list-ref form 1) X) + (IF (,(close-syntax (list-ref form 2) environment) X) + ,(close-syntax (list-ref form 3) environment) + (,(close-syntax (list-ref form 4) environment) + (REAL:->FLONUM X))))))) + +(define-transcendental-unary exp real:exact0= 1 flo:exp) +(define-transcendental-unary log real:exact1= 0 flo:log) +(define-transcendental-unary sin real:exact0= 0 flo:sin) +(define-transcendental-unary cos real:exact0= 1 flo:cos) +(define-transcendental-unary tan real:exact0= 0 flo:tan) +(define-transcendental-unary asin real:exact0= 0 flo:asin) +(define-transcendental-unary acos real:exact1= 0 flo:acos) +(define-transcendental-unary real:atan real:exact0= 0 flo:atan) (define (real:atan2 y x) (if (and (real:exact0= y) (exact? x)) diff --git a/v7/src/sos/class.scm b/v7/src/sos/class.scm index 8b62e950a..0756b967c 100644 --- a/v7/src/sos/class.scm +++ b/v7/src/sos/class.scm @@ -1,25 +1,26 @@ -;;; -*-Scheme-*- -;;; -;;; $Id: class.scm,v 1.13 2002/11/20 19:46:25 cph Exp $ -;;; -;;; Copyright (c) 1995-1999, 2001, 2002 Massachusetts Institute of Technology -;;; -;;; This file is part of MIT Scheme. -;;; -;;; MIT Scheme is free software; you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published -;;; by the Free Software Foundation; either version 2 of the License, -;;; or (at your option) any later version. -;;; -;;; MIT Scheme is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with MIT Scheme; if not, write to the Free Software -;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA -;;; 02111-1307, USA. +#| -*-Scheme-*- + +$Id: class.scm,v 1.14 2003/02/13 05:06:35 cph Exp $ + +Copyright 1995,1997,2002,2002,2003 Massachusetts Institute of Technology + +This file is part of MIT Scheme. + +MIT Scheme is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2 of the License, or (at your +option) any later version. + +MIT Scheme is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT Scheme; if not, write to the Free Software Foundation, +Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +|# ;;;; Classes @@ -44,8 +45,7 @@ dispatch-tag) (define (make-class name direct-superclasses direct-slots) - (if (not (and (list? direct-superclasses) - (for-all? direct-superclasses class?))) + (if (not (list-of-type? direct-superclasses class?)) (error:wrong-type-argument direct-superclasses "list of classes" 'MAKE-CLASS)) @@ -120,41 +120,41 @@ (build-constraints class/direct-superclasses elements) (lambda (partial-cpl elements) (let loop ((partial-cpl (reverse partial-cpl))) - (if (null? partial-cpl) + (if (not (pair? partial-cpl)) (error:bad-range-argument class 'COMPUTE-PRECEDENCE-LIST)) - (let ((ds-of-ce - (class/direct-superclasses (car partial-cpl)))) + (let ((ds-of-ce (class/direct-superclasses (car partial-cpl)))) (let find-common ((elements elements)) - (cond ((null? elements) (loop (cdr partial-cpl))) - ((memq (car elements) ds-of-ce) (car elements)) - (else (find-common (cdr elements))))))))))) + (if (pair? elements) + (if (memq (car elements) ds-of-ce) + (car elements) + (find-common (cdr elements))) + (loop (cdr partial-cpl)))))))))) (define (compute-slots class) (let loop ((slots (append-map class/direct-slots (class/precedence-list class))) (index 1) (descriptors '())) - (if (null? slots) - (reverse! descriptors) + (if (pair? slots) (let ((slot (car slots))) (let ((name (car slot))) (let inner ((slots (cdr slots)) (same '()) (diff '())) - (cond ((null? slots) - (loop (reverse! diff) - (+ index 1) - (cons (compute-slot-descriptor - class - (cons slot (reverse! same)) - index) - descriptors))) - ((eq? name (caar slots)) - (inner (cdr slots) - (cons (car slots) same) - diff)) - (else - (inner (cdr slots) - same - (cons (car slots) diff)))))))))) + (if (pair? slots) + (if (eq? name (caar slots)) + (inner (cdr slots) + (cons (car slots) same) + diff) + (inner (cdr slots) + same + (cons (car slots) diff))) + (loop (reverse! diff) + (+ index 1) + (cons (compute-slot-descriptor + class + (cons slot (reverse! same)) + index) + descriptors)))))) + (reverse! descriptors)))) ;;;; Topological Sort @@ -181,7 +181,7 @@ (let ((minimal (remove-if (lambda (element) (let loop ((constraints constraints)) - (and (not (null? constraints)) + (and (pair? constraints) (or (eq? (cdar constraints) element) (loop (cdr constraints)))))) elements))) @@ -208,26 +208,25 @@ (define (build-transitive-closure get-follow-ons element) (let loop ((result '()) (pending (list element))) - (cond ((null? pending) - result) - ((memq (car pending) result) - (loop result (cdr pending))) - (else - (loop (cons (car pending) result) - (append (get-follow-ons (car pending)) (cdr pending))))))) + (if (pair? pending) + (if (memq (car pending) result) + (loop result (cdr pending)) + (loop (cons (car pending) result) + (append (get-follow-ons (car pending)) (cdr pending)))) + result))) (define (build-constraints get-follow-ons elements) (let loop ((elements elements) (result '())) - (if (null? elements) - result + (if (pair? elements) (loop (cdr elements) (let loop ((element (car elements)) (follow-ons (get-follow-ons (car elements)))) - (if (null? follow-ons) - result + (if (pair? follow-ons) (cons (cons element (car follow-ons)) - (loop (car follow-ons) (cdr follow-ons))))))))) + (loop (car follow-ons) (cdr follow-ons))) + result))) + result))) (define (remove-if predicate items) (let loop ((items items)) @@ -257,28 +256,27 @@ (trim-initial-segment items))) (define (remove-item! item items) - (cond ((null? items) - items) - ((eq? item (car items)) - (cdr items)) - (else - (let loop ((last items) (this (cdr items))) - (if (not (null? this)) - (if (eq? item (car this)) - (set-cdr! last (cdr this)) - (loop this (cdr this))))) - items))) + (if (pair? items) + (if (eq? item (car items)) + (cdr items) + (begin + (let loop ((last items) (this (cdr items))) + (if (pair? this) + (if (eq? item (car this)) + (set-cdr! last (cdr this)) + (loop this (cdr this))))) + items)) + items)) ;;;; Built-in Classes (define (make-class ' (list ) '())) -(let-syntax - ((define-primitive-class - (syntax-rules () - ((define-primitive-class name superclass ...) - (define name - (make-class 'name (list superclass ...) '())))))) +(define-syntax define-primitive-class + (syntax-rules () + ((define-primitive-class name superclass ...) + (define name + (make-class 'name (list superclass ...) '()))))) (define-primitive-class ) (define-primitive-class ) @@ -318,8 +316,6 @@ (define-primitive-class ) (define-primitive-class ) (define-primitive-class ) - -) (define (object-class object) (dispatch-tag->class (dispatch-tag object)))