core: Add module-define!
[mes.git] / mes / module / mes / boot-0.scm.in
1 ;;; -*-scheme-*-
2
3 ;;; GNU Mes --- Maxwell Equations of Software
4 ;;; Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
5 ;;;
6 ;;; This file is part of GNU Mes.
7 ;;;
8 ;;; GNU Mes is free software; you can redistribute it and/or modify it
9 ;;; under the terms of the GNU General Public License as published by
10 ;;; the Free Software Foundation; either version 3 of the License, or (at
11 ;;; your option) any later version.
12 ;;;
13 ;;; GNU Mes is distributed in the hope that it will be useful, but
14 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
16 ;;; GNU General Public License for more details.
17 ;;;
18 ;;; You should have received a copy of the GNU General Public License
19 ;;; along with GNU Mes.  If not, see <http://www.gnu.org/licenses/>.
20
21 ;;; Commentary:
22
23 ;;; read-0.mes - bootstrap reader.  This file is read by a minimal
24 ;;; core reader.  It only supports s-exps and line-comments; quotes,
25 ;;; character literals, string literals cannot be used here.
26
27 ;;; Code:
28
29 ;; boot-00.scm
30 (define mes %version)
31
32 (define (defined? x)
33   (module-variable (current-module) x))
34
35 (define (cond-expand-expander clauses)
36   (if (defined? (car (car clauses)))
37       (cdr (car clauses))
38       (cond-expand-expander (cdr clauses))))
39
40 (define-macro (cond-expand . clauses)
41   (cons 'begin (cond-expand-expander clauses)))
42 ;; end boot-00.scm
43
44 ;; boot-01.scm
45 (define (pair? x) (eq? (core:type x) <cell:pair>))
46 (define (not x) (if x #f #t))
47
48 (define (display x . rest)
49   (if (null? rest) (core:display x)
50       (core:display-port x (car rest))))
51
52 (define (write x . rest)
53   (if (null? rest) (core:write x)
54       (core:write-port x (car rest))))
55
56 (define (list->string lst)
57   (core:make-cell <cell:string> lst 0))
58
59 (define (integer->char x)
60   (core:make-cell <cell:char> 0 x))
61
62 (define (newline . rest)
63   (core:display (list->string (list (integer->char 10)))))
64
65 (define (string->list s)
66   (core:car s))
67
68 (define (cadr x) (car (cdr x)))
69
70 (define (map1 f lst)
71   (if (null? lst) (list)
72       (cons (f (car lst)) (map1 f (cdr lst)))))
73
74 (define (map f lst)
75   (if (null? lst) (list)
76       (cons (f (car lst)) (map f (cdr lst)))))
77
78 (define (cons* . rest)
79   (if (null? (cdr rest)) (car rest)
80       (cons (car rest) (core:apply cons* (cdr rest) (current-module)))))
81
82 (define (apply f h . t)
83   (if (null? t) (core:apply f h (current-module))
84       (apply f (apply cons* (cons h t)))))
85
86 (define (append . rest)
87   (if (null? rest) '()
88       (if (null? (cdr rest)) (car rest)
89           (append2 (car rest) (apply append (cdr rest))))))
90 ;; end boot-01.scm
91
92 ;; boot-02.scm
93 (define-macro (and . x)
94   (if (null? x) #t
95       (if (null? (cdr x)) (car x)
96           (list (quote if) (car x) (cons (quote and) (cdr x))
97                 #f))))
98
99 (define-macro (or . x)
100   (if (null? x) #f
101       (if (null? (cdr x)) (car x)
102           (list (list (quote lambda) (list (quote r))
103                       (list (quote if) (quote r) (quote r)
104                             (cons (quote or) (cdr x))))
105                 (car x)))))
106
107 (define-macro (mes-use-module module)
108   #t)
109 ;; end boot-02.scm
110
111 ;; boot-0.scm
112 (define (primitive-eval e) (core:eval e (current-module)))
113 (define eval core:eval)
114
115 (define (current-output-port) 1)
116 (define (current-error-port) 2)
117 (define (port-filename port) "<stdin>")
118 (define (port-line port) 0)
119 (define (port-column port) 0)
120 (define (ftell port) 0)
121 (define (false-if-exception x) x)
122
123 (define (cons* . rest)
124   (if (null? (cdr rest)) (car rest)
125       (cons (car rest) (core:apply cons* (cdr rest) (current-module)))))
126
127 (define (apply f h . t)
128   (if (null? t) (core:apply f h (current-module))
129       (apply f (apply cons* (cons h t)))))
130
131 (define-macro (cond . clauses)
132   (list 'if (pair? clauses)
133         (list (cons
134                'lambda
135                (cons
136                 '(test)
137                 (list (list 'if 'test
138                             (if (pair? (cdr (car clauses)))
139                                 (if (eq? (car (cdr (car clauses))) '=>)
140                                     (append2 (cdr (cdr (car clauses))) '(test))
141                                     (list (cons 'lambda (cons '() (cons 'test (cdr (car clauses)))))))
142                                 (list (cons 'lambda (cons '() (cons 'test (cdr (car clauses)))))))
143                             (if (pair? (cdr clauses))
144                                 (cons 'cond (cdr clauses)))))))
145               (car (car clauses)))))
146
147 (define else #t)
148
149 (define-macro (load file)
150   (list 'begin
151         (list 'if (list 'and (list getenv "MES_DEBUG")
152                         (list not (list equal2? (list getenv "MES_DEBUG") "0"))
153                         (list not (list equal2? (list getenv "MES_DEBUG") "1")))
154               (list 'begin
155                     (list core:display-error ";;; read ")
156                     (list core:display-error file)
157                     (list core:display-error "\n")))
158      (list 'primitive-load file)))
159
160 (define-macro (include file) (list 'load file))
161
162 (define (append . rest)
163   (if (null? rest) '()
164       (if (null? (cdr rest)) (car rest)
165           (append2 (car rest) (apply append (cdr rest))))))
166
167 (define (string->list s)
168   (core:car s))
169
170 (define %prefix (getenv "MES_PREFIX"))
171 (define %moduledir
172   (if (not %prefix) "mes/module/"
173       (list->string
174        (append (string->list %prefix) (string->list "/module/" )))))
175
176 (include (list->string
177           (append2 (string->list %moduledir) (string->list "mes/type-0.mes"))))
178
179 (define (symbol->string s)
180   (apply string (symbol->list s)))
181
182 (define (string-append . rest)
183   (apply string (apply append (map1 string->list rest))))
184
185 (define %version (if (eq? (car (string->list "@VERSION@")) #\@) "git"
186                      "@VERSION@"))
187 (define (effective-version) %version)
188
189 (if (list 'and (list getenv "MES_DEBUG")
190           (list not (list equal2? (list getenv "MES_DEBUG") "0"))
191           (list not (list equal2? (list getenv "MES_DEBUG") "1")))
192     (begin
193       (core:display-error ";;; %moduledir=")
194       (core:display-error %moduledir)
195       (core:display-error "\n")))
196
197 (define-macro (include-from-path file)
198   (list 'load (list string-append %moduledir file)))
199
200 (define (string-join lst infix)
201   (if (null? lst) ""
202       (if (null? (cdr lst)) (car lst)
203           (string-append (car lst) infix (string-join (cdr lst) infix)))))
204
205 (include-from-path "mes/module.mes")
206
207 (mes-use-module (mes base))
208 (mes-use-module (mes quasiquote))
209 (mes-use-module (mes let))
210 (mes-use-module (mes scm))
211 (mes-use-module (srfi srfi-1))
212 (mes-use-module (srfi srfi-13))
213 (mes-use-module (mes fluids))
214 (mes-use-module (mes catch))
215 (mes-use-module (mes posix))
216
217 (define-macro (include-from-path file)
218   (let loop ((path (cons* %moduledir "@srcdir@/module" (string-split (or (getenv "GUILE_LOAD_PATH")) #\:))))
219     (cond ((and=> (getenv "MES_DEBUG") (compose (lambda (o) (> o 2)) string->number))
220            (core:display-error (string-append "include-from-path: " file " [PATH:" (string-join path ":") "]\n")))
221           ((and=> (getenv "MES_DEBUG") (compose (lambda (o) (> o 1)) string->number))
222            (core:display-error (string-append "include-from-path: " file "\n"))))
223     (if (null? path) (error "include-from-path: not found: " file)
224         (let ((file (string-append (car path) "/" file)))
225           (if (access? file R_OK) `(load ,file)
226               (loop (cdr path)))))))
227
228 (define-macro (define-module module . rest)
229   `(if ,(and (pair? module)
230              (= 1 (length module))
231              (symbol? (car module)))
232        (define (,(car module) . arguments) (main (command-line)))))
233
234 (define-macro (use-modules . rest) #t)
235
236 (mes-use-module (mes getopt-long))
237
238 (define %main #f)
239 (primitive-load 0)
240 (let ((tty? (isatty? 0)))
241   (define (parse-opts args)
242     (let* ((option-spec
243             '((no-auto-compile)
244               (compiled-path (single-char #\C) (value #t))
245               (dump)
246               (help (single-char #\h))
247               (load)
248               (load-path (single-char #\L) (value #t))
249               (main (single-char #\e) (value #t))
250               (source (single-char #\s) (value #t))
251               (version (single-char #\V)))))
252       (getopt-long args option-spec #:stop-at-first-non-option #t)))
253   (define (source-arg? o)
254     (equal? "-s" o))
255   (let* ((s-index (list-index source-arg? %argv))
256          (args (if s-index (list-head %argv (+ s-index 2)) %argv))
257          (options (parse-opts args))
258          (main (option-ref options 'main #f))
259          (source (option-ref options 'source #f))
260          (files (if s-index (list-tail %argv (+ s-index 1))
261                     (option-ref options '() '())))
262          (help? (option-ref options 'help #f))
263          (usage? (and (not help?) (null? files) (not tty?) (not main)))
264          (version? (option-ref options 'version #f)))
265     (or
266      (and version?
267           (display (string-append "mes (GNU Mes) " %version "\n"))
268           (exit 0))
269      (and (or help? usage?)
270           (display "Usage: mes [OPTION]... [FILE]...
271 Evaluate code with Mes, interactively or from a script.
272
273   [-s] FILE           load source code from FILE, and exit
274   --                  stop scanning arguments; run interactively
275
276 The above switches stop argument processing, and pass all
277 remaining arguments as the value of (command-line).
278
279   --dump              dump binary program to stdout
280   -e,--main=MAIN      after reading script, apply MAIN to command-line arguments
281   -h, --help          display this help and exit
282   --load              load binary program [module/mes/boot-0.32-mo]
283   -L,--load-path=DIR  add DIR to the front of the module load path
284   -v, --version       display version information and exit
285
286 Ignored for Guile compatibility:
287   --auto-compile
288   --fresh-auto-compile
289   --no-auto-compile
290   -C,--compiled-path=DIR
291 " (or (and usage? (current-error-port)) (current-output-port)))
292           (exit (or (and usage? 2) 0)))
293      options)
294     (if main (set! %main main))
295     (and=> (option-ref options 'load-path #f)
296            (lambda (dir)
297              (setenv "GUILE_LOAD_PATH" (string-append dir ":" (getenv "GUILE_LOAD_PATH")))))
298     (cond ((pair? files)
299            (let* ((file (car files))
300                   (port (if (equal? file "-") 0
301                             (open-input-file file))))
302              (set! %argv files)
303              (set-current-input-port port)))
304           ((and (null? files) tty?)
305
306            (mes-use-module (mes repl))
307            (set-current-input-port 0)
308            (repl))
309           (else #t))))
310 (primitive-load 0)
311 (primitive-load (open-input-string %main))