;; module system has booted up.
(define %pre-modules-transformer sc-expand)
+(define-syntax and
+ (syntax-rules ()
+ ((_) #t)
+ ((_ x) x)
+ ((_ x y ...) (if x (and y ...) #f))))
+
+(define-syntax or
+ (syntax-rules ()
+ ((_) #f)
+ ((_ x) x)
+ ((_ x y ...) (let ((t x)) (if t t (or y ...))))))
+
+;; The "maybe-more" bits are something of a hack, so that we can support
+;; SRFI-61. Rewrites into a standalone syntax-case macro would be
+;; appreciated.
+(define-syntax cond
+ (syntax-rules (=> else)
+ ((_ "maybe-more" test consequent)
+ (if test consequent))
+
+ ((_ "maybe-more" test consequent clause ...)
+ (if test consequent (cond clause ...)))
+
+ ((_ (else else1 else2 ...))
+ (begin else1 else2 ...))
+
+ ((_ (test => receiver) more-clause ...)
+ (let ((t test))
+ (cond "maybe-more" t (receiver t) more-clause ...)))
+
+ ((_ (generator guard => receiver) more-clause ...)
+ (call-with-values (lambda () generator)
+ (lambda t
+ (cond "maybe-more"
+ (apply guard t) (apply receiver t) more-clause ...))))
+
+ ((_ (test => receiver ...) more-clause ...)
+ (syntax-violation 'cond "wrong number of receiver expressions"
+ '(test => receiver ...)))
+ ((_ (generator guard => receiver ...) more-clause ...)
+ (syntax-violation 'cond "wrong number of receiver expressions"
+ '(generator guard => receiver ...)))
+
+ ((_ (test) more-clause ...)
+ (let ((t test))
+ (cond "maybe-more" t t more-clause ...)))
+
+ ((_ (test body1 body2 ...) more-clause ...)
+ (cond "maybe-more"
+ test (begin body1 body2 ...) more-clause ...))))
+
+(define-syntax case
+ (syntax-rules (else)
+ ((case (key ...)
+ clauses ...)
+ (let ((atom-key (key ...)))
+ (case atom-key clauses ...)))
+ ((case key
+ (else result1 result2 ...))
+ (begin result1 result2 ...))
+ ((case key
+ ((atoms ...) result1 result2 ...))
+ (if (memv key '(atoms ...))
+ (begin result1 result2 ...)))
+ ((case key
+ ((atoms ...) result1 result2 ...)
+ clause clauses ...)
+ (if (memv key '(atoms ...))
+ (begin result1 result2 ...)
+ (case key clause clauses ...)))))
+
+(define-syntax do
+ (syntax-rules ()
+ ((do ((var init step ...) ...)
+ (test expr ...)
+ command ...)
+ (letrec
+ ((loop
+ (lambda (var ...)
+ (if test
+ (begin
+ (if #f #f)
+ expr ...)
+ (begin
+ command
+ ...
+ (loop (do "step" var step ...)
+ ...))))))
+ (loop init ...)))
+ ((do "step" x)
+ x)
+ ((do "step" x y)
+ y)))
+
+(define-syntax delay
+ (syntax-rules ()
+ ((_ exp) (make-promise (lambda () exp)))))
+
\f
;;; {Defmacros}
(define (apply-to-args args fn) (apply fn args))
(defmacro false-if-exception (expr)
- `(catch #t (lambda () ,expr)
- (lambda args #f)))
+ `(catch #t
+ (lambda ()
+ ;; avoid saving backtraces inside false-if-exception
+ (with-fluid* the-last-stack (fluid-ref the-last-stack)
+ (lambda () ,expr)))
+ (lambda args #f)))
\f
(primitive-load-path "ice-9/networking"))
;; 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
-;; C where all that's needed is to inspect the return from stat().
(define file-exists?
(if (provided? 'posix)
(lambda (str)
- (->bool (false-if-exception (stat str))))
+ (->bool (stat str #f)))
(lambda (str)
(let ((port (catch 'system-error (lambda () (open-file str OPEN_READ))
(lambda args #f))))
;;; Reader code for various "#c" forms.
;;;
-(read-hash-extend #\' (lambda (c port)
- (read port)))
-
(define read-eval? (make-fluid))
(fluid-set! read-eval? #f)
(read-hash-extend #\.
(define (%print-module mod port) ; unused args: depth length style table)
(display "#<" port)
(display (or (module-kind mod) "module") port)
- (let ((name (module-name mod)))
- (if name
- (begin
- (display " " port)
- (display name port))))
+ (display " " port)
+ (display (module-name mod) port)
(display " " port)
(display (number->string (object-address mod) 16) port)
(display ">" port))
val
(let ((m (make-module 31)))
(set-module-kind! m 'directory)
- (set-module-name! m (append (or (module-name module) '())
+ (set-module-name! m (append (module-name module)
(list (car name))))
(module-define! module (car name) m)
m)))
(define default-duplicate-binding-procedures #f)
(define %app (make-module 31))
+(set-module-name! %app '(%app))
(define app %app) ;; for backwards compatability
-(local-define '(%app modules) (make-module 31))
+(let ((m (make-module 31)))
+ (set-module-name! m '())
+ (local-define '(%app modules) m))
(local-define '(%app modules guile) the-root-module)
;; This boots the module system. All bindings needed by modules.c
;; must have been defined by now.
;;
(set-current-module the-root-module)
-;; definition deferred for syncase's benefit
-(define module-name (record-accessor module-type 'name))
+;; definition deferred for syncase's benefit.
+(define module-name
+ (let ((accessor (record-accessor module-type 'name)))
+ (lambda (mod)
+ (or (accessor mod)
+ (begin
+ (set-module-name! mod (list (gensym)))
+ (accessor mod))))))
;; (define-special-value '(%app modules new-ws) (lambda () (make-scm-module)))
(resolve-module dir-hint-module-name #f)
(and (not (autoload-done-or-in-progress? dir-hint name))
(let ((didit #f))
- (define (load-file proc file)
- (save-module-excursion (lambda () (proc file)))
- (set! didit #t))
(dynamic-wind
(lambda () (autoload-in-progress! dir-hint name))
(lambda ()
- (let ((file (in-vicinity dir-hint name)))
- (let ((compiled (and load-compiled
- (%search-load-path
- (string-append file ".go"))))
- (source (%search-load-path file)))
- (cond ((and source
- (or (not compiled)
- (< (stat:mtime (stat compiled))
- (stat:mtime (stat source)))))
- (if compiled
- (warn "source file" source "newer than" compiled))
- (with-fluid* current-reader #f
- (lambda () (load-file primitive-load source))))
- (compiled
- (load-file load-compiled compiled))))))
+ (with-fluid* current-reader #f
+ (lambda ()
+ (save-module-excursion
+ (lambda ()
+ (primitive-load-path (in-vicinity dir-hint name) #f)
+ (set! didit #t))))))
(lambda () (set-autoloaded! dir-hint name didit)))
didit))))
;;;
(defmacro define-option-interface (option-group)
- (let* ((option-name car)
- (option-value cadr)
- (option-documentation caddr)
+ (let* ((option-name 'car)
+ (option-value 'cadr)
+ (option-documentation 'caddr)
;; Below follow the macros defining the run-time option interfaces.
(,interface (car args)) (,interface))
(else (for-each
(lambda (option)
- (display (option-name option))
+ (display (,option-name option))
(if (< (string-length
- (symbol->string (option-name option)))
+ (symbol->string (,option-name option)))
8)
(display #\tab))
(display #\tab)
- (display (option-value option))
+ (display (,option-value option))
(display #\tab)
- (display (option-documentation option))
+ (display (,option-documentation option))
(newline))
(,interface #t)))))))
(define (set-repl-prompt! v) (set! scm-repl-prompt v))
(define (default-pre-unwind-handler key . args)
- (save-stack pre-unwind-handler-dispatch)
+ (save-stack 1)
(apply throw key args))
-(define (pre-unwind-handler-dispatch key . args)
- (apply default-pre-unwind-handler key args))
+(begin-deprecated
+ (define (pre-unwind-handler-dispatch key . args)
+ (apply default-pre-unwind-handler key args)))
(define abort-hook (make-hook))
(else
(apply bad-throw key args)))))))
- ;; Note that having just `pre-unwind-handler-dispatch'
- ;; here is connected with the mechanism that
- ;; produces a nice backtrace upon error. If, for
- ;; example, this is replaced with (lambda args
- ;; (apply pre-unwind-handler-dispatch args)), the stack
- ;; cutting (in save-stack) goes wrong and ends up
- ;; saving no stack at all, so there is no
- ;; backtrace.
- pre-unwind-handler-dispatch)))
+ default-pre-unwind-handler)))
(if next (loop next) status)))
(set! set-batch-mode?! (lambda (arg)
\f
-;;; {Compiler interface}
-;;;
-;;; The full compiler interface can be found in (system). Here we put a
-;;; few useful procedures into the global namespace.
-
-(module-autoload! the-scm-module
- '(system base compile)
- '(compile
- compile-time-environment))
-
-
-\f
-
;;; {Parameters}
;;;
;; (module-eval-closure (current-module))))
;; (deannotate/source-properties (sc-expand (annotate exp)))))
-(define-module (guile-user))
+(define-module (guile-user)
+ #:autoload (system base compile) (compile))
;;; boot-9.scm ends here
HCoop / bpt / guile.git / blobdiff