mes/scm.mes

276 lines
7.5 KiB
Plaintext
Raw Normal View History

;;; -*-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/>.
;; The Maxwell Equations of Software -- John McCarthy page 13
;; http://www.softwarepreservation.org/projects/LISP/book/LISP%201.5%20Programmers%20Manual.pdf
(define-macro (if expr then . else)
`(cond
(,expr ,then)
(#t (cond (,(pair? else) ((lambda () ,@else)))))))
(define-macro (when expr . body)
`(if ,expr
((lambda () ,@body))))
(define (list . rest) rest)
(define (split-params bindings params)
2016-07-09 21:12:25 +00:00
(cond ((null? bindings) params)
(#t (split-params (cdr bindings)
(append params (cons (caar bindings) '()))))))
(define (split-values bindings values)
2016-07-09 21:12:25 +00:00
(cond ((null? bindings) values)
(#t (split-values (cdr bindings)
(append values (cdar bindings) '())))))
2016-07-16 17:10:04 +00:00
(define-macro (simple-let bindings rest)
`((lambda ,(split-params bindings '()) ,@rest)
2016-07-16 15:57:19 +00:00
,@(split-values bindings '())))
2016-07-09 18:12:49 +00:00
(define-macro (let-loop label bindings . rest)
2016-07-17 20:15:31 +00:00
`(let ((,label *unspecified*))
(let ((,label (lambda ,(split-params bindings '()) ,@rest)))
(,label ,@(split-values bindings '())))))
2016-07-16 17:10:04 +00:00
(define-macro (let-loop label bindings rest)
`((lambda (,label)
(set! ,label (lambda ,(split-params bindings '()) ,@rest))
(,label ,@(split-values bindings '())))
*unspecified*))
2016-07-16 17:10:04 +00:00
(define-macro (let bindings-or-label . rest)
`(cond (,(symbol? bindings-or-label)
(let-loop ,bindings-or-label ,(car rest) ,(cdr rest)))
(#t (simple-let ,bindings-or-label ,rest))))
2016-07-16 17:10:04 +00:00
2016-07-24 15:03:28 +00:00
(define-macro (do init test . body)
`(let loop ((,(caar init) ,(cadar init)))
(when (not ,@test)
,@body
(loop ,@(cddar init)))))
(define-macro (or2 x y)
`(cond (,x ,x) (#t ,y)))
(define-macro (and2 x y)
`(cond (,x ,y) (#t #f)))
(define-macro (or . x)
(cond
((null? x) #f)
((null? (cdr x)) (car x))
(#t `(cond (,(car x))
(#t (or ,@(cdr x)))))))
(define-macro (and . x)
(cond ((null? x) #t)
((null? (cdr x)) (car x))
(#t `(cond (,(car x) (and ,@(cdr x)))
(#t #f)))))
2016-07-09 18:12:49 +00:00
(define (expand-let* bindings body)
2016-07-09 21:12:25 +00:00
(cond ((null? bindings)
2016-07-16 15:57:19 +00:00
`((lambda () ,@body)))
(#t `((lambda (,(caar bindings))
,(expand-let* (cdr bindings) body))
,@(cdar bindings)))))
2016-07-09 18:12:49 +00:00
(define-macro (let* bindings . body)
(expand-let* bindings body))
2016-07-09 20:01:13 +00:00
(define (equal? a b) ;; FIXME: only 2 arg
(cond ((and (null? a) (null? b)) #t)
((and (pair? a) (pair? b))
(and (equal? (car a) (car b))
(equal? (cdr a) (cdr b))))
((and (string? a) (string? b))
(eq? (string->symbol a) (string->symbol b)))
((and (vector? a) (vector? b))
(equal? (vector->list a) (vector->list b)))
(#t (eq? a b))))
(define (vector . rest) (list->vector rest))
2016-07-23 12:39:33 +00:00
(define (make-vector n . x)
2016-07-24 12:10:18 +00:00
(let ((fill (if (pair? x) (car x) *unspecified*)))
2016-07-23 12:39:33 +00:00
(list->vector (let loop ((n n))
(if (= 0 n) '()
(cons fill (loop (- n 1))))))))
2016-07-23 10:54:34 +00:00
(define-macro (defined? x)
`(assq ,x (cddr (current-module))))
(define (procedure? p)
(cond ((builtin? p) #t)
((and (pair? p) (eq? (car p) 'lambda)))
((and (pair? p) (eq? (car p) '*closure*)))
(#t #f)))
2016-07-24 11:27:05 +00:00
(define integer? number?)
2016-07-22 23:38:25 +00:00
(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)
2016-07-22 23:38:25 +00:00
2016-07-24 10:08:21 +00:00
(define (assoc key alist)
(cond ((null? alist) #f)
((equal? key (caar alist)) (car alist))
(#t (assoc key (cdr alist)))))
(define (memq x lst)
(cond ((null? lst) #f)
((eq? x (car lst)) lst)
(#t (memq x (cdr lst)))))
(define memv memq)
(define (member x lst)
(cond ((null? lst) #f)
((equal? x (car lst)) lst)
(#t (member x (cdr lst)))))
2016-07-09 20:01:13 +00:00
(define (map f l . r)
2016-07-09 21:12:25 +00:00
(cond ((null? l) '())
((null? r) (cons (f (car l)) (map f (cdr l))))
((null? (cdr r))
2016-07-09 20:05:07 +00:00
(cons (f (car l) (caar r)) (map f (cdr l) (cdar r))))))
2016-07-10 11:04:10 +00:00
2016-07-17 20:35:00 +00:00
(define (identity x) x)
(define (for-each f l . r)
2016-07-24 10:40:44 +00:00
(cond ((null? l) '())
((null? r) (f (car l)) (for-each f (cdr l)))
((null? (cdr r))
(for-each f (cdr l) (cdar r)))))
2016-07-17 20:35:00 +00:00
2016-07-10 11:04:10 +00:00
(define (not x)
(cond (x #f)
(#t #t)))
2016-07-17 10:56:31 +00:00
2016-07-24 14:29:38 +00:00
(define (<= . rest)
(or (apply < rest)
(apply = rest)))
2016-07-17 10:56:31 +00:00
2016-07-24 14:29:38 +00:00
(define (>= . rest)
(or (apply > rest)
(apply = rest)))
2016-07-17 10:56:31 +00:00
2016-07-24 13:25:16 +00:00
(define quotient /)
2016-07-24 15:11:49 +00:00
(define (remainder x y)
(- x (* (/ x y) y)))
2016-07-24 15:16:55 +00:00
(define (expt x y)
(let loop ((s 1) (count y))
(if (= 0 count) s
(loop (* s x) (- count 1)))))
2016-07-24 14:34:54 +00:00
(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))))))
2016-07-17 10:56:31 +00:00
(define (list? x)
(or (null? x)
(and (pair? x) (list? (cdr x)))))
2016-07-10 11:04:10 +00:00
2016-07-10 11:47:56 +00:00
(define (unspecified-bindings bindings params)
(cond ((null? bindings) params)
(#t (unspecified-bindings
(cdr bindings)
(append params (cons (cons (caar bindings) '(*unspecified*)) '()))))))
(define (letrec-setters bindings setters)
(cond ((null? bindings) setters)
(#t (letrec-setters (cdr bindings)
(append setters
(cons (cons 'set! (car bindings)) '()))))))
(define-macro (letrec bindings . body)
2016-07-16 15:57:19 +00:00
`(let ,(unspecified-bindings bindings '())
,@(letrec-setters bindings '())
,@body))
2016-07-10 13:19:20 +00:00
(define gensym
(let ((counter 0))
(lambda (. rest)
(let ((value (number->string counter)))
(set! counter (+ counter 1))
(string->symbol (string-append "g" value))))))
2016-07-23 06:17:49 +00:00
(define else #t)
2016-07-24 10:08:21 +00:00
(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))
2016-07-24 15:25:03 +00:00
(define (list-ref lst k)
(let loop ((lst lst) (k k))
(if (= 0 k) (car lst)
(loop (cdr lst) (- k 1)))))
2016-07-23 06:17:49 +00:00
;; srfi-1
(define (last-pair lst)
(let loop ((lst lst))
(if (or (null? lst) (null? (cdr lst))) lst
(loop (cdr lst)))))
2016-07-24 10:08:21 +00:00
(define (reverse lst)
(if (null? lst) '()
(append (reverse (cdr lst)) (cons (car lst) '()))))
(define (eof-object? x)
(and (number? x) (= x -1)))
(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)))))))