mes.c: add syntax, quasisyntax to reader....
[mes.git] / scm.mes
1 ;;; -*-scheme-*-
2
3 ;;; Mes --- Maxwell Equations of Software
4 ;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
5 ;;;
6 ;;; scm.mes: 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 ;; The Maxwell Equations of Software -- John McCarthy page 13
22 ;; http://www.softwarepreservation.org/projects/LISP/book/LISP%201.5%20Programmers%20Manual.pdf
23
24 (define-macro (if expr then . else)
25   `(cond
26     (,expr ,then)
27     (#t (cond (,(pair? else) ((lambda () ,@else)))))))
28
29 (define-macro (when expr . body)
30   `(if ,expr
31        ((lambda () ,@body))))
32
33 (define (list . rest) rest)
34
35 (define (split-params bindings params)
36   (cond ((null? bindings) params)
37         (#t (split-params (cdr bindings)
38                           (append params (cons (caar bindings) '()))))))
39
40 (define (split-values bindings values)
41   (cond ((null? bindings) values)
42         (#t (split-values (cdr bindings)
43                           (append values (cdar bindings) '())))))
44
45 (define-macro (simple-let bindings rest)
46   `((lambda ,(split-params bindings '()) ,@rest)
47     ,@(split-values bindings '())))
48
49 (define-macro (let-loop label bindings . rest)
50   `(let ((,label *unspecified*))
51      (let ((,label (lambda ,(split-params bindings '()) ,@rest)))
52        (,label ,@(split-values bindings '())))))
53
54 (define-macro (let-loop label bindings rest)
55   `((lambda (,label)
56       (set! ,label (lambda ,(split-params bindings '()) ,@rest))
57       (,label ,@(split-values bindings '())))
58     *unspecified*))
59
60 (define-macro (let bindings-or-label . rest)
61   `(cond (,(symbol? bindings-or-label)
62           (let-loop ,bindings-or-label ,(car rest) ,(cdr rest)))
63          (#t (simple-let ,bindings-or-label ,rest))))
64
65 (define-macro (or2 x y)
66   `(cond (,x ,x) (#t ,y)))
67
68 (define-macro (and2 x y)
69   `(cond (,x ,y) (#t #f)))
70
71 (define-macro (or . x)
72   (cond
73    ((null? x) #f)
74    ((null? (cdr x)) (car x))
75    (#t `(cond (,(car x))
76               (#t (or ,@(cdr x)))))))
77
78 (define-macro (and . x)
79   (cond ((null? x) #t)
80         ((null? (cdr x)) (car x))
81         (#t `(cond (,(car x) (and ,@(cdr x)))
82                    (#t #f)))))
83
84 (define (expand-let* bindings body)
85   (cond ((null? bindings)
86          `((lambda () ,@body)))
87         (#t `((lambda (,(caar bindings))
88                 ,(expand-let* (cdr bindings) body))
89               ,@(cdar bindings)))))
90
91 (define-macro (let* bindings . body)
92   (expand-let* bindings body))
93
94 (define (equal? a b) ;; FIXME: only 2 arg
95   (cond ((and (null? a) (null? b)) #t)
96         ((and (pair? a) (pair? b))
97          (and (equal? (car a) (car b))
98               (equal? (cdr a) (cdr b))))
99         ((and (string? a) (string? b))
100          (eq? (string->symbol a) (string->symbol b)))
101         ((and (vector? a) (vector? b))
102          (equal? (vector->list a) (vector->list b)))
103         (#t (eq? a b))))
104
105 (define (vector . rest) (list->vector rest))
106 (define (make-vector n . x)
107   (let ((fill (if (pair? x) (cdr x) *unspecified*)))
108     (list->vector (let loop ((n n))
109                     (if (= 0 n) '()
110                         (cons fill (loop (- n 1))))))))
111
112 (define (apply f args)
113   (eval (cons f args) (current-module)))
114
115 (define-macro (defined? x)
116   `(assq ,x (cddr (current-module))))
117
118 (define (procedure? p)
119   (cond ((builtin? p) #t)
120         ((and (pair? p) (eq? (car p) 'lambda)))
121         ((and (pair? p) (eq? (car p) '*closure*)))
122         (#t #f)))
123
124 (define (assq-set! alist key val)
125   (let ((entry (assq key alist)))
126     (cond (entry (set-cdr! entry val)
127                  alist)
128           (#t (cons (cons key val) alist)))))
129
130 (define (assq-ref alist key)
131   (let ((entry (assq key alist)))
132     (if entry (cdr entry)
133         #f)))
134
135 (define assv assq)
136
137 (define (memq x lst)
138   (cond ((null? lst) #f)
139         ((eq? x (car lst)) lst)
140         (#t (memq x (cdr lst)))))
141 (define memv memq)
142
143 (define (member x lst)
144   (cond ((null? lst) #f)
145         ((equal? x (car lst)) lst)
146         (#t (member x (cdr lst)))))
147
148 (define (map f l . r)
149   (cond ((null? l) '())
150         ((null? r) (cons (f (car l)) (map f (cdr l))))
151         ((null? (cdr r))
152          (cons (f (car l) (caar r)) (map f (cdr l) (cdar r))))))
153
154 (define (identity x) x)
155 (define (for-each f l . r)
156   (apply map (cons f (cons l r)))
157   *unspecified*)
158
159 (define (not x)
160   (cond (x #f)
161         (#t #t)))
162
163 (define (<= a b) ;; FIXME: only 2 arg
164   (or (< a b)
165       (= a b)))
166
167 (define (>= a b) ;; FIXME: only 2 arg
168   (or (> a b)
169       (= a b)))
170
171 (define (list? x)
172   (or (null? x)
173       (and (pair? x) (list? (cdr x)))))
174
175 (define (unspecified-bindings bindings params)
176   (cond ((null? bindings) params)
177         (#t (unspecified-bindings
178              (cdr bindings)
179              (append params (cons (cons (caar bindings) '(*unspecified*)) '()))))))
180
181 (define (letrec-setters bindings setters)
182   (cond ((null? bindings) setters)
183         (#t (letrec-setters (cdr bindings)
184                             (append setters
185                                     (cons (cons 'set! (car bindings)) '()))))))
186
187 (define-macro (letrec bindings . body)
188   `(let ,(unspecified-bindings bindings '())
189      ,@(letrec-setters bindings '())
190      ,@body))
191
192 (define gensym
193   (let ((counter 0))
194     (lambda (. rest)
195       (let ((value (number->string counter)))
196         (set! counter (+ counter 1))
197         (string->symbol (string-append "g" value))))))
198
199 (define else #t)
200
201 ;; srfi-1
202 (define (last-pair lst)
203   (let loop ((lst lst))
204     (if (or (null? lst) (null? (cdr lst))) lst
205         (loop (cdr lst)))))