scm.mes

   1 ;;; -*-scheme-*-
   2
   3 ;;; Mes --- Maxwell Equations of Software
   4 ;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
   5 ;;;
   6 ;;; scm.mes: This file is part of Mes.
   7 ;;;
   8 ;;; Mes is free software; you can redistribute it and/or modify it
   9 ;;; under the terms of the GNU General Public License as published by
  10 ;;; the Free Software Foundation; either version 3 of the License, or (at
  11 ;;; your option) any later version.
  12 ;;;
  13 ;;; Mes is distributed in the hope that it will be useful, but
  14 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;;; GNU General Public License for more details.
  17 ;;;
  18 ;;; You should have received a copy of the GNU General Public License
  19 ;;; along with Mes.  If not, see <http://www.gnu.org/licenses/>.
  20
  21 ;; The Maxwell Equations of Software -- John McCarthy page 13
  22 ;; http://www.softwarepreservation.org/projects/LISP/book/LISP%201.5%20Programmers%20Manual.pdf
  23
  24 (define-macro (if expr then . else)
  25   `(cond
  26     (,expr ,then)
  27     (#t (cond (,(pair? else) ((lambda () ,@else)))))))
  28
  29 (define-macro (when expr . body)
  30   `(if ,expr
  31        ((lambda () ,@body))))
  32
  33 (define (list . rest) rest)
  34
  35 (define (split-params bindings params)
  36   (cond ((null? bindings) params)
  37         (#t (split-params (cdr bindings)
  38                           (append params (cons (caar bindings) '()))))))
  39
  40 (define (split-values bindings values)
  41   (cond ((null? bindings) values)
  42         (#t (split-values (cdr bindings)
  43                           (append values (cdar bindings) '())))))
  44
  45 (define-macro (simple-let bindings rest)
  46   `((lambda ,(split-params bindings '()) ,@rest)
  47     ,@(split-values bindings '())))
  48
  49 (define-macro (let-loop label bindings . rest)
  50   `(let ((,label *unspecified*))
  51      (let ((,label (lambda ,(split-params bindings '()) ,@rest)))
  52        (,label ,@(split-values bindings '())))))
  53
  54 (define-macro (let-loop label bindings rest)
  55   `((lambda (,label)
  56       (set! ,label (lambda ,(split-params bindings '()) ,@rest))
  57       (,label ,@(split-values bindings '())))
  58     *unspecified*))
  59
  60 (define-macro (let bindings-or-label . rest)
  61   `(cond (,(symbol? bindings-or-label)
  62           (let-loop ,bindings-or-label ,(car rest) ,(cdr rest)))
  63          (#t (simple-let ,bindings-or-label ,rest))))
  64
  65 (define-macro (or2 x y)
  66   `(cond (,x ,x) (#t ,y)))
  67
  68 (define-macro (and2 x y)
  69   `(cond (,x ,y) (#t #f)))
  70
  71 (define-macro (or . x)
  72   (cond
  73    ((null? x) #f)
  74    ((null? (cdr x)) (car x))
  75    (#t `(cond (,(car x))
  76               (#t (or ,@(cdr x)))))))
  77
  78 (define-macro (and . x)
  79   (cond ((null? x) #t)
  80         ((null? (cdr x)) (car x))
  81         (#t `(cond (,(car x) (and ,@(cdr x)))
  82                    (#t #f)))))
  83
  84 (define (expand-let* bindings body)
  85   (cond ((null? bindings)
  86          `((lambda () ,@body)))
  87         (#t `((lambda (,(caar bindings))
  88                 ,(expand-let* (cdr bindings) body))
  89               ,@(cdar bindings)))))
  90
  91 (define-macro (let* bindings . body)
  92   (expand-let* bindings body))
  93
  94 (define (equal? a b) ;; FIXME: only 2 arg
  95   (cond ((and (null? a) (null? b)) #t)
  96         ((and (pair? a) (pair? b))
  97          (and (equal? (car a) (car b))
  98               (equal? (cdr a) (cdr b))))
  99         ((and (string? a) (string? b))
 100          (eq? (string->symbol a) (string->symbol b)))
 101         ((and (vector? a) (vector? b))
 102          (equal? (vector->list a) (vector->list b)))
 103         (#t (eq? a b))))
 104
 105 (define (vector . rest) (list->vector rest))
 106 (define (make-vector n . x)
 107   (let ((fill (if (pair? x) (cdr x) *unspecified*)))
 108     (list->vector (let loop ((n n))
 109                     (if (= 0 n) '()
 110                         (cons fill (loop (- n 1))))))))
 111
 112 (define (apply f args)
 113   (eval (cons f args) (current-module)))
 114
 115 (define-macro (defined? x)
 116   `(assq ,x (cddr (current-module))))
 117
 118 (define (procedure? p)
 119   (cond ((builtin? p) #t)
 120         ((and (pair? p) (eq? (car p) 'lambda)))
 121         ((and (pair? p) (eq? (car p) '*closure*)))
 122         (#t #f)))
 123
 124 (define (assq-set! alist key val)
 125   (let ((entry (assq key alist)))
 126     (cond (entry (set-cdr! entry val)
 127                  alist)
 128           (#t (cons (cons key val) alist)))))
 129
 130 (define (assq-ref alist key)
 131   (let ((entry (assq key alist)))
 132     (if entry (cdr entry)
 133         #f)))
 134
 135 (define assv assq)
 136
 137 (define (memq x lst)
 138   (cond ((null? lst) #f)
 139         ((eq? x (car lst)) lst)
 140         (#t (memq x (cdr lst)))))
 141 (define memv memq)
 142
 143 (define (member x lst)
 144   (cond ((null? lst) #f)
 145         ((equal? x (car lst)) lst)
 146         (#t (member x (cdr lst)))))
 147
 148 (define (map f l . r)
 149   (cond ((null? l) '())
 150         ((null? r) (cons (f (car l)) (map f (cdr l))))
 151         ((null? (cdr r))
 152          (cons (f (car l) (caar r)) (map f (cdr l) (cdar r))))))
 153
 154 (define (identity x) x)
 155 (define (for-each f l . r)
 156   (apply map (cons f (cons l r)))
 157   *unspecified*)
 158
 159 (define (not x)
 160   (cond (x #f)
 161         (#t #t)))
 162
 163 (define (<= a b) ;; FIXME: only 2 arg
 164   (or (< a b)
 165       (= a b)))
 166
 167 (define (>= a b) ;; FIXME: only 2 arg
 168   (or (> a b)
 169       (= a b)))
 170
 171 (define (list? x)
 172   (or (null? x)
 173       (and (pair? x) (list? (cdr x)))))
 174
 175 (define (unspecified-bindings bindings params)
 176   (cond ((null? bindings) params)
 177         (#t (unspecified-bindings
 178              (cdr bindings)
 179              (append params (cons (cons (caar bindings) '(*unspecified*)) '()))))))
 180
 181 (define (letrec-setters bindings setters)
 182   (cond ((null? bindings) setters)
 183         (#t (letrec-setters (cdr bindings)
 184                             (append setters
 185                                     (cons (cons 'set! (car bindings)) '()))))))
 186
 187 (define-macro (letrec bindings . body)
 188   `(let ,(unspecified-bindings bindings '())
 189      ,@(letrec-setters bindings '())
 190      ,@body))
 191
 192 (define gensym
 193   (let ((counter 0))
 194     (lambda (. rest)
 195       (let ((value (number->string counter)))
 196         (set! counter (+ counter 1))
 197         (string->symbol (string-append "g" value))))))
 198
 199 (define else #t)
 200
 201 ;; srfi-1
 202 (define (last-pair lst)
 203   (let loop ((lst lst))
 204     (if (or (null? lst) (null? (cdr lst))) lst
 205         (loop (cdr lst)))))