~ chicken-core (chicken-5) a928fe1a4f7707e41fab65e9026596be902c39e8
commit a928fe1a4f7707e41fab65e9026596be902c39e8
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Wed Aug 11 00:26:41 2010 +0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Wed Aug 11 00:26:41 2010 +0200
added -debug option to chicken-install and use error inside setup-api
diff --git a/chicken-install.scm b/chicken-install.scm
index 6150ef27..22f3eecc 100644
--- a/chicken-install.scm
+++ b/chicken-install.scm
@@ -95,6 +95,7 @@
(define *cross-chicken* (feature? #:cross-chicken))
(define *host-extension* *cross-chicken*)
(define *target-extension* *cross-chicken*)
+ (define *debug-setup* #f)
(define (get-prefix)
(cond ((and *cross-chicken*
@@ -397,8 +398,11 @@
(not *host-extension*)) ; host-repo must always take precedence
""
"-setup-mode ")
- "-e \"(require-library setup-api)\" -e \"(import setup-api)\""
- (sprintf " -e \"(extension-name-and-version '(\\\"~a\\\" \\\"~a\\\"))\""
+ "-e \"(require-library setup-api)\" -e \"(import setup-api)\" "
+ (if *debug-setup*
+ ""
+ "-e \"(setup-error-handling)\" ")
+ (sprintf "-e \"(extension-name-and-version '(\\\"~a\\\" \\\"~a\\\"))\""
(car e+d+v) (caddr e+d+v))
(if (sudo-install) " -e \"(sudo-install #t)\"" "")
(if *keep* " -e \"(keep-intermediates #t)\"" "")
@@ -581,6 +585,7 @@ usage: chicken-install [OPTION | EXTENSION[:VERSION]] ...
-deploy build extensions for deployment
-trunk build trunk instead of tagged version (only local)
-D -feature FEATURE features to pass to sub-invocations of `csc'
+ -debug enable full display of error message information
EOF
);|
(exit code))
@@ -604,7 +609,8 @@ EOF
(let loop ((args args) (eggs '()))
(cond ((null? args)
(cond ((and *deploy* (not *prefix*))
- (error "`-deploy' only makes sense in combination with `-prefix DIRECTORY`"))
+ (error
+ "`-deploy' only makes sense in combination with `-prefix DIRECTORY`"))
(update (update-db))
(else
(let ((defaults (load-defaults)))
@@ -622,9 +628,11 @@ EOF
(exit 1))) ) )
(unless defaults
(unless *default-transport*
- (error "no default transport defined - please use `-transport' option"))
+ (error
+ "no default transport defined - please use `-transport' option"))
(unless *default-location*
- (error "no default location defined - please use `-location' option")))
+ (error
+ "no default location defined - please use `-location' option")))
(install (apply-mappings (reverse eggs)))))))
(else
(let ((arg (car args)))
@@ -701,6 +709,9 @@ EOF
((string=? "-target" arg)
(set! *host-extension* #f)
(loop (cdr args) eggs))
+ ((string=? "-debug" arg)
+ (set! *debug-setup* #t)
+ (loop (cdr args) eggs))
((string=? "-deploy" arg)
(set! *deploy* #t)
(loop (cdr args) eggs))
diff --git a/csi.scm b/csi.scm
index 889915b7..e8d57f73 100644
--- a/csi.scm
+++ b/csi.scm
@@ -915,7 +915,8 @@ EOF
(loop (cdr chars))))))
(define-constant simple-options
- '("--" "-b" "-batch" "-q" "-quiet" "-n" "-no-init" "-w" "-no-warnings" "-i" "-case-insensitive"
+ '("--" "-b" "-batch" "-q" "-quiet" "-n" "-no-init" "-w" "-no-warnings"
+ "-i" "-case-insensitive"
"-no-parentheses-synonyms" "-no-symbol-escape" "-r5rs-syntax" "-setup-mode"
; Not "simple" but processed early
"-ss" "-sx" "-s" "-script") )
diff --git a/library.scm b/library.scm
index e3ab347d..85fa4f7d 100644
--- a/library.scm
+++ b/library.scm
@@ -3583,21 +3583,21 @@ EOF
(define ##sys#current-exception-handler
;; Exception-handler for the primordial thread:
- (let ([string-append string-append])
+ (let ((string-append string-append))
(lambda (c)
(when (##sys#structure? c 'condition)
(set! ##sys#last-exception c)
- (let ([kinds (##sys#slot c 1)])
- (cond [(memq 'exn kinds)
- (let* ([props (##sys#slot c 2)]
- [msga (member '(exn . message) props)]
- [argsa (member '(exn . arguments) props)]
- [loca (member '(exn . location) props)] )
+ (let ((kinds (##sys#slot c 1)))
+ (cond ((memq 'exn kinds)
+ (let* ((props (##sys#slot c 2))
+ (msga (member '(exn . message) props))
+ (argsa (member '(exn . arguments) props))
+ (loca (member '(exn . location) props)) )
(apply
(##sys#error-handler)
(if msga
- (let ([msg (cadr msga)]
- [loc (and loca (cadr loca))] )
+ (let ((msg (cadr msga))
+ (loc (and loca (cadr loca))) )
(if (and loc (symbol? loc))
(string-append
"(" (##sys#symbol->qualified-string loc) ") "
@@ -3609,15 +3609,16 @@ EOF
(if argsa
(cadr argsa)
'() ) )
- ((##sys#reset-handler)) ) ]
- [(eq? 'user-interrupt (##sys#slot kinds 0))
+ ;; in case error-handler returns, which shouldn't happen:
+ ((##sys#reset-handler)) ) )
+ ((eq? 'user-interrupt (##sys#slot kinds 0))
(##sys#print "\n*** user interrupt ***\n" #f ##sys#standard-error)
- ((##sys#reset-handler)) ]
- [(eq? 'uncaught-exception (##sys#slot kinds 0))
+ ((##sys#reset-handler)) )
+ ((eq? 'uncaught-exception (##sys#slot kinds 0))
((##sys#error-handler)
"uncaught exception"
(cadr (member '(uncaught-exception . reason) (##sys#slot c 2))) )
- ((##sys#reset-handler)) ] ) ) )
+ ((##sys#reset-handler)) ) ) ) )
(##sys#abort
(##sys#make-structure
'condition
@@ -3631,7 +3632,10 @@ EOF
thunk
(lambda () (set! ##sys#current-exception-handler oldh)) ) ) )
-(define (current-exception-handler) ##sys#current-exception-handler)
+(define (current-exception-handler #!optional proc)
+ (if proc
+ (set! ##sys#current-exception-handler proc)
+ ##sys#current-exception-handler))
(define (make-property-condition kind . props)
(##sys#make-structure
diff --git a/manual/Exceptions b/manual/Exceptions
index 7ddc7a51..40e29abf 100644
--- a/manual/Exceptions
+++ b/manual/Exceptions
@@ -112,7 +112,7 @@ context as the {{condition-case}} form.
(check (lambda () (signal 99))) ; -> "something else"
(condition-case some-unbound-variable
- [(exn file) (print "ignored")] ) ; -> signals error
+ ((exn file) (print "ignored")) ) ; -> signals error
</enscript>
<procedure>(get-condition-property CONDITION KIND PROPERTY [DEFAULT])</procedure>
@@ -144,9 +144,10 @@ exception handler returned. On CHICKEN, system error exceptions
=== Exception Handlers
-<procedure>(current-exception-handler)</procedure><br>
+<parameter>(current-exception-handler [PROCEDURE])</parameter><br>
-Returns the current exception handler.
+Sets or returns the current exception handler, a procedure of one
+argument, the exception object.
<procedure>(with-exception-handler handler thunk)</procedure><br>
diff --git a/manual/Extensions b/manual/Extensions
index 3936118e..d93b684f 100644
--- a/manual/Extensions
+++ b/manual/Extensions
@@ -189,12 +189,14 @@ Runs the shell command {{FORM}}, which is wrapped in an implicit {{quasiquote}}.
{{(run (csc ...))}} is treated specially and passes {{-v}} (if {{-verbose}} has been given
to {{chicken-install}}) and {{-feature compiling-extension}} options to the compiler.
+
==== compile
<macro>(compile FORM ...)</macro>
Equivalent to {{(run (csc FORM ...))}}.
+
==== make
<macro>(make ((TARGET (DEPENDENT ...) COMMAND ...) ...) ARGUMENTS)</macro>
@@ -599,6 +601,7 @@ Available options:
; {{-repository}} : print path to extension repository
; {{-deploy}} : install extension in the application directory for a deployed application (see [[Deployment]] for more information)
: {{-D -feature FEATURE}} : pass this on to subinvocations of {{csi}} and {{csc}} (when done via {{compile}} or {{(run (csc ...))}})
+: {{-debug}} : print full call-trace when encountering errors in the setup script
{{chicken-install}} recognizes the {{http_proxy}} environment variable, if set.
diff --git a/setup-api.scm b/setup-api.scm
index bffd48d7..7de6ef27 100644
--- a/setup-api.scm
+++ b/setup-api.scm
@@ -63,7 +63,8 @@
remove-extension
read-info
register-program find-program
- shellpath)
+ shellpath
+ setup-error-handling)
(import scheme chicken foreign
regex utils posix ports extras data-structures
@@ -181,6 +182,11 @@
(define abort-setup (make-parameter (cut exit 1)))
+(define-syntax ignore-errors
+ (syntax-rules ()
+ ((_ body ...)
+ (handle-exceptions ex #f body ...))))
+
(define (patch which rx subst)
(when (setup-verbose-mode) (printf "patching ~A ...~%" which))
(if (list? which)
@@ -318,7 +324,7 @@
(define (make:check-argv argv)
(or (string? argv)
(every string? argv)
- (error "argument is not a string or string list" argv)))
+ (error "argument-list to `make' is not a string or string list" argv)))
(define (make:make/proc/helper spec argv)
(when (vector? argv) (set! argv (vector->list argv)))
@@ -345,7 +351,11 @@
(any (lambda (dep)
(let ((dep2 (fixmaketarget dep)))
(unless (file-exists? dep2)
- (error (sprintf "dependancy ~a was not made~%" dep2)))
+ ;;XXX internal error?
+ (error
+ (sprintf
+ "(make) dependency ~a was not made~%"
+ dep2)))
(and (> (file-modification-time dep2) date)
dep2)) )
deps))))
@@ -375,7 +385,7 @@
(signal exn) )
((car l))))))))
(unless date
- (error (sprintf "don't know how to make ~a" s2))))))))
+ (error (sprintf "(make) don't know how to make ~a" s2))))))))
(cond
((string? argv) (make-file argv ""))
((null? argv) (make-file (caar spec) ""))
@@ -668,7 +678,7 @@
(when verb (print cmd " ..."))
cmd) ) ) ) )
(when verb (print (if (zero? r) "succeeded." "failed.")))
- ($system (sprintf "~A ~A" *remove-command* (shellpath fname)))
+ (ignore-errors ($system (sprintf "~A ~A" *remove-command* (shellpath fname))))
(zero? r) ) )
(define (required-chicken-version v)
@@ -768,7 +778,7 @@
(error 'remove-directory "cannot remove - directory not found" dir)
#f))
(*sudo*
- ($system (sprintf "sudo rm -fr ~a" (shellpath dir))))
+ (ignore-errors ($system (sprintf "sudo rm -fr ~a" (shellpath dir)))))
(else
(let walk ((dir dir))
(let ((files (directory dir #t)))
@@ -790,15 +800,17 @@
(define ($system str)
(let ((r (system
(if *windows-shell*
- (string-append "\"" str "\"") ; double quotes, yes - thanks to Matthew Flatt
+ (string-append "\"" str "\"") ; (sic) thanks to Matthew Flatt
str))))
(unless (zero? r)
- (quit "shell command failed with nonzero exit status ~a:~%~% ~a" r str))))
+ (error "shell command failed with nonzero exit status ~a:~%~% ~a" r str))))
+
+(define (setup-error-handling)
+ (current-exception-handler
+ (lambda (c)
+ (print-error-message c (current-error-port))
+ (reset))))
-(define (quit fstr . args)
- (flush-output)
- (fprintf (current-error-port) "~%~?~%" fstr args)
- (reset))
;;; Module Setup
Trap