349 lines
9.2 KiB
Scheme
349 lines
9.2 KiB
Scheme
;;; -*-scheme-*-
|
||
|
||
;;; Mes --- Maxwell Equations of Software
|
||
;;; Copyright © 2016,2017 Jan Nieuwenhuizen <janneke@gnu.org>
|
||
;;;
|
||
;;; This file is part of Mes.
|
||
;;;
|
||
;;; Mes is free software; you can redistribute it and/or modify it
|
||
;;; under the terms of the GNU General Public License as published by
|
||
;;; the Free Software Foundation; either version 3 of the License, or (at
|
||
;;; your option) any later version.
|
||
;;;
|
||
;;; Mes is distributed in the hope that it will be useful, but
|
||
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||
;;; GNU General Public License for more details.
|
||
;;;
|
||
;;; You should have received a copy of the GNU General Public License
|
||
;;; along with Mes. If not, see <http://www.gnu.org/licenses/>.
|
||
|
||
;;; Commentary:
|
||
|
||
;;; scm.mes is loaded after base, quasiquote and let. It provides
|
||
;;; basic Scheme functions bringing Mes close to basic RRS Scheme (no
|
||
;;; labels, processes, fluids or throw/catch).
|
||
|
||
;;; Code:
|
||
|
||
(mes-use-module (mes let))
|
||
|
||
(define (cadddr x) (car (cdddr x)))
|
||
|
||
(define-macro (case val . args)
|
||
(if (null? args) #f
|
||
(let ((clause (car args)))
|
||
(let ((pred (car clause)))
|
||
(let ((body (cdr clause)))
|
||
(if (pair? pred) `(if ,(if (null? (cdr pred))
|
||
`(eq? ,val ',(car pred))
|
||
`(member ,val ',pred))
|
||
(begin ,@body)
|
||
(case ,val ,@(cdr args)))
|
||
`(begin ,@body)))))))
|
||
|
||
(define-macro (when expr . body)
|
||
`(if ,expr
|
||
((lambda () ,@body))))
|
||
|
||
(define-macro (unless expr . body)
|
||
`(if (not ,expr)
|
||
((lambda () ,@body))))
|
||
|
||
(define-macro (do init test . body)
|
||
`(let loop ((,(caar init) ,(cadar init)))
|
||
(when (not ,@test)
|
||
,@body
|
||
(loop ,@(cddar init)))))
|
||
|
||
(define (for-each f l . r)
|
||
(if (pair? l) (if (null? r) (begin (f (car l)) (for-each f (cdr l)))
|
||
(if (null? (cdr r)) (begin (f (car l) (caar r)) (for-each f (cdr l) (cdar r)))))))
|
||
|
||
(define core:error error)
|
||
|
||
(define (error who . rest)
|
||
(display "error:" (current-error-port))
|
||
(display who (current-error-port))
|
||
(display ":" (current-error-port))
|
||
(display rest (current-error-port))
|
||
(newline (current-error-port))
|
||
(display "exiting...\n" (current-error-port))
|
||
(core:error (if (symbol? who) who 'error) (cons who rest)))
|
||
|
||
(define (syntax-error message . rest)
|
||
(display "syntax-error:" (current-error-port))
|
||
(display message (current-error-port))
|
||
(display ":" (current-error-port))
|
||
(display rest (current-error-port))
|
||
(newline (current-error-port))
|
||
(core:error 'syntax-error (cons message rest)))
|
||
|
||
|
||
(define integer? number?)
|
||
|
||
(define (eof-object? x)
|
||
(or (and (number? x) (= x -1))
|
||
(and (char? x) (eof-object? (char->integer x)))))
|
||
|
||
(define (peek-char)
|
||
(integer->char (peek-byte)))
|
||
|
||
(define (read-char)
|
||
(integer->char (read-byte)))
|
||
|
||
(define (unread-char c)
|
||
(unread-byte (char->integer c))
|
||
c)
|
||
|
||
(define (assq-set! alist key val)
|
||
(let ((entry (assq key alist)))
|
||
(cond (entry (set-cdr! entry val)
|
||
alist)
|
||
(#t (cons (cons key val) alist)))))
|
||
|
||
(define (assq-ref alist key)
|
||
(let ((entry (assq key alist)))
|
||
(if entry (cdr entry)
|
||
#f)))
|
||
|
||
(define assv assq)
|
||
(define assv-ref assq-ref)
|
||
|
||
(define (assoc key alist)
|
||
(if (null? alist) #f ;; IF
|
||
(if (equal? key (caar alist)) (car alist)
|
||
(assoc key (cdr alist)))))
|
||
|
||
(define (assoc-ref alist key)
|
||
(let ((entry (assoc key alist)))
|
||
(if entry (cdr entry)
|
||
#f)))
|
||
|
||
(define (assoc-set! alist key value)
|
||
(let ((entry (assoc key alist)))
|
||
(if (not entry) (acons key value alist)
|
||
(let ((entry (set-cdr! entry value)))
|
||
alist))))
|
||
|
||
(define (memq x lst)
|
||
(if (null? lst) #f ;; IF
|
||
(if (eq? x (car lst)) lst
|
||
(memq x (cdr lst)))))
|
||
(define memv memq)
|
||
|
||
(define (member x lst)
|
||
(if (null? lst) #f ;; IF
|
||
(if (equal? x (car lst)) lst
|
||
(member x (cdr lst)))))
|
||
|
||
|
||
;;; Lists
|
||
(define (make-list n . x)
|
||
(let ((fill (if (pair? x) (car x) *unspecified*)))
|
||
(let loop ((n n))
|
||
(if (= 0 n) '()
|
||
(cons fill (loop (- n 1)))))))
|
||
|
||
(define (list-ref lst k)
|
||
(let loop ((lst lst) (k k))
|
||
(if (= 0 k) (car lst)
|
||
(loop (cdr lst) (- k 1)))))
|
||
|
||
(define (list-set! lst k v)
|
||
(let loop ((lst lst) (k k))
|
||
(if (= 0 k) (set-car! lst v)
|
||
(loop (cdr lst) (- k 1)))))
|
||
|
||
(define (list-head x n)
|
||
(if (= 0 n) '()
|
||
(cons (car x) (list-head (cdr x) (- n 1)))))
|
||
|
||
(define (list-tail x n)
|
||
(if (= 0 n) x
|
||
(list-tail (cdr x) (- n 1))))
|
||
|
||
(define (last-pair lst)
|
||
(let loop ((lst lst))
|
||
(if (or (null? lst) (null? (cdr lst))) lst
|
||
(loop (cdr lst)))))
|
||
|
||
(define (iota n)
|
||
(if (<= n 0) '()
|
||
(append2 (iota (- n 1)) (list (- n 1)))))
|
||
|
||
(define (reverse lst)
|
||
(if (null? lst) '()
|
||
(append (reverse (cdr lst)) (cons (car lst) '()))))
|
||
|
||
(define (filter pred lst)
|
||
(let loop ((lst lst))
|
||
(if (null? lst) '()
|
||
(if (pred (car lst))
|
||
(cons (car lst) (loop (cdr lst)))
|
||
(loop (cdr lst))))))
|
||
|
||
(define (delete x lst)
|
||
(filter (lambda (e) (not (equal? e x))) lst))
|
||
|
||
(define (delq x lst)
|
||
(filter (lambda (e) (not (eq? e x))) lst))
|
||
|
||
(define (compose proc . rest)
|
||
(if (null? rest) proc
|
||
(lambda args
|
||
(proc (apply (apply compose rest) args)))))
|
||
|
||
|
||
;; Vector
|
||
(define (vector . rest) (list->vector rest))
|
||
(define c:make-vector make-vector)
|
||
(define (make-vector n . x)
|
||
(if (null? x) (c:make-vector n)
|
||
(list->vector (apply make-list (cons n x)))))
|
||
|
||
(define (vector-copy x)
|
||
(list->vector (vector->list x)))
|
||
|
||
|
||
;;; Strings/srfi-13
|
||
(define (string-length s)
|
||
(length (string->list s)))
|
||
|
||
(define (string-ref s k)
|
||
(list-ref (string->list s) k))
|
||
|
||
(define (string-set! s k v)
|
||
(list->string (list-set! (string->list s) k v)))
|
||
|
||
(define (substring s start . rest)
|
||
(let* ((end (and (pair? rest) (car rest)))
|
||
(lst (list-tail (string->list s) start)))
|
||
(list->string (if (not end) lst
|
||
(list-head lst (- end start))))))
|
||
|
||
(define (string-prefix? prefix string)
|
||
(and
|
||
(>= (string-length string) (string-length prefix))
|
||
(equal? (substring string 0 (string-length prefix)) prefix)))
|
||
|
||
(define (string->number s . rest)
|
||
(let* ((radix (if (null? rest) 10 (car rest)))
|
||
(lst (string->list s))
|
||
(sign (if (char=? (car lst) #\-) -1 1))
|
||
(lst (if (= sign -1) (cdr lst) lst)))
|
||
(let loop ((lst lst) (n 0))
|
||
(if (null? lst) (* sign n)
|
||
(let ((i (char->integer (car lst))))
|
||
(loop (cdr lst) (+ (* n radix) (- i (if (<= i (char->integer #\9)) (char->integer #\0)
|
||
(- (char->integer #\a) 10))))))))))
|
||
|
||
(define (number->string n . rest)
|
||
(let* ((radix (if (null? rest) 10 (car rest)))
|
||
(sign (if (< n 0) '(#\-) '())))
|
||
(let loop ((n (abs n)) (lst '()))
|
||
(let* ((i (remainder n radix))
|
||
(lst (cons (integer->char (+ i (if (<= i 10) (char->integer #\0)
|
||
(- (char->integer #\a) 10)))) lst))
|
||
(n (quotient n radix)))
|
||
(if (= 0 n) (list->string (append sign lst))
|
||
(loop n lst))))))
|
||
|
||
|
||
;;; Symbols
|
||
(define (symbol-prefix? prefix symbol)
|
||
(string-prefix? (symbol->string prefix) (symbol->string symbol)))
|
||
|
||
(define (symbol-append . rest)
|
||
(string->symbol (apply string-append (map symbol->string rest))))
|
||
|
||
(define gensym
|
||
(let ((counter 0))
|
||
(lambda (. rest)
|
||
(let ((value (number->string counter)))
|
||
(set! counter (+ counter 1))
|
||
(string->symbol (string-append "g" value))))))
|
||
|
||
|
||
;;; Keywords
|
||
(define (keyword->symbol s)
|
||
(list->symbol (keyword->list s)))
|
||
|
||
|
||
;;; Characters
|
||
(define (char=? x y)
|
||
(and (char? x) (char? y)
|
||
(eq? x y)))
|
||
|
||
(define (char<? a b) (< (char->integer a) (char->integer b)))
|
||
(define (char>? a b) (> (char->integer a) (char->integer b)))
|
||
(define (char<=? a b) (<= (char->integer a) (char->integer b)))
|
||
(define (char>=? a b) (>= (char->integer a) (char->integer b)))
|
||
|
||
(define (char-alphabetic? x)
|
||
(and (char? x)
|
||
(let ((i (char->integer x)))
|
||
(or (and (>= i (char->integer #\A)) (<= i (char->integer #\Z)))
|
||
(and (>= i (char->integer #\a)) (<= i (char->integer #\z)))))))
|
||
|
||
(define (char-numeric? x)
|
||
(and (char? x)
|
||
(let ((i (char->integer x)))
|
||
(and (>= i (char->integer #\0)) (<= i (char->integer #\9))))))
|
||
|
||
|
||
;;; Math
|
||
(define quotient /)
|
||
|
||
(define (<= . rest)
|
||
(or (apply < rest)
|
||
(apply = rest)))
|
||
|
||
(define (>= . rest)
|
||
(or (apply > rest)
|
||
(apply = rest)))
|
||
|
||
(define (remainder x y)
|
||
(- x (* (quotient x y) y)))
|
||
|
||
(define (even? x)
|
||
(= 0 (remainder x 2)))
|
||
|
||
(define (odd? x)
|
||
(= 1 (remainder x 2)))
|
||
|
||
(define (negative? x)
|
||
(< x 0))
|
||
|
||
(define (positive? x)
|
||
(> x 0))
|
||
|
||
(define (zero? x)
|
||
(= x 0))
|
||
|
||
(define (1+ x)
|
||
(+ x 1))
|
||
|
||
(define (1- x)
|
||
(- x 1))
|
||
|
||
(define (abs x)
|
||
(if (>= x 0) x (- x)))
|
||
|
||
(define (expt x y)
|
||
(let loop ((s 1) (count y))
|
||
(if (= 0 count) s
|
||
(loop (* s x) (- count 1)))))
|
||
|
||
(define (max x . rest)
|
||
(if (null? rest) x
|
||
(let ((y (car rest)))
|
||
(let ((z (if (> x y) x y)))
|
||
(apply max (cons z (cdr rest)))))))
|
||
|
||
(define (min x . rest)
|
||
(if (null? rest) x
|
||
(let ((y (car rest)))
|
||
(let ((z (if (< x y) x y)))
|
||
(apply min (cons z (cdr rest)))))))
|