383 lines
11 KiB
Scheme
383 lines
11 KiB
Scheme
;;; -*-scheme-*-
|
||
|
||
;;; GNU Mes --- Maxwell Equations of Software
|
||
;;; Copyright © 2016,2017,2018,2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
|
||
;;;
|
||
;;; This file is part of GNU Mes.
|
||
;;;
|
||
;;; GNU 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.
|
||
;;;
|
||
;;; GNU 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 GNU 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 . xr)
|
||
(if (and (pair? l)
|
||
(or (null? xr)
|
||
(pair? (car xr))))
|
||
(if (null? xr) (begin (f (car l)) (for-each f (cdr l)))
|
||
(if (null? (cdr xr)) (begin (f (car l) (caar xr)) (for-each f (cdr l) (cdar xr)))))))
|
||
|
||
(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 (read . port)
|
||
(if (null? port) (read-env (current-module))
|
||
(let* ((prev (set-current-input-port (car port)))
|
||
(result (read-env (current-module))))
|
||
result)))
|
||
|
||
(if (not (defined? 'peek-char))
|
||
(define (peek-char)
|
||
(integer->char (peek-byte))))
|
||
|
||
(if (not (defined? 'read-char))
|
||
(define (read-char)
|
||
(integer->char (read-byte))))
|
||
|
||
(if (not (defined? 'unread-char))
|
||
(define (unread-char c)
|
||
(integer->char (unread-byte (char->integer c)))))
|
||
|
||
(define (assq-set! alist key val)
|
||
(let ((entry (assq key alist)))
|
||
(if (not entry) (acons key val alist)
|
||
(let ((entry (set-cdr! entry val)))
|
||
alist))))
|
||
|
||
(define (assq-ref alist key)
|
||
(and alist
|
||
(let ((entry (assq key alist)))
|
||
(if entry (cdr entry)
|
||
#f))))
|
||
|
||
(define assv assq)
|
||
(define assv-ref assq-ref)
|
||
|
||
(define (assoc-ref alist key)
|
||
(and (pair? alist)
|
||
(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 memv memq)
|
||
|
||
(define (member x lst)
|
||
(if (null? lst) #f
|
||
(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 (iota n)
|
||
(if (<= n 0) '()
|
||
(append2 (iota (- n 1)) (list (- n 1)))))
|
||
|
||
(define (reverse lst)
|
||
(let loop ((lst lst) (r '()))
|
||
(if (null? lst) r
|
||
(loop (cdr lst) (cons (car lst) r)))))
|
||
|
||
(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 (vector-copy x)
|
||
(list->vector (vector->list x)))
|
||
|
||
|
||
;;; Strings/srfi-13
|
||
(define (make-string n . fill)
|
||
(list->string (apply make-list n fill)))
|
||
|
||
(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)
|
||
(let ((length (string-length string))
|
||
(prefix-length (string-length prefix)))
|
||
(and
|
||
(>= length prefix-length)
|
||
(equal? (substring string 0 prefix-length) prefix))))
|
||
|
||
(define (string-suffix? suffix string)
|
||
(let ((length (string-length string))
|
||
(suffix-length (string-length suffix)))
|
||
(and
|
||
(>= length suffix-length)
|
||
(equal? (substring string (- length suffix-length)) suffix))))
|
||
|
||
(define (string->number s . rest)
|
||
(if (string-prefix? "#x" s) (string->number (string-drop s 2) 16)
|
||
(let ((lst (string->list s)))
|
||
(and (pair? lst)
|
||
(let* ((radix (if (null? rest) 10 (car rest)))
|
||
(sign (if (and (pair? lst) (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))))
|
||
(cond ((and (>= i (char->integer #\0))
|
||
(<= i (char->integer #\9)))
|
||
(let ((d (char->integer #\0)))
|
||
(loop (cdr lst) (+ (* n radix) (- i d)))))
|
||
((and (= radix 16)
|
||
(>= i (char->integer #\a))
|
||
(<= i (char->integer #\f)))
|
||
(let ((d (char->integer #\a)))
|
||
(loop (cdr lst) (+ (* n radix) (- i (- d 10))))))
|
||
((and (= radix 16)
|
||
(>= i (char->integer #\A))
|
||
(<= i (char->integer #\F)))
|
||
(let ((d (char->integer #\A)))
|
||
(loop (cdr lst) (+ (* n radix) (- i (- d 10))))))
|
||
((= i (char->integer #\.)) ; minimal FLOAT support
|
||
(let ((fraction (cdr lst)))
|
||
(if (null? fraction) n
|
||
(let ((fraction ((compose string->number list->string) fraction)))
|
||
(and fraction n))))) ; FLOAT as integer
|
||
(else #f))))))))))
|
||
|
||
(define inexact->exact identity)
|
||
|
||
(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 (abs (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)
|
||
(string->symbol (keyword->string 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)))))))
|
||
|
||
(define (negate proc)
|
||
(lambda args
|
||
(not (apply proc args))))
|
||
|
||
(define ceil identity)
|
||
(define floor identity)
|
||
(define round identity)
|
||
(define inexact->exact identity)
|
||
(define exact->inexact identity)
|
||
|
||
(define (const . rest)
|
||
(lambda (. _)
|
||
(car rest)))
|