This page shows how to get a functionally equivalent feature to the __func__, __FILE__ and ___LINE___ C language preprocessor symbols. The feature is implemented in a Guile module.
It is feature-INcomplete and somewhat dirty, mh? But for debugging purposes it could work.
The module has the following interface.
(---FILE--- "file-name.scm") (---FILE--- 'file-name.scm) (---FILE---)
A parameter, in the SRFI-39 sense, that should be used to hold the current file name. It is automatically used by my-load-file and my-load-module.
(define name value)
a redefinition of the Guile's built in define syntax that, when name is a list:
The variable my-builtin-define holds the original Guile's syntax.
(my-load-file "path/to/file.scm")
Load the selected file and evaluate it in the top level environment; the code can define a module.
Before the evaluation takes place:
While evaluation takes place:
(my-load-module (module spec))
A macro that uses my-load-file to load a file that should contain the selected module. No test is performed to make sure that the file actually defines that module.
The file name is built from the module's specification list by joining the elements with a slash and appending the extension: (my module spec) becomes my/module/spec.scm.
The file is searched in the directories of the %load-path variable, in the order in which they are listed, stopping at the first readable file.
When the OS's environment variable GUILE_LOAD_PATH is used, the directories in there are prepended to the list in %load-path. The default value of %load-path is something like:
("/usr/local/share/guile/site"
"/usr/local/share/guile/1.8"
"/usr/local/share/guile")
and when Guile is invoked with:
$ GUILE_LOAD_PATH=/home/marco/share/guile:/usr/share/guile guile
the value becomes:
("/home/marco/share/guile"
"/usr/share/guile"
"/usr/local/share/guile/site"
"/usr/local/share/guile/1.8"
"/usr/local/share/guile")
got it?
It is meant to be installed in a directory like /usr/local/share/guile/site, file lang-define.scm.
;; lang-define.scm -- (define-module (lang-define) #:use-module (srfi srfi-39) #:use-module (ice-9 rdelim) #:use-module (ice-9 regex) #:use-module (srfi srfi-1) #:duplicates merge-generics) (define my-builtin-define define) ;; ------------------------------------------------------------ (define (my-tree-subst tree alist) (my-builtin-define (tree-map func tree) (map (lambda (v) (cond ((symbol? v) (func v)) ((list? v) (tree-map func v)) (else v))) tree)) (my-builtin-define (subst-from-alist value alist) (cond ((eq? value (caar alist)) (cdar alist)) ((null? (cdr alist)) value) (else (subst-from-alist value (cdr alist))))) (tree-map (lambda (v) (subst-from-alist v alist)) tree)) ;; ---------------------------------------- (define (my-make-alist . args) (let loop ((alist '()) (key (car args)) (val (cadr args)) (args (cddr args))) (if (null? args) (acons key val alist) (loop (acons key val alist) (car args) (cadr args) (cddr args))))) ;; ---------------------------------------- (define ---FILE--- (make-parameter "lang-define.scm" (lambda (s) (cond ((string? s) s) ((symbol? s) (symbol->string s)) (else (scm-error 'wrong-type-arg 'parameterize "invalid ---FILE--- value ~S" (list s) #f)))))) (define-macro (define name-and-args . body) (if (or (list? name-and-args) (pair? name-and-args)) (let* ((alist (my-make-alist '---FILE--- (---FILE---) '---FUNC--- (symbol->string (car name-and-args)))) (body1 (my-tree-subst body alist))) `(my-builtin-define ,name-and-args ,@body1)) `(my-builtin-define ,name-and-args ,@body))) ;; ------------------------------------------------------------ (define *line-regexp* (make-regexp "\\-\\-\\-LINE\\-\\-\\-")) (my-builtin-define (my-load-file file-name) (with-input-from-file file-name (lambda () (let loop ((code "") (count 1) (line (read-line (current-input-port) 'concat))) (if (eof-object? line) (let ((m #f) (f #f)) (dynamic-wind (lambda () (set! m (current-module)) (set! f (---FILE---)) (---FILE--- file-name)) (lambda () (eval-string code)) (lambda () (---FILE--- f) (set-current-module m)))) (begin (let subloop ((ms (regexp-exec *line-regexp* line))) (if ms (begin (set! line (regexp-substitute #f ms 'pre (number->string count) 'post)) (subloop (regexp-exec *line-regexp* line))))) (loop (string-append code line) (1+ count) (read-line (current-input-port) 'concat)))))))) (define-macro (my-load-module module-spec) (let* ((file-name (string-append (string-join (map object->string module-spec) "/") ".scm")) (pathname #f) (directory (find (lambda (d) (set! pathname (string-join (list d file-name) "/")) (access? pathname R_OK)) %load-path))) (if directory (begin (my-load-file pathname) `(use-modules ,module-spec)) (scm-error 'wrong-type-arg 'my-load-module "unable to fine module ~S" (list module-spec) #f)))) ;; ------------------------------------------------------------ (export define my-builtin-define ---FILE--- my-load-file my-load-module) ;;; end of file
We need a couple of source files to load to test ---LINE--- substitution. One that defines no module:
;; lang-define-source-01.scm -- (define (this) (format #t "*** module ~S, file ~A, ~A procedure, source file output~%" (module-name (current-module)) ---FILE--- ---FUNC---)) (this) ;;; end of file
and one that defines a module:
;; lang-define-source-02.scm -- (define-module (lang-define-source-02) #:use-module (lang-define) #:duplicates merge-generics) (define (red) (format #t "*** module ~A, file ~A, ~A procedure, line ~A and line ~A again~%" (module-name (current-module)) ---FILE--- ---FUNC--- ---LINE--- ---LINE---)) (define (other) (format #t "*** module ~A, ~A procedure, line ~A~%" (module-name (current-module)) ---FUNC--- ---LINE---)) (red) (other) ;;; end of file
note that we load (lang-define) in it. To load the module we have to use the GUILE_LOAD_PATH OS's environment variable to select the directory in which the file is stored.
Here is the test file, there are 2 sections: one that tests ---FUNC--- and ---FILE--- substitution and one that loads the source files:
;; lang-define-test.scm -- (define-module (lang-define-test) #:use-module (lang-define) #:duplicates merge-generics) (debug-enable 'debug) (debug-enable 'backtrace) (debug-enable 'trace) ;; ------------------------------------------------------------ (---FILE--- 'proof.scm) (define (my-func) (format #t "file: ~A, func: ~A~%" ---FILE--- ---FUNC---)) (define (other-func alpha beta) (format #t "file: ~A, func: ~A, a ~A, b ~A~%" ---FILE--- ---FUNC--- alpha beta)) (define (further-func . args) (apply format #t "file: ~A, func: ~A, a ~A, b ~A~%" ---FILE--- ---FUNC--- args)) (define (with-nested-func) (define (nested-func) (format #t "file: ~A, func: ~A~%" ---FILE--- ---FUNC---)) (nested-func)) (define (with-nested-nested-func) (define (nested-func) (define (nested-nested-func) (format #t "file: ~A, func: ~A~%" ---FILE--- ---FUNC---)) (nested-nested-func)) (nested-func)) ;; ------------------------------------------------------------ (my-func) (other-func 123 'abc) (further-func 123 'abc) (with-nested-func) (with-nested-nested-func) ;; ------------------------------------------------------------ (format #t "~%+++ test 1, file ~A, module: ~S~%" (---FILE---) (module-name (current-module))) (my-load-file "lang-define-source-01.scm") (format #t "~%+++ test 2, file ~A, module: ~S~%" (---FILE---) (module-name (current-module))) (my-load-module (lang-define-source-02)) (format #t "~%+++ test 3, file ~A, module: ~S~%" (---FILE---) (module-name (current-module))) (catch #t (lambda () (my-load-module (unexistent module))) (lambda (key . args) (apply format #t (cadr args) (caddr args)) (newline))) (format #t "~%+++ end test, module: ~S~%" (module-name (current-module))) ;;; end of file
This page targets beginners in Scheme. It is the result of a discussion on the guile-user mailing list.
This page is unfinished, more explanations are required.