From 4c1bf52ea5e5a0f34643cd434002d66c2b247ffc Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Thu, 19 Feb 2009 05:27:40 +0000 Subject: [PATCH] Type check args to scode procedures. --- v7/src/runtime/scan.scm | 5 +- v7/src/runtime/scode.scm | 120 +++++++++++++++++++++++++-------------- v7/src/runtime/scomb.scm | 44 +++++++++----- 3 files changed, 111 insertions(+), 58 deletions(-) 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 -- 2.25.1