mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-21 12:10:26 +02:00
b7742c6b71
* libguile/eval.c: So, ladies & gents, a new evaluator. It's similar to
the old one, in that we memoize and then evaluate, but in this
incarnation, memoization of an expression happens before evaluation,
not lazily as the expression is evaluated. This makes the evaluation
itself much cleaner, in addition to being threadsafe. In addition,
since this C evaluator will in the future just serve to bootstrap the
Scheme evaluator, we don't have to pay much concern for debugging
conveniences. So the environment is just a list of values, and the
memoizer pre-computes where it's going to find each individual value
in the environment.
Interface changes are commented below, with eval.h.
(scm_evaluator_traps): No need to reset the debug mode after rnning te
traps thing. But really, the whole traps system needs some love.
* libguile/memoize.h:
* libguile/memoize.c: New memoizer, which runs before evaluation,
checking all syntax before evaluation begins. Significantly, no
debugging information is left for lexical variables, which is not so
great for interactive debugging; perhaps we should change this to have
a var list in the future as per the classic interpreters. But it's
quite fast, and the resulting code is quite good. Also note that it
doesn't produce ilocs, memoized code is a smob whose type is in the
first word of the smob itself.
* libguile/eval.h (scm_sym_and, scm_sym_begin, scm_sym_case)
(scm_sym_cond, scm_sym_define, scm_sym_do, scm_sym_if, scm_sym_lambda)
(scm_sym_let, scm_sym_letstar, scm_sym_letrec, scm_sym_quote)
(scm_sym_quasiquote, scm_sym_unquote, scm_sym_uq_splicing, scm_sym_at)
(scm_sym_atat, scm_sym_atapply, scm_sym_atcall_cc)
(scm_sym_at_call_with_values, scm_sym_delay, scm_sym_eval_when)
(scm_sym_arrow, scm_sym_else, scm_sym_apply, scm_sym_set_x)
(scm_sym_args): Remove public declaration of these symbols.
(scm_ilookup, scm_lookupcar, scm_eval_car, scm_eval_body)
(scm_eval_args, scm_i_eval_x, scm_i_eval): Remove public declaration
of these functions.
(scm_ceval, scm_deval, scm_ceval_ptr): Remove declarations of these
deprecated functions.
(scm_i_print_iloc, scm_i_print_isym, scm_i_unmemocopy_expr)
(scm_i_unmemocopy_body): Remove declarations of these internal
functions.
(scm_primitive_eval_x, scm_eval_x): Redefine as macros for their less
destructive siblings.
* libguile/Makefile.am: Add memoize.[ch] to the build.
* libguile/debug.h (scm_debug_mode_p, scm_check_entry_p)
(scm_check_apply_p, scm_check_exit_p, scm_check_memoize_p)
(scm_debug_eframe_size): Remove these vars that were tied to the old
evaluator's execution model.
(SCM_RESET_DEBUG_MODE): Remove, no more need for this.
(SCM_MEMOIZEDP, SCM_MEMOIZED_EXP, SCM_MEMOIZED_ENV): Remove macros
referring to old memoized code representation.
(scm_local_eval, scm_procedure_environment, scm_memoized_environment)
(scm_make_memoized, scm_memoized_p): Remove functions operating on old
memoized code representation.
(scm_memcons, scm_mem_to_proc, scm_proc_to_mem): Remove debug-only
code for old evaluator.
* libguile/debug.c: Remove code to correspond with debug.h removals.
(scm_debug_options): No need to set the debug mode or frame limit
here, as we don't have C stack limits any more. Perhaps this is a bug,
but as long as we can compile eval.scm, we should be fine.
* libguile/init.c (scm_i_init_guile): Init memoize.c.
* libguile/modules.c (scm_top_level_env, scm_env_top_level)
(scm_env_module, scm_system_module_env_p): Remove these functions.
* libguile/print.c (iprin1): No more need to handle isyms. Adapt to new
form of interpreted procedures.
* libguile/procprop.c (scm_i_procedure_arity): Adapt to new form of
interpreted procedures.
* libguile/procs.c (scm_thunk_p): Adapt to new form of interpreted
procedures.
* libguile/procs.h (SCM_CLOSURE_FORMALS): Removed, this exists no more.
(SCM_CLOSURE_NUM_REQUIRED_ARGS, SCM_CLOSURE_HAS_REST_ARGS): New
accessors.
* libguile/srcprop.c (scm_source_properties, scm_source_property)
(scm_set_source_property_x): Remove special cases for memoized code.
* libguile/stacks.c (read_frame): Remove a source-property case for
interpreted code.
(NEXT_FRAME): Remove a case that I don't fully understand, that seems
to be designed to skip over apply frames. Will be obsolete in the
futures.
(read_frames): Default source value for interpreted frames to #f.
(narrow_stack): Don't pay attention to the system_module thing.
* libguile/tags.h: Remove isyms and ilocs. Whee!
* libguile/validate.h (SCM_VALIDATE_MEMOIZED): Fix to use the new
MEMOIZED_P formulation.
* module/ice-9/psyntax-pp.scm (do, quasiquote, case): Adapt for these no
longer being primitive macros.
* module/ice-9/boot-9.scm: Whitespace change, but just a poke to force a
rebuild due to and/or/cond/... not being primitives any more.
* module/ice-9/deprecated.scm (unmemoize-expr): Deprecate, it's
unmemoize-expression now.
* test-suite/tests/eval.test ("define set procedure-name"): XFAIL a
couple of tests here; I don't know what to do about them. I reckon the
expander should ensure that defined values are named.
* test-suite/tests/chars.test ("basic char handling"): Fix expected
exception when trying to apply a char.
1004 lines
27 KiB
Scheme
1004 lines
27 KiB
Scheme
;;;; syntax.test --- test suite for Guile's syntactic forms -*- scheme -*-
|
|
;;;;
|
|
;;;; Copyright (C) 2001,2003,2004, 2005, 2006, 2009 Free Software Foundation, Inc.
|
|
;;;;
|
|
;;;; This library is free software; you can redistribute it and/or
|
|
;;;; modify it under the terms of the GNU Lesser General Public
|
|
;;;; License as published by the Free Software Foundation; either
|
|
;;;; version 3 of the License, or (at your option) any later version.
|
|
;;;;
|
|
;;;; This library 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
|
|
;;;; Lesser General Public License for more details.
|
|
;;;;
|
|
;;;; You should have received a copy of the GNU Lesser General Public
|
|
;;;; License along with this library; if not, write to the Free Software
|
|
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
|
|
|
|
(define-module (test-suite test-syntax)
|
|
:use-module (test-suite lib))
|
|
|
|
|
|
(define exception:generic-syncase-error
|
|
(cons 'syntax-error "source expression failed to match"))
|
|
(define exception:unexpected-syntax
|
|
(cons 'syntax-error "unexpected syntax"))
|
|
|
|
(define exception:bad-expression
|
|
(cons 'syntax-error "Bad expression"))
|
|
|
|
(define exception:missing/extra-expr
|
|
(cons 'syntax-error "Missing or extra expression"))
|
|
(define exception:missing-expr
|
|
(cons 'syntax-error "Missing expression"))
|
|
(define exception:missing-body-expr
|
|
(cons 'syntax-error "no expressions in body"))
|
|
(define exception:extra-expr
|
|
(cons 'syntax-error "Extra expression"))
|
|
(define exception:illegal-empty-combination
|
|
(cons 'syntax-error "Illegal empty combination"))
|
|
|
|
(define exception:bad-lambda
|
|
'(syntax-error . "bad lambda"))
|
|
(define exception:bad-let
|
|
'(syntax-error . "bad let "))
|
|
(define exception:bad-letrec
|
|
'(syntax-error . "bad letrec "))
|
|
(define exception:bad-set!
|
|
'(syntax-error . "bad set!"))
|
|
(define exception:bad-quote
|
|
'(syntax-error . "quote: bad syntax"))
|
|
(define exception:bad-bindings
|
|
(cons 'syntax-error "Bad bindings"))
|
|
(define exception:bad-binding
|
|
(cons 'syntax-error "Bad binding"))
|
|
(define exception:duplicate-binding
|
|
(cons 'syntax-error "duplicate bound variable"))
|
|
(define exception:bad-body
|
|
(cons 'misc-error "^bad body"))
|
|
(define exception:bad-formals
|
|
'(syntax-error . "invalid argument list"))
|
|
(define exception:bad-formal
|
|
(cons 'syntax-error "Bad formal"))
|
|
(define exception:duplicate-formals
|
|
(cons 'syntax-error "duplicate identifier in argument list"))
|
|
|
|
(define exception:missing-clauses
|
|
(cons 'syntax-error "Missing clauses"))
|
|
(define exception:misplaced-else-clause
|
|
(cons 'syntax-error "Misplaced else clause"))
|
|
(define exception:bad-case-clause
|
|
(cons 'syntax-error "Bad case clause"))
|
|
(define exception:bad-case-labels
|
|
(cons 'syntax-error "Bad case labels"))
|
|
(define exception:bad-cond-clause
|
|
(cons 'syntax-error "Bad cond clause"))
|
|
|
|
|
|
(with-test-prefix "expressions"
|
|
|
|
(with-test-prefix "Bad argument list"
|
|
|
|
(pass-if-exception "improper argument list of length 1"
|
|
exception:generic-syncase-error
|
|
(eval '(let ((foo (lambda (x y) #t)))
|
|
(foo . 1))
|
|
(interaction-environment)))
|
|
|
|
(pass-if-exception "improper argument list of length 2"
|
|
exception:generic-syncase-error
|
|
(eval '(let ((foo (lambda (x y) #t)))
|
|
(foo 1 . 2))
|
|
(interaction-environment))))
|
|
|
|
(with-test-prefix "missing or extra expression"
|
|
|
|
;; R5RS says:
|
|
;; *Note:* In many dialects of Lisp, the empty combination, (),
|
|
;; is a legitimate expression. In Scheme, combinations must
|
|
;; have at least one subexpression, so () is not a syntactically
|
|
;; valid expression.
|
|
|
|
;; Fixed on 2001-3-3
|
|
(pass-if-exception "empty parentheses \"()\""
|
|
exception:unexpected-syntax
|
|
(eval '()
|
|
(interaction-environment)))))
|
|
|
|
(with-test-prefix "quote"
|
|
#t)
|
|
|
|
(with-test-prefix "quasiquote"
|
|
|
|
(with-test-prefix "unquote"
|
|
|
|
(pass-if "repeated execution"
|
|
(let ((foo (let ((i 0)) (lambda () (set! i (+ i 1)) `(,i)))))
|
|
(and (equal? (foo) '(1)) (equal? (foo) '(2))))))
|
|
|
|
(with-test-prefix "unquote-splicing"
|
|
|
|
(pass-if-exception "extra arguments"
|
|
'(syntax-error . "unquote-splicing takes exactly one argument")
|
|
(eval '(quasiquote ((unquote-splicing (list 1 2) (list 3 4))))
|
|
(interaction-environment)))))
|
|
|
|
(with-test-prefix "begin"
|
|
|
|
(pass-if "legal (begin)"
|
|
(eval '(begin (begin) #t) (interaction-environment)))
|
|
|
|
(pass-if-exception "illegal (begin)"
|
|
exception:generic-syncase-error
|
|
(eval '(begin (if #t (begin)) #t) (interaction-environment))))
|
|
|
|
(define-syntax matches?
|
|
(syntax-rules (_)
|
|
((_ (op arg ...) pat) (let ((x (op arg ...)))
|
|
(matches? x pat)))
|
|
((_ x ()) (null? x))
|
|
((_ x (a . b)) (and (pair? x)
|
|
(matches? (car x) a)
|
|
(matches? (cdr x) b)))
|
|
((_ x _) #t)
|
|
((_ x pat) (equal? x 'pat))))
|
|
|
|
(with-test-prefix "lambda"
|
|
|
|
(with-test-prefix "bad formals"
|
|
|
|
(pass-if-exception "(lambda)"
|
|
exception:bad-lambda
|
|
(eval '(lambda)
|
|
(interaction-environment)))
|
|
|
|
(pass-if-exception "(lambda . \"foo\")"
|
|
exception:bad-lambda
|
|
(eval '(lambda . "foo")
|
|
(interaction-environment)))
|
|
|
|
(pass-if-exception "(lambda \"foo\")"
|
|
exception:bad-lambda
|
|
(eval '(lambda "foo")
|
|
(interaction-environment)))
|
|
|
|
(pass-if-exception "(lambda \"foo\" #f)"
|
|
exception:bad-formals
|
|
(eval '(lambda "foo" #f)
|
|
(interaction-environment)))
|
|
|
|
(pass-if-exception "(lambda (x 1) 2)"
|
|
exception:bad-formals
|
|
(eval '(lambda (x 1) 2)
|
|
(interaction-environment)))
|
|
|
|
(pass-if-exception "(lambda (1 x) 2)"
|
|
exception:bad-formals
|
|
(eval '(lambda (1 x) 2)
|
|
(interaction-environment)))
|
|
|
|
(pass-if-exception "(lambda (x \"a\") 2)"
|
|
exception:bad-formals
|
|
(eval '(lambda (x "a") 2)
|
|
(interaction-environment)))
|
|
|
|
(pass-if-exception "(lambda (\"a\" x) 2)"
|
|
exception:bad-formals
|
|
(eval '(lambda ("a" x) 2)
|
|
(interaction-environment))))
|
|
|
|
(with-test-prefix "duplicate formals"
|
|
|
|
;; Fixed on 2001-3-3
|
|
(pass-if-exception "(lambda (x x) 1)"
|
|
exception:duplicate-formals
|
|
(eval '(lambda (x x) 1)
|
|
(interaction-environment)))
|
|
|
|
;; Fixed on 2001-3-3
|
|
(pass-if-exception "(lambda (x x x) 1)"
|
|
exception:duplicate-formals
|
|
(eval '(lambda (x x x) 1)
|
|
(interaction-environment))))
|
|
|
|
(with-test-prefix "bad body"
|
|
|
|
(pass-if-exception "(lambda ())"
|
|
exception:bad-lambda
|
|
(eval '(lambda ())
|
|
(interaction-environment)))))
|
|
|
|
(with-test-prefix "let"
|
|
|
|
(with-test-prefix "bindings"
|
|
|
|
(pass-if-exception "late binding"
|
|
exception:unbound-var
|
|
(let ((x 1) (y x)) y)))
|
|
|
|
(with-test-prefix "bad bindings"
|
|
|
|
(pass-if-exception "(let)"
|
|
exception:bad-let
|
|
(eval '(let)
|
|
(interaction-environment)))
|
|
|
|
(pass-if-exception "(let 1)"
|
|
exception:bad-let
|
|
(eval '(let 1)
|
|
(interaction-environment)))
|
|
|
|
(pass-if-exception "(let (x))"
|
|
exception:bad-let
|
|
(eval '(let (x))
|
|
(interaction-environment)))
|
|
|
|
(pass-if-exception "(let ((x)))"
|
|
exception:bad-let
|
|
(eval '(let ((x)))
|
|
(interaction-environment)))
|
|
|
|
(pass-if-exception "(let (x) 1)"
|
|
exception:bad-let
|
|
(eval '(let (x) 1)
|
|
(interaction-environment)))
|
|
|
|
(pass-if-exception "(let ((x)) 3)"
|
|
exception:bad-let
|
|
(eval '(let ((x)) 3)
|
|
(interaction-environment)))
|
|
|
|
(pass-if-exception "(let ((x 1) y) x)"
|
|
exception:bad-let
|
|
(eval '(let ((x 1) y) x)
|
|
(interaction-environment)))
|
|
|
|
(pass-if-exception "(let ((1 2)) 3)"
|
|
exception:bad-let
|
|
(eval '(let ((1 2)) 3)
|
|
(interaction-environment))))
|
|
|
|
(with-test-prefix "duplicate bindings"
|
|
|
|
(pass-if-exception "(let ((x 1) (x 2)) x)"
|
|
exception:duplicate-binding
|
|
(eval '(let ((x 1) (x 2)) x)
|
|
(interaction-environment))))
|
|
|
|
(with-test-prefix "bad body"
|
|
|
|
(pass-if-exception "(let ())"
|
|
exception:bad-let
|
|
(eval '(let ())
|
|
(interaction-environment)))
|
|
|
|
(pass-if-exception "(let ((x 1)))"
|
|
exception:bad-let
|
|
(eval '(let ((x 1)))
|
|
(interaction-environment)))))
|
|
|
|
(with-test-prefix "named let"
|
|
|
|
(with-test-prefix "initializers"
|
|
|
|
(pass-if "evaluated in outer environment"
|
|
(let ((f -))
|
|
(eqv? (let f ((n (f 1))) n) -1))))
|
|
|
|
(with-test-prefix "bad bindings"
|
|
|
|
(pass-if-exception "(let x (y))"
|
|
exception:bad-let
|
|
(eval '(let x (y))
|
|
(interaction-environment))))
|
|
|
|
(with-test-prefix "bad body"
|
|
|
|
(pass-if-exception "(let x ())"
|
|
exception:bad-let
|
|
(eval '(let x ())
|
|
(interaction-environment)))
|
|
|
|
(pass-if-exception "(let x ((y 1)))"
|
|
exception:bad-let
|
|
(eval '(let x ((y 1)))
|
|
(interaction-environment)))))
|
|
|
|
(with-test-prefix "let*"
|
|
|
|
(with-test-prefix "bindings"
|
|
|
|
(pass-if "(let* ((x 1) (x 2)) ...)"
|
|
(let* ((x 1) (x 2))
|
|
(= x 2)))
|
|
|
|
(pass-if "(let* ((x 1) (x x)) ...)"
|
|
(let* ((x 1) (x x))
|
|
(= x 1)))
|
|
|
|
(pass-if "(let ((x 1) (y 2)) (let* () ...))"
|
|
(let ((x 1) (y 2))
|
|
(let* ()
|
|
(and (= x 1) (= y 2))))))
|
|
|
|
(with-test-prefix "bad bindings"
|
|
|
|
(pass-if-exception "(let*)"
|
|
exception:generic-syncase-error
|
|
(eval '(let*)
|
|
(interaction-environment)))
|
|
|
|
(pass-if-exception "(let* 1)"
|
|
exception:generic-syncase-error
|
|
(eval '(let* 1)
|
|
(interaction-environment)))
|
|
|
|
(pass-if-exception "(let* (x))"
|
|
exception:generic-syncase-error
|
|
(eval '(let* (x))
|
|
(interaction-environment)))
|
|
|
|
(pass-if-exception "(let* (x) 1)"
|
|
exception:generic-syncase-error
|
|
(eval '(let* (x) 1)
|
|
(interaction-environment)))
|
|
|
|
(pass-if-exception "(let* ((x)) 3)"
|
|
exception:generic-syncase-error
|
|
(eval '(let* ((x)) 3)
|
|
(interaction-environment)))
|
|
|
|
(pass-if-exception "(let* ((x 1) y) x)"
|
|
exception:generic-syncase-error
|
|
(eval '(let* ((x 1) y) x)
|
|
(interaction-environment)))
|
|
|
|
(pass-if-exception "(let* x ())"
|
|
exception:generic-syncase-error
|
|
(eval '(let* x ())
|
|
(interaction-environment)))
|
|
|
|
(pass-if-exception "(let* x (y))"
|
|
exception:generic-syncase-error
|
|
(eval '(let* x (y))
|
|
(interaction-environment)))
|
|
|
|
(pass-if-exception "(let* ((1 2)) 3)"
|
|
exception:generic-syncase-error
|
|
(eval '(let* ((1 2)) 3)
|
|
(interaction-environment))))
|
|
|
|
(with-test-prefix "bad body"
|
|
|
|
(pass-if-exception "(let* ())"
|
|
exception:generic-syncase-error
|
|
(eval '(let* ())
|
|
(interaction-environment)))
|
|
|
|
(pass-if-exception "(let* ((x 1)))"
|
|
exception:generic-syncase-error
|
|
(eval '(let* ((x 1)))
|
|
(interaction-environment)))))
|
|
|
|
(with-test-prefix "letrec"
|
|
|
|
(with-test-prefix "bindings"
|
|
|
|
(pass-if-exception "initial bindings are undefined"
|
|
exception:used-before-defined
|
|
(let ((x 1))
|
|
(letrec ((x 1) (y x)) y))))
|
|
|
|
(with-test-prefix "bad bindings"
|
|
|
|
(pass-if-exception "(letrec)"
|
|
exception:bad-letrec
|
|
(eval '(letrec)
|
|
(interaction-environment)))
|
|
|
|
(pass-if-exception "(letrec 1)"
|
|
exception:bad-letrec
|
|
(eval '(letrec 1)
|
|
(interaction-environment)))
|
|
|
|
(pass-if-exception "(letrec (x))"
|
|
exception:bad-letrec
|
|
(eval '(letrec (x))
|
|
(interaction-environment)))
|
|
|
|
(pass-if-exception "(letrec (x) 1)"
|
|
exception:bad-letrec
|
|
(eval '(letrec (x) 1)
|
|
(interaction-environment)))
|
|
|
|
(pass-if-exception "(letrec ((x)) 3)"
|
|
exception:bad-letrec
|
|
(eval '(letrec ((x)) 3)
|
|
(interaction-environment)))
|
|
|
|
(pass-if-exception "(letrec ((x 1) y) x)"
|
|
exception:bad-letrec
|
|
(eval '(letrec ((x 1) y) x)
|
|
(interaction-environment)))
|
|
|
|
(pass-if-exception "(letrec x ())"
|
|
exception:bad-letrec
|
|
(eval '(letrec x ())
|
|
(interaction-environment)))
|
|
|
|
(pass-if-exception "(letrec x (y))"
|
|
exception:bad-letrec
|
|
(eval '(letrec x (y))
|
|
(interaction-environment)))
|
|
|
|
(pass-if-exception "(letrec ((1 2)) 3)"
|
|
exception:bad-letrec
|
|
(eval '(letrec ((1 2)) 3)
|
|
(interaction-environment))))
|
|
|
|
(with-test-prefix "duplicate bindings"
|
|
|
|
(pass-if-exception "(letrec ((x 1) (x 2)) x)"
|
|
exception:duplicate-binding
|
|
(eval '(letrec ((x 1) (x 2)) x)
|
|
(interaction-environment))))
|
|
|
|
(with-test-prefix "bad body"
|
|
|
|
(pass-if-exception "(letrec ())"
|
|
exception:bad-letrec
|
|
(eval '(letrec ())
|
|
(interaction-environment)))
|
|
|
|
(pass-if-exception "(letrec ((x 1)))"
|
|
exception:bad-letrec
|
|
(eval '(letrec ((x 1)))
|
|
(interaction-environment)))))
|
|
|
|
(with-test-prefix "if"
|
|
|
|
(with-test-prefix "missing or extra expressions"
|
|
|
|
(pass-if-exception "(if)"
|
|
exception:generic-syncase-error
|
|
(eval '(if)
|
|
(interaction-environment)))
|
|
|
|
(pass-if-exception "(if 1 2 3 4)"
|
|
exception:generic-syncase-error
|
|
(eval '(if 1 2 3 4)
|
|
(interaction-environment)))))
|
|
|
|
(with-test-prefix "cond"
|
|
|
|
(with-test-prefix "cond is hygienic"
|
|
|
|
(pass-if "bound 'else is handled correctly"
|
|
(eq? (let ((else 'ok)) (cond (else))) 'ok))
|
|
|
|
(with-test-prefix "bound '=> is handled correctly"
|
|
|
|
(pass-if "#t => 'ok"
|
|
(let ((=> 'foo))
|
|
(eq? (cond (#t => 'ok)) 'ok)))
|
|
|
|
(pass-if "else =>"
|
|
(let ((=> 'foo))
|
|
(eq? (cond (else =>)) 'foo)))
|
|
|
|
(pass-if "else => identity"
|
|
(let ((=> 'foo))
|
|
(eq? (cond (else => identity)) identity)))))
|
|
|
|
(with-test-prefix "SRFI-61"
|
|
|
|
(pass-if "always available"
|
|
(cond-expand (srfi-61 #t) (else #f)))
|
|
|
|
(pass-if "single value consequent"
|
|
(eq? 'ok (cond (#t identity => (lambda (x) 'ok)) (else #f))))
|
|
|
|
(pass-if "single value alternate"
|
|
(eq? 'ok (cond (#t not => (lambda (x) #f)) (else 'ok))))
|
|
|
|
(pass-if-exception "doesn't affect standard =>"
|
|
exception:wrong-num-args
|
|
(cond ((values 1 2) => (lambda (x y) #t))))
|
|
|
|
(pass-if "multiple values consequent"
|
|
(equal? '(2 1) (cond ((values 1 2)
|
|
(lambda (one two)
|
|
(and (= 1 one) (= 2 two))) =>
|
|
(lambda (one two) (list two one)))
|
|
(else #f))))
|
|
|
|
(pass-if "multiple values alternate"
|
|
(eq? 'ok (cond ((values 2 3 4)
|
|
(lambda args (equal? '(1 2 3) args)) =>
|
|
(lambda (x y z) #f))
|
|
(else 'ok))))
|
|
|
|
(pass-if "zero values"
|
|
(eq? 'ok (cond ((values) (lambda () #t) => (lambda () 'ok))
|
|
(else #f))))
|
|
|
|
(pass-if "bound => is handled correctly"
|
|
(let ((=> 'ok))
|
|
(eq? 'ok (cond (#t identity =>) (else #f)))))
|
|
|
|
(pass-if-exception "missing recipient"
|
|
'(syntax-error . "cond: wrong number of receiver expressions")
|
|
(cond (#t identity =>)))
|
|
|
|
(pass-if-exception "extra recipient"
|
|
'(syntax-error . "cond: wrong number of receiver expressions")
|
|
(cond (#t identity => identity identity))))
|
|
|
|
(with-test-prefix "bad or missing clauses"
|
|
|
|
(pass-if-exception "(cond)"
|
|
exception:generic-syncase-error
|
|
(eval '(cond)
|
|
(interaction-environment)))
|
|
|
|
(pass-if-exception "(cond #t)"
|
|
exception:generic-syncase-error
|
|
(eval '(cond #t)
|
|
(interaction-environment)))
|
|
|
|
(pass-if-exception "(cond 1)"
|
|
exception:generic-syncase-error
|
|
(eval '(cond 1)
|
|
(interaction-environment)))
|
|
|
|
(pass-if-exception "(cond 1 2)"
|
|
exception:generic-syncase-error
|
|
(eval '(cond 1 2)
|
|
(interaction-environment)))
|
|
|
|
(pass-if-exception "(cond 1 2 3)"
|
|
exception:generic-syncase-error
|
|
(eval '(cond 1 2 3)
|
|
(interaction-environment)))
|
|
|
|
(pass-if-exception "(cond 1 2 3 4)"
|
|
exception:generic-syncase-error
|
|
(eval '(cond 1 2 3 4)
|
|
(interaction-environment)))
|
|
|
|
(pass-if-exception "(cond ())"
|
|
exception:generic-syncase-error
|
|
(eval '(cond ())
|
|
(interaction-environment)))
|
|
|
|
(pass-if-exception "(cond () 1)"
|
|
exception:generic-syncase-error
|
|
(eval '(cond () 1)
|
|
(interaction-environment)))
|
|
|
|
(pass-if-exception "(cond (1) 1)"
|
|
exception:generic-syncase-error
|
|
(eval '(cond (1) 1)
|
|
(interaction-environment))))
|
|
|
|
(with-test-prefix "wrong number of arguments"
|
|
|
|
(pass-if-exception "=> (lambda (x y) #t)"
|
|
exception:wrong-num-args
|
|
(cond (1 => (lambda (x y) #t))))))
|
|
|
|
(with-test-prefix "case"
|
|
|
|
(pass-if "clause with empty labels list"
|
|
(case 1 (() #f) (else #t)))
|
|
|
|
(with-test-prefix "case is hygienic"
|
|
|
|
(pass-if-exception "bound 'else is handled correctly"
|
|
exception:generic-syncase-error
|
|
(eval '(let ((else #f)) (case 1 (else #f)))
|
|
(interaction-environment))))
|
|
|
|
(with-test-prefix "bad or missing clauses"
|
|
|
|
(pass-if-exception "(case)"
|
|
exception:generic-syncase-error
|
|
(eval '(case)
|
|
(interaction-environment)))
|
|
|
|
(pass-if-exception "(case . \"foo\")"
|
|
exception:generic-syncase-error
|
|
(eval '(case . "foo")
|
|
(interaction-environment)))
|
|
|
|
(pass-if-exception "(case 1)"
|
|
exception:generic-syncase-error
|
|
(eval '(case 1)
|
|
(interaction-environment)))
|
|
|
|
(pass-if-exception "(case 1 . \"foo\")"
|
|
exception:generic-syncase-error
|
|
(eval '(case 1 . "foo")
|
|
(interaction-environment)))
|
|
|
|
(pass-if-exception "(case 1 \"foo\")"
|
|
exception:generic-syncase-error
|
|
(eval '(case 1 "foo")
|
|
(interaction-environment)))
|
|
|
|
(pass-if-exception "(case 1 ())"
|
|
exception:generic-syncase-error
|
|
(eval '(case 1 ())
|
|
(interaction-environment)))
|
|
|
|
(pass-if-exception "(case 1 (\"foo\"))"
|
|
exception:generic-syncase-error
|
|
(eval '(case 1 ("foo"))
|
|
(interaction-environment)))
|
|
|
|
(pass-if-exception "(case 1 (\"foo\" \"bar\"))"
|
|
exception:generic-syncase-error
|
|
(eval '(case 1 ("foo" "bar"))
|
|
(interaction-environment)))
|
|
|
|
(pass-if-exception "(case 1 ((2) \"bar\") . \"foo\")"
|
|
exception:generic-syncase-error
|
|
(eval '(case 1 ((2) "bar") . "foo")
|
|
(interaction-environment)))
|
|
|
|
(pass-if-exception "(case 1 ((2) \"bar\") (else))"
|
|
exception:generic-syncase-error
|
|
(eval '(case 1 ((2) "bar") (else))
|
|
(interaction-environment)))
|
|
|
|
(pass-if-exception "(case 1 (else #f) . \"foo\")"
|
|
exception:generic-syncase-error
|
|
(eval '(case 1 (else #f) . "foo")
|
|
(interaction-environment)))
|
|
|
|
(pass-if-exception "(case 1 (else #f) ((1) #t))"
|
|
exception:generic-syncase-error
|
|
(eval '(case 1 (else #f) ((1) #t))
|
|
(interaction-environment)))))
|
|
|
|
(with-test-prefix "top-level define"
|
|
|
|
(pass-if "redefinition"
|
|
(let ((m (make-module)))
|
|
(beautify-user-module! m)
|
|
|
|
;; The previous value of `round' must still be visible at the time the
|
|
;; new `round' is defined. According to R5RS (Section 5.2.1), `define'
|
|
;; should behave like `set!' in this case (except that in the case of
|
|
;; Guile, we respect module boundaries).
|
|
(eval '(define round round) m)
|
|
(eq? (module-ref m 'round) round)))
|
|
|
|
(with-test-prefix "missing or extra expressions"
|
|
|
|
(pass-if-exception "(define)"
|
|
exception:generic-syncase-error
|
|
(eval '(define)
|
|
(interaction-environment)))))
|
|
|
|
(with-test-prefix "internal define"
|
|
|
|
(pass-if "internal defines become letrec"
|
|
(eval '(let ((a identity) (b identity) (c identity))
|
|
(define (a x) (if (= x 0) 'a (b (- x 1))))
|
|
(define (b x) (if (= x 0) 'b (c (- x 1))))
|
|
(define (c x) (if (= x 0) 'c (a (- x 1))))
|
|
(and (eq? 'a (a 0) (a 3))
|
|
(eq? 'b (a 1) (a 4))
|
|
(eq? 'c (a 2) (a 5))))
|
|
(interaction-environment)))
|
|
|
|
(pass-if "binding is created before expression is evaluated"
|
|
;; Internal defines are equivalent to `letrec' (R5RS, Section 5.2.2).
|
|
(= (eval '(let ()
|
|
(define foo
|
|
(begin
|
|
(set! foo 1)
|
|
(+ foo 1)))
|
|
foo)
|
|
(interaction-environment))
|
|
2))
|
|
|
|
(pass-if "internal defines with begin"
|
|
(false-if-exception
|
|
(eval '(let ((a identity) (b identity) (c identity))
|
|
(define (a x) (if (= x 0) 'a (b (- x 1))))
|
|
(begin
|
|
(define (b x) (if (= x 0) 'b (c (- x 1)))))
|
|
(define (c x) (if (= x 0) 'c (a (- x 1))))
|
|
(and (eq? 'a (a 0) (a 3))
|
|
(eq? 'b (a 1) (a 4))
|
|
(eq? 'c (a 2) (a 5))))
|
|
(interaction-environment))))
|
|
|
|
(pass-if "internal defines with empty begin"
|
|
(false-if-exception
|
|
(eval '(let ((a identity) (b identity) (c identity))
|
|
(define (a x) (if (= x 0) 'a (b (- x 1))))
|
|
(begin)
|
|
(define (b x) (if (= x 0) 'b (c (- x 1))))
|
|
(define (c x) (if (= x 0) 'c (a (- x 1))))
|
|
(and (eq? 'a (a 0) (a 3))
|
|
(eq? 'b (a 1) (a 4))
|
|
(eq? 'c (a 2) (a 5))))
|
|
(interaction-environment))))
|
|
|
|
(pass-if "internal defines with macro application"
|
|
(false-if-exception
|
|
(eval '(begin
|
|
(defmacro my-define forms
|
|
(cons 'define forms))
|
|
(let ((a identity) (b identity) (c identity))
|
|
(define (a x) (if (= x 0) 'a (b (- x 1))))
|
|
(my-define (b x) (if (= x 0) 'b (c (- x 1))))
|
|
(define (c x) (if (= x 0) 'c (a (- x 1))))
|
|
(and (eq? 'a (a 0) (a 3))
|
|
(eq? 'b (a 1) (a 4))
|
|
(eq? 'c (a 2) (a 5)))))
|
|
(interaction-environment))))
|
|
|
|
(pass-if-exception "missing body expression"
|
|
exception:missing-body-expr
|
|
(eval '(let () (define x #t))
|
|
(interaction-environment))))
|
|
|
|
(with-test-prefix "set!"
|
|
|
|
(with-test-prefix "missing or extra expressions"
|
|
|
|
(pass-if-exception "(set!)"
|
|
exception:bad-set!
|
|
(eval '(set!)
|
|
(interaction-environment)))
|
|
|
|
(pass-if-exception "(set! 1)"
|
|
exception:bad-set!
|
|
(eval '(set! 1)
|
|
(interaction-environment)))
|
|
|
|
(pass-if-exception "(set! 1 2 3)"
|
|
exception:bad-set!
|
|
(eval '(set! 1 2 3)
|
|
(interaction-environment))))
|
|
|
|
(with-test-prefix "bad variable"
|
|
|
|
(pass-if-exception "(set! \"\" #t)"
|
|
exception:bad-set!
|
|
(eval '(set! "" #t)
|
|
(interaction-environment)))
|
|
|
|
(pass-if-exception "(set! 1 #t)"
|
|
exception:bad-set!
|
|
(eval '(set! 1 #t)
|
|
(interaction-environment)))
|
|
|
|
(pass-if-exception "(set! #t #f)"
|
|
exception:bad-set!
|
|
(eval '(set! #t #f)
|
|
(interaction-environment)))
|
|
|
|
(pass-if-exception "(set! #f #t)"
|
|
exception:bad-set!
|
|
(eval '(set! #f #t)
|
|
(interaction-environment)))
|
|
|
|
(pass-if-exception "(set! #\\space #f)"
|
|
exception:bad-set!
|
|
(eval '(set! #\space #f)
|
|
(interaction-environment)))))
|
|
|
|
(with-test-prefix "quote"
|
|
|
|
(with-test-prefix "missing or extra expression"
|
|
|
|
(pass-if-exception "(quote)"
|
|
exception:bad-quote
|
|
(eval '(quote)
|
|
(interaction-environment)))
|
|
|
|
(pass-if-exception "(quote a b)"
|
|
exception:bad-quote
|
|
(eval '(quote a b)
|
|
(interaction-environment)))))
|
|
|
|
(with-test-prefix "while"
|
|
|
|
(define (unreachable)
|
|
(error "unreachable code has been reached!"))
|
|
|
|
;; Return a new procedure COND which when called (COND) will return #t the
|
|
;; first N times, then #f, then any further call is an error. N=0 is
|
|
;; allowed, in which case #f is returned by the first call.
|
|
(define (make-iterations-cond n)
|
|
(lambda ()
|
|
(cond ((not n)
|
|
(error "oops, condition re-tested after giving false"))
|
|
((= 0 n)
|
|
(set! n #f)
|
|
#f)
|
|
(else
|
|
(set! n (1- n))
|
|
#t))))
|
|
|
|
|
|
(pass-if-exception "too few args" exception:wrong-num-args
|
|
(eval '(while) (interaction-environment)))
|
|
|
|
(with-test-prefix "empty body"
|
|
(do ((n 0 (1+ n)))
|
|
((> n 5))
|
|
(pass-if n
|
|
(eval `(letrec ((make-iterations-cond
|
|
(lambda (n)
|
|
(lambda ()
|
|
(cond ((not n)
|
|
(error "oops, condition re-tested after giving false"))
|
|
((= 0 n)
|
|
(set! n #f)
|
|
#f)
|
|
(else
|
|
(set! n (1- n))
|
|
#t))))))
|
|
(let ((cond (make-iterations-cond ,n)))
|
|
(while (cond))
|
|
#t))
|
|
(interaction-environment)))))
|
|
|
|
(pass-if "initially false"
|
|
(while #f
|
|
(unreachable))
|
|
#t)
|
|
|
|
(with-test-prefix "iterations"
|
|
(do ((n 0 (1+ n)))
|
|
((> n 5))
|
|
(pass-if n
|
|
(let ((cond (make-iterations-cond n))
|
|
(i 0))
|
|
(while (cond)
|
|
(set! i (1+ i)))
|
|
(= i n)))))
|
|
|
|
(with-test-prefix "break"
|
|
|
|
(pass-if-exception "too many args" exception:wrong-num-args
|
|
(eval '(while #t
|
|
(break 1))
|
|
(interaction-environment)))
|
|
|
|
(with-test-prefix "from cond"
|
|
(pass-if "first"
|
|
(while (begin
|
|
(break)
|
|
(unreachable))
|
|
(unreachable))
|
|
#t)
|
|
|
|
(do ((n 0 (1+ n)))
|
|
((> n 5))
|
|
(pass-if n
|
|
(let ((cond (make-iterations-cond n))
|
|
(i 0))
|
|
(while (if (cond)
|
|
#t
|
|
(begin
|
|
(break)
|
|
(unreachable)))
|
|
(set! i (1+ i)))
|
|
(= i n)))))
|
|
|
|
(with-test-prefix "from body"
|
|
(pass-if "first"
|
|
(while #t
|
|
(break)
|
|
(unreachable))
|
|
#t)
|
|
|
|
(do ((n 0 (1+ n)))
|
|
((> n 5))
|
|
(pass-if n
|
|
(let ((cond (make-iterations-cond n))
|
|
(i 0))
|
|
(while #t
|
|
(if (not (cond))
|
|
(begin
|
|
(break)
|
|
(unreachable)))
|
|
(set! i (1+ i)))
|
|
(= i n)))))
|
|
|
|
(pass-if "from nested"
|
|
(while #t
|
|
(let ((outer-break break))
|
|
(while #t
|
|
(outer-break)
|
|
(unreachable)))
|
|
(unreachable))
|
|
#t)
|
|
|
|
(pass-if "from recursive"
|
|
(let ((outer-break #f))
|
|
(define (r n)
|
|
(while #t
|
|
(if (eq? n 'outer)
|
|
(begin
|
|
(set! outer-break break)
|
|
(r 'inner))
|
|
(begin
|
|
(outer-break)
|
|
(unreachable))))
|
|
(if (eq? n 'inner)
|
|
(error "broke only from inner loop")))
|
|
(r 'outer))
|
|
#t))
|
|
|
|
(with-test-prefix "continue"
|
|
|
|
(pass-if-exception "too many args" exception:wrong-num-args
|
|
(eval '(while #t
|
|
(continue 1))
|
|
(interaction-environment)))
|
|
|
|
(with-test-prefix "from cond"
|
|
(do ((n 0 (1+ n)))
|
|
((> n 5))
|
|
(pass-if n
|
|
(let ((cond (make-iterations-cond n))
|
|
(i 0))
|
|
(while (if (cond)
|
|
(begin
|
|
(set! i (1+ i))
|
|
(continue)
|
|
(unreachable))
|
|
#f)
|
|
(unreachable))
|
|
(= i n)))))
|
|
|
|
(with-test-prefix "from body"
|
|
(do ((n 0 (1+ n)))
|
|
((> n 5))
|
|
(pass-if n
|
|
(let ((cond (make-iterations-cond n))
|
|
(i 0))
|
|
(while (cond)
|
|
(set! i (1+ i))
|
|
(continue)
|
|
(unreachable))
|
|
(= i n)))))
|
|
|
|
(pass-if "from nested"
|
|
(let ((cond (make-iterations-cond 3)))
|
|
(while (cond)
|
|
(let ((outer-continue continue))
|
|
(while #t
|
|
(outer-continue)
|
|
(unreachable)))))
|
|
#t)
|
|
|
|
(pass-if "from recursive"
|
|
(let ((outer-continue #f))
|
|
(define (r n)
|
|
(let ((cond (make-iterations-cond 3))
|
|
(first #t))
|
|
(while (begin
|
|
(if (and (not first)
|
|
(eq? n 'inner))
|
|
(error "continued only to inner loop"))
|
|
(cond))
|
|
(set! first #f)
|
|
(if (eq? n 'outer)
|
|
(begin
|
|
(set! outer-continue continue)
|
|
(r 'inner))
|
|
(begin
|
|
(outer-continue)
|
|
(unreachable))))))
|
|
(r 'outer))
|
|
#t)))
|