Add list-set!, string-set!
[mes.git] / module / mes / scm.mes
1 ;;; -*-scheme-*-
2
3 ;;; Mes --- Maxwell Equations of Software
4 ;;; Copyright © 2016 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 ;;; scm.mes is loaded after base, quasiquote and let.  It provides
24 ;;; basic Scheme functions bringing Mes close to basic RRS Scheme (no
25 ;;; labels, processes, fluids or throw/catch).
26
27 ;;; Code:
28
29 (mes-use-module (mes let))
30
31 (define (cadddr x) (car (cdddr x)))
32
33 (define-macro (case val . args)
34   (if (null? args) #f
35       (let ((clause (car args)))
36         (let ((pred (car clause)))
37           (let ((body (cdr clause)))
38            (if (pair? pred) `(if ,(if (null? (cdr pred))
39                                       `(eq? ,val ',(car pred))
40                                       `(member ,val ',pred))
41                                  (begin ,@body)
42                                  (case ,val ,@(cdr args)))
43                `(begin ,@body)))))))
44
45 (define-macro (when expr . body)
46   `(if ,expr
47        ((lambda () ,@body))))
48
49 (define-macro (unless expr . body)
50   `(if (not ,expr)
51        ((lambda () ,@body))))
52
53 (define-macro (do init test . body)
54   `(let loop ((,(caar init) ,(cadar init)))
55      (when (not ,@test)
56        ,@body
57        (loop ,@(cddar init)))))
58
59 (define (for-each f l . r)
60   (if (pair? l) (if (null? r) (begin (f (car l)) (for-each f (cdr l)))
61                     (if (null? (cdr r)) (begin (f (car l) (caar r)) (for-each f (cdr l) (cdar r)))))))
62
63 (define (error who . rest)
64   (display "error:" (current-error-port))
65   (display who (current-error-port))
66   (display ":" (current-error-port))
67   (display rest (current-error-port))
68   (newline (current-error-port))
69   (display "exiting...\n" (current-error-port))
70   (exit 1))
71
72 (define (syntax-error message . rest)
73   (display "syntax-error:" (current-error-port))
74   (display message (current-error-port))
75   (display ":" (current-error-port))
76   (display rest (current-error-port))
77   (newline (current-error-port)))
78
79 \f
80 (define integer? number?)
81
82 (define (eof-object? x)
83   (or (and (number? x) (= x -1))
84       (and (char? x) (eof-object? (char->integer x)))))
85
86 (define (peek-char)
87   (integer->char (peek-byte)))
88
89 (define (read-char)
90   (integer->char (read-byte)))
91
92 (define (unread-char c)
93   (unread-byte (char->integer c))
94   c)
95
96 (define (assq-set! alist key val)
97   (let ((entry (assq key alist)))
98     (cond (entry (set-cdr! entry val)
99                  alist)
100           (#t (cons (cons key val) alist)))))
101
102 (define (assq-ref alist key)
103   (let ((entry (assq key alist)))
104     (if entry (cdr entry)
105         #f)))
106
107 (define assv assq)
108 (define assv-ref assq-ref)
109
110 (define (assoc key alist)
111   (if (null? alist) #f ;; IF
112       (if (equal? key (caar alist)) (car alist)
113           (assoc key (cdr alist)))))
114
115 (define (assoc-ref alist key)
116   (let ((entry (assoc key alist)))
117     (if entry (cdr entry)
118         #f)))
119
120 (define (memq x lst)
121   (if (null? lst) #f ;; IF
122       (if (eq? x (car lst)) lst
123           (memq x (cdr lst)))))
124 (define memv memq)
125
126 (define (member x lst)
127   (if (null? lst) #f ;; IF
128       (if (equal? x (car lst)) lst
129           (member x (cdr lst)))))
130
131 \f
132 ;;; Lists
133 (define (make-list n . x)
134   (let ((fill (if (pair? x) (car x) *unspecified*)))
135     (let loop ((n n))
136       (if (= 0 n) '()
137           (cons fill (loop (- n 1)))))))
138
139 (define (list-ref lst k)
140   (let loop ((lst lst) (k k))
141     (if (= 0 k) (car lst)
142         (loop (cdr lst) (- k 1)))))
143
144 (define (list-set! lst k v)
145   (let loop ((lst lst) (k k))
146     (if (= 0 k) (set-car! lst v)
147         (loop (cdr lst) (- k 1)))))
148
149 (define (list-head x n)
150   (if (= 0 n) '()
151       (cons (car x) (list-head (cdr x) (- n 1)))))
152
153 (define (list-tail x n)
154   (if (= 0 n) x
155       (list-tail (cdr x) (- n 1))))
156
157 (define (last-pair lst)
158   (let loop ((lst lst))
159     (if (or (null? lst) (null? (cdr lst))) lst
160         (loop (cdr lst)))))
161
162 (define (iota n)
163   (if (<= n 0) '()
164       (append2 (iota (- n 1)) (list (- n 1)))))
165
166 (define (reverse lst)
167   (if (null? lst) '()
168       (append (reverse (cdr lst)) (cons (car lst) '()))))
169
170 (define (filter pred lst)
171   (let loop ((lst lst))
172     (if (null? lst) '()
173         (if (pred (car lst))
174             (cons (car lst) (loop (cdr lst)))
175             (loop (cdr lst))))))
176
177 (define (delete x lst)
178   (filter (lambda (e) (not (equal? e x))) lst))
179
180 (define (delq x lst)
181   (filter (lambda (e) (not (eq? e x))) lst))
182
183 \f
184 ;; Vector
185 (define (vector . rest) (list->vector rest))
186 (define c:make-vector make-vector)
187 (define (make-vector n . x)
188   (if (null? x) (c:make-vector n)
189       (list->vector (apply make-list (cons n x)))))
190
191 (define (vector-copy x)
192   (list->vector (vector->list x)))
193
194 \f
195 ;;; Strings/srfi-13
196 (define (string-length s)
197   (length (string->list s)))
198
199 (define (string-ref s k)
200   (list-ref (string->list s) k))
201
202 (define (string-set! s k v)
203   (list->string (list-set! (string->list s) k v)))
204
205 (define (substring s start . rest)
206   (let* ((end (and (pair? rest) (car rest)))
207          (lst (list-tail (string->list s) start)))
208     (list->string (if (not end) lst
209                       (list-head lst (- end start))))))
210
211 (define (string-prefix? prefix string)
212   (and
213    (>= (string-length string) (string-length prefix))
214    (equal? (substring string 0 (string-length prefix)) prefix)))
215
216 (define (string->number s . radix)
217   (if (and (pair? radix) (not (= (car radix) 10))) '*STRING->NUMBER:RADIX-NOT-SUPPORTED
218       (let* ((lst (string->list s))
219              (sign (if (char=? (car lst) #\-) -1 1))
220              (lst (if (= sign -1) (cdr lst) lst)))
221         (let loop ((lst lst) (n 0))
222           (if (null? lst) (* sign n)
223               (loop (cdr lst) (+ (* n 10) (- (char->integer (car lst)) (char->integer #\0)))))))))
224
225 (define (number->string n)
226   (let ((sign (if (< n 0) '(#\-) '())))
227     (let loop ((n (abs n)) (lst '()))
228       (let* ((lst (cons (integer->char (+ (remainder n 10) (char->integer #\0))) lst))
229              (n (quotient n 10)))
230         (if (= 0 n) (list->string (append sign lst))
231             (loop n lst))))))
232
233 \f
234 ;;; Symbols
235 (define (symbol-prefix? prefix symbol)
236   (string-prefix? (symbol->string prefix) (symbol->string symbol)))
237
238 (define (symbol-append . rest)
239   (string->symbol (apply string-append (map symbol->string rest))))
240
241 (define gensym
242   (let ((counter 0))
243     (lambda (. rest)
244       (let ((value (number->string counter)))
245         (set! counter (+ counter 1))
246         (string->symbol (string-append "g" value))))))
247
248 \f
249 ;;; Keywords
250 (define (keyword->symbol s)
251   (list->symbol (keyword->list s)))
252
253 \f
254 ;;; Characters
255 (define (char=? x y)
256   (and (char? x) (char? y)
257        (eq? x y)))
258
259 (define (char<? a b) (< (char->integer a) (char->integer b)))
260 (define (char>? a b) (> (char->integer a) (char->integer b)))
261 (define (char<=? a b) (<= (char->integer a) (char->integer b)))
262 (define (char>=? a b) (>= (char->integer a) (char->integer b)))
263
264 (define (char-alphabetic? x)
265   (and (char? x)
266        (let ((i (char->integer x)))
267         (or (and (>= i (char->integer #\A)) (<= i (char->integer #\Z)))
268             (and (>= i (char->integer #\a)) (<= i (char->integer #\z)))))))
269
270 (define (char-numeric? x)
271   (and (char? x)
272        (let ((i (char->integer x)))
273          (and (>= i (char->integer #\0)) (<= i (char->integer #\9))))))
274
275 \f
276 ;;; Math
277 (define (<= . rest)
278   (or (apply < rest)
279       (apply = rest)))
280
281 (define (>= . rest)
282   (or (apply > rest)
283       (apply = rest)))
284
285 (define (remainder x y)
286   (- x (* (quotient x y) y)))
287
288 (define (even? x)
289   (= 0 (remainder x 2)))
290
291 (define (odd? x)
292   (= 1 (remainder x 2)))
293
294 (define (negative? x)
295   (< x 0))
296
297 (define (positive? x)
298   (> x 0))
299
300 (define (zero? x)
301   (= x 0))
302
303 (define (1+ x)
304   (+ x 1))
305
306 (define (1- x)
307   (- x 1))
308
309 (define (abs x)
310   (if (>= x 0) x (- x)))
311
312 (define (expt x y)
313   (let loop ((s 1) (count y))
314     (if (= 0 count) s
315         (loop (* s x) (- count 1)))))
316
317 (define (max x . rest)
318   (if (null? rest) x
319       (let ((y (car rest)))
320         (let ((z (if (> x y) x y)))
321           (apply max (cons z (cdr rest)))))))
322
323 (define (min x . rest)
324   (if (null? rest) x
325       (let ((y (car rest)))
326         (let ((z (if (< x y) x y)))
327           (apply min (cons z (cdr rest)))))))