mes: assq-ref, assoc-ref: Support alist == #f.
[mes.git] / mes / module / mes / scm.mes
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 ;;; 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 core:error error)
64
65 (define (error who . rest)
66   (display "error:" (current-error-port))
67   (display who (current-error-port))
68   (display ":" (current-error-port))
69   (display rest (current-error-port))
70   (newline (current-error-port))
71   (display "exiting...\n" (current-error-port))
72   (core:error (if (symbol? who) who 'error) (cons who rest)))
73
74 (define (syntax-error message . rest)
75   (display "syntax-error:" (current-error-port))
76   (display message (current-error-port))
77   (display ":" (current-error-port))
78   (display rest (current-error-port))
79   (newline (current-error-port))
80   (core:error 'syntax-error (cons message rest)))
81
82 \f
83 (define integer? number?)
84
85 (if (not (defined? 'peek-char))
86     (define (peek-char)
87       (integer->char (peek-byte))))
88
89 (if (not (defined? 'read-char))
90     (define (read-char)
91       (integer->char (read-byte))))
92
93 (if (not (defined? 'unread-char))
94     (define (unread-char c)
95       (integer->char (unread-byte (char->integer c)))))
96
97 (define (assq-set! alist key val)
98   (let ((entry (assq key alist)))
99     (if (not entry) (acons key val alist)
100         (let ((entry (set-cdr! entry val)))
101           alist))))
102
103 (define (assq-ref alist key)
104   (and alist
105        (let ((entry (assq key alist)))
106          (if entry (cdr entry)
107              #f))))
108
109 (define assv assq)
110 (define assv-ref assq-ref)
111
112 (define (assoc-ref alist key)
113   (and (pair? alist)
114        (let ((entry (assoc key alist)))
115          (if entry (cdr entry)
116              #f))))
117
118 (define (assoc-set! alist key value)
119   (let ((entry (assoc key alist)))
120     (if (not entry) (acons key value alist)
121         (let ((entry (set-cdr! entry value)))
122           alist))))
123
124 (define memv memq)
125
126 (define (member x lst)
127   (if (null? lst) #f
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 (iota n)
158   (if (<= n 0) '()
159       (append2 (iota (- n 1)) (list (- n 1)))))
160
161 (define (reverse lst)
162   (let loop ((lst lst) (r '()))
163     (if (null? lst) r
164         (loop (cdr lst) (cons (car lst) r)))))
165
166 (define (filter pred lst)
167   (let loop ((lst lst))
168     (if (null? lst) '()
169         (if (pred (car lst))
170             (cons (car lst) (loop (cdr lst)))
171             (loop (cdr lst))))))
172
173 (define (delete x lst)
174   (filter (lambda (e) (not (equal? e x))) lst))
175
176 (define (delq x lst)
177   (filter (lambda (e) (not (eq? e x))) lst))
178
179 (define (compose proc . rest)
180   (if (null? rest) proc
181       (lambda args
182         (proc (apply (apply compose rest) args)))))
183
184 \f
185 ;; Vector
186 (define (vector . rest) (list->vector rest))
187 (define (make-vector n . x)
188   (if (null? x) (core: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 (make-string n . fill)
197   (list->string (apply make-list n fill)))
198
199 (define (string-set! s k v)
200   (list->string (list-set! (string->list s) k v)))
201
202 (define (substring s start . rest)
203   (let* ((end (and (pair? rest) (car rest)))
204          (lst (list-tail (string->list s) start)))
205     (list->string (if (not end) lst
206                       (list-head lst (- end start))))))
207
208 (define (string-prefix? prefix string)
209   (let ((length (string-length string))
210         (prefix-length (string-length prefix)))
211   (and
212    (>= length prefix-length)
213    (equal? (substring string 0 prefix-length) prefix))))
214
215 (define (string-suffix? suffix string)
216   (let ((length (string-length string))
217         (suffix-length (string-length suffix)))
218     (and
219      (>= length suffix-length)
220      (equal? (substring string (- length suffix-length)) suffix))))
221
222 (define (string->number s . rest)
223   (let ((lst (string->list s)))
224     (and (pair? lst)
225          (let* ((radix (if (null? rest) 10 (car rest)))
226                 (sign (if (and (pair? lst) (char=? (car lst) #\-)) -1 1))
227                 (lst (if (= sign -1) (cdr lst) lst)))
228            (let loop ((lst lst) (n 0))
229              (if (null? lst) (* sign n)
230                  (let ((i (char->integer (car lst))))
231                    (cond ((and (>= i (char->integer #\0))
232                                (<= i (char->integer #\9)))
233                           (let ((d (char->integer #\0)))
234                             (loop (cdr lst) (+ (* n radix) (- i d)))))
235                          ((and (= radix 16)
236                                (>= i (char->integer #\a))
237                                (<= i (char->integer #\f)))
238                           (let ((d (char->integer #\a)))
239                             (loop (cdr lst) (+ (* n radix) (- i (- d 10))))))
240                          ((and (= radix 16)
241                                (>= i (char->integer #\A))
242                                (<= i (char->integer #\F)))
243                           (let ((d (char->integer #\A)))
244                             (loop (cdr lst) (+ (* n radix) (- i (- d 10))))))
245                          ((= i (char->integer #\.)) ; minimal FLOAT support
246                           (let ((fraction (cdr lst)))
247                             (if (null? fraction) n
248                                 (let ((fraction ((compose string->number list->string) fraction)))
249                                   (and fraction n))))) ; FLOAT as integer
250                          (else #f)))))))))
251
252 (define inexact->exact identity)
253
254 (define (number->string n . rest)
255   (let* ((radix (if (null? rest) 10 (car rest)))
256          (sign (if (< n 0) '(#\-) '())))
257     (let loop ((n (abs n)) (lst '()))
258       (let* ((i (remainder n radix))
259              (lst (cons (integer->char (+ i (if (< i 10) (char->integer #\0)
260                                                 (- (char->integer #\a) 10)))) lst))
261              (n (quotient n radix)))
262         (if (= 0 n) (list->string (append sign lst))
263             (loop n lst))))))
264
265 \f
266 ;;; Symbols
267 (define (symbol-prefix? prefix symbol)
268   (string-prefix? (symbol->string prefix) (symbol->string symbol)))
269
270 (define (symbol-append . rest)
271   (string->symbol (apply string-append (map symbol->string rest))))
272
273 (define gensym
274   (let ((counter 0))
275     (lambda (. rest)
276       (let ((value (number->string counter)))
277         (set! counter (+ counter 1))
278         (string->symbol (string-append "g" value))))))
279
280 \f
281 ;;; Keywords
282 (define (keyword->symbol s)
283   (string->symbol (keyword->string s)))
284
285 \f
286 ;;; Characters
287 (define (char=? x y)
288   (and (char? x) (char? y)
289        (eq? x y)))
290
291 (define (char<? a b) (< (char->integer a) (char->integer b)))
292 (define (char>? a b) (> (char->integer a) (char->integer b)))
293 (define (char<=? a b) (<= (char->integer a) (char->integer b)))
294 (define (char>=? a b) (>= (char->integer a) (char->integer b)))
295
296 (define (char-alphabetic? x)
297   (and (char? x)
298        (let ((i (char->integer x)))
299         (or (and (>= i (char->integer #\A)) (<= i (char->integer #\Z)))
300             (and (>= i (char->integer #\a)) (<= i (char->integer #\z)))))))
301
302 (define (char-numeric? x)
303   (and (char? x)
304        (let ((i (char->integer x)))
305          (and (>= i (char->integer #\0)) (<= i (char->integer #\9))))))
306
307 \f
308 ;;; Math
309 (define quotient /)
310
311 (define (<= . rest)
312   (or (apply < rest)
313       (apply = rest)))
314
315 (define (>= . rest)
316   (or (apply > rest)
317       (apply = rest)))
318
319 (define (remainder x y)
320   (- x (* (quotient x y) y)))
321
322 (define (even? x)
323   (= 0 (remainder x 2)))
324
325 (define (odd? x)
326   (= 1 (remainder x 2)))
327
328 (define (negative? x)
329   (< x 0))
330
331 (define (positive? x)
332   (> x 0))
333
334 (define (zero? x)
335   (= x 0))
336
337 (define (1+ x)
338   (+ x 1))
339
340 (define (1- x)
341   (- x 1))
342
343 (define (abs x)
344   (if (>= x 0) x (- x)))
345
346 (define (expt x y)
347   (let loop ((s 1) (count y))
348     (if (= 0 count) s
349         (loop (* s x) (- count 1)))))
350
351 (define (max x . rest)
352   (if (null? rest) x
353       (let ((y (car rest)))
354         (let ((z (if (> x y) x y)))
355           (apply max (cons z (cdr rest)))))))
356
357 (define (min x . rest)
358   (if (null? rest) x
359       (let ((y (car rest)))
360         (let ((z (if (< x y) x y)))
361           (apply min (cons z (cdr rest)))))))
362
363 (define (negate proc)
364   (lambda args
365     (not (apply proc args))))
366
367 (define ceil identity)
368 (define floor identity)
369 (define round identity)
370 (define inexact->exact identity)
371 (define exact->inexact identity)
372
373 (define (const . rest)
374   (lambda (. _)
375     (car rest)))