1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-28 16:00:22 +02:00
guile/test-suite/tests/hooks.test
Andy Wingo 5f1611640a really boot primitive-eval from scheme.
* libguile/eval.c (scm_primitive_eval, scm_c_primitive_eval):
  (scm_init_eval): Rework so that scm_primitive_eval always calls out to
  the primitive-eval variable. The previous definition is the default
  value, which is probably overridden by scm_init_eval_in_scheme.

* libguile/init.c (scm_i_init_guile): Move ports and load-path up, so we
  can debug when initing eval. Call scm_init_eval_in_scheme. Awesome.

* libguile/load.h:
* libguile/load.c (scm_init_eval_in_scheme): New procedure, loads up
  ice-9/eval.scm to replace the primitive-eval definition, if everything
  is there and up-to-date.

* libguile/modules.c (scm_module_transformer): Export to Scheme, so it's
  there for eval.go.

* module/ice-9/boot-9.scm: No need to define module-transformer.

* module/ice-9/eval.scm (capture-env): Only reference the-root-module if
  modules are booted.
  (primitive-eval): Inline a definition for identity. Throw a more
  standard error for "wrong number of arguments".

* module/ice-9/psyntax.scm (chi-install-global): The macro binding for a
  syncase macro is now a pair: the transformer, and the module that was
  current when the transformer was installed. The latter is used for
  hygiene purposes, replacing the use of procedure-module, which didn't
  work with the interpreter's shared-code closures.
  (chi-macro): Adapt for the binding being a pair, and get the hygiene
  from the cdr.
  (eval-local-transformer): Adapt to new form of macro bindings.

* module/ice-9/psyntax-pp.scm: Regenerated.

* .gitignore: Ignore eval.go.stamp.

* module/Makefile.am: Reorder for fastest serial compilation, now that
  there are no ordering constraints. I did a number of experiments here
  and this seems to be the best; but the bulk of the time is compiling
  psyntax-pp.scm with eval.scm. Not so great.

* libguile/vm-engine.c (vm-engine): Throw a more standard error for
  "wrong type to apply".

* test-suite/tests/gc.test ("gc"): Remove a hack that shouldn't affect
  the new evaluator, and throw in another (gc) for good measure.

* test-suite/tests/goops.test ("defining classes"):
* test-suite/tests/hooks.test (proc1): We can't currently check what the
  arity is of a closure made by eval.scm -- or more accurately all
  closures have 0 required args and no rest args. So punt for now.

* test-suite/tests/syntax.test ("letrec"): The scheme evaluator can't
  check that a variable is unbound, currently; perhaps the full "fixing
  letrec" expansion could fix this. But barring that, punt.
2009-12-03 00:00:38 +01:00

129 lines
4.1 KiB
Scheme

;;;; hooks.test --- tests guile's hooks implementation -*- scheme -*-
;;;; Copyright (C) 1999, 2001, 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
;;;
;;; miscellaneous
;;;
;; FIXME: Maybe a standard wrong-num-arg exception should be thrown instead
;; of a misc-error? If so, the tests should be changed to expect failure.
(define exception:wrong-num-hook-args
(cons 'misc-error "Hook .* requires .* arguments"))
;;;
;;; {The tests}
;;;
(let ((proc1 (lambda (x) (+ x 1)))
(proc2 (lambda (x) (- x 1)))
(bad-proc (lambda (x y) #t)))
(with-test-prefix "hooks"
(pass-if "make-hook"
(make-hook 1)
#t)
(pass-if "add-hook!"
(let ((x (make-hook 1)))
(add-hook! x proc1)
(add-hook! x proc2)
#t))
(with-test-prefix "add-hook!"
(pass-if "append"
(let ((x (make-hook 1)))
(add-hook! x proc1)
(add-hook! x proc2 #t)
(eq? (cadr (hook->list x))
proc2)))
(pass-if-exception "illegal proc"
exception:wrong-type-arg
(let ((x (make-hook 1)))
;; Currently fails to raise an exception
;; because we can't usefully get any arity
;; information out of interpreted procedures. A
;; FIXME I guess.
(throw 'unresolved)
(add-hook! x bad-proc)))
(pass-if-exception "illegal hook"
exception:wrong-type-arg
(add-hook! '(foo) proc1)))
(pass-if "run-hook"
(let ((x (make-hook 1)))
(add-hook! x proc1)
(add-hook! x proc2)
(run-hook x 1)
#t))
(with-test-prefix "run-hook"
(pass-if-exception "bad hook"
exception:wrong-type-arg
(let ((x (cons 'a 'b)))
(run-hook x 1)))
(pass-if-exception "too many args"
exception:wrong-num-hook-args
(let ((x (make-hook 1)))
(add-hook! x proc1)
(add-hook! x proc2)
(run-hook x 1 2)))
(pass-if
"destructive procs"
(let ((x (make-hook 1))
(dest-proc1 (lambda (x)
(set-car! x
'i-sunk-your-battleship)))
(dest-proc2 (lambda (x) (set-cdr! x 'no-way!)))
(val '(a-game-of battleship)))
(add-hook! x dest-proc1)
(add-hook! x dest-proc2 #t)
(run-hook x val)
(and (eq? (car val) 'i-sunk-your-battleship)
(eq? (cdr val) 'no-way!)))))
(with-test-prefix "remove-hook!"
(pass-if ""
(let ((x (make-hook 1)))
(add-hook! x proc1)
(add-hook! x proc2)
(remove-hook! x proc1)
(not (memq proc1 (hook->list x)))))
; Maybe it should error, but this is probably
; more convienient
(pass-if "empty hook"
(let ((x (make-hook 1)))
(remove-hook! x proc1)
#t)))
(pass-if "hook->list"
(let ((x (make-hook 1)))
(add-hook! x proc1)
(add-hook! x proc2)
(and (memq proc1 (hook->list x))
(memq proc2 (hook->list x))
#t)))
(pass-if "reset-hook!"
(let ((x (make-hook 1)))
(add-hook! x proc1)
(add-hook! x proc2)
(reset-hook! x)
(null? (hook->list x))))
(with-test-prefix "reset-hook!"
(pass-if "empty hook"
(let ((x (make-hook 1)))
(reset-hook! x)
#t))
(pass-if-exception "bad hook"
exception:wrong-type-arg
(reset-hook! '(a b))))))