andrius
/
mes
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

DRAFT tests: Switch to Guile modules. 

* mes/module/mes/getopt-long.scm: Movo to ...
* mes/module/ice-9/getopt-long.scm: ...here.
* module/mes/optargs.scm,
mes/module/mes/optargs.mes: Remove.
* mes/module/ice-9/optargs.scm: Add functions used by macros to export
* module/mes/test.scm: Likewise.
* mes/module/mes/main.mes: Add module header.
* mes/module/mes/repl.mes: Likewise.
* mes/module/mes/syntax.mes: Likewise.
* mes/module/srfi/srfi-0.mes: Likewise.
* mes/module/srfi/srfi-1.mes: Likewise.
* mes/module/srfi/srfi-14.mes: Likewise.
* mes/module/srfi/srfi-43.mes: Likewise.
* mes/module/srfi/srfi-8.mes: Likewise.
* mes/module/srfi/srfi-9-struct.mes: Likewise.
* mes/module/srfi/srfi-9/gnu-vector.mes: Likewise.
* mes/module/srfi/srfi-9/gnu.mes: Likewise.
This commit is contained in:
Jan (janneke) Nieuwenhuizen 2020-12-30 16:58:32 +01:00
parent 67ac2f92e1
commit b2aa041021
No known key found for this signature in database
GPG Key ID: F3C1A0D9C1D65273
45 changed files with 220 additions and 689 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
module/mes/getopt-long.scm → mes/module/ice-9/getopt-long.scm
View File

