module/mes/read-0.mes

   1 ;;; -*-scheme-*-
   2
   3 ;;; Mes --- Maxwell Equations of Software
   4 ;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
   5 ;;;
   6 ;;; 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 ;;; Commentary:
  22
  23 ;;; read-0.mes - bootstrap reader from Scheme.  Use
  24 ;;;    ./mes --dump < module/mes/read-0.mes > read-0.mo
  25 ;;; to read, garbage collect, and dump this reader; then
  26 ;;;    ./mes --load < tests/gc-3.test
  27 ;;; to use this reader to read and run the minimal gc-3.test
  28 ;;; TODO: complete this reader, remove reader from C.
  29
  30 ;;; Code:
  31
  32 (begin
  33
  34   ;; (define car (make-function 'car 0))
  35   ;; (define cdr (make-function 'cdr 1))
  36   ;; (define cons (make-function 'cons 1))
  37
  38   ;; TODO:
  39   ;; * use case/cond, expand
  40   ;; * etc int/char?
  41   ;; * lookup in Scheme
  42   ;; * read characters, quote, strings
  43
  44   (define (read)
  45     (read-word (read-byte) (list) (current-module)))
  46
  47   (define (read-env a)
  48     (read-word (read-byte) (list) a))
  49
  50   (define (read-input-file)
  51     (define (helper x)
  52       (if (null? x) x
  53           (cons x (helper (read)))))
  54     (helper (read)))
  55
  56   (define-macro (cond . clauses)
  57     (list 'if (pair? clauses)
  58           (list 'if (car (car clauses))
  59                 (if (pair? (cdar clauses))
  60                     (if (eq? (cadar clauses) '=>)
  61                         (append2 (cddar clauses) (list (caar clauses)))
  62                         (list (cons 'lambda (cons '() (car clauses)))))
  63                     (list (cons 'lambda (cons '() (car clauses)))))
  64               (if (pair? (cdr clauses))
  65                   (cons 'cond (cdr clauses))))))
  66
  67   (define (eat-whitespace)
  68     (cond
  69      ((eq? (peek-byte) 9) (read-byte) (eat-whitespace))
  70      ((eq? (peek-byte) 10) (read-byte) (eat-whitespace))
  71      ((eq? (peek-byte) 12) (read-byte) (eat-whitespace))
  72      ((eq? (peek-byte) 13) (read-byte) (eat-whitespace))
  73      ((eq? (peek-byte) 32) (read-byte) (eat-whitespace))
  74      ((eq? (peek-byte) 59) (begin (read-line-comment (read-byte))
  75                                   (eat-whitespace)))
  76      ((eq? (peek-byte) 35) (begin (read-byte)
  77                                   (if (eq? (peek-byte) 33) (begin (read-byte)
  78                                                                   (read-block-comment (read-byte))
  79                                                                   (eat-whitespace))
  80                                       (unread-byte 35))))))
  81
  82   (define (read-block-comment c)
  83     (if (eq? c 33) (if (eq? (peek-byte) 35) (read-byte)
  84                        (read-block-comment (read-byte)))
  85         (read-block-comment (read-byte))))
  86
  87   ;; (define (read-hex c)
  88   ;;   (if (eq? c 10) c
  89   ;;       (read-line-comment (read-byte))))
  90
  91   (define (read-line-comment c)
  92     (if (eq? c 10) c
  93         (read-line-comment (read-byte))))
  94
  95   (define (read-list a)
  96     (eat-whitespace)
  97     (if (eq? (peek-byte) 41) (begin (read-byte) (list))
  98         ((lambda (w)
  99            (if (eq? w *dot*) (car (read-list a))
 100                (cons w (read-list a))))
 101          (read-word (read-byte) (list) a))))
 102
 103   ;;(define (read-string))
 104
 105   (define (lookup-char c a)
 106     (lookup (cons (integer->char c) (list)) a))
 107
 108   (define (read-word c w a)
 109     (cond
 110       ((eq? c -1) (list))
 111       ((eq? c 10) (if (null? w) (read-word (read-byte) (list) a)
 112                       (lookup w a)))
 113       ((eq? c 12) (read-word 10 w a))
 114       ((eq? c 32) (read-word 10 w a))
 115       ((eq? c 34) (if (null? w) (read-string)
 116                       (begin (unread-byte c) (lookup w a))))
 117       ((eq? c 35) (cond
 118                    ((eq? (peek-byte) 33) (begin (read-byte)
 119                                                 (read-block-comment (read-byte))
 120                                                 (read-word (read-byte) w a)))
 121                    ((eq? (peek-byte) 40) (read-byte) (list->vector (read-list a)))
 122                    ((eq? (peek-byte) 92) (read-byte) (read-character))
 123                    ((eq? (peek-byte) 120) (read-byte) (read-hex))
 124                    ((eq? (peek-byte) 44)
 125                     (read-byte)
 126                     (cond ((eq? (peek-byte) 64)
 127                            (read-byte)
 128                            (cons (lookup (symbol->list (quote unsyntax-splicing)) a)
 129                                  (cons (read-word (read-byte) w a) (list))))
 130                           (#t
 131                            (cons (lookup (symbol->list (quote unsyntax)) a)
 132                                  (cons (read-word (read-byte) w a) (list))))))
 133                    ((eq? (peek-byte) 39) (read-byte)
 134                     (cons (lookup (cons (integer->char 35) (cons (integer->char 39) (list))) a)
 135                           (cons (read-word (read-byte) w a) (list))))
 136                    ((eq? (peek-byte) 96) (read-byte)
 137                     (cons (lookup (cons (integer->char 35) (cons (integer->char 96) (list))) a)
 138                           (cons (read-word (read-byte) w a) (list))))
 139                    (#t (read-word (read-byte) (append2 w (cons (integer->char c) (list))) a))))
 140       ((eq? c 39) (if (null? w) (cons (lookup (cons (integer->char c) (list)) a)
 141                                       (cons (read-word (read-byte) w a) (list)))
 142                       (begin (unread-byte c) (lookup w a))))
 143       ((eq? c 40) (if (null? w) (read-list a)
 144                       (begin (unread-byte c) (lookup w a))))
 145       ((eq? c 41) (if (null? w) (cons (lookup (cons (integer->char c) (list)) a)
 146                                       (cons (read-word (read-byte) w a) (list)))
 147                       (begin (unread-byte c) (lookup w a))))
 148       ((eq? c 44) (cond
 149                    ((eq? (peek-byte) 64) (begin (read-byte)
 150                                                 (cons
 151                                                  (lookup (symbol->list (quote unquote-splicing)) a)
 152                                                  (cons (read-word (read-byte) w a) (list)))))
 153                    (#t (cons (lookup-char c a) (cons (read-word (read-byte) w a)
 154                                                         (list))))))
 155       ((eq? c 96) (cons (lookup-char c a) (cons (read-word (read-byte) w a) (list))))
 156       ((eq? c 59) (read-line-comment c) (read-word 10 w a))
 157       (#t (read-word (read-byte) (append2 w (cons (integer->char c) (list))) a))))
 158
 159   ((lambda (p)
 160      ;;(display (quote scheme-program=)) (display p) (newline)
 161      (begin-env p (current-module)))
 162    (read-input-file)))