From e7d91f5a0306ff6876ad89ec357ed9efbe043e77 Mon Sep 17 00:00:00 2001 From: Joe Marshall Date: Sat, 28 Jan 2012 12:41:37 -0800 Subject: [PATCH] Remove unused error codes, add syntax error code. Add syntax-error SCode object. --- src/microcode/errors.h | 40 ++++++++++++++++++++-------------------- src/microcode/gcloop.c | 2 +- src/microcode/interp.c | 3 +++ src/microcode/types.h | 4 ++-- src/runtime/runtime.pkg | 4 ++++ src/runtime/scode.scm | 18 ++++++++++++++++++ src/runtime/uerror.scm | 31 ++++++++++++++++++++----------- 7 files changed, 68 insertions(+), 34 deletions(-) diff --git a/src/microcode/errors.h b/src/microcode/errors.h index 12f996d16..528ea7251 100644 --- a/src/microcode/errors.h +++ b/src/microcode/errors.h @@ -40,8 +40,8 @@ USA. #define ERR_IN_SYSTEM_CALL 0x04 #define ERR_WITH_ARGUMENT 0x05 #define ERR_BAD_FRAME 0x06 -#define ERR_BROKEN_COMPILED_VARIABLE 0x07 -#define ERR_UNDEFINED_USER_TYPE 0x08 +/* #define ERR_BROKEN_COMPILED_VARIABLE 0x07 */ +/* #define ERR_UNDEFINED_USER_TYPE 0x08 */ #define ERR_UNDEFINED_PRIMITIVE 0x09 #define ERR_EXTERNAL_RETURN 0x0A #define ERR_EXECUTE_MANIFEST_VECTOR 0x0B @@ -54,7 +54,7 @@ USA. #define ERR_ARG_3_BAD_RANGE 0x12 #define ERR_MACRO_BINDING 0x13 #define ERR_FASDUMP_OBJECT_TOO_LARGE 0x14 -/* #define ERR_BAD_INTERRUPT_CODE 0x15 */ +#define ERR_SYNTAX_ERROR 0x15 /* #define ERR_NO_ERRORS 0x16 */ #define ERR_FASL_FILE_TOO_BIG 0x17 #define ERR_FASL_FILE_BAD_DATA 0x18 @@ -62,9 +62,9 @@ USA. /* #define ERR_WRITE_INTO_PURE_SPACE 0x1A */ /* #define ERR_LOSING_SPARE_HEAP 0x1B */ /* #define ERR_NO_HASH_TABLE 0x1C */ -#define ERR_BAD_SET 0x1D -#define ERR_ARG_1_FAILED_COERCION 0x1E -#define ERR_ARG_2_FAILED_COERCION 0x1F +/* #define ERR_BAD_SET 0x1D */ +/* #define ERR_ARG_1_FAILED_COERCION 0x1E */ +/* #define ERR_ARG_2_FAILED_COERCION 0x1F */ #define ERR_OUT_OF_FILE_HANDLES 0x20 /* #define ERR_SHELL_DIED 0x21 */ #define ERR_ARG_4_BAD_RANGE 0x22 @@ -86,14 +86,14 @@ USA. #define ERR_FLOATING_OVERFLOW 0x32 #define ERR_UNIMPLEMENTED_PRIMITIVE 0x33 #define ERR_ILLEGAL_REFERENCE_TRAP 0x34 -#define ERR_BROKEN_VARIABLE_CACHE 0x35 +/* #define ERR_BROKEN_VARIABLE_CACHE 0x35 */ #define ERR_WRONG_ARITY_PRIMITIVES 0x36 -#define ERR_IO_ERROR 0x37 +/* #define ERR_IO_ERROR 0x37 */ #define ERR_FASDUMP_ENVIRONMENT 0x38 #define ERR_FASLOAD_BAND 0x39 #define ERR_FASLOAD_COMPILED_MISMATCH 0x3A -#define ERR_UNKNOWN_PRIMITIVE_CONTINUATION 0x3B -#define ERR_ILLEGAL_CONTINUATION 0x3C +/* #define ERR_UNKNOWN_PRIMITIVE_CONTINUATION 0x3B */ +/* #define ERR_ILLEGAL_CONTINUATION 0x3C */ #define ERR_STACK_HAS_SLIPPED 0x3D #define ERR_CANNOT_RECURSE 0x3E #define ERR_PROCESS_TERMINATED 0x3F @@ -111,8 +111,8 @@ USA. /* 0x04 */ "system-call", \ /* 0x05 */ "error-with-argument", \ /* 0x06 */ "bad-frame", \ -/* 0x07 */ "broken-compiled-variable", \ -/* 0x08 */ "undefined-user-type", \ +/* 0x07 */ 0, \ +/* 0x08 */ 0, \ /* 0x09 */ "undefined-primitive-operation", \ /* 0x0a */ "external-return", \ /* 0x0b */ "execute-manifest-vector", \ @@ -125,7 +125,7 @@ USA. /* 0x12 */ "bad-range-argument-2", \ /* 0x13 */ "macro-binding", \ /* 0x14 */ "fasdump-object-too-large", \ -/* 0x15 */ 0, \ +/* 0x15 */ "syntax-error", \ /* 0x16 */ 0, \ /* 0x17 */ "fasl-file-too-big", \ /* 0x18 */ "fasl-file-bad-data", \ @@ -133,9 +133,9 @@ USA. /* 0x1a */ 0, \ /* 0x1b */ 0, \ /* 0x1c */ 0, \ -/* 0x1d */ "bad-assignment", \ -/* 0x1e */ "failed-arg-1-coercion", \ -/* 0x1f */ "failed-arg-2-coercion", \ +/* 0x1d */ 0, \ +/* 0x1e */ 0, \ +/* 0x1f */ 0, \ /* 0x20 */ "out-of-file-handles", \ /* 0x21 */ 0, \ /* 0x22 */ "bad-range-argument-3", \ @@ -157,14 +157,14 @@ USA. /* 0x32 */ "floating-overflow", \ /* 0x33 */ "unimplemented-primitive", \ /* 0x34 */ "illegal-reference-trap", \ -/* 0x35 */ "broken-variable-cache", \ +/* 0x35 */ 0, \ /* 0x36 */ "wrong-arity-primitives", \ -/* 0x37 */ "io-error", \ +/* 0x37 */ 0, \ /* 0x38 */ "fasdump-environment", \ /* 0x39 */ "fasload-band", \ /* 0x3a */ "fasload-compiled-mismatch", \ -/* 0x3b */ "unknown-primitive-continuation", \ -/* 0x3c */ "illegal-continuation", \ +/* 0x3b */ 0, \ +/* 0x3c */ 0, \ /* 0x3d */ "stack-has-slipped", \ /* 0x3e */ "cannot-recurse", \ /* 0x3f */ "process-terminated", \ diff --git a/src/microcode/gcloop.c b/src/microcode/gcloop.c index 6629031d9..2195373e5 100644 --- a/src/microcode/gcloop.c +++ b/src/microcode/gcloop.c @@ -1293,7 +1293,7 @@ gc_type_t gc_type_map [N_TYPE_CODES] = GC_VECTOR, /* TC_EPHEMERON */ GC_TRIPLE, /* TC_VARIABLE */ GC_NON_POINTER, /* TC_THE_ENVIRONMENT */ - GC_UNDEFINED, /* 0x2E */ + GC_PAIR, /* TC_SYNTAX_ERROR */ GC_VECTOR, /* TC_VECTOR_1B,TC_BIT_STRING */ GC_NON_POINTER, /* TC_PCOMB0 */ GC_VECTOR, /* TC_VECTOR_16B */ diff --git a/src/microcode/interp.c b/src/microcode/interp.c index fca00daa4..ff20323c2 100644 --- a/src/microcode/interp.c +++ b/src/microcode/interp.c @@ -569,6 +569,9 @@ Interpret (int pop_return_p) PUSH_ENV (); PUSH_NTH_THEN (RC_SEQ_3_DO_2, SEQUENCE_1); + case TC_SYNTAX_ERROR: + EVAL_ERROR (ERR_SYNTAX_ERROR); + case TC_THE_ENVIRONMENT: SET_VAL (GET_ENV); break; diff --git a/src/microcode/types.h b/src/microcode/types.h index b39224b20..5f52954de 100644 --- a/src/microcode/types.h +++ b/src/microcode/types.h @@ -72,7 +72,7 @@ USA. #define TC_EPHEMERON 0x2B #define TC_VARIABLE 0x2C #define TC_THE_ENVIRONMENT 0x2D -/* #define TC_UNUSED 0x2E */ +#define TC_SYNTAX_ERROR 0x2E #define TC_VECTOR_1B 0x2F #define TC_PCOMB0 0x30 #define TC_VECTOR_16B 0x31 @@ -150,7 +150,7 @@ USA. /* 0x2b */ "ephemeron", \ /* 0x2c */ "variable", \ /* 0x2d */ "the-environment", \ - /* 0x2e */ 0, \ + /* 0x2e */ "syntax-error", \ /* 0x2f */ "vector-1b", \ /* 0x30 */ "primitive-combination-0", \ /* 0x31 */ "vector-16b", \ diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 205e98aec..cfc35ca98 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -3590,6 +3590,7 @@ USA. make-definition make-delay make-quotation + make-syntax-error make-the-environment make-variable quotation-expression @@ -3599,6 +3600,9 @@ USA. set-comment-text! set-declaration-expression! set-declaration-text! + syntax-error? + syntax-error-message + syntax-error-datum the-environment? variable-components variable-name diff --git a/src/runtime/scode.scm b/src/runtime/scode.scm index 0e941ca3f..92efdd04f 100644 --- a/src/runtime/scode.scm +++ b/src/runtime/scode.scm @@ -93,6 +93,24 @@ USA. (guarantee-quotation quotation 'QUOTATION-EXPRESSION) (&singleton-element quotation)) +;;;; Syntax error + +(define (make-syntax-error message datum) + (&typed-pair-cons (ucode-type syntax-error) message datum)) + +(define (syntax-error? object) + (object-type? (ucode-type syntax-error) object)) + +(define-guarantee syntax-error "SCode syntax error") + +(define (syntax-error-message syntax-error) + (guarantee-syntax-error syntax-error 'syntax-error-message) + (system-pair-car syntax-error)) + +(define (syntax-error-datum syntax-error) + (guarantee-syntax-error syntax-error 'syntax-error-datum) + (system-pair-cdr syntax-error)) + ;;;; Variable (define (make-variable name) diff --git a/src/runtime/uerror.scm b/src/runtime/uerror.scm index 7387ad177..c07b159a3 100644 --- a/src/runtime/uerror.scm +++ b/src/runtime/uerror.scm @@ -43,6 +43,7 @@ USA. (define condition-type:primitive-io-error) (define condition-type:primitive-procedure-error) (define condition-type:process-terminated-error) +(define condition-type:syntax-error) (define condition-type:system-call-error) (define condition-type:unimplemented-primitive) (define condition-type:unimplemented-primitive-for-os) @@ -687,17 +688,6 @@ USA. (write-operator (access-condition condition 'OPERATOR) port) (write-string " signalled an anonymous I/O error." port)))) -(define-error-handler 'IO-ERROR - (let ((signal - (condition-signaller condition-type:primitive-io-error - '(OPERATOR OPERANDS)))) - (lambda (continuation) - (let ((frame (continuation/first-subproblem continuation))) - (if (apply-frame? frame) - (signal continuation - (apply-frame/operator frame) - (apply-frame/operands frame))))))) - (set! condition-type:out-of-file-handles (make-condition-type 'OUT-OF-FILE-HANDLES condition-type:primitive-procedure-error @@ -913,6 +903,25 @@ USA. (write (access-condition condition 'DATUM) port) (write-string " is not applicable." port)))) +(set! condition-type:syntax-error + (make-condition-type 'SYNTAX-ERROR condition-type:error + '(MESSAGE DATUM) + (lambda (condition port) + (write-string "Syntax error: " port) + (write-string (access-condition condition 'MESSAGE) port) + (write (access-condition condition 'DATUM) port)))) + +(define-error-handler 'SYNTAX-ERROR + (let ((signal + (condition-signaller condition-type:syntax-error + '(MESSAGE DATUM)))) + (lambda (continuation) + (let ((frame (continuation/first-subproblem continuation))) + (let ((expression (eval-frame/expression frame))) + (signal continuation + (syntax-error-message expression) + (syntax-error-datum expression))))))) + (define-error-handler 'UNDEFINED-PROCEDURE (let ((signal (condition-signaller condition-type:inapplicable-object -- 2.25.1