← Back to branch summary

~ubuntu-branches/ubuntu/hardy/texmacs/hardy

« back to all changes in this revision

Viewing changes to TeXmacs/progs/kernel/boot/prologue.scm

  • Committer: Bazaar Package Importer
  • Author(s): Ralf Treinen
  • Date: 2004-04-19 20:34:00 UTC
  • Revision ID: james.westby@ubuntu.com-20040419203400-g4e34ih0315wcn8v
Tags: upstream-1.0.3-R2
Import upstream version 1.0.3-R2

Show diffs side-by-side

added added

removed removed

Lines of Context:
TeXmacs/progs/kernel/boot/prologue.scm
 
1
 
 
2
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
3
;;
 
4
;; MODULE      : prologue.scm
 
5
;; DESCRIPTION : subroutines which are not well implemented in guile
 
6
;; COPYRIGHT   : (C) 2003  Joris van der Hoeven
 
7
;;
 
8
;; This software falls under the GNU general public license and comes WITHOUT
 
9
;; ANY WARRANTY WHATSOEVER. See the file $TEXMACS_PATH/LICENSE for details.
 
10
;; If you don't have this file, write to the Free Software Foundation, Inc.,
 
11
;; 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 
12
;;
 
13
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
14
 
 
15
(texmacs-module (kernel boot prologue)
 
16
  (:use (kernel boot ahash-table))
 
17
  (:export
 
18
    list->module ;; for module-load macro
 
19
    module-load
 
20
    set-symbol-procedure! symbol-procedure
 
21
    list-sort))
 
22
 
 
23
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
24
;; Additional support for loading modules
 
25
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
26
 
 
27
(define module-loaded-table (make-ahash-table))
 
28
 
 
29
(define (list->module module)
 
30
  (let* ((aux (lambda (s) (string-append "/" (symbol->string s))))
 
31
         (name* (apply string-append (map aux module)))
 
32
         (name (substring name* 1 (string-length name*)))
 
33
         (u (url "$GUILE_LOAD_PATH" (string-append name ".scm"))))
 
34
    (url-materialize u "r")))
 
35
 
 
36
(define (module-load module*)
 
37
  (if (list? module*)
 
38
      (let* ((module (list->module module*))
 
39
             (loaded (ahash-ref module-loaded-table module)))
 
40
        (ahash-set! module-loaded-table module #t)
 
41
        ;(if (not loaded) (display* "TeXmacs] Loading module " module* "\n"))
 
42
        (if (not loaded) (load-module module)))))
 
43
 
 
44
;; FIXME: why does this not work?
 
45
;(define (module-load name)
 
46
;  (module-use! (current-module) (resolve-module name)))
 
47
 
 
48
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
49
;; Work around broken 'symbol-property'
 
50
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
51
 
 
52
(define symbol-procedure-table (make-ahash-table))
 
53
 
 
54
(define (set-symbol-procedure! symb proc)
 
55
  (ahash-set! symbol-procedure-table symb proc))
 
56
 
 
57
(define (symbol-procedure symb)
 
58
  (ahash-ref symbol-procedure-table symb))
 
59
 
 
60
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
61
;; Sorting lists
 
62
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
63
 
 
64
(define (list-sort-insert x l comp?)
 
65
  (cond ((null? l) (list x))
 
66
        ((comp? x (car l)) (cons x l))
 
67
        (else (cons (car l) (list-sort-insert x (cdr l) comp?)))))
 
68
 
 
69
(define (list-sort l comp?)
 
70
  "Sort @l using the comparison @comp?."
 
71
  ;; Should be replaced by built-in 'sort' routine later on (Guile > 1.3.4)
 
72
  (if (null? l) l
 
73
      (let ((r (list-sort (cdr l) comp?)))
 
74
        (list-sort-insert (car l) r comp?))))