added "autorequire"; preparing libraries for autorequire
[k8-xscheme:k8-xscheme.git] / sysinit / build_init.scm
1 (define fo (open-dyn-port "w+"))
2
3 (define (ld-file fname #!optional (noeval #f))
4   (let ([fi (open-file-port (string-append "../" fname) "r")])
5     (if (not fi)
6         (begin
7           (set! fi (open-file-port fname "r"))
8           (if (not fi) (error "can't open file" fname))))
9     (display "loading ") (display fname) (display "...") (newline)
10     (let loop ([datum (read fi)])
11       (if (not (eof-object? datum))
12           (begin
13             (cond
14               [(and (pair? datum) (eq? 'load (car datum)))
15                (ld-file (cadr datum) #t)]
16               [(and (pair? datum) (eq? 'xs:libinfo (car datum)))
17                (pp datum)
18                (write datum fo)]
19               [else
20                (if noeval
21                    (write datum fo)
22                    (eval datum))])
23             (loop (read fi)))))
24     (close-port fi)))
25
26 (ld-file "sysinit/xscheme.scm")
27
28 (port-pos-set! fo 0)
29 (define fi fo)
30 (define fo (open-file-port "xschemeex.c" "w"))
31
32
33 (define (num-len n)
34   (cond
35     [(< n 10) 2]
36     [(< n 100) 3]
37     [else 4]))
38
39 (define (dig-2-h d)
40   (integer->char (+ d (if (< d 10) 48 87))))
41
42 (define (num-2-s n)
43   ;(display n) (newline)
44   (cond
45     [(= n 34) "\\\""]
46     [(= n 92) "\\\\"]
47     [(= n 13) "\\r"]
48     [(= n 10) "\\n"]
49     [(= n 9) "\\t"]
50     [(or (< n 32) (> n 127))
51      (string-append "\\x" (dig-2-h (mod (div n 16) 16)) (dig-2-h (mod n 16)))]
52     [else
53      (string-append (integer->char n))]))
54
55 (display "/* xscheme init library */\n" fo)
56 (display "/* Copyright (c) 1988, David Michael Betz\n" fo)
57 (display " * Copyright (c) 2010, Ketmar // Vampire Avalon\n" fo)
58 (display " * All rights reserved.\n" fo)
59 (display " * see LICENSE for terms of using.\n" fo)
60 (display " */\n" fo)
61 (display "\n" fo)
62 (display "#ifndef XSCHEME_INIT_H\n" fo)
63 (display "#define XSCHEME_INIT_H\n\n\n" fo)
64 (display "const char *xscDefaultInit = \"" fo)
65 (let loop ([bt (read-byte fi)] [cwdt 666])
66   (if (not (eof-object? bt))
67       (let ([bs (num-2-s bt)])
68         ;(write (string? bs)) (newline)
69         ;(display "/*" fo) (write bt fo) (display "*/" fo)
70         (if (>= cwdt 75)
71             (begin
72               ;(newline)
73               (display "\"\n  \"" fo)
74               (loop bt 0))
75             (begin
76               (display bs fo)
77               (loop (read-byte fi) (+ cwdt (string-length bs))))))))
78 (display "\";\n\n\n#endif\n" fo)
79
80 (close-port fo)
81 (close-port fi)
82
83 (exit)