mes/module/mes/boot-0.scm

   1 ;;; -*-scheme-*-
   2
   3 ;;; Mes --- Maxwell Equations of Software
   4 ;;; Copyright © 2016,2017,2018 Jan (janneke) 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.  This file is read by a minimal
  24 ;;; core reader.  It only supports s-exps and line-comments; quotes,
  25 ;;; character literals, string literals cannot be used here.
  26
  27 ;;; Code:
  28
  29 ;; boot-00.scm
  30 (define mes %version)
  31
  32 (define (defined? x)
  33   (assq x (current-module)))
  34
  35 (define (cond-expand-expander clauses)
  36   (if (defined? (car (car clauses)))
  37       (cdr (car clauses))
  38       (cond-expand-expander (cdr clauses))))
  39
  40 (define-macro (cond-expand . clauses)
  41   (cons 'begin (cond-expand-expander clauses)))
  42 ;; end boot-00.scm
  43
  44 ;; boot-01.scm
  45 (define (pair? x) (eq? (core:type x) <cell:pair>))
  46 (define (not x) (if x #f #t))
  47
  48 (define (display x . rest)
  49   (if (null? rest) (core:display x)
  50       (core:display-port x (car rest))))
  51
  52 (define (write x . rest)
  53   (if (null? rest) (core:write x)
  54       (core:write-port x (car rest))))
  55
  56 (define (list->string lst)
  57   (core:make-cell <cell:string> lst 0))
  58
  59 (define (integer->char x)
  60   (core:make-cell <cell:char> 0 x))
  61
  62 (define (newline . rest)
  63   (core:display (list->string (list (integer->char 10)))))
  64
  65 (define (string->list s)
  66   (core:car s))
  67
  68 (define (cadr x) (car (cdr x)))
  69
  70 (define (map1 f lst)
  71   (if (null? lst) (list)
  72       (cons (f (car lst)) (map1 f (cdr lst)))))
  73
  74 (define (map f lst)
  75   (if (null? lst) (list)
  76       (cons (f (car lst)) (map f (cdr lst)))))
  77
  78 (define (cons* . rest)
  79   (if (null? (cdr rest)) (car rest)
  80       (cons (car rest) (core:apply cons* (cdr rest) (current-module)))))
  81
  82 (define (apply f h . t)
  83   (if (null? t) (core:apply f h (current-module))
  84       (apply f (apply cons* (cons h t)))))
  85
  86 (define (append . rest)
  87   (if (null? rest) '()
  88       (if (null? (cdr rest)) (car rest)
  89           (append2 (car rest) (apply append (cdr rest))))))
  90 ;; end boot-01.scm
  91
  92 ;; boot-02.scm
  93 (define-macro (and . x)
  94   (if (null? x) #t
  95       (if (null? (cdr x)) (car x)
  96           (list (quote if) (car x) (cons (quote and) (cdr x))
  97                 #f))))
  98
  99 (define-macro (or . x)
 100   (if (null? x) #f
 101       (if (null? (cdr x)) (car x)
 102           (list (list (quote lambda) (list (quote r))
 103                       (list (quote if) (quote r) (quote r)
 104                             (cons (quote or) (cdr x))))
 105                 (car x)))))
 106
 107 (define-macro (module-define! module name value)
 108   ;;(list 'define name value)
 109   #t)
 110
 111 (define-macro (mes-use-module module)
 112   #t)
 113 ;; end boot-02.scm
 114
 115 ;; boot-0.scm
 116 (define (primitive-eval e) (core:eval e (current-module)))
 117 (define eval core:eval)
 118
 119 (define (current-output-port) 1)
 120 (define (current-error-port) 2)
 121 (define (port-filename port) "<stdin>")
 122 (define (port-line port) 0)
 123 (define (port-column port) 0)
 124 (define (ftell port) 0)
 125 (define (false-if-exception x) x)
 126
 127 (define (cons* . rest)
 128   (if (null? (cdr rest)) (car rest)
 129       (cons (car rest) (core:apply cons* (cdr rest) (current-module)))))
 130
 131 (define (apply f h . t)
 132   (if (null? t) (core:apply f h (current-module))
 133       (apply f (apply cons* (cons h t)))))
 134
 135 (define-macro (cond . clauses)
 136   (list 'if (pair? clauses)
 137         (list (cons
 138                'lambda
 139                (cons
 140                 '(test)
 141                 (list (list 'if 'test
 142                             (if (pair? (cdr (car clauses)))
 143                                 (if (eq? (car (cdr (car clauses))) '=>)
 144                                     (append2 (cdr (cdr (car clauses))) '(test))
 145                                     (list (cons 'lambda (cons '() (cons 'test (cdr (car clauses)))))))
 146                                 (list (cons 'lambda (cons '() (cons 'test (cdr (car clauses)))))))
 147                             (if (pair? (cdr clauses))
 148                                 (cons 'cond (cdr clauses)))))))
 149               (car (car clauses)))))
 150
 151 (define else #t)
 152
 153 (define-macro (load file)
 154   (list 'begin
 155         (list 'if (list 'and (list getenv "MES_DEBUG")
 156                         (list not (list equal2? (list getenv "MES_DEBUG") "0"))
 157                         (list not (list equal2? (list getenv "MES_DEBUG") "1")))
 158               (list 'begin
 159                     (list core:display-error ";;; read ")
 160                     (list core:display-error file)
 161                     (list core:display-error "\n")))
 162      (list 'primitive-load file)))
 163
 164 (define-macro (include file) (list 'load file))
 165
 166 (define (append . rest)
 167   (if (null? rest) '()
 168       (if (null? (cdr rest)) (car rest)
 169           (append2 (car rest) (apply append (cdr rest))))))
 170
 171 (define (string->list s)
 172   (core:car s))
 173
 174 (define %prefix (getenv "MES_PREFIX"))
 175 (define %moduledir
 176   (if (not %prefix) "mes/module/"
 177       (list->string
 178        (append (string->list %prefix) (string->list "/module/" )))))
 179
 180 (include (list->string
 181           (append2 (string->list %moduledir) (string->list "mes/type-0.mes"))))
 182
 183 (define (symbol->string s)
 184   (apply string (symbol->list s)))
 185
 186 (define (string-append . rest)
 187   (apply string (apply append (map1 string->list rest))))
 188
 189 (define %version (if (eq? (car (string->list "@VERSION@")) #\@) "git"
 190                      "@VERSION@"))
 191 (define (effective-version) %version)
 192
 193 (if (list 'and (list getenv "MES_DEBUG")
 194           (list not (list equal2? (list getenv "MES_DEBUG") "0"))
 195           (list not (list equal2? (list getenv "MES_DEBUG") "1")))
 196     (begin
 197       (core:display-error ";;; %moduledir=")
 198       (core:display-error %moduledir)
 199       (core:display-error "\n")))
 200
 201 (define-macro (include-from-path file)
 202   (list 'load (list string-append %moduledir file)))
 203
 204 (define (string-join lst infix)
 205   (if (null? lst) ""
 206       (if (null? (cdr lst)) (car lst)
 207           (string-append (car lst) infix (string-join (cdr lst) infix)))))
 208
 209 (include-from-path "mes/module.mes")
 210
 211 (mes-use-module (mes base))
 212 (mes-use-module (mes quasiquote))
 213 (mes-use-module (mes let))
 214 (mes-use-module (mes scm))
 215 (mes-use-module (srfi srfi-1))
 216 (mes-use-module (srfi srfi-13))
 217 (mes-use-module (mes fluids))
 218 (mes-use-module (mes catch))
 219 (mes-use-module (mes posix))
 220
 221 (define-macro (include-from-path file)
 222   (let loop ((path (cons* %moduledir "module" (string-split (or (getenv "GUILE_LOAD_PATH")) #\:))))
 223     (cond ((and=> (getenv "MES_DEBUG") (compose (lambda (o) (> o 2)) string->number))
 224            (core:display-error (string-append "include-from-path: " file " [PATH:" (string-join path ":") "]\n")))
 225           ((and=> (getenv "MES_DEBUG") (compose (lambda (o) (> o 1)) string->number))
 226            (core:display-error (string-append "include-from-path: " file "\n"))))
 227     (if (null? path) (error "include-from-path: not found: " file)
 228         (let ((file (string-append (car path) "/" file)))
 229           (if (access? file R_OK) `(load ,file)
 230               (loop (cdr path)))))))
 231
 232 (define-macro (define-module module . rest)
 233   `(if ,(and (pair? module)
 234              (= 1 (length module))
 235              (symbol? (car module)))
 236        (define (,(car module) . arguments) (main (command-line)))))
 237
 238 (define-macro (use-modules . rest) #t)
 239
 240 (mes-use-module (mes getopt-long))
 241
 242 (define %main #f)
 243 (primitive-load 0)
 244 (let ((tty? (isatty? 0)))
 245   (define (parse-opts args)
 246     (let* ((option-spec
 247             '((no-auto-compile)
 248               (compiled-path (single-char #\C) (value #t))
 249               (dump)
 250               (help (single-char #\h))
 251               (load)
 252               (load-path (single-char #\L) (value #t))
 253               (main (single-char #\e) (value #t))
 254               (source (single-char #\s) (value #t))
 255               (version (single-char #\V)))))
 256       (getopt-long args option-spec #:stop-at-first-non-option #t)))
 257   (define (source-arg? o)
 258     (equal? "-s" o))
 259   (let* ((s-index (list-index source-arg? %argv))
 260          (args (if s-index (list-head %argv (+ s-index 2)) %argv))
 261          (options (parse-opts args))
 262          (main (option-ref options 'main #f))
 263          (source (option-ref options 'source #f))
 264          (files (if s-index (list-tail %argv (+ s-index 1))
 265                     (option-ref options '() '())))
 266          (help? (option-ref options 'help #f))
 267          (usage? (and (not help?) (null? files) (not tty?) (not main)))
 268          (version? (option-ref options 'version #f)))
 269     (or
 270      (and version?
 271           (display (string-append "mes (Mes) " %version "\n"))
 272           (exit 0))
 273      (and (or help? usage?)
 274           (display "Usage: mes [OPTION]... [FILE]...
 275 Evaluate code with Mes, interactively or from a script.
 276
 277   [-s] FILE           load source code from FILE, and exit
 278   --                  stop scanning arguments; run interactively
 279
 280 The above switches stop argument processing, and pass all
 281 remaining arguments as the value of (command-line).
 282
 283   --dump              dump binary program to stdout
 284   -e,--main=MAIN      after reading script, apply MAIN to command-line arguments
 285   -h, --help          display this help and exit
 286   --load              load binary program [module/mes/boot-0.32-mo]
 287   -L,--load-path=DIR  add DIR to the front of the module load path
 288   -v, --version       display version information and exit
 289
 290 Ignored for Guile compatibility:
 291   --auto-compile
 292   --fresh-auto-compile
 293   --no-auto-compile
 294   -C,--compiled-path=DIR
 295 " (or (and usage? (current-error-port)) (current-output-port)))
 296           (exit (or (and usage? 2) 0)))
 297      options)
 298     (if main (set! %main main))
 299     (and=> (option-ref options 'load-path #f)
 300            (lambda (dir)
 301              (setenv "GUILE_LOAD_PATH" (string-append dir ":" (getenv "GUILE_LOAD_PATH")))))
 302     (cond ((pair? files)
 303            (let* ((file (car files))
 304                   (port (if (equal? file "-") 0
 305                             (open-input-file file))))
 306              (set! %argv files)
 307              (set-current-input-port port)))
 308           ((and (null? files) tty?)
 309
 310            (mes-use-module (mes repl))
 311            (set-current-input-port 0)
 312            (repl))
 313           (else #t))))
 314 (primitive-load 0)
 315 (primitive-load (open-input-string %main))