cleanup
This commit is contained in:
parent
66e67358cc
commit
e518de9ef8
|
@ -34,25 +34,7 @@
|
||||||
|
|
||||||
;;; Code:
|
;;; Code:
|
||||||
|
|
||||||
(define %debug (and=> (getenv "MES_DEBUG") string->number))
|
;;;;;;;;;;;;;;;;;;;;;;;;;; EARLY!
|
||||||
|
|
||||||
(define core:module-define! module-define!)
|
|
||||||
|
|
||||||
(define (provided? x)
|
|
||||||
#f)
|
|
||||||
|
|
||||||
(define (save-stack)
|
|
||||||
#t)
|
|
||||||
|
|
||||||
(define (%get-pre-modules-obarray)
|
|
||||||
(initial-module))
|
|
||||||
|
|
||||||
(define (make-undefined-variable)
|
|
||||||
(make-variable *undefined*))
|
|
||||||
|
|
||||||
(define (hash-fold proc init table)
|
|
||||||
(fold proc init (hash-map->list cons table)))
|
|
||||||
|
|
||||||
(define (pke . stuff)
|
(define (pke . stuff)
|
||||||
(display "\n" (current-error-port))
|
(display "\n" (current-error-port))
|
||||||
(newline (current-error-port))
|
(newline (current-error-port))
|
||||||
|
@ -63,6 +45,22 @@
|
||||||
|
|
||||||
(define warn pke)
|
(define warn pke)
|
||||||
|
|
||||||
|
;;;;;;;;;;;;;;;;;;; GUILE
|
||||||
|
|
||||||
|
;; FIXME: move *features* to core, make dynamic
|
||||||
|
(define *core-features* '(current-time fork popen
|
||||||
|
;;posix
|
||||||
|
system))
|
||||||
|
|
||||||
|
(define *features* (cons* 'defmacro 'record 'define-macro
|
||||||
|
*core-features*))
|
||||||
|
|
||||||
|
(define (include-deprecated-features) #f)
|
||||||
|
|
||||||
|
(define make-weak-value-hash-table make-hash-table)
|
||||||
|
(define (%get-pre-modules-obarray)
|
||||||
|
(initial-module))
|
||||||
|
|
||||||
(define (make-mutex)
|
(define (make-mutex)
|
||||||
'*mutex*)
|
'*mutex*)
|
||||||
(define (lock-mutex m)
|
(define (lock-mutex m)
|
||||||
|
@ -70,6 +68,22 @@
|
||||||
(define (unlock-mutex m)
|
(define (unlock-mutex m)
|
||||||
#t)
|
#t)
|
||||||
|
|
||||||
|
;;;;;;;;;;;;;;;;;;; MODULE-DEPS
|
||||||
|
(define %debug (and=> (getenv "MES_DEBUG") string->number))
|
||||||
|
|
||||||
|
(define core:module-define! module-define!)
|
||||||
|
(define (standard-eval-closure module)
|
||||||
|
(module-eval-closure module))
|
||||||
|
(define (standard-interface-eval-closure module)
|
||||||
|
(module-eval-closure module))
|
||||||
|
|
||||||
|
;; (define (make-undefined-variable)
|
||||||
|
;; (make-variable *undefined*))
|
||||||
|
|
||||||
|
(define (hash-fold proc init table)
|
||||||
|
(fold proc init (hash-map->list cons table)))
|
||||||
|
|
||||||
|
|
||||||
(define current-reader (make-fluid))
|
(define current-reader (make-fluid))
|
||||||
|
|
||||||
(define and-map
|
(define and-map
|
||||||
|
@ -79,12 +93,6 @@
|
||||||
(and (apply f (map car lists))
|
(and (apply f (map car lists))
|
||||||
(apply and-map f (map cdr lists)))))))
|
(apply and-map f (map cdr lists)))))))
|
||||||
|
|
||||||
(define make-weak-value-hash-table make-hash-table)
|
|
||||||
|
|
||||||
(define (standard-eval-closure module)
|
|
||||||
(module-eval-closure module))
|
|
||||||
(define (standard-interface-eval-closure module)
|
|
||||||
(module-eval-closure module))
|
|
||||||
|
|
||||||
(define (hash-for-each proc table)
|
(define (hash-for-each proc table)
|
||||||
(hash-map->list proc table)
|
(hash-map->list proc table)
|
||||||
|
@ -118,18 +126,16 @@
|
||||||
path))
|
path))
|
||||||
|
|
||||||
(define (%search-load-path file-name)
|
(define (%search-load-path file-name)
|
||||||
(when (getenv "MES_DEBUG")
|
(when (> %debug 2)
|
||||||
(display "%search-load-path " (current-error-port))
|
(format (current-error-port) "%search-load-path ~s\n" file-name))
|
||||||
(display file-name (current-error-port)))
|
|
||||||
(let ((file (or (search-path %load-path (string-append file-name ".mes"))
|
(let ((file (or (search-path %load-path (string-append file-name ".mes"))
|
||||||
(search-path %load-path (string-append file-name ".scm")))))
|
(search-path %load-path (string-append file-name ".scm")))))
|
||||||
(when (getenv "MES_DEBUG")
|
(when (> %debug 1)
|
||||||
(display " => " (current-error-port))
|
(format (current-error-port) " => ~s\n" file))
|
||||||
(display file (current-error-port))
|
|
||||||
(display "\n" (current-error-port))
|
|
||||||
)
|
|
||||||
file))
|
file))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
;;;;;;;;;;; ************************************************************
|
;;;;;;;;;;; ************************************************************
|
||||||
|
|
||||||
(define guile:current-module (make-fluid #f))
|
(define guile:current-module (make-fluid #f))
|
||||||
|
@ -153,8 +159,8 @@
|
||||||
(define (run-hook hook . args)
|
(define (run-hook hook . args)
|
||||||
#t)
|
#t)
|
||||||
|
|
||||||
(define-macro (begin-deprecated . args)
|
;; (define-macro (begin-deprecated . args)
|
||||||
#f)
|
;; #f)
|
||||||
|
|
||||||
(define (dynamic-wind in thunk out)
|
(define (dynamic-wind in thunk out)
|
||||||
(catch #t
|
(catch #t
|
||||||
|
@ -170,6 +176,38 @@
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
;;; {Features}
|
||||||
|
;;;
|
||||||
|
|
||||||
|
(define (provide sym)
|
||||||
|
(if (not (memq sym *features*))
|
||||||
|
(set! *features* (cons sym *features*))))
|
||||||
|
|
||||||
|
;; Return #t iff FEATURE is available to this Guile interpreter. In SLIB,
|
||||||
|
;; provided? also checks to see if the module is available. We should do that
|
||||||
|
;; too, but don't.
|
||||||
|
|
||||||
|
(define (provided? feature)
|
||||||
|
(and (memq feature *features*) #t))
|
||||||
|
|
||||||
|
;; let format alias simple-format until the more complete version is loaded
|
||||||
|
|
||||||
|
(define format simple-format)
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
;;; {Deprecation}
|
||||||
|
;;;
|
||||||
|
;;; Depends on: defmacro
|
||||||
|
;;;
|
||||||
|
|
||||||
|
(defmacro begin-deprecated forms
|
||||||
|
(if (include-deprecated-features)
|
||||||
|
(cons begin forms)
|
||||||
|
#f))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
;;; {EVAL-CASE}
|
;;; {EVAL-CASE}
|
||||||
;;;
|
;;;
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue