test: Add syntax tests.
[mes.git] / module / mes / base-0.mes
1 ;;; -*-scheme-*-
2
3 ;;; Mes --- Maxwell Equations of Software
4 ;;; Copyright © 2016,2017,2018 Jan Nieuwenhuizen <janneke@gnu.org>
5 ;;;
6 ;;; This file is part of Mes.
7 ;;;
8 ;;; 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 ;;; 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 Mes.  If not, see <http://www.gnu.org/licenses/>.
20
21 ;;; Commentary:
22
23 ;;; base-0.mes is the first file being loaded from the Mes core.  It
24 ;;; provides primitives that use Mes internals to create the illusion
25 ;;; of compatibility with Guile.  It is not safe to be run by Guile.
26
27 ;;; Code:
28
29 (define mes? #t)
30 (define guile? #f)
31 (define guile-1.8? #f)
32 (define guile-2? #f)
33
34 (define (primitive-eval e) (core:eval e (current-module)))
35 (define eval core:eval)
36
37 (if (defined? 'current-input-port) #t
38     (define (current-input-port) 0))
39
40 (define (current-output-port) 1)
41 (define (current-error-port) 2)
42 (define (port-filename port) "<stdin>")
43 (define (port-line port) 0)
44 (define (port-column port) 0)
45 (define (ftell port) 0)
46 (define (false-if-exception x) x)
47
48 (define (cons* . rest)
49   (if (null? (cdr rest)) (car rest)
50       (cons (car rest) (core:apply cons* (cdr rest) (current-module)))))
51
52 (define (apply f h . t)
53   (if (null? t) (core:apply f h (current-module))
54       (apply f (apply cons* (cons h t)))))
55
56 (define-macro (cond . clauses)
57   (list 'if (pair? clauses)
58         (list (cons
59                'lambda
60                (cons
61                 '(test)
62                 (list (list 'if 'test
63                             (if (pair? (cdr (car clauses)))
64                                 (if (eq? (car (cdr (car clauses))) '=>)
65                                     (append2 (cdr (cdr (car clauses))) '(test))
66                                     (list (cons 'lambda (cons '() (car clauses)))))
67                                 (list (cons 'lambda (cons '() (car clauses)))))
68                             (if (pair? (cdr clauses))
69                                 (cons 'cond (cdr clauses)))))))
70               (car (car clauses)))))
71
72 (define else #t)
73
74 (define (cadr x) (car (cdr x)))
75
76 (define-macro (let bindings . rest)
77   (cons (cons 'lambda (cons (map1 car bindings) rest))
78         (map1 cadr bindings)))
79
80 (define *input-ports* '())
81 (define-macro (push! stack o)
82   (cons
83    'begin
84    (list
85     (list 'set! stack (list cons o stack))
86     stack)))
87 (define-macro (pop! stack)
88   (list 'let (list (list 'o (list car stack)))
89         (list 'set! stack (list cdr stack))
90         'o))
91 (define-macro (load file)
92   (list 'begin
93         (list 'if (list getenv "MES_DEBUG")
94               (list 'begin
95                     (list core:display-error ";;; read ")
96                     (list core:display-error file)
97                     (list core:display-error "\n")))
98      (list 'push! '*input-ports* (list current-input-port))
99      (list 'set-current-input-port (list open-input-file file))
100      (list 'primitive-load)
101      (list 'set-current-input-port (list 'pop! '*input-ports*))))
102
103 (define include load)
104
105 (define (append . rest)
106   (if (null? rest) '()
107       (if (null? (cdr rest)) (car rest)
108           (append2 (car rest) (apply append (cdr rest))))))
109
110 (define (string->list s)
111   (core:car s))
112
113 (define %prefix (getenv "MES_PREFIX"))
114 (define %moduledir
115   (if (not %prefix) "module/"
116       (list->string
117        (append (string->list %prefix)
118                (string->list "/module") ; `module/' gets replaced upon install
119                (string->list "/")))))
120
121 (include (list->string
122           (append (string->list %moduledir) (string->list "/mes/type-0.mes"))))
123
124 (define (symbol->string s)
125   (apply string (symbol->list s)))
126
127 (define (string-append . rest)
128   (apply string (apply append (map1 string->list rest))))
129
130 (define %version (if (eq? (car (string->list "@VERSION@")) #\@) "git"
131                      "@VERSION@"))
132 (define (effective-version) %version)
133
134 (if (getenv "MES_DEBUG")
135     (begin
136       (core:display-error ";;; %moduledir=")
137       (core:display-error %moduledir)
138       (core:display-error "\n")))
139
140 (define-macro (include-from-path file)
141   (list 'load (list string-append %moduledir file)))
142
143 (define (memq x lst)
144   (if (null? lst) #f
145       (if (eq? x (car lst)) lst
146           (memq x (cdr lst)))))
147
148 (define (string-join lst infix)
149   (if (null? (cdr lst)) (car lst)
150       (string-append (car lst) infix (string-join (cdr lst) infix))))
151
152 (include-from-path "mes/module.mes")
153
154 (mes-use-module (mes base))
155 (mes-use-module (srfi srfi-0))
156 (mes-use-module (mes quasiquote))
157 (mes-use-module (mes let))
158
159 (mes-use-module (mes scm))
160
161 (mes-use-module (srfi srfi-13))
162 (mes-use-module (mes catch))
163
164 (mes-use-module (mes posix))
165