#| -*-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.
(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))
\f
-(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)))
(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)
(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))
-;;; -*-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
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))
(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))))
\f
;;;; Topological Sort
(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)))
(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)))
\f
(define (remove-if predicate items)
(let loop ((items items))
(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))
\f
;;;; Built-in Classes
(define <instance> (make-class '<INSTANCE> (list <object>) '()))
-(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 <boolean> <object>)
(define-primitive-class <char> <object>)
(define-primitive-class <procedure> <object>)
(define-primitive-class <generic-procedure> <procedure>)
(define-primitive-class <entity> <procedure>)
-
-)
\f
(define (object-class object)
(dispatch-tag->class (dispatch-tag object)))
projects / mit-scheme.git / commitdiff