diff --git a/check.sh b/check.sh index 7494c38e..6312cf08 100755 --- a/check.sh +++ b/check.sh @@ -1,5 +1,23 @@ #! /bin/sh +# Mes --- Maxwell Equations of Software +# Copyright © 2017,2018 Jan Nieuwenhuizen +# +# This file is part of Mes. +# +# 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. +# +# 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 Mes. If not, see . + export GUILE=${GUILE-guile} export MES=${MES-./mes} @@ -20,11 +38,12 @@ tests/srfi-14.test tests/optargs.test tests/fluids.test tests/catch.test -tests/psyntax.test +tests/record.test +tests/syntax.test tests/pmatch.test tests/let-syntax.test tests/guile.test -tests/record.test +tests/psyntax.test " slow=" diff --git a/make.scm b/make.scm index af2b0843..3302c07a 100755 --- a/make.scm +++ b/make.scm @@ -3,6 +3,24 @@ exec ${GUILE-guile} --no-auto-compile -L . -L guile -C . -C guile -s "$0" ${1+"$@"} !# +;;; Mes --- Maxwell Equations of Software +;;; Copyright © 2017,2018 Jan Nieuwenhuizen +;;; +;;; This file is part of Mes. +;;; +;;; 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. +;;; +;;; 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 Mes. If not, see . + (use-modules (srfi srfi-26) (guix shell-utils)) @@ -464,13 +482,14 @@ exec ${GUILE-guile} --no-auto-compile -L . -L guile -C . -C guile -s "$0" ${1+"$ "tests/optargs.test" "tests/fluids.test" "tests/catch.test" - "tests/psyntax.test" + "tests/record.test" + "tests/syntax.test" "tests/pmatch.test" "tests/let-syntax.test" "tests/guile.test" - "tests/record.test" - ;;sloooowwww - ;;"tests/match.test" + "tests/psyntax.test" + "tests/match.test" + ;;sloooowwww/broken? ;;"tests/peg.test" )) @@ -494,6 +513,8 @@ exec ${GUILE-guile} --no-auto-compile -L . -L guile -C . -C guile -s "$0" ${1+"$ ;; ...mes.guile passes :-) (for-each add-mes.guile-test mes-tests) +(add-target (group "check-tests" #:dependencies (filter (target-prefix? "check-tests/") %targets))) + ;; FIXME: run tests/base.test (setenv "MES" "src/mes.guile") @@ -543,6 +564,7 @@ exec ${GUILE-guile} --no-auto-compile -L . -L guile -C . -C guile -s "$0" ${1+"$ "module/mes/let.mes" "module/mes/match.mes" "module/mes/match.scm" + "module/mes/module.mes" "module/mes/optargs.mes" "module/mes/optargs.scm" "module/mes/peg.mes" diff --git a/module/mes/base-0.mes b/module/mes/base-0.mes index 0334cc28..7db153e5 100644 --- a/module/mes/base-0.mes +++ b/module/mes/base-0.mes @@ -1,7 +1,7 @@ ;;; -*-scheme-*- ;;; Mes --- Maxwell Equations of Software -;;; Copyright © 2016,2017 Jan Nieuwenhuizen +;;; Copyright © 2016,2017,2018 Jan Nieuwenhuizen ;;; ;;; This file is part of Mes. ;;; @@ -72,12 +72,10 @@ (define else #t) (define (cadr x) (car (cdr x))) -(define-macro (simple-let bindings . rest) - (cons (cons 'lambda (cons (map1 car bindings) rest)) - (map1 cadr bindings))) (define-macro (let bindings . rest) - (cons 'simple-let (cons bindings rest))) + (cons (cons 'lambda (cons (map1 car bindings) rest)) + (map1 cadr bindings))) (define *input-ports* '()) (define-macro (push! stack o) @@ -151,35 +149,17 @@ (if (null? (cdr lst)) (car lst) (string-append (car lst) infix (string-join (cdr lst) infix)))) -(define (module->file o) - (string-append (string-join (map1 symbol->string o) "/") ".mes")) - -(define *modules* '(mes/base-0.mes)) -(define (mes-load-module-env module a) - (push! *input-ports* (current-input-port)) - (set-current-input-port (open-input-file (string-append %moduledir (module->file module)))) - (let ((x (core:eval (append2 (cons 'begin (read-input-file-env a)) - '((current-module))) - a))) - (set-current-input-port (pop! *input-ports*)) - x)) -(define (not x) - (if x #f #t)) -(define-macro (mes-use-module module) - (list - 'begin - (list 'if (list 'not (list 'memq (list string->symbol (module->file module)) '*modules*)) - (list - 'begin - (list 'set! '*modules* (list cons (list string->symbol (module->file module)) '*modules*)) - (list 'load (list string-append '%moduledir (module->file module))))))) +(include-from-path "mes/module.mes") (mes-use-module (mes base)) (mes-use-module (srfi srfi-0)) (mes-use-module (mes quasiquote)) (mes-use-module (mes let)) + (mes-use-module (mes scm)) + (mes-use-module (srfi srfi-13)) -(mes-use-module (mes display)) (mes-use-module (mes catch)) + (mes-use-module (mes posix)) + diff --git a/module/mes/catch.mes b/module/mes/catch.mes index baf174a1..31062898 100644 --- a/module/mes/catch.mes +++ b/module/mes/catch.mes @@ -1,7 +1,7 @@ ;;; -*-scheme-*- ;;; Mes --- Maxwell Equations of Software -;;; Copyright © 2016 Jan Nieuwenhuizen +;;; Copyright © 2016,2018 Jan Nieuwenhuizen ;;; ;;; This file is part of Mes. ;;; @@ -23,7 +23,14 @@ (define %eh (make-fluid (lambda (key . args) - (format (current-error-port) "unhandled exception: ~a ~a\n" key args) + (if (defined? 'simple-format) + (simple-format (current-error-port) "unhandled exception:~a:~a\n" key args) + (begin + (display "unhandled exception:" (current-error-port)) + (display key (current-error-port)) + (display ":" (current-error-port)) + (display args (current-error-port)) + (newline (current-error-port)))) (exit 1)))) (define (catch key thunk handler) diff --git a/module/mes/guile.mes b/module/mes/guile.mes index 29fa9580..a131bbae 100644 --- a/module/mes/guile.mes +++ b/module/mes/guile.mes @@ -1,7 +1,7 @@ ;;; -*-scheme-*- ;;; Mes --- Maxwell Equations of Software -;;; Copyright © 2016,2017 Jan Nieuwenhuizen +;;; Copyright © 2016,2017,2018 Jan Nieuwenhuizen ;;; ;;; This file is part of Mes. ;;; @@ -36,7 +36,10 @@ (if (access? file R_OK) `(load ,file) (loop (cdr path))))))) +(mes-use-module (mes catch)) +(mes-use-module (mes posix)) (mes-use-module (srfi srfi-16)) +(mes-use-module (mes display)) (define (read-string) (define (read-string c) @@ -58,7 +61,6 @@ (define (port-filename p) "") (define (port-line p) 0) -(define (simple-format port format . rest) (map (lambda (x) (display x port)) rest)) (define (with-input-from-string string thunk) (define save-peek-char peek-char) diff --git a/module/mes/let.mes b/module/mes/let.mes index 3f89ed53..a9b29fc1 100644 --- a/module/mes/let.mes +++ b/module/mes/let.mes @@ -1,7 +1,7 @@ ;;; -*-scheme-*- ;;; Mes --- Maxwell Equations of Software -;;; Copyright © 2016 Jan Nieuwenhuizen +;;; Copyright © 2016,2018 Jan Nieuwenhuizen ;;; ;;; This file is part of Mes. ;;; @@ -28,6 +28,10 @@ (mes-use-module (mes base)) (mes-use-module (mes quasiquote)) +(define-macro (simple-let bindings . rest) + (cons (cons 'lambda (cons (map1 car bindings) rest)) + (map1 cadr bindings))) + (define-macro (xsimple-let bindings rest) `(,`(lambda ,(map car bindings) ,@rest) ,@(map cadr bindings))) @@ -37,11 +41,10 @@ (set! ,name (lambda ,(map car bindings) ,@rest)) (,name ,@(map cadr bindings)))) -;; IF (define-macro (let bindings-or-name . rest) - `(if ,(symbol? bindings-or-name) ;; IF - (xnamed-let ,bindings-or-name ,(car rest) ,(cdr rest)) - (xsimple-let ,bindings-or-name ,rest))) + (if (symbol? bindings-or-name) + `(xnamed-let ,bindings-or-name ,(car rest) ,(cdr rest)) + `(xsimple-let ,bindings-or-name ,rest))) (define (expand-let* bindings body) (if (null? bindings) diff --git a/module/mes/module.mes b/module/mes/module.mes new file mode 100644 index 00000000..54cd7cd2 --- /dev/null +++ b/module/mes/module.mes @@ -0,0 +1,45 @@ +;;; -*-scheme-*- + +;;; Mes --- Maxwell Equations of Software +;;; Copyright © 2016,2017,2018 Jan Nieuwenhuizen +;;; +;;; This file is part of Mes. +;;; +;;; 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. +;;; +;;; 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 Mes. If not, see . + +;;; Commentary: + +;;; Code: + +(define (module->file o) + (string-append (string-join (map1 symbol->string o) "/") ".mes")) + +(define *modules* '(mes/base-0.mes)) +(define (mes-load-module-env module a) + (push! *input-ports* (current-input-port)) + (set-current-input-port (open-input-file (string-append %moduledir (module->file module)))) + (let ((x (core:eval (append2 (cons 'begin (read-input-file-env a)) + '((current-module))) + a))) + (set-current-input-port (pop! *input-ports*)) + x)) + +(define-macro (mes-use-module module) + (list + 'begin + (list 'if (list 'not (list 'memq (list string->symbol (module->file module)) '*modules*)) + (list + 'begin + (list 'set! '*modules* (list cons (list string->symbol (module->file module)) '*modules*)) + (list 'load (list string-append '%moduledir (module->file module))))))) diff --git a/module/mes/read-0.mes b/module/mes/read-0.mes index e7f99b7d..019e7c58 100644 --- a/module/mes/read-0.mes +++ b/module/mes/read-0.mes @@ -1,7 +1,7 @@ ;;; -*-scheme-*- ;;; Mes --- Maxwell Equations of Software -;;; Copyright © 2016,2017 Jan Nieuwenhuizen +;;; Copyright © 2016,2017,2018 Jan Nieuwenhuizen ;;; ;;; This file is part of Mes. ;;; @@ -116,7 +116,7 @@ (define (newline . rest) (core:display (list->string (list (integer->char 10))))) (define (display x . rest) (if (null? rest) (core:display x) - (core:display x (car rest)))) + (core:display-port x (car rest)))) (define (list->symbol lst) (core:lookup-symbol lst)) diff --git a/module/mes/repl.mes b/module/mes/repl.mes index 3bb77785..06bbb307 100644 --- a/module/mes/repl.mes +++ b/module/mes/repl.mes @@ -1,7 +1,7 @@ ;;; -*-scheme-*- ;;; Mes --- Maxwell Equations of Software -;;; Copyright © 2016,2017 Jan Nieuwenhuizen +;;; Copyright © 2016,2017,2018 Jan Nieuwenhuizen ;;; ;;; This file is part of Mes. ;;; @@ -111,7 +111,7 @@ along with Mes. If not, see . (define (repl) (let ((count 0) (print-sexp? #t)) - + (define (expand a) (lambda () (let ((sexp (read))) @@ -120,16 +120,16 @@ along with Mes. If not, see . (display sexp) (display "]") (newline)) - (display (eval (list core:macro-expand sexp) a)) - (newline)))) + (core:macro-expand sexp)))) - (define (help . x) (display help-commands)) + (define (help . x) (display help-commands) *unspecified*) (define (show . x) (define topic-alist `((#\newline . ,show-commands) (#\c . ,copying) (#\w . ,warranty))) (let ((topic (read-char))) - (display (assoc-ref topic-alist topic)))) + (display (assoc-ref topic-alist topic)) + *unspecified*)) (define (use a) (lambda () (let ((module (read))) @@ -155,22 +155,26 @@ along with Mes. If not, see . (display sexp) (display "]") (newline)) - (cond ((and (pair? sexp) (eq? (car sexp) (string->symbol "unquote"))) - (let ((r (meta (cadr sexp) a))) - (if (pair? r) (loop (append r a)) - (loop a)))) - ((and (pair? sexp) (eq? (car sexp) 'mes-use-module)) - (loop (mes-load-module-env (cadr sexp) a))) - (else - (let ((e (eval sexp a))) - (if (eq? e *unspecified*) (loop a) + (if (and (pair? sexp) (eq? (car sexp) 'mes-use-module)) + (loop (mes-load-module-env (cadr sexp) a)) + (let ((e (if (and (pair? sexp) (eq? (car sexp) (string->symbol "unquote"))) + (meta (cadr sexp) a) + (eval sexp a)))) + (if (eq? e *unspecified*) (loop a) (let ((id (string->symbol (string-append "$" (number->string count))))) (set! count (+ count 1)) (display id) (display " = ") (display e) (newline) - (loop (acons id e a)))))))))) + (loop (acons id e a))))))))) (lambda (key . args) - (format (current-error-port) "exception: ~a ~a\n" key args) + (if (defined? 'with-output-to-string) + (simple-format (current-error-port) "exception:~a:~a\n" key args) + (begin + (display "exception:" (current-error-port)) + (display key (current-error-port)) + (display ":" (current-error-port)) + (display args (current-error-port)) + (newline (current-error-port)))) (loop a)))))) diff --git a/src/lib.c b/src/lib.c index 0ecbcc61..a8f13dd9 100644 --- a/src/lib.c +++ b/src/lib.c @@ -1,6 +1,6 @@ /* -*-comment-start: "//";comment-end:""-*- * Mes --- Maxwell Equations of Software - * Copyright © 2016,2017 Jan Nieuwenhuizen + * Copyright © 2016,2017,2018 Jan Nieuwenhuizen * * This file is part of Mes. * @@ -130,6 +130,13 @@ display_error_ (SCM x) return display_helper (x, 0, "", STDERR); } +SCM +display_port_ (SCM x, SCM p) +{ + assert (TYPE (p) == TNUMBER); + return fdisplay_ (x, VALUE (p)); +} + SCM fdisplay_ (SCM x, int fd) ///((internal)) { diff --git a/src/mes.c b/src/mes.c index f89490e7..70f5a674 100644 --- a/src/mes.c +++ b/src/mes.c @@ -1,6 +1,6 @@ /* -*-comment-start: "//";comment-end:""-*- * Mes --- Maxwell Equations of Software - * Copyright © 2016,2017 Jan Nieuwenhuizen + * Copyright © 2016,2017,2018 Jan Nieuwenhuizen * * This file is part of Mes. * @@ -951,8 +951,8 @@ eval_apply () } case cell_vm_macro_expand: { - push_cc (CADR (r1), r1, r0, cell_vm_return); - goto macro_expand; + push_cc (CADR (r1), r1, r0, cell_vm_macro_expand); + goto eval; } default: { push_cc (r1, r1, r0, cell_vm_eval_macro); diff --git a/tests/base.test-guile b/tests/base.test-guile index 4b5bb6a7..c4982d51 100755 --- a/tests/base.test-guile +++ b/tests/base.test-guile @@ -1,4 +1,23 @@ #! /bin/sh + +# Mes --- Maxwell Equations of Software +# Copyright © 2017,2018 Jan Nieuwenhuizen +# +# This file is part of Mes. +# +# 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. +# +# 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 Mes. If not, see . + test=$(dirname $0)/$(basename $0 -guile) GUILE=${GUILE-guile} cat guile/mes-0.scm module/mes/test.mes $test | exec $GUILE -s /dev/stdin diff --git a/tests/optargs.test b/tests/optargs.test index 974c67e6..f87e64e4 100755 --- a/tests/optargs.test +++ b/tests/optargs.test @@ -9,7 +9,7 @@ exit $? ;;; -*-scheme-*- ;;; Mes --- Maxwell Equations of Software -;;; Copyright © 2016 Jan Nieuwenhuizen +;;; Copyright © 2016,2018 Jan Nieuwenhuizen ;;; ;;; This file is part of Mes. ;;; @@ -122,7 +122,6 @@ exit $? ;; (make #:functions functions #:globals globals #:locals locals #:text text))))) (define (clone o . rest) - (format (current-error-port) "clone rest=~a\n" rest) (cond ((info? o) (let ((functions (.functions o)) (globals (.globals o)) diff --git a/tests/syntax.test b/tests/syntax.test new file mode 100755 index 00000000..df5962b2 --- /dev/null +++ b/tests/syntax.test @@ -0,0 +1,64 @@ +#! /bin/sh +# -*-scheme-*- +MES=${MES-$(dirname $0)/../scripts/mes} +echo ' ()' | cat $(dirname $0)/../module/mes/base-0.mes $0 /dev/stdin | $MES $MES_FLAGS "$@" +#paredit:|| +exit $? +!# + +;;; -*-scheme-*- + +;;; Mes --- Maxwell Equations of Software +;;; Copyright © 2016,2017,2018 Jan Nieuwenhuizen +;;; +;;; This file is part of Mes. +;;; +;;; 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. +;;; +;;; 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 Mes. If not, see . + +(mes-use-module (mes syntax)) +(mes-use-module (mes test)) + +(pass-if "first dummy" #t) +(pass-if-not "second dummy" #f) + +(pass-if "define-syntax when" + (sequal? + (let () + (define-syntax sr:when + (syntax-rules () + ((sc:when condition exp ...) + (if condition + (begin exp ...))))) + (let () + (sr:when #t "if not now, then?"))) + "if not now, then?")) + +(pass-if "define-syntax-rule" + (sequal? + (let () + (define-syntax-rule (sre:when c e ...) + (if c (begin e ...))) + (let () + (sre:when #t "if not now, then?"))) + "if not now, then?")) + +(pass-if-equal "syntax-rules plus" + (+ 1 2 3) + (let () + (define-syntax plus + (syntax-rules () + ((plus x ...) (+ x ...)))) + (plus 1 2 3))) + +(result 'report) diff --git a/tests/syntax.test-guile b/tests/syntax.test-guile new file mode 120000 index 00000000..5631f4a9 --- /dev/null +++ b/tests/syntax.test-guile @@ -0,0 +1 @@ +base.test-guile \ No newline at end of file