1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-17 22:42:25 +02:00

a number of small compilation fixes

* ice-9/boot-9.scm: Allow a compiled load of posix, networking, and
  deprecated files.

* module/language/scheme/translate.scm (lookup-transformer): Lookup the
  sc-macro by value, not by name. Works around the fact that compiled
  macros don't have names, which is probably a bug.

* module/system/base/compile.scm (syntax-error)
  (call-with-compile-error-catch): Throw and catch a key that's not used
  by anyone else. Write error messages to the error port.

* module/system/repl/repl.scm (default-catch-handler): Call display-error
  with the correct number of arguments.

* module/system/vm/frame.scm (frame-program-name): Guard against unbound
  variables.

* ice-9/optargs.scm (let-keywords-template): Don't unquote in a helper
  procedure. A bit irritating. I suppose we should fix the modules +
  syncase situation at some point, and then switch to syncase.
This commit is contained in:
Andy Wingo 2008-09-25 13:46:09 +02:00
parent 5ba9d84978
commit 1e6ebf54db
6 changed files with 20 additions and 16 deletions

View file

@ -523,10 +523,10 @@
(if (provided? 'posix) (if (provided? 'posix)
(primitive-load-path "ice-9/posix.scm")) (primitive-load-path "ice-9/posix"))
(if (provided? 'socket) (if (provided? 'socket)
(primitive-load-path "ice-9/networking.scm")) (primitive-load-path "ice-9/networking"))
;; For reference, Emacs file-exists-p uses stat in this same way. ;; For reference, Emacs file-exists-p uses stat in this same way.
;; ENHANCE-ME: Catching an exception from stat is a bit wasteful, do this in ;; ENHANCE-ME: Catching an exception from stat is a bit wasteful, do this in
@ -3406,7 +3406,7 @@ module '(ice-9 q) '(make-q q-length))}."
(provided? sym))) (provided? sym)))
(begin-deprecated (begin-deprecated
(primitive-load-path "ice-9/deprecated.scm")) (primitive-load-path "ice-9/deprecated"))

View file

@ -149,9 +149,8 @@
=> cdr) => cdr)
(else (else
,(cadr key))))))) ,(cadr key)))))))
`(let* ((ra->kbl ,rest-arg->keyword-binding-list) `(let ((,kb-list-gensym (rest-arg->keyword-binding-list
(,kb-list-gensym (ra->kbl ,REST-ARG ',(map ,REST-ARG ',(map (lambda (x) (symbol->keyword (if (pair? x) (car x) x)))
(lambda (x) (symbol->keyword (if (pair? x) (car x) x)))
BINDINGS) BINDINGS)
,ALLOW-OTHER-KEYS?))) ,ALLOW-OTHER-KEYS?)))
,(let-o-k-template REST-ARG BINDINGS BODY let-type bindfilter))))) ,(let-o-k-template REST-ARG BINDINGS BODY let-type bindfilter)))))

View file

@ -25,6 +25,7 @@
#:use-module (system il ghil) #:use-module (system il ghil)
#:use-module (system il inline) #:use-module (system il inline)
#:use-module (ice-9 receive) #:use-module (ice-9 receive)
#:use-module ((ice-9 syncase) #:select (sc-macro))
#:use-module ((system base compile) #:select (syntax-error)) #:use-module ((system base compile) #:select (syntax-error))
#:export (translate)) #:export (translate))
@ -63,7 +64,7 @@
(lambda (env loc exp) (lambda (env loc exp)
(retrans (apply (defmacro-transformer val) (cdr exp))))) (retrans (apply (defmacro-transformer val) (cdr exp)))))
((and (macro? val) (eq? (macro-name val) 'sc-macro)) ((eq? val sc-macro)
;; syncase! ;; syncase!
(let* ((the-syncase-module (resolve-module '(ice-9 syncase))) (let* ((the-syncase-module (resolve-module '(ice-9 syncase)))
(eec (module-ref the-syncase-module 'expansion-eval-closure)) (eec (module-ref the-syncase-module 'expansion-eval-closure))

View file

@ -38,15 +38,17 @@
;;; ;;;
(define (syntax-error loc msg exp) (define (syntax-error loc msg exp)
(throw 'syntax-error loc msg exp)) (throw 'syntax-error-compile-time loc msg exp))
(define-macro (call-with-compile-error-catch thunk) (define-macro (call-with-compile-error-catch thunk)
`(catch 'syntax-error `(catch 'syntax-error-compile-time
,thunk ,thunk
(lambda (key loc msg exp) (lambda (key loc msg exp)
(if (pair? loc) (if (pair? loc)
(format #t "~A:~A: ~A: ~A~%" (car loc) (cdr loc) msg exp) (format (current-error-port)
(format #t "unknown location: ~A: ~A~%" msg exp))))) "~A:~A: ~A: ~A~%" (car loc) (cdr loc) msg exp)
(format (current-error-port)
"unknown location: ~A: ~A~%" msg exp)))))
(export-syntax call-with-compile-error-catch) (export-syntax call-with-compile-error-catch)

View file

@ -83,7 +83,7 @@
(newline cep) (newline cep)
(run-hook after-backtrace-hook)))) (run-hook after-backtrace-hook))))
(run-hook before-error-hook) (run-hook before-error-hook)
(apply display-error (fluid-ref the-last-stack) cep subr msg args rest) (display-error (fluid-ref the-last-stack) cep subr msg args rest)
(run-hook after-error-hook) (run-hook after-error-hook)
(set! stack-saved? #f) (set! stack-saved? #f)
(force-output cep))) (force-output cep)))

View file

@ -127,7 +127,9 @@
(object-property prog 'name) (object-property prog 'name)
(and (heap-frame? link) (frame-address link) (and (heap-frame? link) (frame-address link)
(frame-object-name link (1- (frame-address link)) prog)) (frame-object-name link (1- (frame-address link)) prog))
(hash-fold (lambda (s v d) (if (eq? prog (variable-ref v)) s d)) (hash-fold (lambda (s v d) (if (and (variable-bound? v)
(eq? prog (variable-ref v)))
s d))
prog (module-obarray (current-module)))))) prog (module-obarray (current-module))))))