From: Chris Hanson <org/chris-hanson/cph>
Date: Thu, 19 Feb 2009 05:27:40 +0000 (+0000)
Subject: Type check args to scode procedures.
X-Git-Tag: 20090517-FFI~68
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=4c1bf52ea5e5a0f34643cd434002d66c2b247ffc;p=mit-scheme.git

Type check args to scode procedures.
---

diff --git a/v7/src/runtime/scan.scm b/v7/src/runtime/scan.scm
index 4e65fb08e..1ecdc7b18 100644
--- a/v7/src/runtime/scan.scm
+++ b/v7/src/runtime/scan.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: scan.scm,v 14.12 2008/01/30 20:02:34 cph Exp $
+$Id: scan.scm,v 14.13 2009/02/19 05:27:40 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -190,7 +190,10 @@ USA.
        (vector? (&triple-first object))
        (eq? (vector-ref (&triple-first object) 0) open-block-tag)))
 
+(define-guarantee open-block "SCode open-block")
+
 (define (open-block-components open-block receiver)
+  (guarantee-open-block open-block 'OPEN-BLOCK-COMPONENTS)
   (receiver (vector-ref (&triple-first open-block) 1)
 	    (vector-ref (&triple-first open-block) 2)
 	    (&triple-third open-block)))
\ No newline at end of file
diff --git a/v7/src/runtime/scode.scm b/v7/src/runtime/scode.scm
index c2ca5658f..11c9e7c42 100644
--- a/v7/src/runtime/scode.scm
+++ b/v7/src/runtime/scode.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: scode.scm,v 14.25 2008/01/30 20:02:34 cph Exp $
+$Id: scode.scm,v 14.26 2009/02/19 05:27:40 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -29,11 +29,11 @@ USA.
 ;;; package: (runtime scode)
 
 (declare (usual-integrations))
-
+
 (define (initialize-package!)
   (set! scode-constant/type-vector (make-scode-constant/type-vector))
   unspecific)
-
+
 ;;;; Constant
 
 (define scode-constant/type-vector)
@@ -82,67 +82,81 @@ USA.
 
 ;;;; Quotation
 
-(define-integrable (make-quotation expression)
+(define (make-quotation expression)
   (&typed-singleton-cons (ucode-type quotation) expression))
 
-(define-integrable (quotation? object)
+(define (quotation? object)
   (object-type? (ucode-type quotation) object))
 
-(define-integrable (quotation-expression quotation)
+(define-guarantee quotation "SCode quotation")
+
+(define (quotation-expression quotation)
+  (guarantee-quotation quotation 'QUOTATION-EXPRESSION)
   (&singleton-element quotation))
 
 ;;;; Variable
 
-(define-integrable (make-variable name)
+(define (make-variable name)
   (system-hunk3-cons (ucode-type variable) name #t '()))
 
-(define-integrable (variable? object)
+(define (variable? object)
   (object-type? (ucode-type variable) object))
 
-(define-integrable (variable-name variable)
+(define-guarantee variable "SCode variable")
+
+(define (variable-name variable)
+  (guarantee-variable variable 'VARIABLE-NAME)
   (system-hunk3-cxr0 variable))
 
-(define-integrable (variable-components variable receiver)
+(define (variable-components variable receiver)
   (receiver (variable-name variable)))
 
 ;;;; Definition/Assignment
 
-(define-integrable (make-definition name value)
+(define (make-definition name value)
   (&typed-pair-cons (ucode-type definition) name value))
 
-(define-integrable (definition? object)
+(define (definition? object)
   (object-type? (ucode-type definition) object))
 
-(define-integrable (definition-name definition)
+(define-guarantee definition "SCode definition")
+
+(define (definition-name definition)
+  (guarantee-definition definition 'DEFINITION-NAME)
   (system-pair-car definition))
 
-(define-integrable (definition-value definition)
+(define (definition-value definition)
+  (guarantee-definition definition 'DEFINITION-VALUE)
   (&pair-cdr definition))
 
 (define (definition-components definition receiver)
   (receiver (definition-name definition)
 	    (definition-value definition)))
 
-(define-integrable (assignment? object)
+(define (assignment? object)
   (object-type? (ucode-type assignment) object))
 
-(define-integrable (make-assignment-from-variable variable value)
+(define-guarantee assignment "SCode assignment")
+
+(define (make-assignment-from-variable variable value)
   (&typed-pair-cons (ucode-type assignment) variable value))
 
-(define-integrable (assignment-variable assignment)
+(define (assignment-variable assignment)
+  (guarantee-assignment assignment 'ASSIGNMENT-VARIABLE)
   (system-pair-car assignment))
 
-(define-integrable (assignment-value assignment)
+(define (assignment-value assignment)
+  (guarantee-assignment assignment 'ASSIGNMENT-VALUE)
   (&pair-cdr assignment))
 
 (define (assignment-components-with-variable assignment receiver)
   (receiver (assignment-variable assignment)
 	    (assignment-value assignment)))
 
-(define-integrable (make-assignment name value)
+(define (make-assignment name value)
   (make-assignment-from-variable (make-variable name) value))
 
-(define-integrable (assignment-name assignment)
+(define (assignment-name assignment)
   (variable-name (assignment-variable assignment)))
 
 (define (assignment-components assignment receiver)
@@ -151,22 +165,28 @@ USA.
 
 ;;;; Comment
 
-(define-integrable (make-comment text expression)
+(define (make-comment text expression)
   (&typed-pair-cons (ucode-type comment) expression text))
 
-(define-integrable (comment? object)
+(define (comment? object)
   (object-type? (ucode-type comment) object))
 
-(define-integrable (comment-text comment)
+(define-guarantee comment "SCode comment")
+
+(define (comment-text comment)
+  (guarantee-comment comment 'COMMENT-TEXT)
   (system-pair-cdr comment))
 
-(define-integrable (set-comment-text! comment text)
+(define (set-comment-text! comment text)
+  (guarantee-comment comment 'SET-COMMENT-TEXT!)
   (system-pair-set-cdr! comment text))
 
-(define-integrable (comment-expression comment)
+(define (comment-expression comment)
+  (guarantee-comment comment 'COMMENT-EXPRESSION)
   (&pair-car comment))
 
-(define-integrable (set-comment-expression! comment expression)
+(define (set-comment-expression! comment expression)
+  (guarantee-comment comment 'SET-COMMENT-EXPRESSION!)
   (&pair-set-car! comment expression))
 
 (define (comment-components comment receiver)
@@ -175,7 +195,7 @@ USA.
 
 ;;;; Declaration
 
-(define-integrable (make-declaration text expression)
+(define (make-declaration text expression)
   (make-comment (cons declaration-tag text) expression))
 
 (define (declaration? object)
@@ -184,19 +204,25 @@ USA.
 	 (and (pair? text)
 	      (eq? (car text) declaration-tag)))))
 
-(define-integrable declaration-tag
+(define declaration-tag
   ((ucode-primitive string->symbol) "#[declaration]"))
 
-(define-integrable (declaration-text declaration)
+(define-guarantee declaration "SCode declaration")
+
+(define (declaration-text declaration)
+  (guarantee-declaration declaration 'DECLARATION-TEXT)
   (cdr (comment-text declaration)))
 
-(define-integrable (set-declaration-text! declaration text)
+(define (set-declaration-text! declaration text)
+  (guarantee-declaration declaration 'SET-DECLARATION-TEXT!)
   (set-cdr! (comment-text declaration) text))
 
-(define-integrable (declaration-expression declaration)
+(define (declaration-expression declaration)
+  (guarantee-declaration declaration 'DECLARATION-EXPRESSION)
   (comment-expression declaration))
 
-(define-integrable (set-declaration-expression! declaration expression)
+(define (set-declaration-expression! declaration expression)
+  (guarantee-declaration declaration 'SET-DECLARATION-EXPRESSION!)
   (set-comment-expression! declaration expression))
 
 (define (declaration-components declaration receiver)
@@ -205,24 +231,28 @@ USA.
 
 ;;;; The-Environment
 
-(define-integrable (make-the-environment)
+(define (make-the-environment)
   (object-new-type (ucode-type the-environment) 0))
 
-(define-integrable (the-environment? object)
+(define (the-environment? object)
   (object-type? (ucode-type the-environment) object))
 
 ;;;; Access
 
-(define-integrable (make-access environment name)
+(define (make-access environment name)
   (&typed-pair-cons (ucode-type access) environment name))
 
-(define-integrable (access? object)
+(define (access? object)
   (object-type? (ucode-type access) object))
 
+(define-guarantee access "SCode access")
+
 (define (access-environment expression)
+  (guarantee-access expression 'ACCESS-ENVIRONMENT)
   (&pair-car expression))
 
-(define-integrable (access-name expression)
+(define (access-name expression)
+  (guarantee-access expression 'ACCESS-NAME)
   (system-pair-cdr expression))
 
 (define (access-components expression receiver)
@@ -242,7 +272,10 @@ USA.
   (and (access? object)
        (system-global-environment? (access-environment object))))
 
-(define-integrable (absolute-reference-name reference)
+(define-guarantee absolute-reference "SCode absolute reference")
+
+(define (absolute-reference-name reference)
+  (guarantee-absolute-reference reference 'ABSOLUTE-REFERENCE-NAME)
   (access-name reference))
 
 (define (absolute-reference-to? object name)
@@ -251,14 +284,17 @@ USA.
 
 ;;;; Delay
 
-(define-integrable (make-delay expression)
+(define (make-delay expression)
   (&typed-singleton-cons (ucode-type delay) expression))
 
-(define-integrable (delay? object)
+(define (delay? object)
   (object-type? (ucode-type delay) object))
 
-(define-integrable (delay-expression expression)
+(define-guarantee delay "SCode delay")
+
+(define (delay-expression expression)
+  (guarantee-delay expression 'DELAY-EXPRESSION)
   (&singleton-element expression))
 
-(define-integrable (delay-components expression receiver)
+(define (delay-components expression receiver)
   (receiver (delay-expression expression)))
\ No newline at end of file
diff --git a/v7/src/runtime/scomb.scm b/v7/src/runtime/scomb.scm
index 4cd8d428c..e7582d35a 100644
--- a/v7/src/runtime/scomb.scm
+++ b/v7/src/runtime/scomb.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: scomb.scm,v 14.29 2008/02/13 14:26:47 cph Exp $
+$Id: scomb.scm,v 14.30 2009/02/19 05:27:40 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -145,6 +145,8 @@ USA.
   (or (object-type? (ucode-type sequence-2) object)
       (object-type? (ucode-type sequence-3) object)))
 
+(define-guarantee sequence "SCode sequence")
+
 (define (sequence-actions expression)
   (cond ((object-type? (ucode-type sequence-2) expression)
 	 (append! (sequence-actions (&pair-car expression))
@@ -165,10 +167,9 @@ USA.
 	       (&triple-second expression)
 	       (&triple-third expression)))
 	(else
-	 (error:wrong-type-argument expression "SCode sequence"
-				    'SEQUENCE-IMMEDIATE-ACTIONS))))
+	 (error:not-sequence expression 'SEQUENCE-IMMEDIATE-ACTIONS))))
 
-(define-integrable (sequence-components expression receiver)
+(define (sequence-components expression receiver)
   (receiver (sequence-actions expression)))
 
 ;;;; Conditional
@@ -187,15 +188,20 @@ USA.
 (define (conditional? object)
   (object-type? (ucode-type conditional) object))
 
+(define-guarantee conditional "SCode conditional")
+
 (define undefined-conditional-branch unspecific)
 
-(define-integrable (conditional-predicate conditional)
+(define (conditional-predicate conditional)
+  (guarantee-conditional conditional 'CONDITIONAL-PREDICATE)
   (&triple-first conditional))
 
-(define-integrable (conditional-consequent conditional)
+(define (conditional-consequent conditional)
+  (guarantee-conditional conditional 'CONDITIONAL-CONSEQUENT)
   (&triple-second conditional))
 
-(define-integrable (conditional-alternative conditional)
+(define (conditional-alternative conditional)
+  (guarantee-conditional conditional 'CONDITIONAL-ALTERNATIVE)
   (&triple-third conditional))
 
 (define (conditional-components conditional receiver)
@@ -216,13 +222,17 @@ USA.
 			true)
       (&typed-pair-cons (ucode-type disjunction) predicate alternative)))
 
-(define-integrable (disjunction? object)
+(define (disjunction? object)
   (object-type? (ucode-type disjunction) object))
 
-(define-integrable (disjunction-predicate disjunction)
+(define-guarantee disjunction "SCode disjunction")
+
+(define (disjunction-predicate disjunction)
+  (guarantee-disjunction disjunction 'DISJUNCTION-PREDICATE)
   (&pair-car disjunction))
 
-(define-integrable (disjunction-alternative disjunction)
+(define (disjunction-alternative disjunction)
+  (guarantee-disjunction disjunction 'DISJUNCTION-ALTERNATIVE)
   (&pair-cdr disjunction))
 
 (define (disjunction-components disjunction receiver)
@@ -243,6 +253,8 @@ USA.
       (object-type? (ucode-type primitive-combination-2) object)
       (object-type? (ucode-type primitive-combination-3) object)))
 
+(define-guarantee combination "SCode combination")
+
 (define (make-combination operator operands)
   (if (and (procedure? operator)
 	   (not (primitive-procedure? operator)))
@@ -317,8 +329,7 @@ USA.
 				 ,combination))
 	       ,case-n)
 	      (ELSE
-	       (ERROR:WRONG-TYPE-ARGUMENT ,combination "SCode combination"
-					  ',name)))))))
+	       (ERROR:NOT-COMBINATION ,combination ',name)))))))
 
 (define (combination-size combination)
   (combination-dispatch combination-size combination
@@ -351,7 +362,7 @@ USA.
 
 (define (combination-subexpressions expression)
   (combination-components expression cons))
-
+
 ;;;; Unassigned?
 
 (define (make-unassigned? name)
@@ -366,8 +377,11 @@ USA.
 	 (and (the-environment? (car operands))
 	      (symbol? (cadr operands))))))
 
-(define-integrable (unassigned?-name expression)
+(define-guarantee unassigned? "SCode unassigned test")
+
+(define (unassigned?-name expression)
+  (guarantee-unassigned? expression 'UNASSIGNED?-NAME)
   (cadr (combination-operands expression)))
 
-(define-integrable (unassigned?-components expression receiver)
+(define (unassigned?-components expression receiver)
   (receiver (unassigned?-name expression)))
\ No newline at end of file