an incorrect implementation of LET-SYNTAX.
#| -*-Scheme-*-
-$Id: lvalue.scm,v 4.26 2002/11/20 19:45:47 cph Exp $
+$Id: lvalue.scm,v 4.27 2003/02/13 02:38:56 cph Exp $
-Copyright (c) 1988-1990, 1999, 2001, 2002 Massachusetts Institute of Technology
+Copyright 1987,1988,1989,1990,1993,2001 Massachusetts Institute of Technology
+Copyright 2002,2003 Massachusetts Institute of Technology
This file is part of MIT Scheme.
(define-integrable (lvalue/variable? lvalue)
(eq? (tagged-vector/tag lvalue) variable-tag))
-(let-syntax
- ((define-named-variable
- (sc-macro-transformer
- (lambda (form environment)
- environment
- (let* ((name (cadr form))
- (symbol
- (intern (string-append "#[" (symbol->string name) "]"))))
- `(BEGIN (DEFINE-INTEGRABLE
- (,(symbol-append 'MAKE- name '-VARIABLE) BLOCK)
- (MAKE-VARIABLE BLOCK ',symbol))
- (DEFINE-INTEGRABLE
- (,(symbol-append 'VARIABLE/ name '-VARIABLE?) LVALUE)
- (EQ? (VARIABLE-NAME LVALUE) ',symbol))
- (DEFINE (,(symbol-append name '-VARIABLE?) LVALUE)
- (AND (VARIABLE? LVALUE)
- (EQ? (VARIABLE-NAME LVALUE) ',symbol)))))))))
- (define-named-variable continuation)
- (define-named-variable value))
+(define-syntax define-named-variable
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ (let* ((name (cadr form))
+ (symbol
+ (intern (string-append "#[" (symbol->string name) "]"))))
+ `(BEGIN (DEFINE-INTEGRABLE
+ (,(symbol-append 'MAKE- name '-VARIABLE) BLOCK)
+ (MAKE-VARIABLE BLOCK ',symbol))
+ (DEFINE-INTEGRABLE
+ (,(symbol-append 'VARIABLE/ name '-VARIABLE?) LVALUE)
+ (EQ? (VARIABLE-NAME LVALUE) ',symbol))
+ (DEFINE (,(symbol-append name '-VARIABLE?) LVALUE)
+ (AND (VARIABLE? LVALUE)
+ (EQ? (VARIABLE-NAME LVALUE) ',symbol))))))))
+
+(define-named-variable continuation)
+(define-named-variable value)
(define (variable/register variable)
(let ((maybe-delayed-register (variable-register variable)))
#| -*-Scheme-*-
-$Id: macros.scm,v 4.29 2002/11/20 19:45:47 cph Exp $
+$Id: macros.scm,v 4.30 2003/02/13 02:39:03 cph Exp $
-Copyright (c) 1988-1999, 2001, 2002 Massachusetts Institute of Technology
+Copyright 1986,1987,1988,1989,1990,1992 Massachusetts Institute of Technology
+Copyright 1993,1995,2001,2002,2003 Massachusetts Institute of Technology
This file is part of MIT Scheme.
(DESCRIPTOR-LIST OBJECT ,type ,@slots)))))))
(ill-formed-syntax form))))))
\f
-(let-syntax
- ((define-type-definition
- (sc-macro-transformer
- (lambda (form environment)
- (let ((name (cadr form))
- (reserved (caddr form))
- (enumeration (close-syntax (cadddr form) environment)))
- (let ((parent
- (close-syntax (symbol-append name '-TAG) environment)))
- `(define-syntax ,(symbol-append 'DEFINE- name)
- (sc-macro-transformer
- (let ((pattern
- `(SYMBOL * ,(lambda (x)
- (or (symbol? x)
- (and (pair? x)
- (list-of-type? x symbol?)))))))
- (lambda (form environment)
- (if (syntax-match? pattern (cdr form))
- (let ((type (cadr form))
- (slots (cddr form)))
- (let ((tag-name (symbol-append type '-TAG)))
- (let ((tag-ref
- (close-syntax tag-name environment)))
- `(BEGIN
- (DEFINE ,tag-name
- (MAKE-VECTOR-TAG ,',parent ',type
- ,',enumeration))
- (DEFINE ,(symbol-append type '?)
- (TAGGED-VECTOR/PREDICATE ,tag-ref))
- (DEFINE-VECTOR-SLOTS ,type ,,reserved
- ,@slots)
- (SET-VECTOR-TAG-DESCRIPTION!
- ,tag-name
- (LAMBDA (OBJECT)
- (APPEND!
- ((VECTOR-TAG-DESCRIPTION ,',parent)
- OBJECT)
- (DESCRIPTOR-LIST OBJECT
- ,type
- ,@slots))))))))
- (ill-formed-syntax form))))))))))))
- (define-type-definition snode 5 #f)
- (define-type-definition pnode 6 #f)
- (define-type-definition rvalue 2 rvalue-types)
- (define-type-definition lvalue 14 #f))
+(define-syntax define-type-definition
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((name (cadr form))
+ (reserved (caddr form))
+ (enumeration (close-syntax (cadddr form) environment)))
+ (let ((parent
+ (close-syntax (symbol-append name '-TAG) environment)))
+ `(define-syntax ,(symbol-append 'DEFINE- name)
+ (sc-macro-transformer
+ (let ((pattern
+ `(SYMBOL * ,(lambda (x)
+ (or (symbol? x)
+ (and (pair? x)
+ (list-of-type? x symbol?)))))))
+ (lambda (form environment)
+ (if (syntax-match? pattern (cdr form))
+ (let ((type (cadr form))
+ (slots (cddr form)))
+ (let ((tag-name (symbol-append type '-TAG)))
+ (let ((tag-ref
+ (close-syntax tag-name environment)))
+ `(BEGIN
+ (DEFINE ,tag-name
+ (MAKE-VECTOR-TAG ,',parent ',type
+ ,',enumeration))
+ (DEFINE ,(symbol-append type '?)
+ (TAGGED-VECTOR/PREDICATE ,tag-ref))
+ (DEFINE-VECTOR-SLOTS ,type ,,reserved
+ ,@slots)
+ (SET-VECTOR-TAG-DESCRIPTION!
+ ,tag-name
+ (LAMBDA (OBJECT)
+ (APPEND!
+ ((VECTOR-TAG-DESCRIPTION ,',parent)
+ OBJECT)
+ (DESCRIPTOR-LIST OBJECT
+ ,type
+ ,@slots))))))))
+ (ill-formed-syntax form)))))))))))
+
+(define-type-definition snode 5 #f)
+(define-type-definition pnode 6 #f)
+(define-type-definition rvalue 2 rvalue-types)
+(define-type-definition lvalue 14 #f)
(define-syntax descriptor-list
(sc-macro-transformer
#| -*-Scheme-*-
-$Id: utils.scm,v 4.25 2002/11/20 19:45:48 cph Exp $
+$Id: utils.scm,v 4.26 2003/02/13 02:39:10 cph Exp $
-Copyright (c) 1987-1999, 2001, 2002 Massachusetts Institute of Technology
+Copyright 1986,1987,1988,1989,1990,1992 Massachusetts Institute of Technology
+Copyright 1994,2001,2001,2003 Massachusetts Institute of Technology
This file is part of MIT Scheme.
(if (null? sets)
(eq-set-union set accum)
(loop (car sets) (cdr sets) (eq-set-union set accum)))))
-\f
+
(package (transitive-closure enqueue-node! enqueue-nodes!)
(define *queue*)
\f
;;;; Type Codes
-(let-syntax ((define-type-code
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE-INTEGRABLE ,(symbol-append 'TYPE-CODE: (cadr form))
- ',(microcode-type (cadr form)))))))
- (define-type-code lambda)
- (define-type-code extended-lambda)
- (define-type-code procedure)
- (define-type-code extended-procedure)
- (define-type-code cell)
- (define-type-code environment)
- (define-type-code unassigned)
- (define-type-code stack-environment)
- (define-type-code compiled-entry))
+(define-syntax define-type-code
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ `(DEFINE-INTEGRABLE ,(symbol-append 'TYPE-CODE: (cadr form))
+ ',(microcode-type (cadr form))))))
+
+(define-type-code lambda)
+(define-type-code extended-lambda)
+(define-type-code procedure)
+(define-type-code extended-procedure)
+(define-type-code cell)
+(define-type-code environment)
+(define-type-code unassigned)
+(define-type-code stack-environment)
+(define-type-code compiled-entry)
(define (scode/procedure-type-code *lambda)
(cond ((object-type? type-code:lambda *lambda)
(let ((arity (primitive-procedure-arity primitive)))
(or (= arity -1)
(= arity argument-count)))))
-\f
+
;;;; Special Compiler Support
(define compiled-error-procedure
(define procedure-object?
(lexical-reference system-global-environment 'PROCEDURE?))
-;;!(define (careful-object-datum object)
-;;! ;; This works correctly when cross-compiling.
-;;! (if (and (object-type? (ucode-type fixnum) object)
-;;! (negative? object))
-;;! (+ object unsigned-fixnum/upper-limit)
-;;! (object-datum object)))
-
(define (careful-object-datum object)
;; This works correctly when cross-compiling.
(if (and (fix:fixnum? object)
(negative? object))
(+ object unsigned-fixnum/upper-limit)
- (object-datum object)))
-
+ (object-datum object)))
\ No newline at end of file
#| -*-Scheme-*-
-$Id: canon.scm,v 1.23 2002/11/20 19:45:49 cph Exp $
+$Id: canon.scm,v 1.24 2003/02/13 02:39:32 cph Exp $
-Copyright (c) 1988-1999, 2001, 2002 Massachusetts Institute of Technology
+Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology
+Copyright 2001,2002,2003 Massachusetts Institute of Technology
This file is part of MIT Scheme.
\f
;;;; Hairier expressions
-(let-syntax
- ((is-operator?
- (sc-macro-transformer
- (lambda (form environment)
- (let ((value (close-syntax (cadr form) environment))
- (name (caddr form)))
- `(OR (EQ? ,value (UCODE-PRIMITIVE ,name))
- (AND (SCODE/ABSOLUTE-REFERENCE? ,value)
- (EQ? (SCODE/ABSOLUTE-REFERENCE-NAME ,value) ',name))))))))
-
- (define (canonicalize/combination expr bound context)
- (scode/combination-components
- expr
- (lambda (operator operands)
- (cond ((lambda? operator)
- (canonicalize/let operator operands bound context))
- ((and (is-operator? operator lexical-unassigned?)
- (scode/the-environment? (car operands))
- (symbol? (cadr operands)))
- (canonicalize/unassigned? (cadr operands) expr bound context))
- ((and (is-operator? operator error-procedure)
- (scode/the-environment? (caddr operands)))
- (canonicalize/error operator operands bound context))
- (else
- (canonicalize/combine-binary
- scode/make-combination
- (canonicalize/expression operator bound context)
- (combine-list
- (map (lambda (op)
- (canonicalize/expression op bound context))
- operands)))))))))
+(define-syntax is-operator?
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((value (close-syntax (cadr form) environment))
+ (name (caddr form)))
+ `(OR (EQ? ,value (UCODE-PRIMITIVE ,name))
+ (AND (SCODE/ABSOLUTE-REFERENCE? ,value)
+ (EQ? (SCODE/ABSOLUTE-REFERENCE-NAME ,value) ',name)))))))
+
+(define (canonicalize/combination expr bound context)
+ (scode/combination-components
+ expr
+ (lambda (operator operands)
+ (cond ((lambda? operator)
+ (canonicalize/let operator operands bound context))
+ ((and (is-operator? operator lexical-unassigned?)
+ (scode/the-environment? (car operands))
+ (symbol? (cadr operands)))
+ (canonicalize/unassigned? (cadr operands) expr bound context))
+ ((and (is-operator? operator error-procedure)
+ (scode/the-environment? (caddr operands)))
+ (canonicalize/error operator operands bound context))
+ (else
+ (canonicalize/combine-binary
+ scode/make-combination
+ (canonicalize/expression operator bound context)
+ (combine-list
+ (map (lambda (op)
+ (canonicalize/expression op bound context))
+ operands))))))))
(define (canonicalize/unassigned? name expr bound context)
(cond ((not (eq? context 'FIRST-CLASS))
(caddr text))
false true false)
(make-canout expr true true false))))))))
-\f
+
;;;; Utility for hairy expressions
(define (scode/make-evaluation exp env arbitrary? original-expression)
#| -*-Scheme-*-
-$Id: lapgen.scm,v 1.32 2002/11/20 19:45:52 cph Exp $
+$Id: lapgen.scm,v 1.33 2003/02/13 02:39:48 cph Exp $
-Copyright (c) 1992-1999, 2001, 2002 Massachusetts Institute of Technology
+Copyright 1992,1993,1998,2001,2002,2003 Massachusetts Institute of Technology
This file is part of MIT Scheme.
register-block/stack-guard-offset))
-(let-syntax ((define-codes
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(BEGIN
- ,@(let loop ((names (cddr form)) (index (cadr form)))
- (if (pair? names)
- (cons `(DEFINE-INTEGRABLE
- ,(symbol-append 'CODE:COMPILER-
- (car names))
- ,index)
- (loop (cdr names) (+ index 1)))
- '())))))))
- (define-codes #x012
- primitive-apply primitive-lexpr-apply
- apply error lexpr-apply link
- interrupt-closure interrupt-dlink interrupt-procedure
- interrupt-continuation interrupt-ic-procedure
- assignment-trap cache-reference-apply
- reference-trap safe-reference-trap unassigned?-trap
- -1+ &/ &= &> 1+ &< &- &* negative? &+ positive? zero?
- access lookup safe-lookup unassigned? unbound?
- set! define lookup-apply primitive-error
- quotient remainder modulo))
+(define-syntax define-codes
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ `(BEGIN
+ ,@(let loop ((names (cddr form)) (index (cadr form)))
+ (if (pair? names)
+ (cons `(DEFINE-INTEGRABLE
+ ,(symbol-append 'CODE:COMPILER-
+ (car names))
+ ,index)
+ (loop (cdr names) (+ index 1)))
+ '()))))))
+
+(define-codes #x012
+ primitive-apply primitive-lexpr-apply
+ apply error lexpr-apply link
+ interrupt-closure interrupt-dlink interrupt-procedure
+ interrupt-continuation interrupt-ic-procedure
+ assignment-trap cache-reference-apply
+ reference-trap safe-reference-trap unassigned?-trap
+ -1+ &/ &= &> 1+ &< &- &* negative? &+ positive? zero?
+ access lookup safe-lookup unassigned? unbound?
+ set! define lookup-apply primitive-error
+ quotient remainder modulo)
(define-integrable (invoke-hook entry)
(LAP (JMP ,entry)))
(LAP (MOV B (R ,eax) (& ,code))
,@(invoke-hook/call entry:compiler-scheme-to-interface/call)))
\f
-(let-syntax
- ((define-entries
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(BEGIN
- ,@(let loop
- ((names (cdddr form))
- (index (cadr form))
- (high (caddr form)))
- (if (pair? names)
- (if (< index high)
- (cons `(DEFINE-INTEGRABLE
- ,(symbol-append 'ENTRY:COMPILER-
- (car names))
- (byte-offset-reference regnum:regs-pointer
- ,index))
- (loop (cdr names) (+ index 4) high))
- (begin
- (warn "define-entries: Too many for byte offsets.")
- (loop names index (+ high 32000))))
- '())))))))
- (define-entries #x40 #x80 ; (* 16 4)
- scheme-to-interface ; Main entry point (only one necessary)
- scheme-to-interface/call ; Used by rules3&4, for convenience.
- trampoline-to-interface ; Used by trampolines, for convenience.
- interrupt-procedure
- interrupt-continuation
- interrupt-closure
- interrupt-dlink
- primitive-apply
- primitive-lexpr-apply
- assignment-trap
- reference-trap
- safe-reference-trap
- link
- error
- primitive-error
- short-primitive-apply)
-
- (define-entries #x-80 0
- &+
- &-
- &*
- &/
- &=
- &<
- &>
- 1+
- -1+
- zero?
- positive?
- negative?
- quotient
- remainder
- modulo
- shortcircuit-apply ; Used by rules3, for speed.
- shortcircuit-apply-size-1 ; Small frames, save time and space.
- shortcircuit-apply-size-2
- shortcircuit-apply-size-3
- shortcircuit-apply-size-4
- shortcircuit-apply-size-5
- shortcircuit-apply-size-6
- shortcircuit-apply-size-7
- shortcircuit-apply-size-8
- interrupt-continuation-2
- conditionally-serialize))
+(define-syntax define-entries
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ `(BEGIN
+ ,@(let loop
+ ((names (cdddr form))
+ (index (cadr form))
+ (high (caddr form)))
+ (if (pair? names)
+ (if (< index high)
+ (cons `(DEFINE-INTEGRABLE
+ ,(symbol-append 'ENTRY:COMPILER-
+ (car names))
+ (byte-offset-reference regnum:regs-pointer
+ ,index))
+ (loop (cdr names) (+ index 4) high))
+ (begin
+ (warn "define-entries: Too many for byte offsets.")
+ (loop names index (+ high 32000))))
+ '()))))))
+
+(define-entries #x40 #x80 ; (* 16 4)
+ scheme-to-interface ; Main entry point (only one necessary)
+ scheme-to-interface/call ; Used by rules3&4, for convenience.
+ trampoline-to-interface ; Used by trampolines, for convenience.
+ interrupt-procedure
+ interrupt-continuation
+ interrupt-closure
+ interrupt-dlink
+ primitive-apply
+ primitive-lexpr-apply
+ assignment-trap
+ reference-trap
+ safe-reference-trap
+ link
+ error
+ primitive-error
+ short-primitive-apply)
+
+(define-entries #x-80 0
+ &+
+ &-
+ &*
+ &/
+ &=
+ &<
+ &>
+ 1+
+ -1+
+ zero?
+ positive?
+ negative?
+ quotient
+ remainder
+ modulo
+ shortcircuit-apply ; Used by rules3, for speed.
+ shortcircuit-apply-size-1 ; Small frames, save time and space.
+ shortcircuit-apply-size-2
+ shortcircuit-apply-size-3
+ shortcircuit-apply-size-4
+ shortcircuit-apply-size-5
+ shortcircuit-apply-size-6
+ shortcircuit-apply-size-7
+ shortcircuit-apply-size-8
+ interrupt-continuation-2
+ conditionally-serialize)
\f
;; Operation tables
#| -*-Scheme-*-
-$Id: rtlreg.scm,v 4.10 2002/11/20 19:45:56 cph Exp $
+$Id: rtlreg.scm,v 4.11 2003/02/13 02:38:20 cph Exp $
-Copyright (c) 1987, 1988, 1990, 1999, 2001, 2002 Massachusetts Institute of Technology
+Copyright 1987,1988,1990,1999,2001,2002 Massachusetts Institute of Technology
+Copyright 2003 Massachusetts Institute of Technology
This file is part of MIT Scheme.
;;;; RTL Registers
(declare (usual-integrations))
-\f
+
(define *machine-register-map*)
(define (initialize-machine-register-map!)
(loop (1+ register)))))
(loop number-of-machine-registers)))
\f
-(let-syntax
- ((define-register-references
- (sc-macro-transformer
- (lambda (form environment)
- (let ((slot (cadr form)))
- (let ((name (symbol-append 'REGISTER- slot)))
- (let ((vector
- `(,(close-syntax (symbol-append 'RGRAPH- name)
- environment)
- *CURRENT-RGRAPH*)))
- `(BEGIN
- (DEFINE-INTEGRABLE (,name REGISTER)
- (VECTOR-REF ,vector REGISTER))
- (DEFINE-INTEGRABLE
- (,(symbol-append 'SET- name '!) REGISTER VALUE)
- (VECTOR-SET! ,vector REGISTER VALUE))))))))))
- (define-register-references bblock)
- (define-register-references n-refs)
- (define-register-references n-deaths)
- (define-register-references live-length)
- (define-register-references renumber))
+(define-syntax define-register-references
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((slot (cadr form)))
+ (let ((name (symbol-append 'REGISTER- slot)))
+ (let ((vector
+ `(,(close-syntax (symbol-append 'RGRAPH- name)
+ environment)
+ *CURRENT-RGRAPH*)))
+ `(BEGIN
+ (DEFINE-INTEGRABLE (,name REGISTER)
+ (VECTOR-REF ,vector REGISTER))
+ (DEFINE-INTEGRABLE
+ (,(symbol-append 'SET- name '!) REGISTER VALUE)
+ (VECTOR-SET! ,vector REGISTER VALUE)))))))))
+
+(define-register-references bblock)
+(define-register-references n-refs)
+(define-register-references n-deaths)
+(define-register-references live-length)
+(define-register-references renumber)
(define-integrable (reset-register-n-refs! register)
(set-register-n-refs! register 0))
#| -*-Scheme-*-
-$Id: valclass.scm,v 1.6 2002/11/20 19:45:56 cph Exp $
+$Id: valclass.scm,v 1.7 2003/02/13 02:38:27 cph Exp $
-Copyright (c) 1989, 1990, 1999, 2002 Massachusetts Institute of Technology
+Copyright 1989,1990,1999,2001,2002,2003 Massachusetts Institute of Technology
This file is part of MIT Scheme.
(loop (car x) (cdr x) (cdr y))
join)))
\f
-(let-syntax
- ((define-value-class
- (sc-macro-transformer
- (lambda (form environment)
- (let ((name (cadr form))
- (parent-name (caddr form)))
- (let* ((name->variable
- (lambda (name)
- (symbol-append 'VALUE-CLASS= name)))
- (variable (name->variable name))
- (var-ref (close-syntax variable environment)))
- `(BEGIN
- (DEFINE ,variable
- (MAKE-VALUE-CLASS
- ',name
- ,(if parent-name
- (close-syntax (name->variable parent-name)
- environment)
- `#F)))
- (DEFINE (,(symbol-append variable '?) CLASS)
- (VALUE-CLASS/ANCESTOR-OR-SELF? CLASS ,variable))
- (DEFINE (,(symbol-append 'REGISTER- variable '?) REGISTER)
- (VALUE-CLASS/ANCESTOR-OR-SELF?
- (REGISTER-VALUE-CLASS REGISTER)
- ,variable)))))))))
- (define-value-class value #f)
- (define-value-class float value)
- (define-value-class word value)
- (define-value-class object word)
- (define-value-class unboxed word)
- (define-value-class address unboxed)
- (define-value-class immediate unboxed)
- (define-value-class ascii immediate)
- (define-value-class datum immediate)
- (define-value-class fixnum immediate)
- (define-value-class type immediate))
\ No newline at end of file
+(define-syntax define-value-class
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((name (cadr form))
+ (parent-name (caddr form)))
+ (let* ((name->variable
+ (lambda (name)
+ (symbol-append 'VALUE-CLASS= name)))
+ (variable (name->variable name))
+ (var-ref (close-syntax variable environment)))
+ `(BEGIN
+ (DEFINE ,variable
+ (MAKE-VALUE-CLASS
+ ',name
+ ,(if parent-name
+ (close-syntax (name->variable parent-name)
+ environment)
+ `#F)))
+ (DEFINE (,(symbol-append variable '?) CLASS)
+ (VALUE-CLASS/ANCESTOR-OR-SELF? CLASS ,variable))
+ (DEFINE (,(symbol-append 'REGISTER- variable '?) REGISTER)
+ (VALUE-CLASS/ANCESTOR-OR-SELF?
+ (REGISTER-VALUE-CLASS REGISTER)
+ ,variable))))))))
+
+(define-value-class value #f)
+(define-value-class float value)
+(define-value-class word value)
+(define-value-class object word)
+(define-value-class unboxed word)
+(define-value-class address unboxed)
+(define-value-class immediate unboxed)
+(define-value-class ascii immediate)
+(define-value-class datum immediate)
+(define-value-class fixnum immediate)
+(define-value-class type immediate)
\ No newline at end of file
-;;; -*-Scheme-*-
-;;;
-;;; $Id: buffer.scm,v 1.188 2002/11/20 19:45:58 cph Exp $
-;;;
-;;; Copyright (c) 1986, 1989-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: buffer.scm,v 1.189 2003/02/13 02:36:44 cph Exp $
+
+Copyright 1986,1989,1990,1991,1992,1993 Massachusetts Institute of Technology
+Copyright 1994,1995,1996,1998,1999,2000 Massachusetts Institute of Technology
+Copyright 2001,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.
+
+|#
;;;; Buffer Abstraction
backed-up?
modification-time)
-(let-syntax
- ((rename
- (sc-macro-transformer
- (lambda (form environment)
- (let ((slot-name (cadr form)))
- `(DEFINE-INTEGRABLE ,(symbol-append 'BUFFER- slot-name)
- ,(close-syntax (symbol-append 'BUFFER-% slot-name)
- environment)))))))
- (rename name)
- (rename default-directory)
- (rename pathname)
- (rename truename)
- (rename save-length))
+(define-syntax rename-buffer-accessor
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((slot-name (cadr form)))
+ `(DEFINE-INTEGRABLE ,(symbol-append 'BUFFER- slot-name)
+ ,(close-syntax (symbol-append 'BUFFER-% slot-name)
+ environment))))))
+
+(rename-buffer-accessor name)
+(rename-buffer-accessor default-directory)
+(rename-buffer-accessor pathname)
+(rename-buffer-accessor truename)
+(rename-buffer-accessor save-length)
(define-variable buffer-creation-hook
"An event distributor that is invoked when a new buffer is created.
#| -*-Scheme-*-
-$Id: calias.scm,v 1.28 2003/01/10 18:52:09 cph Exp $
+$Id: calias.scm,v 1.29 2003/02/13 02:36:51 cph Exp $
Copyright 1986,1989,1991,1992,1994,1995 Massachusetts Institute of Technology
Copyright 1998,2000,2001,2002,2003 Massachusetts Institute of Technology
intern-special-key)
;; Predefined special keys
-(let-syntax ((make-key
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE ,(cadr form)
- (INTERN-SPECIAL-KEY ',(cadr form) 0))))))
- (make-key backspace)
- (make-key stop)
- (make-key f1)
- (make-key f2)
- (make-key f3)
- (make-key f4)
- (make-key menu)
- (make-key system)
- (make-key user)
- (make-key f5)
- (make-key f6)
- (make-key f7)
- (make-key f8)
- (make-key f9)
- (make-key f10)
- (make-key f11)
- (make-key f12)
- (make-key insertline)
- (make-key deleteline)
- (make-key insertchar)
- (make-key deletechar)
- (make-key home)
- (make-key prior)
- (make-key next)
- (make-key up)
- (make-key down)
- (make-key left)
- (make-key right)
- (make-key select)
- (make-key print))
\ No newline at end of file
+(define-syntax define-special-key
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ `(DEFINE ,(cadr form)
+ (INTERN-SPECIAL-KEY ',(cadr form) 0)))))
+
+(define-special-key backspace)
+(define-special-key stop)
+(define-special-key f1)
+(define-special-key f2)
+(define-special-key f3)
+(define-special-key f4)
+(define-special-key menu)
+(define-special-key system)
+(define-special-key user)
+(define-special-key f5)
+(define-special-key f6)
+(define-special-key f7)
+(define-special-key f8)
+(define-special-key f9)
+(define-special-key f10)
+(define-special-key f11)
+(define-special-key f12)
+(define-special-key insertline)
+(define-special-key deleteline)
+(define-special-key insertchar)
+(define-special-key deletechar)
+(define-special-key home)
+(define-special-key prior)
+(define-special-key next)
+(define-special-key up)
+(define-special-key down)
+(define-special-key left)
+(define-special-key right)
+(define-special-key select)
+(define-special-key print)
\ No newline at end of file
-;;; -*-Scheme-*-
-;;;
-;;; $Id: dosproc.scm,v 1.10 2002/11/20 19:45:59 cph Exp $
-;;;
-;;; Copyright (c) 1992-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: dosproc.scm,v 1.11 2003/02/13 02:36:59 cph Exp $
+
+Copyright 1992,1993,2001,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.
+
+|#
;;;; Dummy subprocess support
;; package: (edwin process)
(lambda (process)
(editor-error "Processes not implemented" name process)))
-(let-syntax ((define-process-operation
- (sc-macro-transformer
- (lambda (form environment)
- environment
- `(DEFINE ,(cadr form) (PROCESS-OPERATION ',(cadr form)))))))
- (define-process-operation delete-process))
+(define delete-process
+ (process-operation 'DELETE-PROCESS))
(define (process-status-changes?)
#f)
-;;; -*-Scheme-*-
-;;;
-;;; $Id: grpops.scm,v 1.29 2002/11/20 19:46:00 cph Exp $
-;;;
-;;; Copyright (c) 1986, 1989-2000 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: grpops.scm,v 1.30 2003/02/13 02:37:06 cph Exp $
+
+Copyright 1986,1989,1991,1993,1995,1996 Massachusetts Institute of Technology
+Copyright 1999,2000,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.
+
+|#
;;;; Group Operations
-;;; -*-Scheme-*-
-;;;
-;;;$Id: search.scm,v 1.156 2002/11/20 19:46:03 cph Exp $
-;;;
-;;; Copyright (c) 1986, 1989-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: search.scm,v 1.157 2003/02/13 02:37:13 cph Exp $
+
+Copyright 1986,1989,1990,1991,2001,2002 Massachusetts Institute of Technology
+Copyright 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.
+
+|#
;;;; Search/Match Primitives
(declare (usual-integrations))
\f
-(let-syntax
- ((define-search
- (sc-macro-transformer
- (lambda (form environment)
- (let ((name (cadr form))
- (find-next (close-syntax (caddr form) environment)))
- `(DEFINE (,name GROUP START END CHAR)
- ;; Assume (FIX:<= START END)
- (AND (NOT (FIX:= START END))
- (COND ((FIX:<= END (GROUP-GAP-START GROUP))
- (,find-next (GROUP-TEXT GROUP) START END CHAR))
- ((FIX:<= (GROUP-GAP-START GROUP) START)
- (LET ((POSITION
- (,find-next
- (GROUP-TEXT GROUP)
- (FIX:+ START (GROUP-GAP-LENGTH GROUP))
- (FIX:+ END (GROUP-GAP-LENGTH GROUP))
- CHAR)))
- (AND POSITION
- (FIX:- POSITION (GROUP-GAP-LENGTH GROUP)))))
- ((,find-next (GROUP-TEXT GROUP)
- START
- (GROUP-GAP-START GROUP)
- CHAR))
- (ELSE
- (LET ((POSITION
- (,find-next (GROUP-TEXT GROUP)
- (GROUP-GAP-END GROUP)
- (FIX:+ END
- (GROUP-GAP-LENGTH GROUP))
- CHAR)))
- (AND POSITION
- (FIX:- POSITION
- (GROUP-GAP-LENGTH GROUP)))))))))))))
- (define-search group-find-next-char substring-find-next-char)
- (define-search group-find-next-char-ci substring-find-next-char-ci)
- (define-search group-find-next-char-in-set substring-find-next-char-in-set))
+(define-syntax define-next-char-search
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((name (cadr form))
+ (find-next (close-syntax (caddr form) environment)))
+ `(DEFINE (,name GROUP START END CHAR)
+ ;; Assume (FIX:<= START END)
+ (AND (NOT (FIX:= START END))
+ (COND ((FIX:<= END (GROUP-GAP-START GROUP))
+ (,find-next (GROUP-TEXT GROUP) START END CHAR))
+ ((FIX:<= (GROUP-GAP-START GROUP) START)
+ (LET ((POSITION
+ (,find-next
+ (GROUP-TEXT GROUP)
+ (FIX:+ START (GROUP-GAP-LENGTH GROUP))
+ (FIX:+ END (GROUP-GAP-LENGTH GROUP))
+ CHAR)))
+ (AND POSITION
+ (FIX:- POSITION (GROUP-GAP-LENGTH GROUP)))))
+ ((,find-next (GROUP-TEXT GROUP)
+ START
+ (GROUP-GAP-START GROUP)
+ CHAR))
+ (ELSE
+ (LET ((POSITION
+ (,find-next (GROUP-TEXT GROUP)
+ (GROUP-GAP-END GROUP)
+ (FIX:+ END
+ (GROUP-GAP-LENGTH GROUP))
+ CHAR)))
+ (AND POSITION
+ (FIX:- POSITION
+ (GROUP-GAP-LENGTH GROUP))))))))))))
+
+(define-next-char-search group-find-next-char
+ substring-find-next-char)
+(define-next-char-search group-find-next-char-ci
+ substring-find-next-char-ci)
+(define-next-char-search group-find-next-char-in-set
+ substring-find-next-char-in-set)
+
+(define-syntax define-prev-char-search
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((name (cadr form))
+ (find-previous (close-syntax (caddr form) environment)))
+ `(DEFINE (,name GROUP START END CHAR)
+ ;; Assume (FIX:<= START END)
+ (AND (NOT (FIX:= START END))
+ (COND ((FIX:<= END (GROUP-GAP-START GROUP))
+ (,find-previous (GROUP-TEXT GROUP) START END CHAR))
+ ((FIX:<= (GROUP-GAP-START GROUP) START)
+ (LET ((POSITION
+ (,find-previous
+ (GROUP-TEXT GROUP)
+ (FIX:+ START (GROUP-GAP-LENGTH GROUP))
+ (FIX:+ END (GROUP-GAP-LENGTH GROUP))
+ CHAR)))
+ (AND POSITION
+ (FIX:- POSITION (GROUP-GAP-LENGTH GROUP)))))
+ ((,find-previous (GROUP-TEXT GROUP)
+ (GROUP-GAP-END GROUP)
+ (FIX:+ END (GROUP-GAP-LENGTH GROUP))
+ CHAR)
+ => (LAMBDA (POSITION)
+ (FIX:- POSITION (GROUP-GAP-LENGTH GROUP))))
+ (else
+ (,find-previous (GROUP-TEXT GROUP)
+ START
+ (GROUP-GAP-START GROUP)
+ CHAR)))))))))
-(let-syntax
- ((define-search
- (sc-macro-transformer
- (lambda (form environment)
- (let ((name (cadr form))
- (find-previous (close-syntax (caddr form) environment)))
- `(DEFINE (,name GROUP START END CHAR)
- ;; Assume (FIX:<= START END)
- (AND (NOT (FIX:= START END))
- (COND ((FIX:<= END (GROUP-GAP-START GROUP))
- (,find-previous (GROUP-TEXT GROUP) START END CHAR))
- ((FIX:<= (GROUP-GAP-START GROUP) START)
- (LET ((POSITION
- (,find-previous
- (GROUP-TEXT GROUP)
- (FIX:+ START (GROUP-GAP-LENGTH GROUP))
- (FIX:+ END (GROUP-GAP-LENGTH GROUP))
- CHAR)))
- (AND POSITION
- (FIX:- POSITION (GROUP-GAP-LENGTH GROUP)))))
- ((,find-previous (GROUP-TEXT GROUP)
- (GROUP-GAP-END GROUP)
- (FIX:+ END (GROUP-GAP-LENGTH GROUP))
- CHAR)
- => (LAMBDA (POSITION)
- (FIX:- POSITION (GROUP-GAP-LENGTH GROUP))))
- (else
- (,find-previous (GROUP-TEXT GROUP)
- START
- (GROUP-GAP-START GROUP)
- CHAR))))))))))
- (define-search group-find-previous-char substring-find-previous-char)
- (define-search group-find-previous-char-ci substring-find-previous-char-ci)
- (define-search group-find-previous-char-in-set
- substring-find-previous-char-in-set))
+(define-prev-char-search group-find-previous-char
+ substring-find-previous-char)
+(define-prev-char-search group-find-previous-char-ci
+ substring-find-previous-char-ci)
+(define-prev-char-search group-find-previous-char-in-set
+ substring-find-previous-char-in-set)
\f
(define-integrable (%find-next-newline group start end)
(group-find-next-char group start end #\newline))
#| -*-Scheme-*-
-$Id: tterm.scm,v 1.36 2003/01/22 18:43:51 cph Exp $
+$Id: tterm.scm,v 1.37 2003/02/13 02:37:21 cph Exp $
Copyright 1990,1991,1993,1994,1998,1999 Massachusetts Institute of Technology
Copyright 2001,2002,2003 Massachusetts Institute of Technology
(scroll-region false)
(key-table false))
-(let-syntax ((define-accessor
- (sc-macro-transformer
- (lambda (form environment)
- (let ((name (cadr form)))
- `(DEFINE-INTEGRABLE (,(symbol-append 'SCREEN- name) SCREEN)
- (,(close-syntax (symbol-append 'TERMINAL-STATE/ name)
- environment)
- (SCREEN-STATE SCREEN)))))))
- (define-updater
- (sc-macro-transformer
- (lambda (form environment)
- (let ((name (cadr form)))
- (let ((param (make-synthetic-identifier name)))
- `(DEFINE-INTEGRABLE
- (,(symbol-append 'SET-SCREEN- name '!) SCREEN ,param)
- (,(close-syntax
- (symbol-append 'SET-TERMINAL-STATE/ name '!)
- environment)
- (SCREEN-STATE SCREEN)
- ,param))))))))
- (define-accessor description)
- (define-accessor baud-rate-index)
- (define-accessor baud-rate)
- (define-accessor insert-line-cost)
- (define-accessor insert-line-next-cost)
- (define-accessor delete-line-cost)
- (define-accessor delete-line-next-cost)
- (define-accessor scroll-region-cost)
- (define-accessor cursor-x)
- (define-updater cursor-x)
- (define-accessor cursor-y)
- (define-updater cursor-y)
- (define-accessor standout-mode?)
- (define-updater standout-mode?)
- (define-accessor insert-mode?)
- (define-updater insert-mode?)
- (define-accessor delete-mode?)
- (define-updater delete-mode?)
- (define-accessor scroll-region)
- (define-updater scroll-region))
+(define-syntax define-ts-accessor
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((name (cadr form)))
+ `(DEFINE-INTEGRABLE (,(symbol-append 'SCREEN- name) SCREEN)
+ (,(close-syntax (symbol-append 'TERMINAL-STATE/ name)
+ environment)
+ (SCREEN-STATE SCREEN)))))))
+
+(define-syntax define-ts-modifier
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((name (cadr form)))
+ (let ((param (make-synthetic-identifier name)))
+ `(DEFINE-INTEGRABLE
+ (,(symbol-append 'SET-SCREEN- name '!) SCREEN ,param)
+ (,(close-syntax
+ (symbol-append 'SET-TERMINAL-STATE/ name '!)
+ environment)
+ (SCREEN-STATE SCREEN)
+ ,param)))))))
+
+(define-ts-accessor description)
+(define-ts-accessor baud-rate-index)
+(define-ts-accessor baud-rate)
+(define-ts-accessor insert-line-cost)
+(define-ts-accessor insert-line-next-cost)
+(define-ts-accessor delete-line-cost)
+(define-ts-accessor delete-line-next-cost)
+(define-ts-accessor scroll-region-cost)
+(define-ts-accessor cursor-x)
+(define-ts-modifier cursor-x)
+(define-ts-accessor cursor-y)
+(define-ts-modifier cursor-y)
+(define-ts-accessor standout-mode?)
+(define-ts-modifier standout-mode?)
+(define-ts-accessor insert-mode?)
+(define-ts-modifier insert-mode?)
+(define-ts-accessor delete-mode?)
+(define-ts-modifier delete-mode?)
+(define-ts-accessor scroll-region)
+(define-ts-modifier scroll-region)
\f
;;;; Console Screen Operations
-;;; -*-Scheme-*-
-;;;
-;;; $Id: xcom.scm,v 1.22 2002/11/20 19:46:04 cph Exp $
-;;;
-;;; Copyright (c) 1989-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: xcom.scm,v 1.23 2003/02/13 02:37:28 cph Exp $
+
+Copyright 1989,1990,1994,1996,2000,2001 Massachusetts Institute of Technology
+Copyright 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.
+
+|#
;;;; X Commands
(lambda ()
(list (prompt-for-alist-value "Set mouse shape"
(map (lambda (x) (cons x x))
- (vector->list mouse-cursor-shapes)))))
+ mouse-cursor-shapes))))
(lambda (shape)
(x-window-set-mouse-shape
(current-xterm)
- (let ((end (vector-length mouse-cursor-shapes)))
- (let loop ((index 0))
- (cond ((>= index end)
- (error "Unknown shape name" shape))
- ((string-ci=? (vector-ref mouse-cursor-shapes index) shape)
- index)
- (else
- (loop (1+ index)))))))))
-\f
+ (let loop ((shapes mouse-cursor-shapes) (index 0))
+ (if (not (pair? shapes))
+ (error "Unknown shape name:" shape))
+ (if (string-ci=? shape (car shapes))
+ index
+ (loop (cdr shapes) (fix:+ index 1)))))))
+
(define mouse-cursor-shapes
- '#("X-cursor"
- "arrow"
- "based-arrow-down"
- "based-arrow-up"
- "boat"
- "bogosity"
- "bottom-left-corner"
- "bottom-right-corner"
- "bottom-side"
- "bottom-tee"
- "box-spiral"
- "center-ptr"
- "circle"
- "clock"
- "coffee-mug"
- "cross"
- "cross-reverse"
- "crosshair"
- "diamond-cross"
- "dot"
- "dotbox"
- "double-arrow"
- "draft-large"
- "draft-small"
- "draped-box"
- "exchange"
- "fleur"
- "gobbler"
- "gumby"
- "hand1"
- "hand2"
- "heart"
- "icon"
- "iron-cross"
- "left-ptr"
- "left-side"
- "left-tee"
- "leftbutton"
- "ll-angle"
- "lr-angle"
- "man"
- "middlebutton"
- "mouse"
- "pencil"
- "pirate"
- "plus"
- "question-arrow"
- "right-ptr"
- "right-side"
- "right-tee"
- "rightbutton"
- "rtl-logo"
- "sailboat"
- "sb-down-arrow"
- "sb-h-double-arrow"
- "sb-left-arrow"
- "sb-right-arrow"
- "sb-up-arrow"
- "sb-v-double-arrow"
- "shuttle"
- "sizing"
- "spider"
- "spraycan"
- "star"
- "target"
- "tcross"
- "top-left-arrow"
- "top-left-corner"
- "top-right-corner"
- "top-side"
- "top-tee"
- "trek"
- "ul-angle"
- "umbrella"
- "ur-angle"
- "watch"
- "xterm"))
+ '("X-cursor" "arrow" "based-arrow-down" "based-arrow-up" "boat" "bogosity"
+ "bottom-left-corner" "bottom-right-corner" "bottom-side"
+ "bottom-tee" "box-spiral" "center-ptr" "circle" "clock"
+ "coffee-mug" "cross" "cross-reverse" "crosshair" "diamond-cross"
+ "dot" "dotbox" "double-arrow" "draft-large" "draft-small"
+ "draped-box" "exchange" "fleur" "gobbler" "gumby" "hand1"
+ "hand2" "heart" "icon" "iron-cross" "left-ptr" "left-side"
+ "left-tee" "leftbutton" "ll-angle" "lr-angle" "man"
+ "middlebutton" "mouse" "pencil" "pirate" "plus" "question-arrow"
+ "right-ptr" "right-side" "right-tee" "rightbutton" "rtl-logo"
+ "sailboat" "sb-down-arrow" "sb-h-double-arrow" "sb-left-arrow"
+ "sb-right-arrow" "sb-up-arrow" "sb-v-double-arrow" "shuttle"
+ "sizing" "spider" "spraycan" "star" "target" "tcross"
+ "top-left-arrow" "top-left-corner" "top-right-corner"
+ "top-side" "top-tee" "trek" "ul-angle" "umbrella" "ur-angle"
+ "watch" "xterm"))
\f
;;;; Mouse Commands
;;; (For compatibility with old code.)
-(let-syntax
- ((copy
- (sc-macro-transformer
- (lambda (form environment)
- (let ((name (cadr form)))
- `(DEFINE ,(symbol-append 'EDWIN-COMMAND$X- name)
- ,(close-syntax (symbol-append 'EDWIN-COMMAND$ name)
- environment)))))))
- (copy set-foreground-color)
- (copy set-background-color)
- (copy set-border-color)
- (copy set-cursor-color)
- (copy set-mouse-color)
- (copy set-font)
- (copy set-border-width)
- (copy set-internal-border-width)
- (copy set-mouse-shape)
- (copy mouse-select)
- (copy mouse-keep-one-window)
- (copy mouse-select-and-split)
- (copy mouse-set-point)
- (copy mouse-set-mark)
- (copy mouse-show-event)
- (copy mouse-ignore))
+(define-syntax define-old-mouse-command
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((name (cadr form)))
+ `(DEFINE ,(symbol-append 'EDWIN-COMMAND$X- name)
+ ,(close-syntax (symbol-append 'EDWIN-COMMAND$ name)
+ environment))))))
+
+(define-old-mouse-command set-foreground-color)
+(define-old-mouse-command set-background-color)
+(define-old-mouse-command set-border-color)
+(define-old-mouse-command set-cursor-color)
+(define-old-mouse-command set-mouse-color)
+(define-old-mouse-command set-font)
+(define-old-mouse-command set-border-width)
+(define-old-mouse-command set-internal-border-width)
+(define-old-mouse-command set-mouse-shape)
+(define-old-mouse-command mouse-select)
+(define-old-mouse-command mouse-keep-one-window)
+(define-old-mouse-command mouse-select-and-split)
+(define-old-mouse-command mouse-set-point)
+(define-old-mouse-command mouse-set-mark)
+(define-old-mouse-command mouse-show-event)
+(define-old-mouse-command mouse-ignore)
(define edwin-command$x-set-size edwin-command$set-frame-size)
(define edwin-command$x-set-position edwin-command$set-frame-position)
(define edwin-command$x-raise-screen edwin-command$raise-frame)
(define edwin-command$x-lower-screen edwin-command$lower-frame)
-(let-syntax
- ((copy
- (sc-macro-transformer
- (lambda (form environment)
- (let ((name (cadr form)))
- `(DEFINE ,(symbol-append 'EDWIN-VARIABLE$X-SCREEN- name)
- ,(close-syntax (symbol-append 'EDWIN-VARIABLE$FRAME- name)
- environment)))))))
- (copy icon-name-format)
- (copy icon-name-length))
+(define-syntax define-old-screen-command
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((name (cadr form)))
+ `(DEFINE ,(symbol-append 'EDWIN-VARIABLE$X-SCREEN- name)
+ ,(close-syntax (symbol-append 'EDWIN-VARIABLE$FRAME- name)
+ environment))))))
+
+(define-old-screen-command icon-name-format)
+(define-old-screen-command icon-name-length)
(define x-button1-down button1-down)
(define x-button2-down button2-down)
#| -*-Scheme-*-
-$Id: arith.scm,v 1.54 2003/01/02 01:54:32 cph Exp $
+$Id: arith.scm,v 1.55 2003/02/13 02:35:13 cph Exp $
-Copyright (c) 1989,1990,1991,1992,1993 Massachusetts Institute of Technology
-Copyright (c) 1994,1995,1996,1997,1999 Massachusetts Institute of Technology
-Copyright (c) 2001,2002,2003 Massachusetts Institute of Technology
+Copyright 1989,1990,1991,1992,1993,1994 Massachusetts Institute of Technology
+Copyright 1995,1996,1997,1999,2001,2002 Massachusetts Institute of Technology
+Copyright 2003 Massachusetts Institute of Technology
This file is part of MIT Scheme.
;;; this is generally important only for bignums, and the bignum
;;; quotient already performs that check.
-(let-syntax
- ((define-addition-operator
- (sc-macro-transformer
- (lambda (form environment)
- (let ((name (list-ref form 1))
- (int:op (close-syntax (list-ref form 2) environment)))
- `(DEFINE (,name U/U* V/V*)
- (RAT:BINARY-OPERATOR U/U* V/V*
- ,int:op
- (LAMBDA (U V V*)
- (MAKE-RATIONAL (,int:op (INT:* U V*) V) V*))
- (LAMBDA (U U* V)
- (MAKE-RATIONAL (,int:op U (INT:* V U*)) U*))
- (LAMBDA (U U* V V*)
- (LET ((D1 (INT:GCD U* V*)))
- (IF (INT:= D1 1)
- (MAKE-RATIONAL (,int:op (INT:* U V*) (INT:* V U*))
- (INT:* U* V*))
- (LET* ((U*/D1 (INT:QUOTIENT U* D1))
- (T
- (,int:op (INT:* U (INT:QUOTIENT V* D1))
- (INT:* V U*/D1))))
- (IF (INT:ZERO? T)
- 0 ;(MAKE-RATIONAL 0 1)
- (LET ((D2 (INT:GCD T D1)))
- (MAKE-RATIONAL
- (INT:QUOTIENT T D2)
- (INT:* U*/D1
- (INT:QUOTIENT V* D2))))))))))))))))
- (define-addition-operator rat:+ int:+)
- (define-addition-operator rat:- int:-))
+(define-syntax define-addition-operator
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((name (list-ref form 1))
+ (int:op (close-syntax (list-ref form 2) environment)))
+ `(DEFINE (,name U/U* V/V*)
+ (RAT:BINARY-OPERATOR U/U* V/V*
+ ,int:op
+ (LAMBDA (U V V*)
+ (MAKE-RATIONAL (,int:op (INT:* U V*) V) V*))
+ (LAMBDA (U U* V)
+ (MAKE-RATIONAL (,int:op U (INT:* V U*)) U*))
+ (LAMBDA (U U* V V*)
+ (LET ((D1 (INT:GCD U* V*)))
+ (IF (INT:= D1 1)
+ (MAKE-RATIONAL (,int:op (INT:* U V*) (INT:* V U*))
+ (INT:* U* V*))
+ (LET* ((U*/D1 (INT:QUOTIENT U* D1))
+ (T
+ (,int:op (INT:* U (INT:QUOTIENT V* D1))
+ (INT:* V U*/D1))))
+ (IF (INT:ZERO? T)
+ 0 ;(MAKE-RATIONAL 0 1)
+ (LET ((D2 (INT:GCD T D1)))
+ (MAKE-RATIONAL
+ (INT:QUOTIENT T D2)
+ (INT:* U*/D1
+ (INT:QUOTIENT V* D2)))))))))))))))
+
+(define-addition-operator rat:+ int:+)
+(define-addition-operator rat:- int:-)
(define (rat:1+ v/v*)
(if (ratnum? v/v*)
((int:integer? q) 1)
(else (error:wrong-type-argument q false 'DENOMINATOR))))
-(let-syntax
- ((define-integer-coercion
- (sc-macro-transformer
- (lambda (form environment)
- `(DEFINE (,(list-ref form 1) Q)
- (COND ((RATNUM? Q)
- (,(close-syntax (list-ref form 3) environment)
- (RATNUM-NUMERATOR Q)
- (RATNUM-DENOMINATOR Q)))
- ((INT:INTEGER? Q) Q)
- (ELSE
- (ERROR:WRONG-TYPE-ARGUMENT Q
- "real number"
- ',(list-ref form 2)))))))))
- (define-integer-coercion rat:floor floor int:floor)
- (define-integer-coercion rat:ceiling ceiling int:ceiling)
- (define-integer-coercion rat:truncate truncate int:quotient)
- (define-integer-coercion rat:round round int:round))
+(define-syntax define-integer-coercion
+ (sc-macro-transformer
+ (lambda (form environment)
+ `(DEFINE (,(list-ref form 1) Q)
+ (COND ((RATNUM? Q)
+ (,(close-syntax (list-ref form 3) environment)
+ (RATNUM-NUMERATOR Q)
+ (RATNUM-DENOMINATOR Q)))
+ ((INT:INTEGER? Q) Q)
+ (ELSE
+ (ERROR:WRONG-TYPE-ARGUMENT Q
+ "real number"
+ ',(list-ref form 2))))))))
+
+(define-integer-coercion rat:floor floor int:floor)
+(define-integer-coercion rat:ceiling ceiling int:ceiling)
+(define-integer-coercion rat:truncate truncate int:quotient)
+(define-integer-coercion rat:round round int:round)
(define (rat:rationalize q e)
(rat:simplest-rational (rat:- q e) (rat:+ q e)))
(define (real:positive? x)
(if (flonum? x) (flo:positive? x) ((copy rat:positive?) x)))
-(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 real:1+ (lambda (x) (flo:+ x flo:1)) (copy rat:1+))
- (define-standard-unary real:-1+ (lambda (x) (flo:- x flo:1)) (copy rat:-1+))
- (define-standard-unary real:negate flo:negate (copy rat:negate))
- (define-standard-unary real:invert (lambda (x) (flo:/ flo:1 x)) rat:invert)
- (define-standard-unary real:abs flo:abs rat:abs)
- (define-standard-unary real:square (lambda (x) (flo:* x x)) rat:square)
- (define-standard-unary real:floor flo:floor rat:floor)
- (define-standard-unary real:ceiling flo:ceiling rat:ceiling)
- (define-standard-unary real:truncate flo:truncate rat:truncate)
- (define-standard-unary real:round flo:round rat:round)
- (define-standard-unary real:floor->exact flo:floor->exact rat:floor)
- (define-standard-unary real:ceiling->exact flo:ceiling->exact rat:ceiling)
- (define-standard-unary real:truncate->exact flo:truncate->exact rat:truncate)
- (define-standard-unary real:round->exact flo:round->exact rat:round)
- (define-standard-unary real:exact->inexact (lambda (x) x) rat:->inexact)
- (define-standard-unary real:inexact->exact flo:->rational
- (lambda (q)
- (if (rat:rational? q)
- q
- (error:wrong-type-argument q false 'INEXACT->EXACT)))))
+(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 real:1+ (lambda (x) (flo:+ x flo:1)) (copy rat:1+))
+(define-standard-unary real:-1+ (lambda (x) (flo:- x flo:1)) (copy rat:-1+))
+(define-standard-unary real:negate flo:negate (copy rat:negate))
+(define-standard-unary real:invert (lambda (x) (flo:/ flo:1 x)) rat:invert)
+(define-standard-unary real:abs flo:abs rat:abs)
+(define-standard-unary real:square (lambda (x) (flo:* x x)) rat:square)
+(define-standard-unary real:floor flo:floor rat:floor)
+(define-standard-unary real:ceiling flo:ceiling rat:ceiling)
+(define-standard-unary real:truncate flo:truncate rat:truncate)
+(define-standard-unary real:round flo:round rat:round)
+(define-standard-unary real:floor->exact flo:floor->exact rat:floor)
+(define-standard-unary real:ceiling->exact flo:ceiling->exact rat:ceiling)
+(define-standard-unary real:truncate->exact flo:truncate->exact rat:truncate)
+(define-standard-unary real:round->exact flo:round->exact rat:round)
+(define-standard-unary real:exact->inexact (lambda (x) x) rat:->inexact)
+(define-standard-unary real:inexact->exact flo:->rational
+ (lambda (q)
+ (if (rat:rational? q)
+ q
+ (error:wrong-type-argument q false 'INEXACT->EXACT))))
\f
-(let-syntax
- ((define-standard-binary
- (sc-macro-transformer
- (lambda (form environment)
- (let ((flo:op (close-syntax (list-ref form 2) environment))
- (rat: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 (RAT:->INEXACT Y)))
- (IF (FLONUM? Y)
- (,flo:op (RAT:->INEXACT X) Y)
- (,rat:op X Y)))))))))
- (define-standard-binary real:+ flo:+ (copy rat:+))
- (define-standard-binary real:- flo:- (copy rat:-))
- (define-standard-binary real:rationalize
- flo:rationalize
- rat:rationalize)
- (define-standard-binary real:rationalize->exact
- flo:rationalize->exact
- rat:rationalize)
- (define-standard-binary real:simplest-rational
- flo:simplest-rational
- rat:simplest-rational)
- (define-standard-binary real:simplest-exact-rational
- flo:simplest-exact-rational
- rat:simplest-rational))
+(define-syntax define-standard-binary
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((flo:op (close-syntax (list-ref form 2) environment))
+ (rat: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 (RAT:->INEXACT Y)))
+ (IF (FLONUM? Y)
+ (,flo:op (RAT:->INEXACT X) Y)
+ (,rat:op X Y))))))))
+
+(define-standard-binary real:+ flo:+ (copy rat:+))
+(define-standard-binary real:- flo:- (copy rat:-))
+(define-standard-binary real:rationalize
+ flo:rationalize
+ rat:rationalize)
+(define-standard-binary real:rationalize->exact
+ flo:rationalize->exact
+ rat:rationalize)
+(define-standard-binary real:simplest-rational
+ flo:simplest-rational
+ rat:simplest-rational)
+(define-standard-binary real:simplest-exact-rational
+ flo:simplest-exact-rational
+ rat:simplest-rational)
(define (real:= x y)
(if (flonum? x)
(error:wrong-type-argument n false 'EVEN?))
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:->INEXACT
- (,operator ,(flo->int 'N)
- (IF (FLONUM? M)
- ,(flo->int 'M)
- M)))
- (IF (FLONUM? M)
- (INT:->INEXACT (,operator N ,(flo->int 'M)))
- (,operator N M)))))))))
- (define-integer-binary real:quotient quotient int:quotient)
- (define-integer-binary real:remainder remainder int:remainder)
- (define-integer-binary real:modulo modulo int:modulo)
- (define-integer-binary real:integer-floor integer-floor int:floor)
- (define-integer-binary real:integer-ceiling integer-ceiling int:ceiling)
- (define-integer-binary real:integer-round integer-round int:round)
- (define-integer-binary real:divide integer-divide int:divide)
- (define-integer-binary real:gcd gcd int:gcd)
- (define-integer-binary real:lcm lcm int:lcm))
-
-(let-syntax
- ((define-rational-unary
- (sc-macro-transformer
- (lambda (form environment)
- (let ((operator (close-syntax (list-ref form 2) environment)))
- `(DEFINE (,(list-ref form 1) Q)
- (IF (FLONUM? Q)
- (RAT:->INEXACT (,operator (FLO:->RATIONAL Q)))
- (,operator Q))))))))
- (define-rational-unary real:numerator rat:numerator)
- (define-rational-unary real:denominator rat:denominator))
+(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:->INEXACT
+ (,operator ,(flo->int 'N)
+ (IF (FLONUM? M)
+ ,(flo->int 'M)
+ M)))
+ (IF (FLONUM? M)
+ (INT:->INEXACT (,operator N ,(flo->int 'M)))
+ (,operator N M))))))))
+
+(define-integer-binary real:quotient quotient int:quotient)
+(define-integer-binary real:remainder remainder int:remainder)
+(define-integer-binary real:modulo modulo int:modulo)
+(define-integer-binary real:integer-floor integer-floor int:floor)
+(define-integer-binary real:integer-ceiling integer-ceiling int:ceiling)
+(define-integer-binary real:integer-round integer-round int:round)
+(define-integer-binary real:divide integer-divide int:divide)
+(define-integer-binary real:gcd gcd int:gcd)
+(define-integer-binary real:lcm lcm int:lcm)
+
+(define-syntax define-rational-unary
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((operator (close-syntax (list-ref form 2) environment)))
+ `(DEFINE (,(list-ref form 1) Q)
+ (IF (FLONUM? Q)
+ (RAT:->INEXACT (,operator (FLO:->RATIONAL Q)))
+ (,operator Q)))))))
+
+(define-rational-unary real:numerator rat:numerator)
+(define-rational-unary real:denominator rat:denominator)
\f
-(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:->INEXACT X))))))))
- (define-transcendental-unary real:exp real:exact0= 1 flo:exp)
- (define-transcendental-unary real:log real:exact1= 0 flo:log)
- (define-transcendental-unary real:sin real:exact0= 0 flo:sin)
- (define-transcendental-unary real:cos real:exact0= 1 flo:cos)
- (define-transcendental-unary real:tan real:exact0= 0 flo:tan)
- (define-transcendental-unary real:asin real:exact0= 0 flo:asin)
- (define-transcendental-unary real: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:->INEXACT X)))))))
+
+(define-transcendental-unary real:exp real:exact0= 1 flo:exp)
+(define-transcendental-unary real:log real:exact1= 0 flo:log)
+(define-transcendental-unary real:sin real:exact0= 0 flo:sin)
+(define-transcendental-unary real:cos real:exact0= 1 flo:cos)
+(define-transcendental-unary real:tan real:exact0= 0 flo:tan)
+(define-transcendental-unary real:asin real:exact0= 0 flo:asin)
+(define-transcendental-unary real: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)
(and (int:integer? object)
(int:positive? object)))
-(let-syntax
- ((define-guarantee
- (sc-macro-transformer
- (lambda (form environment)
- `(DEFINE (,(symbol-append 'GUARANTEE- (cadr form)) OBJECT OPERATOR)
- (IF (NOT (,(symbol-append (cadr form) '?) OBJECT))
- (ERROR:WRONG-TYPE-ARGUMENT OBJECT
- ,(close-syntax (caddr form)
- environment)
- OPERATOR))
- OBJECT)))))
- (define-guarantee number "number")
- (define-guarantee complex "complex number")
- (define-guarantee real "real number")
- (define-guarantee rational "rational number")
- (define-guarantee integer "integer")
- (define-guarantee exact "exact number")
- (define-guarantee exact-rational "exact rational number")
- (define-guarantee exact-integer "exact integer")
- (define-guarantee inexact "inexact number")
- (define-guarantee exact-nonnegative-integer "exact non-negative integer")
- (define-guarantee exact-positive-integer "exact positive integer"))
+(define-syntax define-guarantee
+ (sc-macro-transformer
+ (lambda (form environment)
+ `(DEFINE (,(symbol-append 'GUARANTEE- (cadr form)) OBJECT OPERATOR)
+ (IF (NOT (,(symbol-append (cadr form) '?) OBJECT))
+ (ERROR:WRONG-TYPE-ARGUMENT OBJECT
+ ,(close-syntax (caddr form)
+ environment)
+ OPERATOR))
+ OBJECT))))
+
+(define-guarantee number "number")
+(define-guarantee complex "complex number")
+(define-guarantee real "real number")
+(define-guarantee rational "rational number")
+(define-guarantee integer "integer")
+(define-guarantee exact "exact number")
+(define-guarantee exact-rational "exact rational number")
+(define-guarantee exact-integer "exact integer")
+(define-guarantee inexact "inexact number")
+(define-guarantee exact-nonnegative-integer "exact non-negative integer")
+(define-guarantee exact-positive-integer "exact positive integer")
\f
;; Replaced with arity-dispatched version in INITIALIZE-PACKAGE!
#| -*-Scheme-*-
-$Id: graphics.scm,v 1.22 2002/11/20 19:46:20 cph Exp $
+$Id: graphics.scm,v 1.23 2003/02/13 02:35:21 cph Exp $
-Copyright (c) 1989-1999, 2001, 2002 Massachusetts Institute of Technology
+Copyright 1989,1990,1992,1992,1993,1994 Massachusetts Institute of Technology
+Copyright 1995,1996,2001,2002,2003 Massachusetts Institute of Technology
This file is part of MIT Scheme.
(%make-graphics-device type descriptor)))
arguments)))
-(let-syntax
- ((define-graphics-operation
- (sc-macro-transformer
- (lambda (form environment)
- (let ((name (cadr form)))
- `(DEFINE-INTEGRABLE
- (,(symbol-append 'GRAPHICS-DEVICE/OPERATION/ name) DEVICE)
- (,(close-syntax (symbol-append 'GRAPHICS-DEVICE-TYPE/OPERATION/
- name)
- environment)
- (GRAPHICS-DEVICE/TYPE DEVICE))))))))
- (define-graphics-operation clear)
- (define-graphics-operation close)
- (define-graphics-operation coordinate-limits)
- (define-graphics-operation device-coordinate-limits)
- (define-graphics-operation drag-cursor)
- (define-graphics-operation draw-line)
- (define-graphics-operation draw-point)
- (define-graphics-operation draw-text)
- (define-graphics-operation flush)
- (define-graphics-operation move-cursor)
- (define-graphics-operation reset-clip-rectangle)
- (define-graphics-operation set-clip-rectangle)
- (define-graphics-operation set-coordinate-limits)
- (define-graphics-operation set-drawing-mode)
- (define-graphics-operation set-line-style))
+(define-syntax define-graphics-operation
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((name (cadr form)))
+ `(DEFINE-INTEGRABLE
+ (,(symbol-append 'GRAPHICS-DEVICE/OPERATION/ name) DEVICE)
+ (,(close-syntax (symbol-append 'GRAPHICS-DEVICE-TYPE/OPERATION/
+ name)
+ environment)
+ (GRAPHICS-DEVICE/TYPE DEVICE)))))))
+
+(define-graphics-operation clear)
+(define-graphics-operation close)
+(define-graphics-operation coordinate-limits)
+(define-graphics-operation device-coordinate-limits)
+(define-graphics-operation drag-cursor)
+(define-graphics-operation draw-line)
+(define-graphics-operation draw-point)
+(define-graphics-operation draw-text)
+(define-graphics-operation flush)
+(define-graphics-operation move-cursor)
+(define-graphics-operation reset-clip-rectangle)
+(define-graphics-operation set-clip-rectangle)
+(define-graphics-operation set-coordinate-limits)
+(define-graphics-operation set-drawing-mode)
+(define-graphics-operation set-line-style)
(define (graphics-operation device name . arguments)
(let ((value
arguments)))
(maybe-flush device)
value))
-
+\f
(define (graphics-enable-buffering device)
(set-graphics-device/buffer?! device true))
(define-integrable (graphics-flush device)
((graphics-device/operation/flush device) device))
-\f
+
(define (graphics-device-coordinate-limits device)
((graphics-device/operation/device-coordinate-limits device) device))
((graphics-device/operation/set-drawing-mode device)
device drawing-mode)
(set-graphics-device/drawing-mode! device drawing-mode))
-
+\f
(define-integrable line-style:solid 0)
(define-integrable line-style:dash 1)
(define-integrable line-style:dot 2)
(define (graphics-set-line-style device line-style)
((graphics-device/operation/set-line-style device) device line-style)
(set-graphics-device/line-style! device line-style))
-\f
+
(define (graphics-clear device)
((graphics-device/operation/clear device) device)
(maybe-flush device))
(and error?
(error "Graphics type has no associated image type:"
type))))))))
-\f
+
(define (make-image-type operations)
(let ((operations
(map (lambda (entry)
(%make-image-type create destroy
width height
draw draw-subimage fill-from-byte-vector))))))
-
+\f
(define-structure (image (conc-name image/) (constructor %make-image))
type
descriptor)
#| -*-Scheme-*-
-$Id: list.scm,v 14.31 2002/11/20 19:46:20 cph Exp $
+$Id: list.scm,v 14.32 2003/02/13 02:35:29 cph Exp $
-Copyright (c) 1988-2002 Massachusetts Institute of Technology
+Copyright 1986,1987,1988,1989,1990,1991 Massachusetts Institute of Technology
+Copyright 1992,1993,1994,1995,1996,2000 Massachusetts Institute of Technology
+Copyright 2001,2002,2003 Massachusetts Institute of Technology
This file is part of MIT Scheme.
(map-2 first (car rest)))
(map-1 first)))
\f
-(let-syntax
- ((mapper
- (rsc-macro-transformer
- (lambda (form environment)
- environment
- (let ((name (list-ref form 1))
- (combiner (list-ref form 2))
- (initial-value (list-ref form 3))
- (procedure (list-ref form 4))
- (first (list-ref form 5))
- (rest (list-ref form 6)))
- `(BEGIN
- (DEFINE (MAP-1 L)
- (COND ((PAIR? L)
- (,combiner (,procedure (CAR L))
- (MAP-1 (CDR L))))
- ((NULL? L) ,initial-value)
- (ELSE (BAD-END))))
-
- (DEFINE (MAP-2 L1 L2)
- (COND ((AND (PAIR? L1) (PAIR? L2))
- (,combiner (,procedure (CAR L1) (CAR L2))
- (MAP-2 (CDR L1) (CDR L2))))
- ((AND (NULL? L1) (NULL? L2)) ,initial-value)
- (ELSE (BAD-END))))
-
- (DEFINE (MAP-N LISTS)
- (LET N-LOOP ((LISTS LISTS))
- (IF (PAIR? (CAR LISTS))
- (DO ((LISTS LISTS (CDR LISTS))
- (CARS '() (CONS (CAAR LISTS) CARS))
- (CDRS '() (CONS (CDAR LISTS) CDRS)))
- ((NOT (PAIR? LISTS))
- (,combiner (APPLY ,procedure (REVERSE! CARS))
- (N-LOOP (REVERSE! CDRS))))
- (IF (NOT (PAIR? (CAR LISTS)))
- (BAD-END)))
- (DO ((LISTS LISTS (CDR LISTS)))
- ((NOT (PAIR? LISTS)) ,initial-value)
- (IF (NOT (NULL? (CAR LISTS)))
- (BAD-END))))))
-
- (DEFINE (BAD-END)
- (DO ((LISTS (CONS ,first ,rest) (CDR LISTS)))
- ((NOT (PAIR? LISTS)))
- (IF (NOT (LIST? (CAR LISTS)))
- (ERROR:WRONG-TYPE-ARGUMENT (CAR LISTS) "list" ',name)))
- (LET ((N (LENGTH ,first)))
- (DO ((LISTS ,rest (CDR LISTS)))
- ((NOT (PAIR? LISTS)))
- (IF (NOT (= N (LENGTH (CAR LISTS))))
- (ERROR:BAD-RANGE-ARGUMENT (CAR LISTS) ',name)))))
-
- (IF (PAIR? ,rest)
- (IF (PAIR? (CDR ,rest))
- (MAP-N (CONS ,first ,rest))
- (MAP-2 ,first (CAR ,rest)))
- (MAP-1 ,first))))))))
-
- (define (for-each procedure first . rest)
- (mapper for-each begin unspecific procedure first rest))
-
- ;;(define (map procedure first . rest)
- ;; (mapper map cons '() procedure first rest))
-
- (define (map* initial-value procedure first . rest)
- (mapper map* cons initial-value procedure first rest))
-
- (define (append-map procedure first . rest)
- (mapper append-map append '() procedure first rest))
-
- (define (append-map* initial-value procedure first . rest)
- (mapper append-map* append initial-value procedure first rest))
-
- (define (append-map! procedure first . rest)
- (mapper append-map! append! '() procedure first rest))
-
- (define (append-map*! initial-value procedure first . rest)
- (mapper append-map*! append! initial-value procedure first rest)))
+(define-syntax mapper
+ (rsc-macro-transformer
+ (lambda (form environment)
+ environment
+ (let ((name (list-ref form 1))
+ (combiner (list-ref form 2))
+ (initial-value (list-ref form 3))
+ (procedure (list-ref form 4))
+ (first (list-ref form 5))
+ (rest (list-ref form 6)))
+ `(BEGIN
+ (DEFINE (MAP-1 L)
+ (COND ((PAIR? L)
+ (,combiner (,procedure (CAR L))
+ (MAP-1 (CDR L))))
+ ((NULL? L) ,initial-value)
+ (ELSE (BAD-END))))
+
+ (DEFINE (MAP-2 L1 L2)
+ (COND ((AND (PAIR? L1) (PAIR? L2))
+ (,combiner (,procedure (CAR L1) (CAR L2))
+ (MAP-2 (CDR L1) (CDR L2))))
+ ((AND (NULL? L1) (NULL? L2)) ,initial-value)
+ (ELSE (BAD-END))))
+
+ (DEFINE (MAP-N LISTS)
+ (LET N-LOOP ((LISTS LISTS))
+ (IF (PAIR? (CAR LISTS))
+ (DO ((LISTS LISTS (CDR LISTS))
+ (CARS '() (CONS (CAAR LISTS) CARS))
+ (CDRS '() (CONS (CDAR LISTS) CDRS)))
+ ((NOT (PAIR? LISTS))
+ (,combiner (APPLY ,procedure (REVERSE! CARS))
+ (N-LOOP (REVERSE! CDRS))))
+ (IF (NOT (PAIR? (CAR LISTS)))
+ (BAD-END)))
+ (DO ((LISTS LISTS (CDR LISTS)))
+ ((NOT (PAIR? LISTS)) ,initial-value)
+ (IF (NOT (NULL? (CAR LISTS)))
+ (BAD-END))))))
+
+ (DEFINE (BAD-END)
+ (DO ((LISTS (CONS ,first ,rest) (CDR LISTS)))
+ ((NOT (PAIR? LISTS)))
+ (IF (NOT (LIST? (CAR LISTS)))
+ (ERROR:WRONG-TYPE-ARGUMENT (CAR LISTS) "list" ',name)))
+ (LET ((N (LENGTH ,first)))
+ (DO ((LISTS ,rest (CDR LISTS)))
+ ((NOT (PAIR? LISTS)))
+ (IF (NOT (= N (LENGTH (CAR LISTS))))
+ (ERROR:BAD-RANGE-ARGUMENT (CAR LISTS) ',name)))))
+
+ (IF (PAIR? ,rest)
+ (IF (PAIR? (CDR ,rest))
+ (MAP-N (CONS ,first ,rest))
+ (MAP-2 ,first (CAR ,rest)))
+ (MAP-1 ,first)))))))
+
+(define (for-each procedure first . rest)
+ (mapper for-each begin unspecific procedure first rest))
+
+;;(define (map procedure first . rest)
+;; (mapper map cons '() procedure first rest))
+
+(define (map* initial-value procedure first . rest)
+ (mapper map* cons initial-value procedure first rest))
+
+(define (append-map procedure first . rest)
+ (mapper append-map append '() procedure first rest))
+
+(define (append-map* initial-value procedure first . rest)
+ (mapper append-map* append initial-value procedure first rest))
+
+(define (append-map! procedure first . rest)
+ (mapper append-map! append! '() procedure first rest))
+
+(define (append-map*! initial-value procedure first . rest)
+ (mapper append-map*! append! initial-value procedure first rest))
\f
(define mapcan append-map!)
(define mapcan* append-map*!)
-;;; -*-Scheme-*-
-;;;
-;;; $Id: parser-buffer.scm,v 1.5 2002/11/20 19:46:22 cph Exp $
-;;;
-;;; Copyright (c) 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: parser-buffer.scm,v 1.6 2003/02/13 02:35:37 cph Exp $
+
+Copyright 2001,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.
+
+|#
;;;; Parser-buffer abstraction
(string-ref (parser-buffer-string buffer)
(fix:+ (parser-buffer-index buffer) index))))
\f
-(let-syntax
- ((char-matcher
- (sc-macro-transformer
- (lambda (form environment)
- (let ((name (cadr form))
- (test
- (make-syntactic-closure environment '(REFERENCE CHAR)
- (caddr form))))
- `(BEGIN
- (DEFINE (,(symbol-append 'MATCH-PARSER-BUFFER- name '-NO-ADVANCE)
- BUFFER REFERENCE)
- (AND (GUARANTEE-BUFFER-CHARS BUFFER 1)
- (LET ((CHAR
- (STRING-REF (PARSER-BUFFER-STRING BUFFER)
- (PARSER-BUFFER-INDEX BUFFER))))
- (DECLARE (INTEGRATE CHAR))
- ,test)))
- (DEFINE (,(symbol-append 'MATCH-PARSER-BUFFER- name)
- BUFFER REFERENCE)
- (AND (GUARANTEE-BUFFER-CHARS BUFFER 1)
- (LET ((CHAR
- (STRING-REF (PARSER-BUFFER-STRING BUFFER)
- (PARSER-BUFFER-INDEX BUFFER))))
- (AND ,test
- (BEGIN
- (INCREMENT-BUFFER-INDEX! BUFFER CHAR)
- #T)))))))))))
- (char-matcher char (char=? char reference))
- (char-matcher char-ci (char-ci=? char reference))
- (char-matcher not-char (not (char=? char reference)))
- (char-matcher not-char-ci (not (char-ci=? char reference)))
- (char-matcher char-in-set (char-set-member? reference char)))
+(define-syntax char-matcher
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((name (cadr form))
+ (test
+ (make-syntactic-closure environment '(REFERENCE CHAR)
+ (caddr form))))
+ `(BEGIN
+ (DEFINE (,(symbol-append 'MATCH-PARSER-BUFFER- name '-NO-ADVANCE)
+ BUFFER REFERENCE)
+ (AND (GUARANTEE-BUFFER-CHARS BUFFER 1)
+ (LET ((CHAR
+ (STRING-REF (PARSER-BUFFER-STRING BUFFER)
+ (PARSER-BUFFER-INDEX BUFFER))))
+ (DECLARE (INTEGRATE CHAR))
+ ,test)))
+ (DEFINE (,(symbol-append 'MATCH-PARSER-BUFFER- name)
+ BUFFER REFERENCE)
+ (AND (GUARANTEE-BUFFER-CHARS BUFFER 1)
+ (LET ((CHAR
+ (STRING-REF (PARSER-BUFFER-STRING BUFFER)
+ (PARSER-BUFFER-INDEX BUFFER))))
+ (AND ,test
+ (BEGIN
+ (INCREMENT-BUFFER-INDEX! BUFFER CHAR)
+ #T))))))))))
+
+(char-matcher char (char=? char reference))
+(char-matcher char-ci (char-ci=? char reference))
+(char-matcher not-char (not (char=? char reference)))
+(char-matcher not-char-ci (not (char-ci=? char reference)))
+(char-matcher char-in-set (char-set-member? reference char))
(define (match-utf8-char-in-alphabet buffer alphabet)
(let ((p (get-parser-buffer-pointer buffer)))
(set-parser-buffer-pointer! buffer p)
#f))))
\f
-(let-syntax
- ((string-matcher
- (sc-macro-transformer
- (lambda (form environment)
- (let ((suffix (cadr form)))
- `(DEFINE (,(intern
- (string-append "match-parser-buffer-string" suffix))
- BUFFER STRING)
- (,(close-syntax
- (intern
- (string-append "match-parser-buffer-substring" suffix))
- environment)
- BUFFER STRING 0 (STRING-LENGTH STRING))))))))
- (string-matcher "")
- (string-matcher "-ci")
- (string-matcher "-no-advance")
- (string-matcher "-ci-no-advance"))
-
-(let-syntax
- ((substring-matcher
- (sc-macro-transformer
- (lambda (form environment)
- (let ((suffix (cadr form)))
- `(DEFINE (,(intern
- (string-append "match-parser-buffer-substring" suffix))
- BUFFER STRING START END)
- (LET ((N (FIX:- END START)))
- (AND (GUARANTEE-BUFFER-CHARS BUFFER N)
- (,(close-syntax
- (intern (string-append "substring" suffix "=?"))
- environment)
- STRING START END
- (PARSER-BUFFER-STRING BUFFER)
- (PARSER-BUFFER-INDEX BUFFER)
- (FIX:+ (PARSER-BUFFER-INDEX BUFFER) N))
- (BEGIN
- (BUFFER-INDEX+N! BUFFER N)
- #T)))))))))
- (substring-matcher "")
- (substring-matcher "-ci"))
-
-(let-syntax
- ((substring-matcher
- (sc-macro-transformer
- (lambda (form environment)
- (let ((suffix (cadr form)))
- `(DEFINE (,(intern
- (string-append "match-parser-buffer-substring"
- suffix
- "-no-advance"))
- BUFFER STRING START END)
- (LET ((N (FIX:- END START)))
- (AND (GUARANTEE-BUFFER-CHARS BUFFER N)
- (,(close-syntax
- (intern (string-append "substring" suffix "=?"))
- environment)
- STRING START END
- (PARSER-BUFFER-STRING BUFFER)
- (PARSER-BUFFER-INDEX BUFFER)
- (FIX:+ (PARSER-BUFFER-INDEX BUFFER) N))))))))))
- (substring-matcher "")
- (substring-matcher "-ci"))
+(define-syntax string-matcher
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((suffix (cadr form)))
+ `(DEFINE (,(intern
+ (string-append "match-parser-buffer-string" suffix))
+ BUFFER STRING)
+ (,(close-syntax
+ (intern
+ (string-append "match-parser-buffer-substring" suffix))
+ environment)
+ BUFFER STRING 0 (STRING-LENGTH STRING)))))))
+
+(string-matcher "")
+(string-matcher "-ci")
+(string-matcher "-no-advance")
+(string-matcher "-ci-no-advance")
+
+(define-syntax substring-matcher
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((suffix (cadr form)))
+ `(DEFINE (,(intern
+ (string-append "match-parser-buffer-substring" suffix))
+ BUFFER STRING START END)
+ (LET ((N (FIX:- END START)))
+ (AND (GUARANTEE-BUFFER-CHARS BUFFER N)
+ (,(close-syntax
+ (intern (string-append "substring" suffix "=?"))
+ environment)
+ STRING START END
+ (PARSER-BUFFER-STRING BUFFER)
+ (PARSER-BUFFER-INDEX BUFFER)
+ (FIX:+ (PARSER-BUFFER-INDEX BUFFER) N))
+ (BEGIN
+ (BUFFER-INDEX+N! BUFFER N)
+ #T))))))))
+
+(substring-matcher "")
+(substring-matcher "-ci")
+
+(define-syntax substring-matcher-no-advance
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((suffix (cadr form)))
+ `(DEFINE (,(intern
+ (string-append "match-parser-buffer-substring"
+ suffix
+ "-no-advance"))
+ BUFFER STRING START END)
+ (LET ((N (FIX:- END START)))
+ (AND (GUARANTEE-BUFFER-CHARS BUFFER N)
+ (,(close-syntax
+ (intern (string-append "substring" suffix "=?"))
+ environment)
+ STRING START END
+ (PARSER-BUFFER-STRING BUFFER)
+ (PARSER-BUFFER-INDEX BUFFER)
+ (FIX:+ (PARSER-BUFFER-INDEX BUFFER) N)))))))))
+
+(substring-matcher-no-advance "")
+(substring-matcher-no-advance "-ci")
\f
(define-integrable (increment-buffer-index! buffer char)
(set-parser-buffer-index! buffer (fix:+ (parser-buffer-index buffer) 1))
#| -*-Scheme-*-
-$Id: scomb.scm,v 14.21 2002/11/20 19:46:22 cph Exp $
+$Id: scomb.scm,v 14.22 2003/02/13 02:35:44 cph Exp $
-Copyright (c) 1988-1999, 2001, 2002 Massachusetts Institute of Technology
+Copyright 1986,1987,1988,1989,1990,1991 Massachusetts Institute of Technology
+Copyright 1992,1995,1997,2001,2002,2003 Massachusetts Institute of Technology
This file is part of MIT Scheme.
(define (conditional-subexpressions expression)
(conditional-components expression list))
-\f
+
;;;; Disjunction
(define (make-disjunction predicate alternative)
(ucode-type combination))
(cons operator operands)))))
\f
-(let-syntax
- ((combination-dispatch
- (sc-macro-transformer
- (lambda (form environment)
- (let ((name (list-ref form 1))
- (combination (close-syntax (list-ref form 2) environment))
- (case-0 (close-syntax (list-ref form 3) environment))
- (case-1 (close-syntax (list-ref form 4) environment))
- (case-2 (close-syntax (list-ref form 5) environment))
- (case-n (close-syntax (list-ref form 6) environment)))
- `(COND ((OBJECT-TYPE? (UCODE-TYPE PRIMITIVE-COMBINATION-0)
- ,combination)
- ,case-0)
- ((OR (OBJECT-TYPE? (UCODE-TYPE COMBINATION-1) ,combination)
- (OBJECT-TYPE? (UCODE-TYPE PRIMITIVE-COMBINATION-1)
- ,combination))
- ,case-1)
- ((OR (OBJECT-TYPE? (UCODE-TYPE COMBINATION-2) ,combination)
- (OBJECT-TYPE? (UCODE-TYPE PRIMITIVE-COMBINATION-2)
- ,combination))
- ,case-2)
- ((OR (OBJECT-TYPE? (UCODE-TYPE COMBINATION) ,combination)
- (OBJECT-TYPE? (UCODE-TYPE PRIMITIVE-COMBINATION-3)
- ,combination))
- ,case-n)
- (ELSE
- (ERROR:WRONG-TYPE-ARGUMENT ,combination "SCode combination"
- ',name))))))))
+(define-syntax combination-dispatch
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((name (list-ref form 1))
+ (combination (close-syntax (list-ref form 2) environment))
+ (case-0 (close-syntax (list-ref form 3) environment))
+ (case-1 (close-syntax (list-ref form 4) environment))
+ (case-2 (close-syntax (list-ref form 5) environment))
+ (case-n (close-syntax (list-ref form 6) environment)))
+ `(COND ((OBJECT-TYPE? (UCODE-TYPE PRIMITIVE-COMBINATION-0)
+ ,combination)
+ ,case-0)
+ ((OR (OBJECT-TYPE? (UCODE-TYPE COMBINATION-1) ,combination)
+ (OBJECT-TYPE? (UCODE-TYPE PRIMITIVE-COMBINATION-1)
+ ,combination))
+ ,case-1)
+ ((OR (OBJECT-TYPE? (UCODE-TYPE COMBINATION-2) ,combination)
+ (OBJECT-TYPE? (UCODE-TYPE PRIMITIVE-COMBINATION-2)
+ ,combination))
+ ,case-2)
+ ((OR (OBJECT-TYPE? (UCODE-TYPE COMBINATION) ,combination)
+ (OBJECT-TYPE? (UCODE-TYPE PRIMITIVE-COMBINATION-3)
+ ,combination))
+ ,case-n)
+ (ELSE
+ (ERROR:WRONG-TYPE-ARGUMENT ,combination "SCode combination"
+ ',name)))))))
(define (combination-size combination)
(combination-dispatch combination-size combination
(receiver (&vector-ref combination 0)
(&subvector->list combination 1 (&vector-length combination)))))
-)
-
(define (combination-subexpressions expression)
(combination-components expression cons))
-\f
+
;;;; Unassigned?
(define (make-unassigned? name)
#| -*-Scheme-*-
-$Id: starbase.scm,v 1.18 2002/11/20 19:46:23 cph Exp $
+$Id: starbase.scm,v 1.19 2003/02/13 02:35:51 cph Exp $
-Copyright (c) 1989-1999, 2001, 2002 Massachusetts Institute of Technology
+Copyright 1989,1990,1991,1992,1993,1994 Massachusetts Institute of Technology
+Copyright 1995,2001,2002,2003 Massachusetts Institute of Technology
This file is part of MIT Scheme.
(define-structure (starbase-graphics-descriptor
(conc-name starbase-graphics-descriptor/)
(constructor make-starbase-descriptor (identifier)))
- (identifier false read-only true)
+ (identifier #f read-only #t)
x-left
y-bottom
x-right
(starbase-graphics-descriptor/identifier
(graphics-device/descriptor device)))
-(let-syntax
- ((define-accessors-and-mutators
- (sc-macro-transformer
- (lambda (form environment)
- (let ((name (cadr form)))
- `(BEGIN
- (DEFINE (,(symbol-append 'STARBASE-DEVICE/ name) DEVICE)
- (,(close-syntax
- (symbol-append 'STARBASE-GRAPHICS-DESCRIPTOR/ name)
- environment)
- (GRAPHICS-DEVICE/DESCRIPTOR DEVICE)))
- (DEFINE
- (,(symbol-append 'SET-STARBASE-DEVICE/ name '!) DEVICE VALUE)
- (,(close-syntax
- (symbol-append 'SET-STARBASE-GRAPHICS-DESCRIPTOR/ name '!)
- environment)
- (GRAPHICS-DEVICE/DESCRIPTOR DEVICE)
- VALUE))))))))
- (define-accessors-and-mutators x-left)
- (define-accessors-and-mutators y-bottom)
- (define-accessors-and-mutators x-right)
- (define-accessors-and-mutators y-top)
- (define-accessors-and-mutators text-height)
- (define-accessors-and-mutators text-aspect)
- (define-accessors-and-mutators text-slant)
- (define-accessors-and-mutators text-rotation))
+(define-syntax define-accessors-and-mutators
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((name (cadr form)))
+ `(BEGIN
+ (DEFINE (,(symbol-append 'STARBASE-DEVICE/ name) DEVICE)
+ (,(close-syntax
+ (symbol-append 'STARBASE-GRAPHICS-DESCRIPTOR/ name)
+ environment)
+ (GRAPHICS-DEVICE/DESCRIPTOR DEVICE)))
+ (DEFINE
+ (,(symbol-append 'SET-STARBASE-DEVICE/ name '!) DEVICE VALUE)
+ (,(close-syntax
+ (symbol-append 'SET-STARBASE-GRAPHICS-DESCRIPTOR/ name '!)
+ environment)
+ (GRAPHICS-DEVICE/DESCRIPTOR DEVICE)
+ VALUE)))))))
+
+(define-accessors-and-mutators x-left)
+(define-accessors-and-mutators y-bottom)
+(define-accessors-and-mutators x-right)
+(define-accessors-and-mutators y-top)
+(define-accessors-and-mutators text-height)
+(define-accessors-and-mutators text-aspect)
+(define-accessors-and-mutators text-slant)
+(define-accessors-and-mutators text-rotation)
\f
(define (operation/available?)
(implemented-primitive-procedure? starbase-open-device))
#| -*-Scheme-*-
-$Id: object.scm,v 4.16 2002/11/20 19:46:24 cph Exp $
+$Id: object.scm,v 4.17 2003/02/13 02:36:19 cph Exp $
-Copyright (c) 1987-1999, 2001, 2002 Massachusetts Institute of Technology
+Copyright 1987,1988,1989,1992,1993,1997 Massachusetts Institute of Technology
+Copyright 2001,2002,2003 Massachusetts Institute of Technology
This file is part of MIT Scheme.
(define (enumeration/name->index enumeration name)
(enumerand/index (enumeration/name->enumerand enumeration name)))
-(let-syntax
- ((define-enumeration
- (sc-macro-transformer
- (lambda (form environment)
- (let ((enumeration-name (cadr form))
- (enumerand-names (caddr form)))
- `(BEGIN
- (DEFINE ,enumeration-name
- (ENUMERATION/MAKE ',enumerand-names))
- ,@(map (lambda (enumerand-name)
- `(DEFINE ,(symbol-append enumerand-name '/ENUMERAND)
- (ENUMERATION/NAME->ENUMERAND
- ,(close-syntax enumeration-name environment)
- ',enumerand-name)))
- enumerand-names)))))))
- (define-enumeration enumeration/random
- (block
- delayed-integration
- variable))
- (define-enumeration enumeration/expression
- (access
- assignment
- combination
- conditional
- constant
- declaration
- delay
- disjunction
- open-block
- procedure
- quotation
- reference
- sequence
- the-environment)))
+(define-syntax define-enumeration
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((enumeration-name (cadr form))
+ (enumerand-names (caddr form)))
+ `(BEGIN
+ (DEFINE ,enumeration-name
+ (ENUMERATION/MAKE ',enumerand-names))
+ ,@(map (lambda (enumerand-name)
+ `(DEFINE ,(symbol-append enumerand-name '/ENUMERAND)
+ (ENUMERATION/NAME->ENUMERAND
+ ,(close-syntax enumeration-name environment)
+ ',enumerand-name)))
+ enumerand-names))))))
+
+(define-enumeration enumeration/random
+ (block
+ delayed-integration
+ variable))
+(define-enumeration enumeration/expression
+ (access
+ assignment
+ combination
+ conditional
+ constant
+ declaration
+ delay
+ disjunction
+ open-block
+ procedure
+ quotation
+ reference
+ sequence
+ the-environment))
\f
;;;; Records
operations
value)
-(let-syntax
- ((define-simple-type
- (sc-macro-transformer
- (lambda (form environment)
- (let ((name (cadr form))
- (slots (caddr form))
- (scode? (if (pair? (cdddr form)) (cadddr form) #t)))
- `(DEFINE-STRUCTURE
- (,name
- (TYPE VECTOR)
- (NAMED
- ,(close-syntax (symbol-append name '/ENUMERAND) environment))
- (CONC-NAME ,(symbol-append name '/))
- (CONSTRUCTOR ,(symbol-append name '/MAKE)))
- ,@(if scode?
- `((scode #f read-only #t))
- `())
- ,@slots))))))
- (define-simple-type variable (block name flags) #F)
- (define-simple-type access (environment name))
- (define-simple-type assignment (block variable value))
- (define-simple-type combination (block operator operands))
- (define-simple-type conditional (predicate consequent alternative))
- (define-simple-type constant (value))
- (define-simple-type declaration (declarations expression))
- (define-simple-type delay (expression))
- (define-simple-type disjunction (predicate alternative))
- (define-simple-type open-block (block variables values actions optimized))
- (define-simple-type procedure (block name required optional rest body))
- (define-simple-type quotation (block expression))
- (define-simple-type reference (block variable))
- (define-simple-type sequence (actions))
- (define-simple-type the-environment (block)))
+(define-syntax define-simple-type
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((name (cadr form))
+ (slots (caddr form))
+ (scode? (if (pair? (cdddr form)) (cadddr form) #t)))
+ `(DEFINE-STRUCTURE
+ (,name
+ (TYPE VECTOR)
+ (NAMED
+ ,(close-syntax (symbol-append name '/ENUMERAND) environment))
+ (CONC-NAME ,(symbol-append name '/))
+ (CONSTRUCTOR ,(symbol-append name '/MAKE)))
+ ,@(if scode?
+ `((scode #f read-only #t))
+ `())
+ ,@slots)))))
+
+(define-simple-type variable (block name flags) #F)
+(define-simple-type access (environment name))
+(define-simple-type assignment (block variable value))
+(define-simple-type combination (block operator operands))
+(define-simple-type conditional (predicate consequent alternative))
+(define-simple-type constant (value))
+(define-simple-type declaration (declarations expression))
+(define-simple-type delay (expression))
+(define-simple-type disjunction (predicate alternative))
+(define-simple-type open-block (block variables values actions optimized))
+(define-simple-type procedure (block name required optional rest body))
+(define-simple-type quotation (block expression))
+(define-simple-type reference (block variable))
+(define-simple-type sequence (actions))
+(define-simple-type the-environment (block))
;; Abstraction violations
\f
;;;; Miscellany
-(let-syntax
- ((define-flag
- (sc-macro-transformer
- (lambda (form environment)
- environment
- (let ((name (cadr form))
- (tester (caddr form))
- (setter (cadddr form)))
- `(BEGIN
- (DEFINE (,tester VARIABLE)
- (MEMQ ',name (VARIABLE/FLAGS VARIABLE)))
- (DEFINE (,setter VARIABLE)
- (IF (NOT (MEMQ ',name (VARIABLE/FLAGS VARIABLE)))
- (SET-VARIABLE/FLAGS!
- VARIABLE
- (CONS ',name (VARIABLE/FLAGS VARIABLE)))))))))))
- (define-flag SIDE-EFFECTED variable/side-effected variable/side-effect!)
- (define-flag REFERENCED variable/referenced variable/reference!)
- (define-flag INTEGRATED variable/integrated variable/integrated!)
- (define-flag CAN-IGNORE variable/can-ignore? variable/can-ignore!))
+(define-syntax define-flag
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ (let ((name (cadr form))
+ (tester (caddr form))
+ (setter (cadddr form)))
+ `(BEGIN
+ (DEFINE (,tester VARIABLE)
+ (MEMQ ',name (VARIABLE/FLAGS VARIABLE)))
+ (DEFINE (,setter VARIABLE)
+ (IF (NOT (MEMQ ',name (VARIABLE/FLAGS VARIABLE)))
+ (SET-VARIABLE/FLAGS!
+ VARIABLE
+ (CONS ',name (VARIABLE/FLAGS VARIABLE))))))))))
+
+(define-flag SIDE-EFFECTED variable/side-effected variable/side-effect!)
+(define-flag REFERENCED variable/referenced variable/reference!)
+(define-flag INTEGRATED variable/integrated variable/integrated!)
+(define-flag CAN-IGNORE variable/can-ignore? variable/can-ignore!)
(define open-block/value-marker
;; This must be an interned object because we will fasdump it and
projects / mit-scheme.git / commitdiff