mes/module/mes/boot-0.scm

   1 ;;; -*-scheme-*-
   2
   3 ;;; GNU Mes --- Maxwell Equations of Software
   4 ;;; Copyright © 2016,2017,2018,2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
   5 ;;;
   6 ;;; This file is part of GNU Mes.
   7 ;;;
   8 ;;; GNU 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 ;;; GNU 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 GNU 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   (module-variable (current-module) x))
  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 (not x) (if x #f #t))
  46
  47 (define (display x . rest)
  48   (if (null? rest) (core:display x)
  49       (core:display-port x (car rest))))
  50
  51 (define (write x . rest)
  52   (if (null? rest) (core:write x)
  53       (core:write-port x (car rest))))
  54
  55 (define (newline . rest)
  56   (core:display "\n"))
  57
  58 (define (cadr x) (car (cdr x)))
  59
  60 (define (map1 f lst)
  61   (if (null? lst) (list)
  62       (cons (f (car lst)) (map1 f (cdr lst)))))
  63
  64 (define (map f lst)
  65   (if (null? lst) (list)
  66       (cons (f (car lst)) (map f (cdr lst)))))
  67
  68 (define (cons* . rest)
  69   (if (null? (cdr rest)) (car rest)
  70       (cons (car rest) (core:apply cons* (cdr rest) (current-module)))))
  71
  72 (define (apply f h . t)
  73   (if (null? t) (core:apply f h (current-module))
  74       (apply f (apply cons* (cons h t)))))
  75
  76 (define (append . rest)
  77   (if (null? rest) '()
  78       (if (null? (cdr rest)) (car rest)
  79           (append2 (car rest) (apply append (cdr rest))))))
  80 ;; end boot-01.scm
  81
  82 ;; boot-02.scm
  83 (define-macro (and . x)
  84   (if (null? x) #t
  85       (if (null? (cdr x)) (car x)
  86           (list (quote if) (car x) (cons (quote and) (cdr x))
  87                 #f))))
  88
  89 (define-macro (or . x)
  90   (if (null? x) #f
  91       (if (null? (cdr x)) (car x)
  92           (list (list (quote lambda) (list (quote r))
  93                       (list (quote if) (quote r) (quote r)
  94                             (cons (quote or) (cdr x))))
  95                 (car x)))))
  96
  97 (define-macro (mes-use-module module)
  98   #t)
  99 ;; end boot-02.scm
 100
 101 ;; boot-03.scm
 102 (define guile? #f)
 103 (define mes? #t)
 104 (define (primitive-eval e) (core:eval e (current-module)))
 105 (define eval core:eval)
 106
 107 (define (port-filename port) "<stdin>")
 108 (define (port-line port) 0)
 109 (define (port-column port) 0)
 110 (define (ftell port) 0)
 111 (define (false-if-exception x) x)
 112
 113 (define (cons* . rest)
 114   (if (null? (cdr rest)) (car rest)
 115       (cons (car rest) (core:apply cons* (cdr rest) (current-module)))))
 116
 117 (define (apply f h . t)
 118   (if (null? t) (core:apply f h (current-module))
 119       (apply f (apply cons* (cons h t)))))
 120
 121 (define-macro (load file)
 122   (list 'begin
 123         (list 'if (list 'and (list getenv "MES_DEBUG")
 124                         (list not (list equal2? (list getenv "MES_DEBUG") "0"))
 125                         (list not (list equal2? (list getenv "MES_DEBUG") "1")))
 126               (list 'begin
 127                     (list core:display-error ";;; read ")
 128                     (list core:display-error file)
 129                     (list core:display-error "\n")))
 130      (list 'primitive-load file)))
 131
 132 (define-macro (include file) (list 'load file))
 133
 134 (define (append . rest)
 135   (if (null? rest) '()
 136       (if (null? (cdr rest)) (car rest)
 137           (append2 (car rest) (apply append (cdr rest))))))
 138
 139 (define %moduledir (string-append %datadir "/module/"))
 140
 141 (include (string-append %moduledir "mes/type-0.mes"))
 142
 143 (if (and (getenv "MES_DEBUG")
 144           (not (equal2? (getenv "MES_DEBUG") "0"))
 145           (not (equal2? (getenv "MES_DEBUG") "1")))
 146     (begin
 147       (core:display-error ";;; %moduledir=")
 148       (core:display-error %moduledir)
 149       (core:display-error "\n")))
 150
 151 (define-macro (include-from-path file)
 152   (list 'load (list string-append %moduledir file)))
 153
 154 (define (string-join lst infix)
 155   (if (null? lst) ""
 156       (if (null? (cdr lst)) (car lst)
 157           (string-append (car lst) infix (string-join (cdr lst) infix)))))
 158
 159 (include-from-path "mes/module.mes")
 160
 161 (mes-use-module (mes base))
 162 (mes-use-module (mes quasiquote))
 163 (mes-use-module (mes let))
 164 (mes-use-module (mes scm))
 165
 166 (define-macro (define-module module . rest)
 167   `(if ,(and (pair? module)
 168              (= 1 (length module))
 169              (symbol? (car module)))
 170        (define (,(car module) . arguments) (main (command-line)))))
 171
 172 (define-macro (use-modules . rest) #t)
 173 ;; end boot-03.scm
 174
 175 (define (effective-version) %version)
 176
 177 (mes-use-module (srfi srfi-1))
 178 (mes-use-module (srfi srfi-13))
 179 (mes-use-module (mes fluids))
 180 (mes-use-module (mes catch))
 181 (mes-use-module (mes posix))
 182
 183 (define-macro (include-from-path file)
 184   (let loop ((path (cons* %moduledir "module" (string-split (or (getenv "GUILE_LOAD_PATH") "") #\:))))
 185     (cond ((and=> (getenv "MES_DEBUG") (compose (lambda (o) (> o 2)) string->number))
 186            (core:display-error (string-append "include-from-path: " file " [PATH:" (string-join path ":") "]\n")))
 187           ((and=> (getenv "MES_DEBUG") (compose (lambda (o) (> o 1)) string->number))
 188            (core:display-error (string-append "include-from-path: " file "\n"))))
 189     (if (null? path) (error "include-from-path: not found: " file)
 190         (let ((file (string-append (car path) "/" file)))
 191           (if (access? file R_OK) `(load ,file)
 192               (loop (cdr path)))))))
 193
 194 (define-macro (define-module module . rest)
 195   `(if ,(and (pair? module)
 196              (= 1 (length module))
 197              (symbol? (car module)))
 198        (define (,(car module) . arguments) (main (command-line)))))
 199
 200 (define-macro (use-modules . rest) #t)
 201
 202 (mes-use-module (mes getopt-long))
 203
 204 (define %main #f)
 205 (primitive-load 0)
 206 (let ((tty? (isatty? 0)))
 207   (define (parse-opts args)
 208     (let* ((option-spec
 209             '((no-auto-compile)
 210               (command (single-char #\c) (value #t))
 211               (compiled-path (single-char #\C) (value #t))
 212               (help (single-char #\h))
 213               (load-path (single-char #\L) (value #t))
 214               (main (single-char #\e) (value #t))
 215               (source (single-char #\s) (value #t))
 216               (version (single-char #\V)))))
 217       (getopt-long args option-spec #:stop-at-first-non-option #t)))
 218   (define (source-arg? o)
 219     (equal? "-s" o))
 220   (let* ((s-index (list-index source-arg? %argv))
 221          (args (if s-index (list-head %argv (+ s-index 2)) %argv))
 222          (options (parse-opts args))
 223          (command (option-ref options 'command #f))
 224          (main (option-ref options 'main #f))
 225          (source (option-ref options 'source #f))
 226          (files (if s-index (list-tail %argv (+ s-index 1))
 227                     (option-ref options '() '())))
 228          (help? (option-ref options 'help #f))
 229          (usage? #f)
 230          (version? (option-ref options 'version #f)))
 231     (or
 232      (and version?
 233           (display (string-append "mes (GNU Mes) " %version "\n"))
 234           (exit 0))
 235      (and (or help? usage?)
 236           (display "Usage: mes [OPTION]... [FILE]...
 237 Evaluate code with Mes, interactively or from a script.
 238
 239   [-s] FILE            load source code from FILE, and exit
 240   -c EXPR              evalute expression EXPR, and exit
 241   --                   stop scanning arguments; run interactively
 242
 243 The above switches stop argument processing, and pass all
 244 remaining arguments as the value of (command-line).
 245
 246   -e, --main=MAIN      after reading script, apply MAIN to command-line arguments
 247   -h, --help           display this help and exit
 248   -L, --load-path=DIR  add DIR to the front of the module load path
 249   -v, --version        display version information and exit
 250
 251 Ignored for Guile compatibility:
 252   --auto-compile
 253   --fresh-auto-compile
 254   --no-auto-compile
 255   -C, --compiled-path=DIR
 256
 257 Report bugs to: bug-mes@gnu.org
 258 GNU Mes home page: <http://gnu.org/software/mes/>
 259 General help using GNU software: <http://gnu.org/gethelp/>
 260 " (or (and usage? (current-error-port)) (current-output-port)))
 261           (exit (or (and usage? 2) 0)))
 262      options)
 263     (and=> (option-ref options 'load-path #f)
 264            (lambda (dir)
 265              (setenv "GUILE_LOAD_PATH" (string-append dir ":" (getenv "GUILE_LOAD_PATH")))))
 266     (when command
 267       (let* ((prev (set-current-input-port (open-input-string command)))
 268              (expr (cons 'begin (read-input-file-env (current-module))))
 269              (set-current-input-port prev))
 270         (primitive-eval expr)
 271         (exit 0)))
 272     (when main (set! %main main))
 273     (cond ((pair? files)
 274            (let* ((file (car files))
 275                   (port (if (equal? file "-") 0
 276                             (open-input-file file))))
 277              (set! %argv files)
 278              (set-current-input-port port)))
 279           ((and (null? files) tty?)
 280
 281            (mes-use-module (mes repl))
 282            (set-current-input-port 0)
 283            (repl))
 284           (else #t))))
 285 (primitive-load 0)
 286 (primitive-load (open-input-string %main))