mes/scm.mes

209 lines
5.9 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 (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
(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))
(define (apply f args)
(eval (cons f args) (current-module)))
(define (defined? x)
(assq x (current-module)))
(define (procedure? p)
(cond ((builtin? p) #t)
((and (pair? p) (eq? (car p) 'lambda)))
((and (pair? p) (eq? (car p) '*lambda*)))
(#t #f)))
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
(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)
(apply map (cons f (cons l r)))
*unspecified*)
2016-07-10 11:04:10 +00:00
(define (not x)
(cond (x #f)
(#t #t)))
2016-07-17 10:56:31 +00:00
(define (<= a b) ;; FIXME: only 2 arg
(or (< a b)
(= a b)))
(define (>= a b) ;; FIXME: only 2 arg
(or (> a b)
(= a b)))
(define (list? x)
(or (null? x)
(and (pair? x) (list? (cdr x)))))
2016-07-10 11:04:10 +00:00
(define-macro (if expr then . else)
`(cond
(,expr ,then)
(#t (cond (,(pair? else) ((lambda () ,@else)))))))
2016-07-16 11:24:38 +00:00
(define-macro (when expr . body)
`(if ,expr
((lambda () ,@body))))
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
2016-07-16 18:02:14 +00:00
;; TODO
;; (define gensym
;; (let ((counter 0))
;; (lambda (. rest)
;; (let ((value (number->string counter)))
2016-07-16 18:02:14 +00:00
;; (set! counter (+ counter 1))
;; (string->symbol (string-append "g" value))))))
(define gensym #f)
(let ((counter 0))
(set! gensym
(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
2016-07-23 09:51:06 +00:00
()
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)))))