From 052ab7e961593ff647c73d0efb1f460f7bb2ac9d Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Tue, 11 Jan 2005 03:57:23 +0000 Subject: [PATCH] New syntax DEFINE-GUARANTEE. --- v7/src/runtime/arith.scm | 15 ++------------- v7/src/runtime/runtime.pkg | 3 ++- v7/src/runtime/sfile.scm | 21 ++------------------- v7/src/runtime/sysmac.scm | 23 ++++++++++++++++++++--- 4 files changed, 26 insertions(+), 36 deletions(-) diff --git a/v7/src/runtime/arith.scm b/v7/src/runtime/arith.scm index 77dc12cbe..2ab691431 100644 --- a/v7/src/runtime/arith.scm +++ b/v7/src/runtime/arith.scm @@ -1,10 +1,10 @@ #| -*-Scheme-*- -$Id: arith.scm,v 1.61 2004/10/13 03:22:40 cph Exp $ +$Id: arith.scm,v 1.62 2005/01/11 03:56:44 cph Exp $ Copyright 1989,1990,1991,1992,1993,1994 Massachusetts Institute of Technology Copyright 1995,1996,1997,1999,2001,2002 Massachusetts Institute of Technology -Copyright 2003,2004 Massachusetts Institute of Technology +Copyright 2003,2004,2005 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -1813,17 +1813,6 @@ USA. (and (int:integer? object) (int:positive? object))) -(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") diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg index e565d3754..9c1726b8d 100644 --- a/v7/src/runtime/runtime.pkg +++ b/v7/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: runtime.pkg,v 14.526 2005/01/07 15:10:06 cph Exp $ +$Id: runtime.pkg,v 14.527 2005/01/11 03:57:00 cph Exp $ Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology Copyright 1994,1995,1996,1997,1998,1999 Massachusetts Institute of Technology @@ -3931,6 +3931,7 @@ USA. (files "sysmac") (parent (runtime)) (export (runtime) + define-guarantee define-primitives ucode-primitive ucode-return-address diff --git a/v7/src/runtime/sfile.scm b/v7/src/runtime/sfile.scm index e4771805d..814e365a9 100644 --- a/v7/src/runtime/sfile.scm +++ b/v7/src/runtime/sfile.scm @@ -1,9 +1,9 @@ #| -*-Scheme-*- -$Id: sfile.scm,v 14.39 2004/10/29 16:30:25 cph Exp $ +$Id: sfile.scm,v 14.40 2005/01/11 03:57:16 cph Exp $ Copyright 1986,1987,1988,1989,1990,1991 Massachusetts Institute of Technology -Copyright 1999,2001,2003,2004 Massachusetts Institute of Technology +Copyright 1999,2001,2003,2004,2005 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -373,23 +373,6 @@ USA. i) end))) -(define-syntax define-guarantee - (sc-macro-transformer - (lambda (form environment) - (if (syntax-match? '(SYMBOL EXPRESSION) (cdr form)) - (let ((root (cadr form)) - (desc (close-syntax (caddr form) environment))) - (let ((p-name (symbol root '?)) - (g-name (symbol 'guarantee- root)) - (e-name (symbol 'error:not- root))) - `(BEGIN - (DEFINE (,g-name OBJECT CALLER) - (IF (NOT (,(close-syntax p-name environment) OBJECT)) - (,(close-syntax e-name environment) OBJECT CALLER))) - (DEFINE (,e-name OBJECT CALLER) - (ERROR:WRONG-TYPE-ARGUMENT OBJECT ,desc CALLER))))) - (ill-formed-syntax form))))) - (define-guarantee mime-type "MIME type") (define-guarantee mime-type-string "MIME type string") (define-guarantee mime-token "MIME token") diff --git a/v7/src/runtime/sysmac.scm b/v7/src/runtime/sysmac.scm index 43136f256..32d7924ed 100644 --- a/v7/src/runtime/sysmac.scm +++ b/v7/src/runtime/sysmac.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: sysmac.scm,v 14.12 2003/02/14 18:28:34 cph Exp $ +$Id: sysmac.scm,v 14.13 2005/01/11 03:57:23 cph Exp $ -Copyright (c) 1988, 1999, 2001, 2002 Massachusetts Institute of Technology +Copyright 1988,2001,2002,2005 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -61,4 +61,21 @@ USA. (sc-macro-transformer (lambda (form environment) environment - (make-return-address (apply microcode-return (cdr form)))))) \ No newline at end of file + (make-return-address (apply microcode-return (cdr form)))))) + +(define-syntax define-guarantee + (sc-macro-transformer + (lambda (form environment) + (if (syntax-match? '(SYMBOL EXPRESSION) (cdr form)) + (let ((root (cadr form)) + (desc (close-syntax (caddr form) environment))) + (let ((p-name (symbol root '?)) + (g-name (symbol 'guarantee- root)) + (e-name (symbol 'error:not- root))) + `(BEGIN + (DEFINE (,g-name OBJECT CALLER) + (IF (NOT (,(close-syntax p-name environment) OBJECT)) + (,(close-syntax e-name environment) OBJECT CALLER))) + (DEFINE (,e-name OBJECT CALLER) + (ERROR:WRONG-TYPE-ARGUMENT OBJECT ,desc CALLER))))) + (ill-formed-syntax form))))) \ No newline at end of file -- 2.25.1