From 472624f79909f2c816df1b5b2b31e9654d71d6ff Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sun, 17 Nov 2019 09:10:46 +0100 Subject: [PATCH] boot modules WIP --- mes/module/ice-9/optargs.scm | 499 ++++++++++++++++++ mes/module/mes/boot-0.scm | 121 +---- mes/module/mes/boot-03.scm | 12 +- mes/module/mes/boot-5.mes | 183 +++++++ mes/module/mes/guile.mes | 30 +- .../mes/{boot-module.scm => guile/module.mes} | 41 +- mes/module/mes/main.mes | 116 ++++ mes/module/srfi/srfi-1.mes | 3 + mes/module/srfi/srfi-1.scm | 1 + module/system/base/pmatch.scm | 84 +++ src/eval-apply.c | 2 +- src/module.c | 2 +- tests/display.test | 8 +- 13 files changed, 935 insertions(+), 167 deletions(-) create mode 100644 mes/module/ice-9/optargs.scm create mode 100644 mes/module/mes/boot-5.mes rename mes/module/mes/{boot-module.scm => guile/module.mes} (99%) create mode 100644 mes/module/mes/main.mes create mode 100644 module/system/base/pmatch.scm diff --git a/mes/module/ice-9/optargs.scm b/mes/module/ice-9/optargs.scm new file mode 100644 index 00000000..da94ceda --- /dev/null +++ b/mes/module/ice-9/optargs.scm @@ -0,0 +1,499 @@ +;;;; optargs.scm -- support for optional arguments +;;;; +;;;; Copyright (C) 1997, 1998, 1999, 2001, 2002, 2004, 2006 Free Software Foundation, Inc. +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA +;;;; +;;;; Contributed by Maciej Stachowiak + + + +;;; Commentary: + +;;; {Optional Arguments} +;;; +;;; The C interface for creating Guile procedures has a very handy +;;; "optional argument" feature. This module attempts to provide +;;; similar functionality for procedures defined in Scheme with +;;; a convenient and attractive syntax. +;;; +;;; exported macros are: +;;; let-optional +;;; let-optional* +;;; let-keywords +;;; let-keywords* +;;; lambda* +;;; define* +;;; define*-public +;;; defmacro* +;;; defmacro*-public +;;; +;;; +;;; Summary of the lambda* extended parameter list syntax (brackets +;;; are used to indicate grouping only): +;;; +;;; ext-param-list ::= [identifier]* [#:optional [ext-var-decl]+]? +;;; [#:key [ext-var-decl]+ [#:allow-other-keys]?]? +;;; [[#:rest identifier]|[. identifier]]? +;;; +;;; ext-var-decl ::= identifier | ( identifier expression ) +;;; +;;; The characters `*', `+' and `?' are not to be taken literally; they +;;; mean respectively, zero or more occurences, one or more occurences, +;;; and one or zero occurences. +;;; + +;;; Code: + +(define-module (ice-9 optargs) + #:use-module (system base pmatch) + #:replace (lambda*) + #:export-syntax (let-optional + let-optional* + let-keywords + let-keywords* + define* + define*-public + defmacro* + defmacro*-public)) + +;; let-optional rest-arg (binding ...) . body +;; let-optional* rest-arg (binding ...) . body +;; macros used to bind optional arguments +;; +;; These two macros give you an optional argument interface that is +;; very "Schemey" and introduces no fancy syntax. They are compatible +;; with the scsh macros of the same name, but are slightly +;; extended. Each of binding may be of one of the forms or +;; ( ). rest-arg should be the rest-argument of +;; the procedures these are used from. The items in rest-arg are +;; sequentially bound to the variable namess are given. When rest-arg +;; runs out, the remaining vars are bound either to the default values +;; or to `#f' if no default value was specified. rest-arg remains +;; bound to whatever may have been left of rest-arg. +;; + +(defmacro let-optional (REST-ARG BINDINGS . BODY) + (let-optional-template REST-ARG BINDINGS BODY 'let)) + +(defmacro let-optional* (REST-ARG BINDINGS . BODY) + (let-optional-template REST-ARG BINDINGS BODY 'let*)) + + + +;; let-keywords rest-arg allow-other-keys? (binding ...) . body +;; let-keywords* rest-arg allow-other-keys? (binding ...) . body +;; macros used to bind keyword arguments +;; +;; These macros pick out keyword arguments from rest-arg, but do not +;; modify it. This is consistent at least with Common Lisp, which +;; duplicates keyword args in the rest arg. More explanation of what +;; keyword arguments in a lambda list look like can be found below in +;; the documentation for lambda*. Bindings can have the same form as +;; for let-optional. If allow-other-keys? is false, an error will be +;; thrown if anything that looks like a keyword argument but does not +;; match a known keyword parameter will result in an error. +;; + + +(defmacro let-keywords (REST-ARG ALLOW-OTHER-KEYS? BINDINGS . BODY) + (let-keywords-template REST-ARG ALLOW-OTHER-KEYS? BINDINGS BODY 'let)) + +(defmacro let-keywords* (REST-ARG ALLOW-OTHER-KEYS? BINDINGS . BODY) + (let-keywords-template REST-ARG ALLOW-OTHER-KEYS? BINDINGS BODY 'let*)) + + +;; some utility procedures for implementing the various let-forms. + +(define (let-o-k-template REST-ARG BINDINGS BODY let-type proc) + (let ((bindings (map (lambda (x) + (if (list? x) + x + (list x #f))) + BINDINGS))) + `(,let-type ,(map proc bindings) ,@BODY))) + +(define (let-optional-template REST-ARG BINDINGS BODY let-type) + (if (null? BINDINGS) + `(let () ,@BODY) + (let-o-k-template REST-ARG BINDINGS BODY let-type + (lambda (optional) + `(,(car optional) + (cond + ((not (null? ,REST-ARG)) + (let ((result (car ,REST-ARG))) + ,(list 'set! REST-ARG + `(cdr ,REST-ARG)) + result)) + (else + ,(cadr optional)))))))) + +(define (let-keywords-template REST-ARG ALLOW-OTHER-KEYS? BINDINGS BODY let-type) + (if (null? BINDINGS) + `(let () ,@BODY) + (let* ((kb-list-gensym (gensym "kb:G")) + (bindfilter (lambda (key) + `(,(car key) + (cond + ((assq ',(car key) ,kb-list-gensym) + => cdr) + (else + ,(cadr key))))))) + `(let ((,kb-list-gensym ((if (not mes?) (@@ (mes optargs) rest-arg->keyword-binding-list) + rest-arg->keyword-binding-list) + ,REST-ARG ',(map (lambda (x) (symbol->keyword (if (pair? x) (car x) x))) + BINDINGS) + ,ALLOW-OTHER-KEYS?))) + ,(let-o-k-template REST-ARG BINDINGS BODY let-type bindfilter))))) + +(define (rest-arg->keyword-binding-list rest-arg keywords allow-other-keys?) + (if (null? rest-arg) + '() + (let loop ((first (car rest-arg)) + (rest (cdr rest-arg)) + (accum '())) + (let ((next (lambda (a) + (if (null? (cdr rest)) + a + (loop (cadr rest) (cddr rest) a))))) + (if (keyword? first) + (cond + ((memq first keywords) + (if (null? rest) + (error "Keyword argument has no value:" first) + (next (cons (cons (keyword->symbol first) + (car rest)) accum)))) + ((not allow-other-keys?) + (error "Unknown keyword in arguments:" first)) + (else (if (null? rest) + accum + (next accum)))) + (if (null? rest) + accum + (loop (car rest) (cdr rest) accum))))))) + + +;; lambda* args . body +;; lambda extended for optional and keyword arguments +;; +;; lambda* creates a procedure that takes optional arguments. These +;; are specified by putting them inside brackets at the end of the +;; paramater list, but before any dotted rest argument. For example, +;; (lambda* (a b #:optional c d . e) '()) +;; creates a procedure with fixed arguments a and b, optional arguments c +;; and d, and rest argument e. If the optional arguments are omitted +;; in a call, the variables for them are bound to `#f'. +;; +;; lambda* can also take keyword arguments. For example, a procedure +;; defined like this: +;; (lambda* (#:key xyzzy larch) '()) +;; can be called with any of the argument lists (#:xyzzy 11) +;; (#:larch 13) (#:larch 42 #:xyzzy 19) (). Whichever arguments +;; are given as keywords are bound to values. +;; +;; Optional and keyword arguments can also be given default values +;; which they take on when they are not present in a call, by giving a +;; two-item list in place of an optional argument, for example in: +;; (lambda* (foo #:optional (bar 42) #:key (baz 73)) (list foo bar baz)) +;; foo is a fixed argument, bar is an optional argument with default +;; value 42, and baz is a keyword argument with default value 73. +;; Default value expressions are not evaluated unless they are needed +;; and until the procedure is called. +;; +;; lambda* now supports two more special parameter list keywords. +;; +;; lambda*-defined procedures now throw an error by default if a +;; keyword other than one of those specified is found in the actual +;; passed arguments. However, specifying #:allow-other-keys +;; immediately after the keyword argument declarations restores the +;; previous behavior of ignoring unknown keywords. lambda* also now +;; guarantees that if the same keyword is passed more than once, the +;; last one passed is the one that takes effect. For example, +;; ((lambda* (#:key (heads 0) (tails 0)) (display (list heads tails))) +;; #:heads 37 #:tails 42 #:heads 99) +;; would result in (99 47) being displayed. +;; +;; #:rest is also now provided as a synonym for the dotted syntax rest +;; argument. The argument lists (a . b) and (a #:rest b) are equivalent in +;; all respects to lambda*. This is provided for more similarity to DSSSL, +;; MIT-Scheme and Kawa among others, as well as for refugees from other +;; Lisp dialects. + + +(defmacro lambda* (ARGLIST . BODY) + (parse-arglist + ARGLIST + (lambda (non-optional-args optionals keys aok? rest-arg) + ;; Check for syntax errors. + (if (not (every? symbol? non-optional-args)) + (error "Syntax error in fixed argument declaration.")) + (if (not (every? ext-decl? optionals)) + (error "Syntax error in optional argument declaration.")) + (if (not (every? ext-decl? keys)) + (error "Syntax error in keyword argument declaration.")) + (if (not (or (symbol? rest-arg) (eq? #f rest-arg))) + (error "Syntax error in rest argument declaration.")) + ;; generate the code. + (let ((rest-gensym (or rest-arg (gensym "lambda*:G"))) + (lambda-gensym (gensym "lambda*:L"))) + (if (not (and (null? optionals) (null? keys))) + `(let ((,lambda-gensym + (lambda (,@non-optional-args . ,rest-gensym) + ;; Make sure that if the proc had a docstring, we put it + ;; here where it will be visible. + ,@(if (and (not (null? BODY)) + (string? (car BODY))) + (list (car BODY)) + '()) + (let-optional* + ,rest-gensym + ,optionals + (let-keywords* ,rest-gensym + ,aok? + ,keys + ,@(if (and (not rest-arg) (null? keys)) + `((if (not (null? ,rest-gensym)) + (error "Too many arguments."))) + '()) + (let () + ,@BODY)))))) + (set-procedure-property! ,lambda-gensym 'arglist + '(,non-optional-args + ,optionals + ,keys + ,aok? + ,rest-arg)) + ,lambda-gensym) + `(lambda (,@non-optional-args . ,(if rest-arg rest-arg '())) + ,@BODY)))))) + + +(define (every? pred lst) + (or (null? lst) + (and (pred (car lst)) + (every? pred (cdr lst))))) + +(define (ext-decl? obj) + (or (symbol? obj) + (and (list? obj) (= 2 (length obj)) (symbol? (car obj))))) + +;; XXX - not tail recursive +(define (improper-list-copy obj) + (if (pair? obj) + (cons (car obj) (improper-list-copy (cdr obj))) + obj)) + +(define (parse-arglist arglist cont) + (define (split-list-at val lst cont) + (cond + ((memq val lst) + => (lambda (pos) + (if (memq val (cdr pos)) + (error (with-output-to-string + (lambda () + (map display `(,val + " specified more than once in argument list."))))) + (cont (reverse (cdr (memq val (reverse lst)))) (cdr pos) #t)))) + (else (cont lst '() #f)))) + (define (parse-opt-and-fixed arglist keys aok? rest cont) + (split-list-at + #:optional arglist + (lambda (before after split?) + (if (and split? (null? after)) + (error "#:optional specified but no optional arguments declared.") + (cont before after keys aok? rest))))) + (define (parse-keys arglist rest cont) + (split-list-at + #:allow-other-keys arglist + (lambda (aok-before aok-after aok-split?) + (if (and aok-split? (not (null? aok-after))) + (error "#:allow-other-keys not at end of keyword argument declarations.") + (split-list-at + #:key aok-before + (lambda (key-before key-after key-split?) + (cond + ((and aok-split? (not key-split?)) + (error "#:allow-other-keys specified but no keyword arguments declared.")) + (key-split? + (cond + ((null? key-after) (error "#:key specified but no keyword arguments declared.")) + ((memq #:optional key-after) (error "#:optional arguments declared after #:key arguments.")) + (else (parse-opt-and-fixed key-before key-after aok-split? rest cont)))) + (else (parse-opt-and-fixed arglist '() #f rest cont))))))))) + (define (parse-rest arglist cont) + (cond + ((null? arglist) (cont '() '() '() #f #f)) + ((not (pair? arglist)) (cont '() '() '() #f arglist)) + ((not (list? arglist)) + (let* ((copy (improper-list-copy arglist)) + (lp (last-pair copy)) + (ra (cdr lp))) + (set-cdr! lp '()) + (if (memq #:rest copy) + (error "Cannot specify both #:rest and dotted rest argument.") + (parse-keys copy ra cont)))) + (else (split-list-at + #:rest arglist + (lambda (before after split?) + (if split? + (case (length after) + ((0) (error "#:rest not followed by argument.")) + ((1) (parse-keys before (car after) cont)) + (else (error "#:rest argument must be declared last."))) + (parse-keys before #f cont))))))) + + (parse-rest arglist cont)) + + + +;; define* args . body +;; define*-public args . body +;; define and define-public extended for optional and keyword arguments +;; +;; define* and define*-public support optional arguments with +;; a similar syntax to lambda*. They also support arbitrary-depth +;; currying, just like Guile's define. Some examples: +;; (define* (x y #:optional a (z 3) #:key w . u) (display (list y z u))) +;; defines a procedure x with a fixed argument y, an optional agument +;; a, another optional argument z with default value 3, a keyword argument w, +;; and a rest argument u. +;; (define-public* ((foo #:optional bar) #:optional baz) '()) +;; This illustrates currying. A procedure foo is defined, which, +;; when called with an optional argument bar, returns a procedure that +;; takes an optional argument baz. +;; +;; Of course, define*[-public] also supports #:rest and #:allow-other-keys +;; in the same way as lambda*. + +(defmacro define* (ARGLIST . BODY) + (define*-guts 'define ARGLIST BODY)) + +(defmacro define*-public (ARGLIST . BODY) + (define*-guts 'define-public ARGLIST BODY)) + +;; The guts of define* and define*-public. +(define (define*-guts DT ARGLIST BODY) + (define (nest-lambda*s arglists) + (if (null? arglists) + BODY + `((lambda* ,(car arglists) ,@(nest-lambda*s (cdr arglists)))))) + (define (define*-guts-helper ARGLIST arglists) + (let ((first (car ARGLIST)) + (al (cons (cdr ARGLIST) arglists))) + (if (symbol? first) + `(,DT ,first ,@(nest-lambda*s al)) + (define*-guts-helper first al)))) + (if (symbol? ARGLIST) + `(,DT ,ARGLIST ,@BODY) + (define*-guts-helper ARGLIST '()))) + + + +;; defmacro* name args . body +;; defmacro*-public args . body +;; defmacro and defmacro-public extended for optional and keyword arguments +;; +;; These are just like defmacro and defmacro-public except that they +;; take lambda*-style extended paramter lists, where #:optional, +;; #:key, #:allow-other-keys and #:rest are allowed with the usual +;; semantics. Here is an example of a macro with an optional argument: +;; (defmacro* transmorgify (a #:optional b) + +(defmacro defmacro* (NAME ARGLIST . BODY) + `(define-macro ,NAME #f (lambda* ,ARGLIST ,@BODY))) + +(defmacro defmacro*-public (NAME ARGLIST . BODY) + `(begin + (defmacro* ,NAME ,ARGLIST ,@BODY) + (export-syntax ,NAME))) + +;;; Support for optional & keyword args with the interpreter. +(define *uninitialized* (list 'uninitialized)) +(define (parse-lambda-case spec inits predicate args) + (pmatch spec + ((,nreq ,nopt ,rest-idx ,nargs ,allow-other-keys? ,kw-indices) + (define (req args prev tail n) + (cond + ((zero? n) + (if prev (set-cdr! prev '())) + (let ((slots-tail (make-list (- nargs nreq) *uninitialized*))) + (opt (if prev (append! args slots-tail) slots-tail) + slots-tail tail nopt inits))) + ((null? tail) + #f) ;; fail + (else + (req args tail (cdr tail) (1- n))))) + (define (opt slots slots-tail args-tail n inits) + (cond + ((zero? n) + (rest-or-key slots slots-tail args-tail inits rest-idx)) + ((null? args-tail) + (set-car! slots-tail (apply (car inits) slots)) + (opt slots (cdr slots-tail) '() (1- n) (cdr inits))) + (else + (set-car! slots-tail (car args-tail)) + (opt slots (cdr slots-tail) (cdr args-tail) (1- n) (cdr inits))))) + (define (rest-or-key slots slots-tail args-tail inits rest-idx) + (cond + (rest-idx + ;; it has to be this way, vars are allocated in this order + (set-car! slots-tail args-tail) + (if (pair? kw-indices) + (key slots (cdr slots-tail) args-tail inits) + (rest-or-key slots (cdr slots-tail) '() inits #f))) + ((pair? kw-indices) + ;; fail early here, because once we're in keyword land we throw + ;; errors instead of failing + (and (or (null? args-tail) rest-idx (keyword? (car args-tail))) + (key slots slots-tail args-tail inits))) + ((pair? args-tail) + #f) ;; fail + (else + (pred slots)))) + (define (key slots slots-tail args-tail inits) + (cond + ((null? args-tail) + (if (null? inits) + (pred slots) + (begin + (if (eq? (car slots-tail) *uninitialized*) + (set-car! slots-tail (apply (car inits) slots))) + (key slots (cdr slots-tail) '() (cdr inits))))) + ((not (keyword? (car args-tail))) + (if rest-idx + ;; no error checking, everything goes to the rest.. + (key slots slots-tail '() inits) + (error "bad keyword argument list" args-tail))) + ((and (keyword? (car args-tail)) + (pair? (cdr args-tail)) + (assq-ref kw-indices (car args-tail))) + => (lambda (i) + (list-set! slots i (cadr args-tail)) + (key slots slots-tail (cddr args-tail) inits))) + ((and (keyword? (car args-tail)) + (pair? (cdr args-tail)) + allow-other-keys?) + (key slots slots-tail (cddr args-tail) inits)) + (else (error "unrecognized keyword" args-tail)))) + (define (pred slots) + (cond + (predicate + (if (apply predicate slots) + slots + #f)) + (else slots))) + (let ((args (list-copy args))) + (req args #f args nreq))) + (else (error "unexpected spec" spec)))) diff --git a/mes/module/mes/boot-0.scm b/mes/module/mes/boot-0.scm index b701ef02..6a81c6fc 100644 --- a/mes/module/mes/boot-0.scm +++ b/mes/module/mes/boot-0.scm @@ -96,6 +96,9 @@ (define-macro (mes-use-module module) #t) + +(define-macro (define-module module . rest) + #t) ;; end boot-02.scm ;; boot-03.scm @@ -165,127 +168,17 @@ (mes-use-module (mes quasiquote)) (mes-use-module (mes let)) (mes-use-module (mes scm)) - -(define-macro (define-module module . rest) - `(if ,(and (pair? module) - (= 1 (length module)) - (symbol? (car module))) - (define (,(car module) . arguments) (main (command-line))))) - -(define-macro (use-modules . rest) #t) ;; end boot-03.scm -(define (effective-version) %version) - (mes-use-module (srfi srfi-1)) (mes-use-module (srfi srfi-13)) (mes-use-module (mes fluids)) (mes-use-module (mes catch)) (mes-use-module (mes posix)) +(mes-use-module (mes guile)) +;; end boot-04.scm -(define-macro (include-from-path file) - (let loop ((path (cons* %moduledir "module" (string-split (or (getenv "GUILE_LOAD_PATH") "") #\:)))) - (cond ((and=> (getenv "MES_DEBUG") (compose (lambda (o) (> o 2)) string->number)) - (core:display-error (string-append "include-from-path: " file " [PATH:" (string-join path ":") "]\n"))) - ((and=> (getenv "MES_DEBUG") (compose (lambda (o) (> o 1)) string->number)) - (core:display-error (string-append "include-from-path: " file "\n")))) - (if (null? path) (error "include-from-path: not found: " file) - (let ((file (string-append (car path) "/" file))) - (if (access? file R_OK) `(load ,file) - (loop (cdr path))))))) - -(define-macro (define-module module . rest) - `(if ,(and (pair? module) - (= 1 (length module)) - (symbol? (car module))) - (define (,(car module) . arguments) (main (command-line))))) - -(define-macro (use-modules . rest) #t) - -(mes-use-module (mes getopt-long)) - -(define %main #f) -(primitive-load 0) -(let ((tty? (isatty? 0))) - (define (parse-opts args) - (let* ((option-spec - '((no-auto-compile) - (command (single-char #\c) (value #t)) - (compiled-path (single-char #\C) (value #t)) - (help (single-char #\h)) - (load-path (single-char #\L) (value #t)) - (main (single-char #\e) (value #t)) - (source (single-char #\s) (value #t)) - (version (single-char #\v)) - (version (single-char #\V))))) - (getopt-long args option-spec #:stop-at-first-non-option #t))) - (define (source-arg? o) - (equal? "-s" o)) - (let* ((s-index (list-index source-arg? %argv)) - (args (if s-index (list-head %argv (+ s-index 2)) %argv)) - (options (parse-opts args)) - (command (option-ref options 'command #f)) - (main (option-ref options 'main #f)) - (source (option-ref options 'source #f)) - (files (if s-index (list-tail %argv (+ s-index 1)) - (option-ref options '() '()))) - (help? (option-ref options 'help #f)) - (usage? #f) - (version? (option-ref options 'version #f))) - (or - (and version? - (display (string-append "mes (GNU Mes) " %version "\n")) - (exit 0)) - (and (or help? usage?) - (display "Usage: mes [OPTION]... [FILE]... -Scheme interpreter for bootstrapping the GNU system. - -Options: - [-s] FILE load source code from FILE, and exit - -c EXPR evaluate expression EXPR, and exit - -- stop scanning arguments; run interactively - -The above switches stop argument processing, and pass all -remaining arguments as the value of (command-line). - - -e, --main=MAIN after reading script, apply MAIN to command-line arguments - -h, --help display this help and exit - -L, --load-path=DIR add DIR to the front of the module load path - -v, --version display version information and exit - -Ignored for Guile compatibility: - --auto-compile - --fresh-auto-compile - --no-auto-compile - -C, --compiled-path=DIR - -Report bugs to: bug-mes@gnu.org -GNU Mes home page: -General help using GNU software: -" (or (and usage? (current-error-port)) (current-output-port))) - (exit (or (and usage? 2) 0))) - options) - (and=> (option-ref options 'load-path #f) - (lambda (dir) - (setenv "GUILE_LOAD_PATH" (string-append dir ":" (getenv "GUILE_LOAD_PATH"))))) - (when command - (let* ((prev (set-current-input-port (open-input-string command))) - (expr (cons 'begin (read-input-file-env (current-module)))) - (set-current-input-port prev)) - (primitive-eval expr) - (exit 0))) - (when main (set! %main main)) - (cond ((pair? files) - (let* ((file (car files)) - (port (if (equal? file "-") 0 - (open-input-file file)))) - (set! %argv files) - (set-current-input-port port))) - ((and (null? files) tty?) - - (mes-use-module (mes repl)) - (set-current-input-port 0) - (repl)) - (else #t)))) +(mes-use-module (mes main)) +(top-main) (primitive-load 0) (primitive-load (open-input-string %main)) diff --git a/mes/module/mes/boot-03.scm b/mes/module/mes/boot-03.scm index 6b80c05a..e2c7ce53 100644 --- a/mes/module/mes/boot-03.scm +++ b/mes/module/mes/boot-03.scm @@ -96,6 +96,9 @@ (define-macro (mes-use-module module) #t) + +(define-macro (define-module module . rest) + #t) ;; end boot-02.scm ;; boot-03.scm @@ -162,14 +165,7 @@ (mes-use-module (mes quasiquote)) (mes-use-module (mes let)) (mes-use-module (mes scm)) - -(define-macro (define-module module . rest) - `(if ,(and (pair? module) - (= 1 (length module)) - (symbol? (car module))) - (define (,(car module) . arguments) (main (command-line))))) - -(define-macro (use-modules . rest) #t) ;; end boot-03.scm + (primitive-load 0) (primitive-load 0) diff --git a/mes/module/mes/boot-5.mes b/mes/module/mes/boot-5.mes new file mode 100644 index 00000000..44452682 --- /dev/null +++ b/mes/module/mes/boot-5.mes @@ -0,0 +1,183 @@ +;;; -*-scheme-*- + +;;; GNU Mes --- Maxwell Equations of Software +;;; Copyright © 2016,2017,2018,2019 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of GNU Mes. +;;; +;;; GNU Mes is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Mes is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Mes. If not, see . + +;;; Commentary: + +;;; read-0.mes - bootstrap reader. This file is read by a minimal +;;; core reader. It only supports s-exps and line-comments; quotes, +;;; character literals, string literals cannot be used here. + +;;; Code: + +;; boot-00.scm +(define mes %version) + +(define (defined? x) + (lookup-handle x #f)) + +(define (cond-expand-expander clauses) + (if (defined? (car (car clauses))) + (cdr (car clauses)) + (cond-expand-expander (cdr clauses)))) + +(define-macro (cond-expand . clauses) + (cons 'begin (cond-expand-expander clauses))) +;; end boot-00.scm + +;; boot-01.scm +(define (not x) (if x #f #t)) + +(define (display x . rest) + (if (null? rest) (core:display x) + (core:display-port x (car rest)))) + +(define (write x . rest) + (if (null? rest) (core:write x) + (core:write-port x (car rest)))) + +(define (newline . rest) + (core:display "\n")) + +(define (cadr x) (car (cdr x))) + +(define (map1 f lst) + (if (null? lst) (list) + (cons (f (car lst)) (map1 f (cdr lst))))) + +(define (map f lst) + (if (null? lst) (list) + (cons (f (car lst)) (map f (cdr lst))))) + +(define (cons* . rest) + (if (null? (cdr rest)) (car rest) + (cons (car rest) (core:apply cons* (cdr rest) (current-module))))) + +(define (apply f h . t) + (if (null? t) (core:apply f h (current-module)) + (apply f (apply cons* (cons h t))))) + +(define (append . rest) + (if (null? rest) '() + (if (null? (cdr rest)) (car rest) + (append2 (car rest) (apply append (cdr rest)))))) +;; end boot-01.scm + +;; boot-02.scm +(define-macro (and . x) + (if (null? x) #t + (if (null? (cdr x)) (car x) + (list (quote if) (car x) (cons (quote and) (cdr x)) + #f)))) + +(define-macro (or . x) + (if (null? x) #f + (if (null? (cdr x)) (car x) + (list (list (quote lambda) (list (quote r)) + (list (quote if) (quote r) (quote r) + (cons (quote or) (cdr x)))) + (car x))))) + +(define-macro (mes-use-module module) + #t) + +(define-macro (define-module module . rest) + #t) +;; end boot-02.scm + +;; boot-03.scm +(define guile? #f) +(define mes? #t) +(define (primitive-eval e) (core:eval e (current-module))) +(define eval core:eval) + +(define (port-filename port) "") +(define (port-line port) 0) +(define (port-column port) 0) +(define (ftell port) 0) +(define (false-if-exception x) x) + +(define (cons* . rest) + (if (null? (cdr rest)) (car rest) + (cons (car rest) (core:apply cons* (cdr rest) (current-module))))) + +(define (apply f h . t) + (if (null? t) (core:apply f h (current-module)) + (apply f (apply cons* (cons h t))))) + +(define-macro (load file) + (list 'begin + (list 'if (list 'and (list getenv "MES_DEBUG") + (list not (list equal2? (list getenv "MES_DEBUG") "0")) + (list not (list equal2? (list getenv "MES_DEBUG") "1"))) + (list 'begin + (list core:display-error ";;; read ") + (list core:display-error file) + (list core:display-error "\n"))) + (list 'primitive-load file))) + +(define-macro (include file) (list 'load file)) + +(define (append . rest) + (if (null? rest) '() + (if (null? (cdr rest)) (car rest) + (append2 (car rest) (apply append (cdr rest)))))) + +(define %moduledir (string-append %datadir "/module/")) + +(include (string-append %moduledir "mes/type-0.mes")) + +(if (and (getenv "MES_DEBUG") + (not (equal2? (getenv "MES_DEBUG") "0")) + (not (equal2? (getenv "MES_DEBUG") "1"))) + (begin + (core:display-error ";;; %moduledir=") + (core:display-error %moduledir) + (core:display-error "\n"))) + +(define-macro (include-from-path file) + (list 'load (list string-append %moduledir file))) + +(define (string-join lst infix) + (if (null? lst) "" + (if (null? (cdr lst)) (car lst) + (string-append (car lst) infix (string-join (cdr lst) infix))))) + +(include-from-path "mes/module.mes") + +(mes-use-module (mes base)) +(mes-use-module (mes quasiquote)) +(mes-use-module (mes let)) +(mes-use-module (mes scm)) +;; end boot-03.scm + +(mes-use-module (srfi srfi-1)) +(mes-use-module (srfi srfi-13)) +(mes-use-module (mes fluids)) +(mes-use-module (mes catch)) +(mes-use-module (mes posix)) +(mes-use-module (mes guile)) +;; end boot-04.mes + +;; FIXME: need no load before booting guile module -- srfi-1 stuff +(mes-use-module (mes getopt-long)) +(mes-use-module (mes main)) + +(mes-use-module (srfi srfi-9)) +(mes-use-module (mes guile module)) diff --git a/mes/module/mes/guile.mes b/mes/module/mes/guile.mes index 42ac445e..ec5c880b 100644 --- a/mes/module/mes/guile.mes +++ b/mes/module/mes/guile.mes @@ -22,10 +22,36 @@ ;;; Code: -(mes-use-module (srfi srfi-13)) - (define-macro (cond-expand-provide . rest) #t) +(define-macro (include-from-path file) + (let loop ((path (cons* %moduledir "module" (string-split (or (getenv "GUILE_LOAD_PATH") "") #\:)))) + (cond ((and=> (getenv "MES_DEBUG") (compose (lambda (o) (> o 2)) string->number)) + (core:display-error (string-append "include-from-path: " file " [PATH:" (string-join path ":") "]\n"))) + ((and=> (getenv "MES_DEBUG") (compose (lambda (o) (> o 1)) string->number)) + (core:display-error (string-append "include-from-path: " file "\n")))) + (if (null? path) (error "include-from-path: not found: " file) + (let ((file (string-append (car path) "/" file))) + (if (access? file R_OK) `(load ,file) + (loop (cdr path))))))) + +(define-macro (define-module module . rest) + `(if ,(and (pair? module) + (= 1 (length module)) + (symbol? (car module))) + (define (,(car module) . arguments) (main (command-line))))) + +(define-macro (defmacro name args . body) + `(define-macro ,(cons name args) ,@body)) + +(define-macro (set-procedure-property! proc key value) + proc) + +(define-macro (use-modules . rest) #t) + +(define (effective-version) %version) + +(mes-use-module (srfi srfi-13)) (mes-use-module (mes catch)) (mes-use-module (mes posix)) (mes-use-module (srfi srfi-16)) diff --git a/mes/module/mes/boot-module.scm b/mes/module/mes/guile/module.mes similarity index 99% rename from mes/module/mes/boot-module.scm rename to mes/module/mes/guile/module.mes index db1e3333..8bea9bce 100644 --- a/mes/module/mes/boot-module.scm +++ b/mes/module/mes/guile/module.mes @@ -1,3 +1,5 @@ +;;; -*-scheme-*- + ;;; GNU Mes --- Maxwell Equations of Software ;;; Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007 ;;; Free Software Foundation, Inc. @@ -21,7 +23,7 @@ ;;; Commentary: -;;; boot-module.mes taken from GNU Guile 1.8 boot-9.scm +;;; guile/module.mes taken from GNU Guile 1.8 boot-9.scm ;;; This is experimental code for proper Guile module load support. ;;; This file is the first thing loaded into Guile. It adds many mundane @@ -32,8 +34,6 @@ ;;; Code: -(mes-use-module (mes simple-format)) - (define (module? x) (display "core:module?\n")) @@ -2746,39 +2746,6 @@ ;;; Place the user in the guile-user module. ;;; -;;;(define-module (guile-user)) +(define-module (guile-user)) ;;; boot-9.scm ends here - -(display "===============================\n") -;;(define-module (guile-user) #:use-module (boo)) -(define-module (guile-user) - #:use-module (boo)) - -(display "\nnow in guile-user\n") -(display "keil-user: ") -(write *current-module*) -(display "\n") -(display "ZEE-MODULE:") -(display ((module-ref (guile:current-module) 'ZEE-MODULE))) -;; (display (module-ref (resolve-module '(boo)) 'ZEE-MODULE)) -;; (display "\n") -;; (ZEE-MODULE) -(display "\n") -(display "bah: ") -(display (module-ref (guile:current-module) 'bah)) -;;(display bah) -(display "\n") - - -(display "===> ZEE\n") -(display ZEE-MODULE) -(display "\n") - -(display "===> (ZEE)\n") -(display (ZEE-MODULE)) -(display "\n") - -(display "===> (foo-bar)\n") -(display (foo-bar)) -(display "\n") diff --git a/mes/module/mes/main.mes b/mes/module/mes/main.mes new file mode 100644 index 00000000..cb72e4b9 --- /dev/null +++ b/mes/module/mes/main.mes @@ -0,0 +1,116 @@ +;;; -*-scheme-*- + +;;; GNU Mes --- Maxwell Equations of Software +;;; Copyright © 2016,2017,2018,2019 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of GNU Mes. +;;; +;;; GNU Mes is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Mes is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Mes. If not, see . + +;;; Commentary: + +;;; Code: + +(mes-use-module (mes getopt-long)) + +(define %main #f) +(define (top-main) + (let ((tty? (isatty? 0))) + (define (parse-opts args) + (let* ((option-spec + '((no-auto-compile) + (command (single-char #\c) (value #t)) + (compiled-path (single-char #\C) (value #t)) + (help (single-char #\h)) + (load-path (single-char #\L) (value #t)) + (main (single-char #\e) (value #t)) + (source (single-char #\s) (value #t)) + (version (single-char #\V))))) + (getopt-long args option-spec #:stop-at-first-non-option #t))) + (define (source-arg? o) + (equal? "-s" o)) + (let* ((s-index (list-index source-arg? %argv)) + (args (if s-index (list-head %argv (+ s-index 2)) %argv)) + (options (parse-opts args)) + (command (option-ref options 'command #f)) + (main (option-ref options 'main #f)) + (source (option-ref options 'source #f)) + (files (if s-index (list-tail %argv (+ s-index 1)) + (option-ref options '() '()))) + (help? (option-ref options 'help #f)) + (usage? #f) + (version? (option-ref options 'version #f))) + (or + (and version? + (display (string-append "mes (GNU Mes) " %version "\n")) + (exit 0)) + (and (or help? usage?) + (display "Usage: mes [OPTION]... [FILE]... +Evaluate code with Mes, interactively or from a script. + + [-s] FILE load source code from FILE, and exit + -c EXPR evalute expression EXPR, and exit + -- stop scanning arguments; run interactively + +The above switches stop argument processing, and pass all +remaining arguments as the value of (command-line). + + -e, --main=MAIN after reading script, apply MAIN to command-line arguments + -h, --help display this help and exit + -L, --load-path=DIR add DIR to the front of the module load path + -v, --version display version information and exit + +Ignored for Guile compatibility: + --auto-compile + --fresh-auto-compile + --no-auto-compile + -C, --compiled-path=DIR + +Report bugs to: bug-mes@gnu.org +GNU Mes home page: +General help using GNU software: +" (or (and usage? (current-error-port)) (current-output-port))) + (exit (or (and usage? 2) 0))) + options) + (and=> (option-ref options 'load-path #f) + (lambda (dir) + (setenv "GUILE_LOAD_PATH" (string-append dir ":" (getenv "GUILE_LOAD_PATH"))))) + (when command + (let* ((prev (set-current-input-port (open-input-string command))) + (expr (cons 'begin (read-input-file-env (current-module)))) + (set-current-input-port prev)) + (primitive-eval expr) + (exit 0))) + (when main (set! %main main)) + (cond ((pair? files) + (display "pair!\n") + (let* ((file (car files)) + (port (if (equal? file "-") 0 + (open-input-file file)))) + (set! %argv files) + (set-current-input-port port) + (display "DUN\n") + )) + ((and (null? files) tty?) + + (mes-use-module (mes repl)) + (set-current-input-port 0) + (repl)) + (else #t)) + (display "top\n") + (display "**********************load hack:\n")))) + +(define (top-load *undefined*) + (primitive-load 0) + (primitive-load (open-input-string %main))) diff --git a/mes/module/srfi/srfi-1.mes b/mes/module/srfi/srfi-1.mes index 8a69b7bc..41eb7671 100644 --- a/mes/module/srfi/srfi-1.mes +++ b/mes/module/srfi/srfi-1.mes @@ -24,6 +24,9 @@ ;;; Code: +(define-module (srfi srfi-1) + #:export (find)) + (define (find pred lst) (let loop ((lst lst)) (if (null? lst) #f diff --git a/mes/module/srfi/srfi-1.scm b/mes/module/srfi/srfi-1.scm index f76d6f05..13cd5446 100644 --- a/mes/module/srfi/srfi-1.scm +++ b/mes/module/srfi/srfi-1.scm @@ -25,6 +25,7 @@ ;; Internal helper procedure. Map `f' over the single list `ls'. ;; + (define map1 map) (define (any pred ls . lists) diff --git a/module/system/base/pmatch.scm b/module/system/base/pmatch.scm new file mode 100644 index 00000000..30e5103a --- /dev/null +++ b/module/system/base/pmatch.scm @@ -0,0 +1,84 @@ +;;; pmatch, a simple matcher + +;;; GNU Mes --- Maxwell Equations of Software +;;; Copyright (C) 2009, 2010, 2012 Free Software Foundation, Inc +;;; Copyright (C) 2005,2006,2007 Oleg Kiselyov +;;; Copyright (C) 2007 Daniel P. Friedman +;;; Copyright (C) 2018 Jan (janneke) Nieuwenhuizen +;;; Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of GNU Mes. +;;; +;;; GNU Mes is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Mes is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Mes. If not, see . + +;;; Taken from GNU Guile + +;;; Originally written by Oleg Kiselyov for LeanTAP in Kanren, which is +;;; available under the MIT license. +;;; +;;; http://kanren.cvs.sourceforge.net/viewvc/kanren/kanren/mini/leanTAP.scm?view=log +;;; +;;; This version taken from: +;;; αKanren: A Fresh Name in Nominal Logic Programming +;;; by William E. Byrd and Daniel P. Friedman +;;; Proceedings of the 2007 Workshop on Scheme and Functional Programming +;;; Université Laval Technical Report DIUL-RT-0701 + +;;; To be clear: the original code is MIT-licensed, and the modifications +;;; made to it by Guile are under Guile's license (currently LGPL v3+). + +;;; Code: + +;; (pmatch exp ...[]) +;; ::= ( exp ...) +;; ::= (else exp ...) +;; ::= boolean exp | () +;; :: = +;; ,var -- matches always and binds the var +;; pattern must be linear! No check is done +;; _ -- matches always +;; 'exp -- comparison with exp (using equal?) REMOVED (August 8, 2012) +;; exp -- comparison with exp (using equal?) +;; ( ...) -- matches the list of patterns +;; ( . ) -- ditto +;; () -- matches the empty list + +(define-module (system base pmatch) + #:export-syntax (pmatch)) + +(define-syntax pmatch + (syntax-rules (else guard) + ((_ v) (if #f #f)) + ((_ v (else e0 e ...)) (let () e0 e ...)) + ((_ v (pat (guard g ...) e0 e ...) cs ...) + (let ((fk (lambda () (pmatch v cs ...)))) + (ppat v pat + (if (and g ...) (let () e0 e ...) (fk)) + (fk)))) + ((_ v (pat e0 e ...) cs ...) + (let ((fk (lambda () (pmatch v cs ...)))) + (ppat v pat (let () e0 e ...) (fk)))))) + +(define-syntax ppat + (syntax-rules (_ quote unquote) + ((_ v _ kt kf) kt) + ((_ v () kt kf) (if (null? v) kt kf)) + ((_ v (quote lit) kt kf) + (if (equal? v (quote lit)) kt kf)) + ((_ v (unquote var) kt kf) (let ((var v)) kt)) + ((_ v (x . y) kt kf) + (if (pair? v) + (ppat (pmatch-car v) x (ppat (pmatch-cdr v) y kt kf) kf) + kf)) + ((_ v lit kt kf) (if (eq? v (quote lit)) kt kf)))) diff --git a/src/eval-apply.c b/src/eval-apply.c index fe4cc8d3..5d2a2d70 100644 --- a/src/eval-apply.c +++ b/src/eval-apply.c @@ -673,7 +673,7 @@ eval: else if (global_p != 0) { handle = lookup_handle (name, cell_f); - if (g_debug > 0) + if (g_debug > 2) { eputs ("global set: "); write_error_ (name); diff --git a/src/module.c b/src/module.c index 55896664..8c020682 100644 --- a/src/module.c +++ b/src/module.c @@ -68,7 +68,7 @@ module_handle (struct scm *module, struct scm *name) /*:((internal)) */ { /* 1. Check module defines. */ struct scm *table = module_defines (module); - if (g_debug > 0) + if (g_debug > 2) { eputs ("module_handle:"); eputs (" name = "); diff --git a/tests/display.test b/tests/display.test index e17e8ab9..f649eede 100755 --- a/tests/display.test +++ b/tests/display.test @@ -1,7 +1,7 @@ #! /bin/sh +# -*-scheme-*- exec ${MES-bin/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests display)' -s "$0" "$@" !# - ;;; -*-scheme-*- ;;; GNU Mes --- Maxwell Equations of Software @@ -22,9 +22,9 @@ exec ${MES-bin/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests ;;; You should have received a copy of the GNU General Public License ;;; along with GNU Mes. If not, see . -(define-module (tests display) - #:use-module (mes mes-0) - #:use-module (mes test)) +;; (define-module (tests display) +;; #:use-module (mes mes-0) +;; #:use-module (mes test)) (mes-use-module (mes display)) (mes-use-module (mes guile))