229 lines
5.8 KiB
Scheme
Executable file
229 lines
5.8 KiB
Scheme
Executable file
;;; -*-scheme-*-
|
|
|
|
;;; Mes --- Maxwell Equations of Software
|
|
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
|
|
;;;
|
|
;;; scm.mes: 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/>.
|
|
|
|
(define (list . rest) rest)
|
|
|
|
(define-macro (case val . args)
|
|
(if (null? args)
|
|
#f
|
|
(let* ((clause (car args))
|
|
(pred (car clause))
|
|
(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 (do init test . body)
|
|
`(let loop ((,(caar init) ,(cadar init)))
|
|
(when (not ,@test)
|
|
,@body
|
|
(loop ,@(cddar init)))))
|
|
|
|
(define (procedure? p)
|
|
(cond ((builtin? p) #t)
|
|
((and (pair? p) (eq? (car p) 'lambda)))
|
|
((and (pair? p) (eq? (car p) '*closure*)))
|
|
(#t #f)))
|
|
|
|
(define integer? number?)
|
|
|
|
(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 (vector . rest) (list->vector rest))
|
|
(define (make-vector n . x)
|
|
(list->vector (apply make-list (cons n x))))
|
|
|
|
(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)
|
|
(cond ((null? alist) #f) ;; COND
|
|
((equal? key (caar alist)) (car alist))
|
|
(#t (assoc key (cdr alist)))))
|
|
|
|
(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 (memq x lst)
|
|
(cond ((null? lst) #f) ;; COND
|
|
((eq? x (car lst)) lst)
|
|
(#t (memq x (cdr lst)))))
|
|
|
|
(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)
|
|
(cond ((null? lst) #f) ;; COND
|
|
((equal? x (car lst)) lst)
|
|
(#t (member x (cdr lst)))))
|
|
|
|
(define (member x lst)
|
|
(if (null? lst) #f ;; IF
|
|
(if (equal? x (car lst)) lst
|
|
(member x (cdr lst)))))
|
|
|
|
(define (for-each f l . r)
|
|
(cond ((null? l) '()) ;; COND
|
|
((null? r) (f (car l)) (for-each f (cdr l)))
|
|
((null? (cdr r))
|
|
(for-each f (cdr l) (cdar r)))))
|
|
|
|
(define (for-each f l . r)
|
|
(if (null? l) '() ;; IF
|
|
(if (null? r) (begin (f (car l)) (for-each f (cdr l)))
|
|
(if (null? (cdr r))
|
|
(for-each f (cdr l) (cdar r))))))
|
|
|
|
(define (<= . rest)
|
|
(or (apply < rest)
|
|
(apply = rest)))
|
|
|
|
(define (>= . rest)
|
|
(or (apply > rest)
|
|
(apply = rest)))
|
|
|
|
;; (define (>= . rest)
|
|
;; (if (apply > rest) #t
|
|
;; (if (apply = rest) #t
|
|
;; #f)))
|
|
|
|
(define quotient /)
|
|
|
|
(define (remainder x y)
|
|
(- x (* (/ x y) y)))
|
|
|
|
(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))
|
|
(z (if (> x y) x y)))
|
|
(apply max (cons z (cdr rest))))))
|
|
|
|
(define (min x . rest)
|
|
(if (null? rest) x
|
|
(let* ((y (car rest))
|
|
(z (if (< x y) x y)))
|
|
(apply min (cons z (cdr rest))))))
|
|
|
|
(define (list? x)
|
|
(or (null? x)
|
|
(and (pair? x) (list? (cdr x)))))
|
|
|
|
(define gensym
|
|
(let ((counter 0))
|
|
(lambda (. rest)
|
|
(let ((value (number->string counter)))
|
|
(set! counter (+ counter 1))
|
|
(string->symbol (string-append "g" value))))))
|
|
|
|
(define else #t)
|
|
|
|
(define (error who . rest)
|
|
(display "error:")
|
|
(display who)
|
|
(display ":")
|
|
(display rest)
|
|
(display newline))
|
|
|
|
(define (syntax-error message . rest)
|
|
(display "syntax-error:")
|
|
(display message)
|
|
(display ":")
|
|
(display rest)
|
|
(newline))
|
|
|
|
(define (list-ref lst k)
|
|
(let loop ((lst lst) (k k))
|
|
(if (= 0 k) (car lst)
|
|
(loop (cdr lst) (- k 1)))))
|
|
|
|
;; srfi-1
|
|
(define (last-pair lst)
|
|
(let loop ((lst lst))
|
|
(if (or (null? lst) (null? (cdr lst))) lst
|
|
(loop (cdr lst)))))
|
|
|
|
(define (reverse lst)
|
|
(if (null? lst) '()
|
|
(append (reverse (cdr lst)) (cons (car lst) '()))))
|
|
|
|
(define (eof-object? x)
|
|
(or (and (number? x) (= x -1))
|
|
(and (char? x) (eof-object? (char->integer x)))))
|
|
|
|
(define (char=? x y)
|
|
(and (char? x) (char? y)
|
|
(eq? x y)))
|
|
|
|
(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))))))
|
|
|
|
(define (current-input-port) #f)
|
|
(define (port-filename port) "<stdin>")
|
|
(define (port-line port) 0)
|
|
(define (port-column port) 0)
|
|
(define (ftell port) 0)
|
|
(define (false-if-exception x) x)
|