boot-9.scm

MSYS在windows下模拟了一个类unix的终端

      (if (null? kws)
	  (begin
	    (for-each (lambda (interface)
			(module-use! module interface))
		      (reverse reversed-interfaces))
	    (module-export! module exports)
	    (module-re-export! module re-exports))
	  (case (car kws)
	    ((#:use-module #:use-syntax)
	     (or (pair? (cdr kws))
		 (unrecognized kws))
	     (let* ((interface-args (cadr kws))
		    (interface (apply resolve-interface interface-args)))
	       (and (eq? (car kws) 'use-syntax)
		    (or (symbol? (car spec))
			(error "invalid module name for use-syntax"
			       spec))
		    (set-module-transformer!
		     module
		     (module-ref interface (car
					    (last-pair (car interface-args)))
				 #f)))
	       (loop (cddr kws)
		     (cons interface reversed-interfaces)
		     exports
		     re-exports)))
	    ((#:autoload)
	     (or (and (pair? (cdr kws)) (pair? (cddr kws)))
		 (unrecognized kws))
	     (loop (cdddr kws)
		   (cons (make-autoload-interface module
						  (cadr kws)
						  (caddr kws))
			 reversed-interfaces)
		   exports
		   re-exports))
	    ((#:no-backtrace)
	     (set-system-module! module #t)
	     (loop (cdr kws) reversed-interfaces exports re-exports))
	    ((#:pure)
	     (purify-module! module)
	     (loop (cdr kws) reversed-interfaces exports re-exports))
	    ((#:export #:export-syntax)
	     (or (pair? (cdr kws))
		 (unrecognized kws))
	     (loop (cddr kws)
		   reversed-interfaces
		   (append (cadr kws) exports)
		   re-exports))
	    ((#:re-export #:re-export-syntax)
	     (or (pair? (cdr kws))
		 (unrecognized kws))
	     (loop (cddr kws)
		   reversed-interfaces
		   exports
		   (append (cadr kws) re-exports)))
	    (else
	     (unrecognized kws)))))
    module))

;;; {Autoload}

(define (make-autoload-interface module name bindings)
  (let ((b (lambda (a sym definep)
	     (and (memq sym bindings)
		  (let ((i (module-public-interface (resolve-module name))))
		    (if (not i)
			(error "missing interface for module" name))
		    ;; Replace autoload-interface with interface
		    (set-car! (memq a (module-uses module)) i)
		    (module-local-variable i sym))))))
    (module-constructor #() '() b #f #f name 'autoload
			'() (make-weak-value-hash-table 31) 0)))

;;; {Compiled module}

(define load-compiled #f)


;;; {Autoloading modules}

(define autoloads-in-progress '())

;; This function is called from "modules.c".  If you change it, be
;; sure to update "modules.c" as well.

(define (try-module-autoload module-name)
  (let* ((reverse-name (reverse module-name))
	 (name (symbol->string (car reverse-name)))
	 (dir-hint-module-name (reverse (cdr reverse-name)))
	 (dir-hint (apply string-append
			  (map (lambda (elt)
				 (string-append (symbol->string elt) "/"))
			       dir-hint-module-name))))
    (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)))
		(cond ((and load-compiled
			    (%search-load-path (string-append file ".go")))
		       => (lambda (full)
			    (load-file load-compiled full)))
		      ((%search-load-path file)
		       => (lambda (full)
			    (load-file primitive-load full))))))
	    (lambda () (set-autoloaded! dir-hint name didit)))
	   didit))))


;;; Dynamic linking of modules

;; This method of dynamically linking Guile Extensions is deprecated.
;; Use `load-extension' explicitely from Scheme code instead.

(begin-deprecated

 (define (split-c-module-name str)
   (let loop ((rev '())
	      (start 0)
	      (pos 0)
	      (end (string-length str)))
     (cond
      ((= pos end)
       (reverse (cons (string->symbol (substring str start pos)) rev)))
      ((eq? (string-ref str pos) #\space)
       (loop (cons (string->symbol (substring str start pos)) rev)
	     (+ pos 1)
	     (+ pos 1)
	     end))
      (else
       (loop rev start (+ pos 1) end)))))

 (define (convert-c-registered-modules dynobj)
   (let ((res (map (lambda (c)
		     (list (split-c-module-name (car c)) (cdr c) dynobj))
		   (c-registered-modules))))
     (c-clear-registered-modules)
     res))

 (define registered-modules '())

 (define (register-modules dynobj)
   (set! registered-modules
	 (append! (convert-c-registered-modules dynobj)
		  registered-modules)))

 (define (warn-autoload-deprecation modname)
   (issue-deprecation-warning
    "Autoloading of compiled code modules is deprecated."
    "Write a Scheme file instead that uses `load-extension'.")
   (issue-deprecation-warning
    (simple-format #f "(You just autoloaded module ~S.)" modname)))

 (define (init-dynamic-module modname)
   ;; Register any linked modules which have been registered on the C level
   (register-modules #f)
   (or-map (lambda (modinfo)
	     (if (equal? (car modinfo) modname)
		 (begin
		   (warn-autoload-deprecation modname)
		   (set! registered-modules (delq! modinfo registered-modules))
		   (let ((mod (resolve-module modname #f)))
		     (save-module-excursion
		      (lambda ()
			(set-current-module mod)
			(set-module-public-interface! mod mod)
			(dynamic-call (cadr modinfo) (caddr modinfo))
			))
		     #t))
		 #f))
	   registered-modules))

 (define (dynamic-maybe-call name dynobj)
   (catch #t				; could use false-if-exception here
	  (lambda ()
	    (dynamic-call name dynobj))
	  (lambda args
	    #f)))

 (define (dynamic-maybe-link filename)
   (catch #t				; could use false-if-exception here
	  (lambda ()
	    (dynamic-link filename))
	  (lambda args
	    #f)))

 (define (find-and-link-dynamic-module module-name)
   (define (make-init-name mod-name)
     (string-append "scm_init"
		    (list->string (map (lambda (c)
					 (if (or (char-alphabetic? c)
						 (char-numeric? c))
					     c
					     #\_))
				       (string->list mod-name)))
		    "_module"))

   ;; Put the subdirectory for this module in the car of SUBDIR-AND-LIBNAME,
   ;; and the `libname' (the name of the module prepended by `lib') in the cdr
   ;; field.  For example, if MODULE-NAME is the list (inet tcp-ip udp), then
   ;; SUBDIR-AND-LIBNAME will be the pair ("inet/tcp-ip" . "libudp").
   (let ((subdir-and-libname
	  (let loop ((dirs "")
		     (syms module-name))
	    (if (null? (cdr syms))
		(cons dirs (string-append "lib" (symbol->string (car syms))))
		(loop (string-append dirs (symbol->string (car syms)) "/")
		      (cdr syms)))))
	 (init (make-init-name (apply string-append
				      (map (lambda (s)
					     (string-append "_"
							    (symbol->string s)))
					   module-name)))))
     (let ((subdir (car subdir-and-libname))
	   (libname (cdr subdir-and-libname)))

       ;; Now look in each dir in %LOAD-PATH for `subdir/libfoo.la'.  If that
       ;; file exists, fetch the dlname from that file and attempt to link
       ;; against it.  If `subdir/libfoo.la' does not exist, or does not seem
       ;; to name any shared library, look for `subdir/libfoo.so' instead and
       ;; link against that.
       (let check-dirs ((dir-list %load-path))
	 (if (null? dir-list)
	     #f
	     (let* ((dir (in-vicinity (car dir-list) subdir))
		    (sharlib-full
		     (or (try-using-libtool-name dir libname)
			 (try-using-sharlib-name dir libname))))
	       (if (and sharlib-full (file-exists? sharlib-full))
		   (link-dynamic-module sharlib-full init)
		   (check-dirs (cdr dir-list)))))))))

 (define (try-using-libtool-name libdir libname)
   (let ((libtool-filename (in-vicinity libdir
					(string-append libname ".la"))))
     (and (file-exists? libtool-filename)
	  libtool-filename)))

 (define (try-using-sharlib-name libdir libname)
   (in-vicinity libdir (string-append libname ".so")))

 (define (link-dynamic-module filename initname)
   ;; Register any linked modules which have been registered on the C level
   (register-modules #f)
   (let ((dynobj (dynamic-link filename)))
     (dynamic-call initname dynobj)
     (register-modules dynobj)))

 (define (try-module-linked module-name)
   (init-dynamic-module module-name))

 (define (try-module-dynamic-link module-name)
   (and (find-and-link-dynamic-module module-name)
	(init-dynamic-module module-name))))
;; end of deprecated section


(define autoloads-done '((guile . guile)))

(define (autoload-done-or-in-progress? p m)
  (let ((n (cons p m)))
    (->bool (or (member n autoloads-done)
		(member n autoloads-in-progress)))))

(define (autoload-done! p m)
  (let ((n (cons p m)))
    (set! autoloads-in-progress
	  (delete! n autoloads-in-progress))
    (or (member n autoloads-done)
	(set! autoloads-done (cons n autoloads-done)))))

(define (autoload-in-progress! p m)
  (let ((n (cons p m)))
    (set! autoloads-done
	  (delete! n autoloads-done))
    (set! autoloads-in-progress (cons n autoloads-in-progress))))

(define (set-autoloaded! p m done?)
  (if done?
      (autoload-done! p m)
      (let ((n (cons p m)))
	(set! autoloads-done (delete! n autoloads-done))
	(set! autoloads-in-progress (delete! n autoloads-in-progress)))))




;; {EVAL-CASE}
;;
;; (eval-case ((situation*) forms)* (else forms)?)
;;
;; Evaluate certain code based on the situation that eval-case is used
;; in.  The only defined situation right now is `load-toplevel' which
;; triggers for code evaluated at the top-level, for example from the
;; REPL or when loading a file.

(define eval-case
  (procedure->memoizing-macro
   (lambda (exp env)
     (define (toplevel-env? env)
       (or (not (pair? env)) (not (pair? (car env)))))
     (define (syntax)
       (error "syntax error in eval-case"))
     (let loop ((clauses (cdr exp)))
       (cond
	((null? clauses)
	 #f)
	((not (list? (car clauses)))
	 (syntax))
	((eq? 'else (caar clauses))
	 (or (null? (cdr clauses))
	     (syntax))
	 (cons 'begin (cdar clauses)))
	((not (list? (caar clauses)))
	 (syntax))
	((and (toplevel-env? env)
	      (memq 'load-toplevel (caar clauses)))
	 (cons 'begin (cdar clauses)))
	(else
	 (loop (cdr clauses))))))))


;;; {Macros}
;;;

(define (primitive-macro? m)
  (and (macro? m)
       (not (macro-transformer m))))

;;; {Defmacros}
;;;
(define macro-table (make-weak-key-hash-table 523))
(define xformer-table (make-weak-key-hash-table 523))

(define (defmacro? m)  (hashq-ref macro-table m))
(define (assert-defmacro?! m) (hashq-set! macro-table m #t))
(define (defmacro-transformer m) (hashq-ref xformer-table m))
(define (set-defmacro-transformer! m t) (hashq-set! xformer-table m t))

(define defmacro:transformer
  (lambda (f)
    (let* ((xform (lambda (exp env)
		    (copy-tree (apply f (cdr exp)))))
	   (a (procedure->memoizing-macro xform)))
      (assert-defmacro?! a)
      (set-defmacro-transformer! a f)
      a)))


(define defmacro
  (let ((defmacro-transformer
	  (lambda (name parms . body)
	    (let ((transformer `(lambda ,parms ,@body)))
	      `(eval-case
		((load-toplevel)
		 (define ,name (defmacro:transformer ,transformer)))
		(else
		 (error "defmacro can only be used at the top level")))))))
    (defmacro:transformer defmacro-transformer)))

(define defmacro:syntax-transformer
  (lambda (f)
    (procedure->syntax
	      (lambda (exp env)
		(copy-tree (apply f (cdr exp)))))))


;; XXX - should the definition of the car really be looked up in the
;; current module?

(define (macroexpand-1 e)
  (cond
   ((pair? e) (let* ((a (car e))
		     (val (and (symbol? a) (local-ref (list a)))))
		(if (defmacro? val)
		    (apply (defmacro-transformer val) (cdr e))
		    e)))
   (#t e)))

(define (macroexpand e)
  (cond
   ((pair? e) (let* ((a (car e))
		     (val (and (symbol? a) (local-ref (list a)))))
		(if (defmacro? val)
		    (macroexpand (apply (defmacro-transformer val) (cdr e)))
		    e)))
   (#t e)))

(provide 'defmacro)



;;; {Run-time options}

(define define-option-interface
  (let* ((option-name car)
	 (option-value cadr)
	 (option-documentation caddr)

	 (print-option (lambda (option)
			 (display (option-name option))
			 (if (< (string-length
				 (symbol->string (option-name option)))
				8)
			     (display #\tab))
			 (display #\tab)
			 (display (option-value option))
			 (display #\tab)
			 (display (option-documentation option))
			 (newline)))

	 ;; Below follow the macros defining the run-time option interfaces.

	 (make-options (lambda (interface)
			 `(lambda args
			    (cond ((null? args) (,interface))
				  ((list? (car args))
				   (,interface (car args)) (,interface))
				  (else (for-each ,print-option
						  (,interface #t)))))))

	 (make-enable (lambda (interface)
			`(lambda flags
			   (,interface (append flags (,interface)))
			   (,interface))))

	 (make-disable (lambda (interface)
			 `(lambda flags
			    (l