From f55c5b0ace61d2cb7464d4270d26eafcef78d115 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Thu, 13 Feb 2003 02:39:48 +0000 Subject: [PATCH] Eliminate definitions embedded inside LET-SYNTAX, since they depend on an incorrect implementation of LET-SYNTAX. --- v7/src/compiler/base/lvalue.scm | 43 +-- v7/src/compiler/base/macros.scm | 95 +++--- v7/src/compiler/base/utils.scm | 50 ++- v7/src/compiler/fggen/canon.scm | 68 ++-- v7/src/compiler/machines/i386/lapgen.scm | 187 +++++------ v7/src/compiler/rtlbase/rtlreg.scm | 49 +-- v7/src/compiler/rtlbase/valclass.scm | 76 ++--- v7/src/edwin/buffer.scm | 73 ++--- v7/src/edwin/calias.scm | 75 ++--- v7/src/edwin/dosproc.scm | 53 ++-- v7/src/edwin/grpops.scm | 46 +-- v7/src/edwin/search.scm | 195 ++++++------ v7/src/edwin/tterm.scm | 84 ++--- v7/src/edwin/xcom.scm | 225 +++++--------- v7/src/runtime/arith.scm | 380 +++++++++++------------ v7/src/runtime/graphics.scm | 69 ++-- v7/src/runtime/list.scm | 163 +++++----- v7/src/runtime/parser-buffer.scm | 233 +++++++------- v7/src/runtime/scomb.scm | 66 ++-- v7/src/runtime/starbase.scm | 59 ++-- v7/src/sf/object.scm | 179 +++++------ 21 files changed, 1210 insertions(+), 1258 deletions(-) diff --git a/v7/src/compiler/base/lvalue.scm b/v7/src/compiler/base/lvalue.scm index a7ca095c7..a49401e3b 100644 --- a/v7/src/compiler/base/lvalue.scm +++ b/v7/src/compiler/base/lvalue.scm @@ -1,8 +1,9 @@ #| -*-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. @@ -103,25 +104,25 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. (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))) diff --git a/v7/src/compiler/base/macros.scm b/v7/src/compiler/base/macros.scm index 3345e9724..8cdbb329b 100644 --- a/v7/src/compiler/base/macros.scm +++ b/v7/src/compiler/base/macros.scm @@ -1,8 +1,9 @@ #| -*-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. @@ -128,51 +129,51 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. (DESCRIPTOR-LIST OBJECT ,type ,@slots))))))) (ill-formed-syntax form)))))) -(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 diff --git a/v7/src/compiler/base/utils.scm b/v7/src/compiler/base/utils.scm index b480f9644..a9717e332 100644 --- a/v7/src/compiler/base/utils.scm +++ b/v7/src/compiler/base/utils.scm @@ -1,8 +1,9 @@ #| -*-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. @@ -109,7 +110,7 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. (if (null? sets) (eq-set-union set accum) (loop (car sets) (cdr sets) (eq-set-union set accum))))) - + (package (transitive-closure enqueue-node! enqueue-nodes!) (define *queue*) @@ -138,21 +139,22 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. ;;;; 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) @@ -174,7 +176,7 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. (let ((arity (primitive-procedure-arity primitive))) (or (= arity -1) (= arity argument-count))))) - + ;;;; Special Compiler Support (define compiled-error-procedure @@ -352,17 +354,9 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. (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 diff --git a/v7/src/compiler/fggen/canon.scm b/v7/src/compiler/fggen/canon.scm index 7c24f4571..3418d5aad 100644 --- a/v7/src/compiler/fggen/canon.scm +++ b/v7/src/compiler/fggen/canon.scm @@ -1,8 +1,9 @@ #| -*-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. @@ -505,37 +506,36 @@ ARBITRARY: The expression may be executed more than once. It ;;;; 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)) @@ -595,7 +595,7 @@ ARBITRARY: The expression may be executed more than once. It (caddr text)) false true false) (make-canout expr true true false)))))))) - + ;;;; Utility for hairy expressions (define (scode/make-evaluation exp env arbitrary? original-expression) diff --git a/v7/src/compiler/machines/i386/lapgen.scm b/v7/src/compiler/machines/i386/lapgen.scm index d55bb6a5b..ef4669eb8 100644 --- a/v7/src/compiler/machines/i386/lapgen.scm +++ b/v7/src/compiler/machines/i386/lapgen.scm @@ -1,8 +1,8 @@ #| -*-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. @@ -569,30 +569,31 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. 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))) @@ -608,73 +609,73 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. (LAP (MOV B (R ,eax) (& ,code)) ,@(invoke-hook/call entry:compiler-scheme-to-interface/call))) -(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) ;; Operation tables diff --git a/v7/src/compiler/rtlbase/rtlreg.scm b/v7/src/compiler/rtlbase/rtlreg.scm index 7d9800c20..6c80d96c2 100644 --- a/v7/src/compiler/rtlbase/rtlreg.scm +++ b/v7/src/compiler/rtlbase/rtlreg.scm @@ -1,8 +1,9 @@ #| -*-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. @@ -25,7 +26,7 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. ;;;; RTL Registers (declare (usual-integrations)) - + (define *machine-register-map*) (define (initialize-machine-register-map!) @@ -67,27 +68,27 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. (loop (1+ register))))) (loop number-of-machine-registers))) -(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)) diff --git a/v7/src/compiler/rtlbase/valclass.scm b/v7/src/compiler/rtlbase/valclass.scm index 7bf13e510..78951ea7f 100644 --- a/v7/src/compiler/rtlbase/valclass.scm +++ b/v7/src/compiler/rtlbase/valclass.scm @@ -1,8 +1,8 @@ #| -*-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. @@ -76,39 +76,39 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. (loop (car x) (cdr x) (cdr y)) join))) -(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 diff --git a/v7/src/edwin/buffer.scm b/v7/src/edwin/buffer.scm index 11a7a9c50..bb3c8c846 100644 --- a/v7/src/edwin/buffer.scm +++ b/v7/src/edwin/buffer.scm @@ -1,25 +1,28 @@ -;;; -*-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 @@ -46,19 +49,19 @@ 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. diff --git a/v7/src/edwin/calias.scm b/v7/src/edwin/calias.scm index 2794b94fb..717d401a8 100644 --- a/v7/src/edwin/calias.scm +++ b/v7/src/edwin/calias.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -272,39 +272,40 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. 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 diff --git a/v7/src/edwin/dosproc.scm b/v7/src/edwin/dosproc.scm index 58a0fca10..27b86a47e 100644 --- a/v7/src/edwin/dosproc.scm +++ b/v7/src/edwin/dosproc.scm @@ -1,25 +1,26 @@ -;;; -*-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) @@ -44,12 +45,8 @@ (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) diff --git a/v7/src/edwin/grpops.scm b/v7/src/edwin/grpops.scm index 83399ebbf..a0e6588c1 100644 --- a/v7/src/edwin/grpops.scm +++ b/v7/src/edwin/grpops.scm @@ -1,25 +1,27 @@ -;;; -*-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 diff --git a/v7/src/edwin/search.scm b/v7/src/edwin/search.scm index 33d9aebfd..31ba0cb24 100644 --- a/v7/src/edwin/search.scm +++ b/v7/src/edwin/search.scm @@ -1,103 +1,110 @@ -;;; -*-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)) -(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) (define-integrable (%find-next-newline group start end) (group-find-next-char group start end #\newline)) diff --git a/v7/src/edwin/tterm.scm b/v7/src/edwin/tterm.scm index a9898fd24..05f062339 100644 --- a/v7/src/edwin/tterm.scm +++ b/v7/src/edwin/tterm.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -445,46 +445,48 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. (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) ;;;; Console Screen Operations diff --git a/v7/src/edwin/xcom.scm b/v7/src/edwin/xcom.scm index 8e6574830..86a6688c0 100644 --- a/v7/src/edwin/xcom.scm +++ b/v7/src/edwin/xcom.scm @@ -1,25 +1,27 @@ -;;; -*-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 @@ -215,125 +217,62 @@ When called interactively, completion is available on the input." (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))))))))) - + (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")) ;;;; 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) @@ -342,16 +281,16 @@ When called interactively, completion is available on the input." (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) diff --git a/v7/src/runtime/arith.scm b/v7/src/runtime/arith.scm index aac5fdad8..37150f33a 100644 --- a/v7/src/runtime/arith.scm +++ b/v7/src/runtime/arith.scm @@ -1,10 +1,10 @@ #| -*-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. @@ -537,37 +537,37 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. ;;; 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*) @@ -700,24 +700,24 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. ((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))) @@ -956,63 +956,63 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. (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)))) -(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) @@ -1072,66 +1072,66 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. (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) -(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) @@ -1793,28 +1793,28 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. (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") ;; Replaced with arity-dispatched version in INITIALIZE-PACKAGE! diff --git a/v7/src/runtime/graphics.scm b/v7/src/runtime/graphics.scm index 739cc3731..37fb1feea 100644 --- a/v7/src/runtime/graphics.scm +++ b/v7/src/runtime/graphics.scm @@ -1,8 +1,9 @@ #| -*-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. @@ -253,32 +254,32 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. (%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 @@ -288,7 +289,7 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. arguments))) (maybe-flush device) value)) - + (define (graphics-enable-buffering device) (set-graphics-device/buffer?! device true)) @@ -306,7 +307,7 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. (define-integrable (graphics-flush device) ((graphics-device/operation/flush device) device)) - + (define (graphics-device-coordinate-limits device) ((graphics-device/operation/device-coordinate-limits device) device)) @@ -342,7 +343,7 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. ((graphics-device/operation/set-drawing-mode device) device drawing-mode) (set-graphics-device/drawing-mode! device drawing-mode)) - + (define-integrable line-style:solid 0) (define-integrable line-style:dash 1) (define-integrable line-style:dot 2) @@ -364,7 +365,7 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. (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)) - + (define (graphics-clear device) ((graphics-device/operation/clear device) device) (maybe-flush device)) @@ -423,7 +424,7 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. (and error? (error "Graphics type has no associated image type:" type)))))))) - + (define (make-image-type operations) (let ((operations (map (lambda (entry) @@ -454,7 +455,7 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. (%make-image-type create destroy width height draw draw-subimage fill-from-byte-vector)))))) - + (define-structure (image (conc-name image/) (constructor %make-image)) type descriptor) diff --git a/v7/src/runtime/list.scm b/v7/src/runtime/list.scm index 91edea2fe..7180b9d22 100644 --- a/v7/src/runtime/list.scm +++ b/v7/src/runtime/list.scm @@ -1,8 +1,10 @@ #| -*-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. @@ -547,85 +549,84 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. (map-2 first (car rest))) (map-1 first))) -(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)) (define mapcan append-map!) (define mapcan* append-map*!) diff --git a/v7/src/runtime/parser-buffer.scm b/v7/src/runtime/parser-buffer.scm index 86eb3242f..cdd8e4389 100644 --- a/v7/src/runtime/parser-buffer.scm +++ b/v7/src/runtime/parser-buffer.scm @@ -1,25 +1,26 @@ -;;; -*-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 @@ -143,38 +144,38 @@ (string-ref (parser-buffer-string buffer) (fix:+ (parser-buffer-index buffer) index)))) -(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))) @@ -189,68 +190,68 @@ (set-parser-buffer-pointer! buffer p) #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") (define-integrable (increment-buffer-index! buffer char) (set-parser-buffer-index! buffer (fix:+ (parser-buffer-index buffer) 1)) diff --git a/v7/src/runtime/scomb.scm b/v7/src/runtime/scomb.scm index 76816cd92..b10b1b143 100644 --- a/v7/src/runtime/scomb.scm +++ b/v7/src/runtime/scomb.scm @@ -1,8 +1,9 @@ #| -*-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. @@ -205,7 +206,7 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. (define (conditional-subexpressions expression) (conditional-components expression list)) - + ;;;; Disjunction (define (make-disjunction predicate alternative) @@ -287,34 +288,33 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. (ucode-type combination)) (cons operator operands))))) -(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 @@ -345,11 +345,9 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. (receiver (&vector-ref combination 0) (&subvector->list combination 1 (&vector-length combination))))) -) - (define (combination-subexpressions expression) (combination-components expression cons)) - + ;;;; Unassigned? (define (make-unassigned? name) diff --git a/v7/src/runtime/starbase.scm b/v7/src/runtime/starbase.scm index 4c77c6d3e..48f3de557 100644 --- a/v7/src/runtime/starbase.scm +++ b/v7/src/runtime/starbase.scm @@ -1,8 +1,9 @@ #| -*-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. @@ -92,7 +93,7 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. (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 @@ -106,32 +107,32 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. (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) (define (operation/available?) (implemented-primitive-procedure? starbase-open-device)) diff --git a/v7/src/sf/object.scm b/v7/src/sf/object.scm index e88578f7b..ddf1f5894 100644 --- a/v7/src/sf/object.scm +++ b/v7/src/sf/object.scm @@ -1,8 +1,9 @@ #| -*-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. @@ -65,40 +66,40 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. (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)) ;;;; Records @@ -124,39 +125,39 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. 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 @@ -176,26 +177,26 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. ;;;; 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 -- 2.25.1