mes.mes

   1 ;;; -*-scheme-*-
   2
   3 ;;; Mes --- Maxwell Equations of Software
   4 ;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
   5 ;;;
   6 ;;; mes.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 (caar x) (car (car x)))
  25 ;; (define (cadr x) (car (cdr x)))
  26 ;; (define (cdar x) (cdr (car x)))
  27 ;; (define (cddr x) (cdr (cdr x)))
  28 ;; (define (caadr x) (car (car (cdr x))))
  29 ;; (define (caddr x) (car (cdr (cdr x))))
  30 ;; (define (cddar x) (cdr (cdr (car x))))
  31 ;; (define (cdadr x) (cdr (car (cdr x))))
  32 ;; (define (cadar x) (car (cdr (car x))))
  33 ;; (define (cdddr x) (cdr (cdr (cdr x))))
  34
  35 ;; ;; Page 12
  36 ;; (define (pairlis x y a)
  37 ;;   ;;(debug "pairlis x=~a y=~a a=~a\n" x y a)
  38 ;;   (cond
  39 ;;    ((null? x) a)
  40 ;;    ((atom? x) (cons (cons x y) a))
  41 ;;    (#t (cons (cons (car x) (car y))
  42 ;;              (pairlis (cdr x) (cdr y) a)))))
  43
  44 ;; (define (assq x a)
  45 ;;   ;;(stderr "assq x=~a\n" x)
  46 ;;   ;;(debug "assq x=~a a=~a\n" x a)
  47 ;;   (cond
  48 ;;    ((null? a) #f)
  49 ;;    ((eq? (caar a) x) (car a))
  50 ;;    (#t (assq x (cdr a)))))
  51
  52 ;; ;; Page 13
  53 ;; (define (eval-quote fn x)
  54 ;;   ;(debug "eval-quote fn=~a x=~a" fn x)
  55 ;;   (apply-env fn x '()))
  56
  57 (define (evcon c a)
  58   ;;(debug "evcon c=~a a=~a\n" c a)
  59   (cond
  60    ((null? c) *unspecified*)
  61    ;; single-statement cond
  62    ;; ((eval (caar c) a) (eval (cadar c) a))
  63    ((eval (caar c) a)
  64     (cond ((null? (cddar c)) (eval (cadar c) a))
  65           (#t (eval (cadar c) a)
  66               (evcon
  67                (cons (cons #t (cddar c)) '())
  68                a))))
  69    (#t (evcon (cdr c) a))))
  70
  71 (define (evlis m a)
  72   ;;(debug "evlis m=~a a=~a\n" m a)
  73   ;; (display 'mes-evlis:)
  74   ;; (display m)
  75   ;; (newline)
  76   (cond
  77    ((null? m) '())
  78    (#t (cons (eval (car m) a) (evlis (cdr m) a)))))
  79
  80
  81 (define (apply-env fn x a)
  82   ;; (display 'mes-apply-env:)
  83   ;; (newline)
  84   ;; (display 'fn:)
  85   ;; (display fn)
  86   ;; (newline)
  87   ;; (display 'builtin:)
  88   ;; (display (builtin? fn))
  89   ;; (newline)
  90   ;; (display 'x:)
  91   ;; (display x)
  92   ;; (newline)
  93   (cond
  94    ((atom? fn)
  95     (cond
  96      ((eq? fn 'current-module)
  97       (c:apply-env current-module '() a))
  98      ((eq? fn 'call-with-values)
  99       (c:apply-env 'call-with-values x a))
 100      ((builtin? fn)
 101       (call fn x))
 102      (#t (apply-env (eval fn a) x a))))
 103    ((eq? (car fn) 'lambda)
 104     (begin-env (cddr fn) (pairlis (cadr fn) x a)))
 105    ((eq? (car fn) 'label) (apply-env (caddr fn) x (cons (cons (cadr fn)
 106                                                          (caddr fn)) a)))))
 107
 108 (define (begin-env body a)
 109   (cond ((null? body) *unspecified*)
 110         ((null? (cdr body)) (eval (car body) a))
 111         (#t (eval (car body) a)
 112             (begin-env (cdr body) a))))
 113
 114 (define (set-env! x e a)
 115   (set-cdr! (assq x a) e))
 116
 117 (define (eval e a)
 118   ;;(debug "eval e=~a a=~a\n" e a)
 119   ;;(debug "eval (atom? ~a)=~a\n" e (atom? e))
 120   ;; (display 'mes-eval:)
 121   ;; (display e)
 122   ;; (newline)
 123   ;; (display 'a:)
 124   ;; (display a)
 125   ;; (newline)
 126   (cond
 127    ((eq? e #t) #t)
 128    ((eq? e #f) #f)
 129    ((char? e) e)
 130    ((number? e) e)
 131    ((string? e) e)
 132    ((vector? e) e)
 133    ((atom? e) (cdr (assq e a)))
 134    ((builtin? e) e)
 135    ((atom? (car e))
 136     (cond
 137      ((eq? (car e) 'quote) (cadr e))
 138      ((eq? (car e) 'lambda) e)
 139      ((eq? (car e) 'set!) (set-env! (cadr e) (caddr e) a))
 140      ((eq? (car e) 'unquote) (eval (cadr e) a))
 141      ((eq? (car e) 'quasiquote) (eval-quasiquote (cadr e) a))
 142      ((eq? (car e) 'cond) (evcon (cdr e) a))
 143      ((pair? (assq (car e) (cdr (assq '*macro* a))))
 144       (c:eval
 145        (c:apply-env
 146         (cdr (assq (car e) (cdr (assq '*macro* a))))
 147         (cdr e)
 148         a)
 149        a))
 150      (#t (apply-env (car e) (evlis (cdr e) a) a))))
 151    (#t (apply-env (car e) (evlis (cdr e) a) a))))
 152
 153 (define (eval-quasiquote e a)
 154   ;; (display 'mes-eval-quasiquote:)
 155   ;; (display e)
 156   ;; (newline)
 157   (cond ((null? e) e)
 158         ((atom? e) e)
 159         ((atom? (car e)) (cons (car e) (eval-quasiquote (cdr e) a)))
 160         ((eq? (caar e) 'unquote) (cons (eval (cadar e) a) '()))
 161         ((eq? (caar e) 'quote) (cons (cadar e) '()))
 162         ((eq? (caar e) 'quasiquote) (cons (cadar e) '()))
 163         (#t (cons (car e) (eval-quasiquote (cdr e) a)))))
 164
 165 ;; readenv et al works, but slows down dramatically
 166 (define (DISABLED-readenv a)
 167   (readword (getchar) '() a))
 168
 169 (define (readword c w a)
 170   ;; (display 'mes-readword:)
 171   ;; (display c)
 172   ;; (newline)
 173   (cond ((eq? c -1) ;; eof
 174          (cond ((eq? w '()) '())
 175                (#t (lookup w a))))
 176         ((eq? c 10) ;; \n
 177          (cond ((eq? w '()) (readword (getchar) w a))
 178                ;; DOT ((eq? w '(*dot*)) (car (readword (getchar) '() a)))
 179                (#t (lookup w a))))
 180         ((eq? c 32) ;; \space
 181          (readword 10 w a))
 182         ((eq? c 40) ;; (
 183          (cond ((eq? w '()) (readlist a))
 184                (#t (ungetchar c) (lookup w a))))
 185         ((eq? c 41) ;; )
 186          (cond ((eq? w '()) (ungetchar c) w)
 187                (#t (ungetchar c) (lookup w a))))
 188         ((eq? c 39) ;; '
 189          (cond ((eq? w '())
 190                 (cons (lookup (cons c '()) a)
 191                       (cons (readword (getchar) w a) '())))
 192                (#t (ungetchar c) (lookup w a))))
 193         ((eq? c 59) ;; ;
 194          (readcomment c)
 195          (readword 10 w a))
 196         ((eq? c 35) ;; #
 197          (cond ((eq? (peekchar) 33) ;; !
 198                 (getchar)
 199                 (readblock (getchar))
 200                 (readword 10 w a))
 201                ;; TODO: char, vector
 202                (#t (readword (getchar) (append w (cons c '())) a))))
 203         (#t (readword (getchar) (append w (cons c '())) a))))
 204
 205 (define (readblock c)
 206   ;; (display 'mes-readblock:)
 207   ;; (display c)
 208   ;; (newline)
 209   (cond ((eq? c 33) (cond ((eq? (peekchar) 35) (getchar))
 210                          (#t (readblock (getchar)))))
 211         (#t (readblock (getchar)))))
 212
 213 (define (eat-whitespace)
 214   (cond ((eq? (peekchar) 10) (getchar) (eat-whitespace))
 215         ((eq? (peekchar) 32) (getchar) (eat-whitespace))
 216         ((eq? (peekchar) 35) (getchar) (eat-whitespace))
 217         (#t #t)))
 218
 219 (define (readlist a)
 220   ;; (display 'mes-readlist:)
 221   ;; (newline)
 222   (eat-whitespace)
 223   (cond ((eq? (peekchar) 41) ;; )
 224          (getchar)
 225          '())
 226         ;; TODO *dot*
 227         (#t (cons (readword (getchar) '() a) (readlist a)))))
 228
 229 (define (readcomment c)
 230   (cond ((eq? c 10) ;; \n
 231          c)
 232         (#t (readcomment (getchar)))))