@ -19,6 +19,12 @@
;;; (regexps removed by Jan (janneke) Nieuwenhuizen)
;;; (srfi-9 backport by Jan (janneke) Nieuwenhuizen)
(define-module (ice-9 getopt-long)
#:use-module (ice-9 optargs)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:export (getopt-long option-ref))
;;; Commentary:
;;; This module implements some complex command line option parsing, in
@ -159,12 +165,6 @@
;;; Code:
(define-module (mes getopt-long)
#:use-module (ice-9 optargs)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:export (getopt-long option-ref))
(define-record-type option-spec
(%make-option-spec name value required? option-spec->single-char predicate value-policy)
option-spec?

33
mes/module/ice-9/optargs.scm
View File

@ -58,17 +58,27 @@
;;; Code:
(define-module (ice-9 optargs)
#:use-module (mes mes-0)
#:use-module (system base pmatch)
#:replace (lambda*)
#:export-syntax (let-optional
let-optional*
let-keywords
let-keywords*
define*
define*-public
defmacro*
defmacro*-public))
#:export (lambda*
let-optional
let-optional*
let-keywords
let-keywords*
define*
define*-public
defmacro*
defmacro*-public
define-macro*
define*-guts
parse-arglist
every?
ext-decl?
let-optional-template
let-keywords-template
rest-arg->keyword-binding-list))
;
;; let-optional rest-arg (binding ...) . body
;; let-optional* rest-arg (binding ...) . body
;; macros used to bind optional arguments
@ -151,7 +161,7 @@
=> cdr)
(else
,(cadr key)))))))
`(let ((,kb-list-gensym ((if (not mes?) (@@ (mes optargs) rest-arg->keyword-binding-list)
`(let ((,kb-list-gensym ((if (not mes?) #f ;;(@@ (ice-9 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)
@ -419,6 +429,9 @@
(defmacro* ,NAME ,ARGLIST ,@BODY)
(export-syntax ,NAME)))
(define-macro (define-macro* NAME+ARGLIST . BODY)
`(define-macro ,(car NAME+ARGLIST) #f (lambda* ,(cdr NAME+ARGLIST) ,@BODY)))
;;; Support for optional & keyword args with the interpreter.
(define *uninitialized* (list 'uninitialized))
(define (parse-lambda-case spec inits predicate args)

4
mes/module/mes/boot-0.scm
View File

@ -178,7 +178,11 @@
(mes-use-module (mes guile))
;; end boot-04.scm
(include-from-path "ice-9/optargs.scm")
(include-from-path "srfi/srfi-9.mes")
(include-from-path "ice-9/getopt-long.scm")
(mes-use-module (mes main))
(top-main)
(primitive-load 0)
(primitive-load (open-input-string %main))

3
mes/module/mes/boot-5.mes
View File

@ -179,12 +179,11 @@
;; end boot-04.scm
;; 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 syntax))
(mes-use-module (mes boot-6))
(include-from-path "mes/main.mes")
(top-main)
(primitive-load 0)
(primitive-load (open-input-string %main))

20
mes/module/mes/boot-6.mes
View File

@ -2156,26 +2156,6 @@
;;; {with-fluids}
;;;
;; with-fluids is a convenience wrapper for the builtin procedure
;; `with-fluids*'. The syntax is just like `let':
;;
;; (with-fluids ((fluid val)
;; ...)
;; body)
(defmacro with-fluids (bindings . body)
(let ((fluids (map car bindings))
(values (map cadr bindings)))
(if (and (= (length fluids) 1) (= (length values) 1))
`(with-fluid* ,(car fluids) ,(car values) (lambda () ,@body))
`(with-fluids* (list ,@fluids) (list ,@values)
(lambda () ,@body)))))
;;; {Module System Macros}
;;;

4
mes/module/mes/getopt-long.mes
View File

@ -25,5 +25,5 @@
(mes-use-module (srfi srfi-1))
(mes-use-module (srfi srfi-9))
(mes-use-module (srfi srfi-13))
(mes-use-module (mes optargs))
(include-from-path "mes/getopt-long.scm")
(mes-use-module (ice-9 optargs))
(include-from-path "ice-9/getopt-long.scm")

3
mes/module/mes/guile.mes
View File

@ -44,6 +44,9 @@
(define-macro (defmacro name args . body)
`(define-macro ,(cons name args) ,@body))
(define-macro (set-object-property! object key value)
object)
(define-macro (set-procedure-property! proc key value)
proc)

9
mes/module/mes/main.mes
View File

@ -22,7 +22,10 @@
;;; Code:
(mes-use-module (mes getopt-long))
(define-module (mes main)
#:use-module (ice-9 getopt-long)
#:use-module (mes repl)
#:export (top-main))
(define %main #f)
(define (top-main)
@ -105,7 +108,3 @@ General help using GNU software: <http://gnu.org/gethelp/>
(set-current-input-port 0)
(repl))
(else #t)))))
(define (top-load *undefined*)
(primitive-load 0)
(primitive-load (open-input-string %main)))

38
mes/module/mes/optargs.mes
View File

@ -1,38 +0,0 @@
;;; -*-scheme-*-
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 2016,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; 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 <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; Optargs (define*, lambda* et al.) from Guile
;;; Code:
(mes-use-module (mes scm))
(define-macro (defmacro name args . body)
`(define-macro ,(cons name args) ,@body))
(define-macro (set-procedure-property! proc key value)
proc)
(include-from-path "mes/optargs.scm")
(define-macro (define-macro* NAME+ARGLIST . BODY)
`(define-macro ,(car NAME+ARGLIST) #f (lambda* ,(cdr NAME+ARGLIST) ,@BODY)))

8
mes/module/mes/repl.mes
View File

@ -1,7 +1,7 @@
;;; -*-scheme-*-
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2016,2017,2018,2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Mes.
;;;
@ -24,9 +24,13 @@
;;; Code:
(mes-use-module (mes scm))
;;; XXX FIXME
(mes-use-module (srfi srfi-14))
(define-module (mes repl)
;;#:use-module (srfi srfi-14)
#:export (repl))
(define welcome
(string-append "GNU Mes " %version "
Copyright (C) 2016,2017,2018,2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>

10
mes/module/mes/syntax.mes
View File

@ -25,7 +25,15 @@
;;; syntax-rules is adapted from scheme48-1.1/scheme/alt/syntax.scm
;;; Code:
(mes-use-module (mes scm))
(define-module (mes syntax)
#:export (define-syntax
define-syntax-rule
syntax-error
silent-syntax-error
id-pattern
let-syntax))
(include-from-path "mes/syntax.scm")
(define (syntax-error message thing)

5
mes/module/srfi/srfi-0.mes
View File

@ -1,7 +1,7 @@
;;; -*-scheme-*-
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 2016 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2016,2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Mes.
;;;
@ -24,6 +24,9 @@
;;; Code:
(define-module (srfi srfi-0)
#:export (cend-expand))
(define mes '(0 1))
(define (cond-expand-expander clauses)

29
mes/module/srfi/srfi-1.mes
View File

@ -25,7 +25,34 @@
;;; Code:
(define-module (srfi srfi-1)
#:export (find))
#:export (every
find
filter
append-map
filter-map
fold
fold-right
unfold
remove
reverse!
srfi-1:member
mes:member
member
mes:iota
srfi-1:iota
iota
srfi-1:iota
delete-duplicates
any
any1
every
every1
list-index
lset-union
lset-intersection
lset-difference
reverse!
take-while))
(define (find pred lst)
(let loop ((lst lst))

20
mes/module/srfi/srfi-14.mes
View File

@ -1,7 +1,7 @@
;;; -*-scheme-*-
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 2016,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2016,2018,2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Mes.
;;;
@ -24,6 +24,24 @@
;;; Code:
(define-module (srfi srfi-14)
#:export (char-set
char-set?
char-set=
char-set:whitespace
char-set:digit
char-set:upper-case
char-set lst
string->char-set
string->char-set!
char-set-adjoin
char-set-contains?
char-set-complement
char-whitespace?
char-set-copy
char-upcase
char-downcase))
;; FIXME: have structs
(define (char-set . x)
(cons '*char-set* x))

6
mes/module/srfi/srfi-43.mes
View File

@ -1,7 +1,7 @@
;;; -*-scheme-*-
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 2016,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2016,2018,2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Mes.
;;;
@ -24,6 +24,10 @@
;;; Code:
(define-module (srfi srfi-43)
#:export (vector-map
vector-for-each))
(define (vector-map f v)
(let* ((k (vector-length v))
(n (make-vector k)))

5
mes/module/srfi/srfi-8.mes
View File

@ -1,7 +1,7 @@
;;; -*-scheme-*-
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2018,2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Mes.
;;;
@ -24,6 +24,9 @@
;;; Code:
(define-module (ice-9 receive)
#:export (receive))
(define-macro (receive vars vals . body)
`(call-with-values (lambda () ,vals)
(lambda ,vars . ,body)))

18
mes/module/srfi/srfi-9-struct.mes
View File

@ -1,7 +1,7 @@
;;; -*-scheme-*-
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 2017,2018,2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2017,2018,2019,2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Mes.
;;;
@ -22,6 +22,22 @@
;;; srfi-9.mes - records, based on struct.
;;; Code:
(define-module (srfi srfi-9)
#:export (define-record-type
make-record-type
record-type?
struct-vtable
record-type-name
record-type-descriptor
record-type-fields
record-predicate
record?
record-constructor
record-accessor
record-modifier))
(define-macro (define-record-type name constructor+field-names predicate . fields)
(let ((type (make-record-type name (map car fields))))
`(begin

16
mes/module/srfi/srfi-9-vector.mes
View File

@ -1,7 +1,7 @@
;;; -*-scheme-*-
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 2017,2018,2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2017,2018,2019,2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Mes.
;;;
@ -22,6 +22,20 @@
;;; srfi-9-vector.mes - records, based on vector
(define-module (srfi srfi-9)
#:export (define-record-type
make-record-type
record-type?
struct-vtable
record-type-name
record-type-descriptor
record-type-fields
record-predicate
record?
record-constructor
record-accessor
record-modifier))
(define-macro (define-record-type type constructor+field-names predicate . fields)
(let ((record (make-record-type type (map car fields))))
`(begin

8
mes/module/srfi/srfi-9/gnu-struct.mes
View File

@ -1,7 +1,7 @@
;;; -*-scheme-*-
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 2017,2018,2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2017,2018,2019,2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Mes.
;;;
@ -22,6 +22,12 @@
;;; srfi-9.mes - GNU immutable records.
;;; Code:
(define-module (srfi srfi-9 gnu)
#:export (define-immutable-record-type
set-field))
(define-macro (define-immutable-record-type type constructor+parameters predicate . fields)
`(define-record-type ,type ,constructor+parameters ,predicate ,@(map (lambda (f) (list-head f 2)) fields)))

8
mes/module/srfi/srfi-9/gnu-vector.mes
View File

@ -1,7 +1,7 @@
;;; -*-scheme-*-
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2017,2018,2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Mes.
;;;
@ -22,6 +22,12 @@
;;; srfi-9.mes - GNU immutable records.
;;; Code:
(define-module (srfi srfi-9 gnu)
#:export (define-immutable-record-type
set-field))
(define-macro (define-immutable-record-type type constructor+params predicate . fields)
`(define-record-type ,type ,constructor+params ,predicate ,@(map (lambda (f) (list-head f 2)) fields)))

499
module/mes/optargs.scm
View File

@ -1,499 +0,0 @@
;;;; 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 <mstachow@alum.mit.edu>
;;; 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 (mes 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 <var> or
;; (<var> <default-value>). 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))))

1
module/mes/test.scm
View File

@ -36,6 +36,7 @@
result
seq? ; deprecated
sequal? ; deprecated
sequal2? ;deprecated
))
(cond-expand

6
tests/base.test
View File

@ -1,9 +1,9 @@
#! /bin/sh
# -*-scheme-*-
-*-scheme-*-
if [ "$MES" != guile ]; then
MES_BOOT=boot-03.scm exec ${MES-mes} < $0
MES_BOOT=boot-03.scm exec ${MES-bin/mes} < $0
fi
exec ${MES-mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests boot)' -s "$0" "$@"
exec ${MES-bin/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests boot)' -s "$0" "$@"
!#
;;; -*-scheme-*-

2
tests/boot.test
View File

@ -1,7 +1,7 @@
#! /bin/sh
# -*-scheme-*-
if [ "$MES" != guile ]; then
MES_BOOT=boot-02.scm exec ${MES-mes} < $0
MES_BOOT=boot-02.scm exec ${MES-bin/mes} < $0
fi
exec ${MES-mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests boot)' -s "$0" "$@"
!#

8
tests/catch.test
View File

@ -1,12 +1,14 @@
#! /bin/sh
# -*-scheme-*-
MES_BOOT=boot-5.mes
export MES_BOOT
exec ${MES-bin/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests catch)' -s "$0" "$@"
!#
;;; -*-scheme-*-
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 2016 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2016,2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Mes.
;;;
@ -24,12 +26,8 @@ exec ${MES-bin/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests
;;; along with GNU Mes. If not, see <http://www.gnu.org/licenses/>.
(define-module (tests base)
#:use-module (mes mes-0)
#:use-module (mes test))
(mes-use-module (mes catch))
(mes-use-module (mes test))
(pass-if "first dummy" #t)
(pass-if-not "second dummy" #f)

7
tests/closure.test
View File

@ -1,12 +1,14 @@
#! /bin/sh
# -*-scheme-*-
MES_BOOT=boot-5.mes
export MES_BOOT
exec ${MES-bin/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests closure)' -s "$0" "$@"
!#
;;; -*-scheme-*-
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 2016,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2016,2018,2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Mes.
;;;
@ -24,11 +26,8 @@ exec ${MES-bin/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests
;;; along with GNU Mes. If not, see <http://www.gnu.org/licenses/>.
(define-module (tests closure)
#:use-module (mes mes-0)
#:use-module (mes test))
(mes-use-module (mes test))
(pass-if "first dummy" #t)
(pass-if-not "second dummy" #f)

7
tests/cwv.test
View File

@ -1,12 +1,14 @@
#! /bin/sh
# -*-scheme-*-
MES_BOOT=boot-5.mes
export MES_BOOT
exec ${MES-bin/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests cwv)' -s "$0" "$@"
!#
;;; -*-scheme-*-
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 2016 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2016,2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Mes.
;;;
@ -27,9 +29,6 @@ exec ${MES-bin/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests
#:use-module (mes mes-0)
#:use-module (mes test))
(mes-use-module (mes scm))
(mes-use-module (mes test))
(if (not guile-1.8?)
(pass-if "values" (seq? (values 0 1) 0)))
(if (not guile-1.8?)

9
tests/display.test
View File

@ -1,11 +1,14 @@
#! /bin/sh
# -*-scheme-*-
MES_BOOT=boot-5.mes
export MES_BOOT
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
;;; Copyright © 2016,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2016,2018,2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Mes.
;;;
@ -26,10 +29,6 @@ exec ${MES-bin/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests
#:use-module (mes mes-0)
#:use-module (mes test))
(mes-use-module (mes display))
(mes-use-module (mes guile))
(mes-use-module (mes test))
(pass-if "first dummy" #t)
(pass-if-not "second dummy" #f)

5
tests/fluids.test
View File

@ -1,5 +1,7 @@
#! /bin/sh
# -*-scheme-*-
MES_BOOT=boot-5.mes
export MES_BOOT
exec ${MES-bin/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests fluids)' -s "$0" "$@"
!#
@ -27,9 +29,6 @@ exec ${MES-bin/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests
#:use-module (mes mes-0)
#:use-module (mes test))
(mes-use-module (mes fluids))
(mes-use-module (mes test))
(define a (make-fluid))
(define b (make-fluid))
(define c #f)

14
tests/getopt-long.test
View File

@ -1,4 +1,7 @@
#! /bin/sh
# -*-scheme-*-
MES_BOOT=boot-5.mes
export MES_BOOT
exec ${MES-bin/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests getopt-long)' -s "$0" "$@"
!#
@ -23,15 +26,8 @@ exec ${MES-bin/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests
;;; along with GNU Mes. If not, see <http://www.gnu.org/licenses/>.
(define-module (tests getopt-long)
#:use-module (mes mes-0)
#:use-module (mes test)
#:use-module (mes getopt-long))
(cond-expand
(mes
(mes-use-module (mes getopt-long))
(mes-use-module (mes test)))
(else))
#:use-module (ice-9 getopt-long)
#:use-module (mes test))
(pass-if "first dummy" #t)
(pass-if-not "second dummy" #f)

9
tests/guile.test
View File

@ -1,5 +1,7 @@
#! /bin/sh
# -*-scheme-*-
MES_BOOT=boot-5.mes
export MES_BOOT
exec ${MES-bin/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests guile)' -s "$0" "$@"
!#
@ -26,15 +28,8 @@ exec ${MES-bin/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests
(define-module (tests guile)
#:use-module (ice-9 rdelim)
#:use-module (mes mes-0)
#:use-module (mes misc)
#:use-module (mes test))
(cond-expand
(mes
(mes-use-module (mes test))
(mes-use-module (mes guile)))
(else))
(pass-if "first dummy" #t)
(pass-if-not "second dummy" #f)

6
tests/let-syntax.test
View File

@ -1,5 +1,7 @@
#! /bin/sh
# -*-scheme-*-
MES_BOOT=boot-5.mes
export MES_BOOT
exec ${MES-bin/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests let-syntax)' -s "$0" "$@"
!#
@ -24,12 +26,8 @@ exec ${MES-bin/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests
;;; along with GNU Mes. If not, see <http://www.gnu.org/licenses/>.
(define-module (tests let-syntax)
#:use-module (mes mes-0)
#:use-module (mes test))
(mes-use-module (mes syntax))
(mes-use-module (mes test))
(pass-if "first dummy" #t)
(pass-if-not "second dummy" #f)

6
tests/let.test
View File

@ -1,5 +1,7 @@
#! /bin/sh
# -*-scheme-*-
MES_BOOT=boot-5.mes
export MES_BOOT
exec ${MES-bin/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests let)' -s "$0" "$@"
!#
@ -24,12 +26,8 @@ exec ${MES-bin/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests
;;; along with GNU Mes. If not, see <http://www.gnu.org/licenses/>.
(define-module (tests let)
#:use-module (mes mes-0)
#:use-module (mes test))
(mes-use-module (mes let))
(mes-use-module (mes test))
(pass-if "first dummy" #t)
(pass-if-not "second dummy" #f)

2
tests/match.test
View File

@ -1,5 +1,7 @@
#! /bin/sh
# -*-scheme-*-
MES_BOOT=boot-5.mes
export MES_BOOT
exec ${MES-bin/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests match)' -s "$0" "$@"
!#

4
tests/math.test
View File

@ -1,5 +1,7 @@
#! /bin/sh
# -*-scheme-*-
MES_BOOT=boot-5.mes
export MES_BOOT
exec ${MES-bin/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests math)' -s "$0" "$@"
!#
@ -24,10 +26,8 @@ exec ${MES-bin/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests
;;; along with GNU Mes. If not, see <http://www.gnu.org/licenses/>.
(define-module (tests math)
#:use-module (mes mes-0)
#:use-module (mes test))
(mes-use-module (mes test))
(pass-if-equal "string->number" 42 (string->number "42"))
(pass-if-equal "string->number neg" -42 (string->number "-42"))
(pass-if-equal "string->number #hex" 170 (string->number "#xaa"))

11
tests/optargs.test
View File

@ -1,5 +1,7 @@
#! /bin/sh
# -*-scheme-*-
MES_BOOT=boot-5.mes
export MES_BOOT
exec ${MES-bin/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests optargs)' -s "$0" "$@"
!#
@ -24,16 +26,9 @@ exec ${MES-bin/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests
;;; along with GNU Mes. If not, see <http://www.gnu.org/licenses/>.
(define-module (tests optargs)
#:use-module (mes optargs)
#:use-module (mes mes-0)
#:use-module (ice-9 optargs)
#:use-module (mes test))
(cond-expand
(mes
(mes-use-module (mes optargs))
(mes-use-module (mes test)))
(else))
(pass-if-equal "cond =>" 10
(cond
(5 => (lambda (p) (* p 2)))))

5
tests/posix.test
View File

@ -1,5 +1,7 @@
#! /bin/sh
# -*-scheme-*-
MES_BOOT=boot-5.mes
export MES_BOOT
exec ${MES-bin/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests srfi-13)' -s "$0" "$@"
!#
@ -27,9 +29,6 @@ exec ${MES-bin/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests
#:use-module (mes mes-0)
#:use-module (mes test))
(mes-use-module (srfi srfi-13))
(mes-use-module (mes test))
(pass-if "first dummy" #t)
(pass-if-not "second dummy" #f)

5
tests/srfi-1.test
View File

@ -1,5 +1,7 @@
#! /bin/sh
# -*-scheme-*-
MES_BOOT=boot-5.mes
export MES_BOOT
exec ${MES-bin/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests srfi-1)' -s "$0" "$@"
!#
@ -28,9 +30,6 @@ exec ${MES-bin/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests
#:use-module (mes mes-0)
#:use-module (mes test))
(mes-use-module (srfi srfi-1))
(mes-use-module (mes test))
(pass-if "first dummy" #t)
(pass-if-not "second dummy" #f)

5
tests/srfi-13.test
View File

@ -1,5 +1,7 @@
#! /bin/sh
# -*-scheme-*-
MES_BOOT=boot-5.mes
export MES_BOOT
exec ${MES-bin/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests srfi-13)' -s "$0" "$@"
!#
@ -27,9 +29,6 @@ exec ${MES-bin/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests
#:use-module (mes mes-0)
#:use-module (mes test))
(mes-use-module (srfi srfi-13))
(mes-use-module (mes test))
(pass-if "first dummy" #t)
(pass-if-not "second dummy" #f)

5
tests/srfi-14.test
View File

@ -1,5 +1,7 @@
#! /bin/sh
# -*-scheme-*-
MES_BOOT=boot-5.mes
export MES_BOOT
exec ${MES-bin/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests srfi-14)' -s "$0" "$@"
!#
@ -28,9 +30,6 @@ exec ${MES-bin/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests
#:use-module (mes mes-0)
#:use-module (mes test))
(mes-use-module (srfi srfi-14))
(mes-use-module (mes test))
(pass-if "first dummy" #t)
(pass-if-not "second dummy" #f)

6
tests/srfi-16.test
View File

@ -1,5 +1,7 @@
#! /bin/sh
# -*-scheme-*-
MES_BOOT=boot-5.mes
export MES_BOOT
exec ${MES-bin/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests srfi-16)' -s "$0" "$@"
!#
@ -24,12 +26,8 @@ exec ${MES-bin/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests
;;; along with GNU Mes. If not, see <http://www.gnu.org/licenses/>.
(define-module (tests srfi-16)
#:use-module (mes mes-0)
#:use-module (mes test))
(mes-use-module (srfi srfi-16))
(mes-use-module (mes test))
(pass-if "first dummy" #t)
(pass-if-not "second dummy" #f)

8
tests/srfi-43.test
View File

@ -1,12 +1,14 @@
#! /bin/sh
# -*-scheme-*-
MES_BOOT=boot-5.mes
export MES_BOOT
exec ${MES-bin/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests srfi-43)' -s "$0" "$@"
!#
;;; -*-scheme-*-
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2018,2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Mes.
;;;
@ -25,12 +27,8 @@ exec ${MES-bin/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests
(define-module (tests srfi-43)
#:use-module (srfi srfi-43)
#:use-module (mes mes-0)
#:use-module (mes test))
(mes-use-module (srfi srfi-43))
(mes-use-module (mes test))
(pass-if "first dummy" #t)
(pass-if-not "second dummy" #f)

10
tests/srfi-9.test
View File

@ -38,15 +38,7 @@ exec ${MES-bin/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests
;; bootstrap test
(primitive-load "module/mes/test.scm")
(primitive-load "mes/module/srfi/srfi-9-struct.mes")
(primitive-load "mes/module/srfi/srfi-9/gnu-struct.mes")
(define-macro (mes-use-module . rest) #t)
;; (primitive-load "mes/module/srfi/srfi-9-vector.mes")
;; (primitive-load "mes/module/srfi/srfi-9/gnu-vector.mes")
(mes-use-module (srfi srfi-9))
(mes-use-module (srfi srfi-9 gnu))
(mes-use-module (mes test)))
(primitive-load "mes/module/srfi/srfi-9/gnu-struct.mes"))
(else))
(pass-if "first dummy" #t)

5
tests/syntax.test
View File

@ -1,5 +1,7 @@
#! /bin/sh
# -*-scheme-*-
MES_BOOT=boot-5.mes
export MES_BOOT
exec ${MES-bin/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests syntax)' -s "$0" "$@"
!#
@ -27,9 +29,6 @@ exec ${MES-bin/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests
#:use-module (mes mes-0)
#:use-module (mes test))
(mes-use-module (mes test))
(mes-use-module (mes syntax))
(pass-if "first dummy" #t)
(pass-if-not "second dummy" #f)

5
tests/vector.test
View File

@ -1,5 +1,7 @@
#! /bin/sh
# -*-scheme-*-
MES_BOOT=boot-5.mes
export MES_BOOT
exec ${MES-bin/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests vector)' -s "$0" "$@"
!#
@ -27,9 +29,6 @@ exec ${MES-bin/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests
#:use-module (mes mes-0)
#:use-module (mes test))
(mes-use-module (mes scm))
(mes-use-module (mes test))
(pass-if "first dummy" #t)
(pass-if-not "second dummy" #f)