src/TeXmacs/progs/kernel/boot/boot.scm

   1
   2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   3 ;;
   4 ;; MODULE      : boot.scm
   5 ;; DESCRIPTION : some global variables, public macros, on-entry, on-exit and
   6 ;;               initialization of the TeXmacs module system
   7 ;; COPYRIGHT   : (C) 1999  Joris van der Hoeven
   8 ;;
   9 ;; This software falls under the GNU general public license version 3 or later.
  10 ;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
  11 ;; in the root directory or <http://www.gnu.org/licenses/gpl-3.0.html>.
  12 ;;
  13 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  14
  15 (define texmacs-user (current-module))
  16 (define temp-module (current-module))
  17 (define temp-value #f)
  18
  19 (define (guile-a?) (equal? (scheme-dialect) "guile-a"))
  20 (define (guile-b?) (equal? (scheme-dialect) "guile-b"))
  21 (define (guile-c?) (equal? (scheme-dialect) "guile-c"))
  22 (define (guile-b-c?) (or (guile-b?) (guile-c?)))
  23 (if (guile-c?) (use-modules (ice-9 rdelim) (ice-9 pretty-print)))
  24
  25 ;; Should be defined
  26 (define dialogue-break #f)
  27 (define dialogue-return #f)
  28 (define dialogue-error #f)
  29
  30 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  31 ;; Redirect standard output
  32 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  33
  34 (define original-display display)
  35 (define original-write write)
  36
  37 (define (display . l)
  38   "display one object on the standard output or a specified port."
  39   (if (or (null? l) (not (null? (cdr l))))
  40       (apply original-display l)
  41       (tm-output (display-to-string (car l)))))
  42
  43 (define (write . l)
  44   "write an object to the standard output or a specified port."
  45   (if (or (null? l) (not (null? (cdr l))))
  46       (apply original-write l)
  47       (tm-output (object->string (car l)))))
  48
  49 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  50 ;; Provide functions if not defined and public macros
  51 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  52
  53 (define-macro (provide-public head . body)
  54   (if (or (and (symbol? head) (not (defined? head)))
  55           (and (pair? head) (symbol? (car head)) (not (defined? (car head)))))
  56       `(define-public ,head ,@body)
  57       '(noop)))
  58
  59 (if (guile-a?)
  60     (define-macro (define-public-macro head . body)
  61       `(define-public ,(car head)
  62          ;; FIXME: why can't we use procedure->macro
  63          ;; for a non-memoizing variant?
  64          (procedure->memoizing-macro
  65           (lambda (cmd env)
  66             (apply (lambda ,(cdr head) ,@body) (cdr cmd)))))))
  67
  68 (if (not (guile-a?))
  69     (define-macro (define-public-macro head . body)
  70       `(begin
  71          (define-macro ,(car head)
  72            (lambda ,(cdr head) ,@body))
  73          (export ,(car head)))))
  74
  75 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  76 ;; On-entry and on-exit macros
  77 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  78
  79 (define (quit-TeXmacs-scheme) (noop))
  80
  81 (define-macro (on-entry . cmd)
  82   `(begin ,@cmd))
  83
  84 (define-macro (on-exit . cmd)
  85   `(set! quit-TeXmacs-scheme (lambda () ,@cmd (,quit-TeXmacs-scheme))))
  86
  87 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  88 ;; Module switching
  89 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  90
  91 (define-macro (with-module module . body)
  92   `(begin
  93      (set! temp-module (current-module))
  94      (set-current-module ,module)
  95      ,@body
  96      (set-current-module temp-module)))
  97
  98 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  99 ;; Module handling
 100 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 101
 102 (if (guile-a?)
 103     (begin
 104       (define import-from use-modules)
 105       (define re-export export)))
 106
 107 (if (guile-b-c?)
 108     (begin
 109       (define-macro (import-from . modules)
 110         `(process-use-modules
 111           (list ,@(map (lambda (m)
 112                          `(list ,@(compile-interface-spec m)))
 113                        modules))))
 114       ;; FIXME: why does this not work?
 115       ;; (define-macro (import-from . modules)
 116       ;;   (define (import-from-body module)
 117       ;;     `(module-use! (current-module) (resolve-module ',module)))
 118       ;;   `(begin
 119       ;;     ,@(map import-from-body modules)))
 120       ))
 121
 122 (define-macro (inherit-modules . which-list)
 123   (define (module-exports which)
 124     (let* ((m (resolve-module which))
 125            (m-public (module-ref m '%module-public-interface)))
 126       (module-map (lambda (sym var) sym) m-public)))
 127   (let ((l (apply append (map module-exports which-list))))
 128     `(begin
 129        (use-modules ,@which-list)
 130        (re-export ,@l))))
 131
 132 (define-macro (texmacs-module name . options)
 133   (define (transform action)
 134     (cond ((not (pair? action)) (noop))
 135           ((equal? (car action) :use) (cons 'use-modules (cdr action)))
 136           ((equal? (car action) :inherit) (cons 'inherit-modules (cdr action)))
 137           ((equal? (car action) :export)
 138            (display "Warning] The option :export is no longer supported\n")
 139            (display "       ] Please use tm-define instead\n"))
 140           (else '(noop))))
 141   (let ((l (map-in-order transform options)))
 142     (if (guile-b-c?)
 143         (set! l (cons `(module-use! (current-module) ,texmacs-user) l)))
 144     ;;(display "loading ") (display name) (display "\n")
 145     `(begin
 146        (define-module ,name)
 147        ,@l)))
 148
 149 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 150 ;; Lazy modules for extern mactos in style packages
 151 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 152
 153 (define markup-modules-list '((utils misc markup-funcs)))
 154
 155 (define-macro (lazy-markup-modules . l)
 156   `(set! markup-modules-list (append markup-modules-list ',l)))
 157
 158 (define-macro (lazy-markup-modules-force)
 159   `(begin
 160      (use-modules ,@markup-modules-list)
 161      (set! markup-modules-list '())))