DRAFT boot-6: Support Guile modules.
* mes/module/mes/boot-5.mes, mes/module/mes/boot-6.mes: New files. * src/variable.c (handle_set_x): (lookup_handle): (lookup_ref): (lookup_ref_): * tests/display.test: XXX disable some loading * src/module.c (current_module): (module_defines): (module_define_x): (module_handle): (module_variable): * src/hash.c (hashq_get_handle_): (hashq_ref_): (hash_ref_): * src/eval-apply.c (eval_apply): * src/core.c (error): * src/builtins.c (mes_builtins): * scaffold/boot/60-let-syntax-expanded.scm (defined?): * scaffold/boot/53-closure-display.scm (guile): * mes/module/mes/main.mes: New file. * mes/module/mes/guile.mes (include-from-path): (define-module): (defmacro): (set-procedure-property!): (use-modules): (effective-version):
This commit is contained in:
parent
b12f9d027b
commit
99b34bb853
|
@ -63,7 +63,7 @@ struct scm *gc ();
|
|||
/* src/hash.c */
|
||||
struct scm *hashq (struct scm *x, struct scm *size);
|
||||
struct scm *hash (struct scm *x, struct scm *size);
|
||||
struct scm *hashq_get_handle_ (struct scm *table, struct scm *key, struct scm *dflt);
|
||||
struct scm *hashq_get_handle_ (struct scm *table, struct scm *key);
|
||||
struct scm *hashq_ref_ (struct scm *table, struct scm *key, struct scm *dflt);
|
||||
struct scm *hash_ref_ (struct scm *table, struct scm *key, struct scm *dflt);
|
||||
struct scm *hashq_set_handle_x (struct scm *table, struct scm *key, struct scm *value);
|
||||
|
@ -174,8 +174,8 @@ struct scm *struct_set_x (struct scm *x, struct scm *i, struct scm *e);
|
|||
struct scm *variable_ref (struct scm *var);
|
||||
struct scm *variable_set_x (struct scm *var, struct scm *value);
|
||||
struct scm *variable_bound_p (struct scm *var);
|
||||
struct scm *lookup_variable (struct scm *name, struct scm *define_p);
|
||||
struct scm *lookup_ref (struct scm *name);
|
||||
struct scm *lookup_handle (struct scm *name, struct scm* define_p);
|
||||
struct scm *lookup_ref (struct scm *name, struct scm* bound_p);
|
||||
/* src/vector.c */
|
||||
struct scm *make_vector (struct scm *x);
|
||||
struct scm *vector_length (struct scm *x);
|
||||
|
|
|
@ -73,6 +73,12 @@
|
|||
// CONSTANT FRAME_PROCEDURE 4
|
||||
#define FRAME_PROCEDURE 4
|
||||
|
||||
// CONSTANT MODULE_DEFINES 3
|
||||
#define MODULE_DEFINES 3
|
||||
|
||||
// CONSTANT MODULE_USES 4
|
||||
#define MODULE_USES 4
|
||||
|
||||
// CONSTANT STDIN 0
|
||||
// CONSTANT STDOUT 1
|
||||
// CONSTANT STDERR 2
|
||||
|
|
|
@ -121,14 +121,17 @@ struct scm *apply_builtin1 (struct scm *fn, struct scm *x);
|
|||
struct scm *apply_builtin2 (struct scm *fn, struct scm *x, struct scm *y);
|
||||
struct scm *apply_builtin3 (struct scm *fn, struct scm *x, struct scm *y, struct scm *z);
|
||||
struct scm *builtin_name (struct scm *builtin);
|
||||
struct scm *cell_ref (struct scm *cell, long index);
|
||||
struct scm *cstring_to_list (char const *s);
|
||||
struct scm *cstring_to_symbol (char const *s);
|
||||
struct scm *cell_ref (struct scm *cell, long index);
|
||||
struct scm *current_module ();
|
||||
struct scm *deep_variable_ref (struct scm *var);
|
||||
struct scm *fdisplay_ (struct scm *, int, int);
|
||||
struct scm *handle_set_x (struct scm *name, struct scm *value);
|
||||
struct scm *init_symbols ();
|
||||
struct scm *init_time (struct scm *a);
|
||||
struct scm *lookup_variable_ (char const* name);
|
||||
struct scm *lookup_handle (struct scm *name, struct scm *define_p);
|
||||
struct scm *lookup_ref_ (char const *name);
|
||||
struct scm *make_builtin_type ();
|
||||
struct scm *make_bytes (char const *s, size_t length);
|
||||
struct scm *make_cell (long type, struct scm *car, struct scm *cdr);
|
||||
|
@ -147,6 +150,9 @@ struct scm *make_string0 (char const *s);
|
|||
struct scm *make_string_port (struct scm *x);
|
||||
struct scm *make_vector_ (long k, struct scm *e);
|
||||
struct scm *mes_builtins (struct scm *a);
|
||||
struct scm *module_defines (struct scm *module);
|
||||
struct scm *module_handle (struct scm *module, struct scm *name);
|
||||
struct scm *module_variable (struct scm *module, struct scm *name);
|
||||
struct scm *push_cc (struct scm *p1, struct scm *p2, struct scm *a, struct scm *c);
|
||||
struct scm *set_x (struct scm *x, struct scm *e);
|
||||
struct scm *struct_ref_ (struct scm *x, long i);
|
||||
|
|
|
@ -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 <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 (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 <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))))
|
|
@ -30,7 +30,7 @@
|
|||
(define mes %version)
|
||||
|
||||
(define (defined? x)
|
||||
(lookup-variable x #f))
|
||||
(lookup-handle x #f))
|
||||
|
||||
(define (cond-expand-expander clauses)
|
||||
(if (defined? (car (car clauses)))
|
||||
|
@ -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: <http://gnu.org/software/mes/>
|
||||
General help using GNU software: <http://gnu.org/gethelp/>
|
||||
" (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))
|
||||
|
|
|
@ -20,7 +20,7 @@
|
|||
(define mes %version)
|
||||
|
||||
(define (defined? x)
|
||||
(lookup-variable x #f))
|
||||
(lookup-handle x #f))
|
||||
|
||||
(define (cond-expand-expander clauses)
|
||||
(if (defined? (car (car clauses)))
|
||||
|
|
|
@ -20,7 +20,7 @@
|
|||
(define mes %version)
|
||||
|
||||
(define (defined? x)
|
||||
(lookup-variable x #f))
|
||||
(lookup-handle x #f))
|
||||
|
||||
(define (cond-expand-expander clauses)
|
||||
(if (defined? (car (car clauses)))
|
||||
|
|
|
@ -30,7 +30,7 @@
|
|||
(define mes %version)
|
||||
|
||||
(define (defined? x)
|
||||
(lookup-variable x #f))
|
||||
(lookup-handle x #f))
|
||||
|
||||
(define (cond-expand-expander clauses)
|
||||
(if (defined? (car (car clauses)))
|
||||
|
|
|
@ -30,7 +30,7 @@
|
|||
(define mes %version)
|
||||
|
||||
(define (defined? x)
|
||||
(lookup-variable x #f))
|
||||
(lookup-handle x #f))
|
||||
|
||||
(define (cond-expand-expander clauses)
|
||||
(if (defined? (car (car clauses)))
|
||||
|
@ -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)
|
||||
|
|
|
@ -0,0 +1,189 @@
|
|||
;;; -*-scheme-*-
|
||||
|
||||
;;; GNU Mes --- Maxwell Equations of Software
|
||||
;;; Copyright © 2016,2017,2018,2019 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:
|
||||
|
||||
;;; 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) "<stdin>")
|
||||
(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))))))
|
||||
|
||||
(if (not (defined? '%datadir))
|
||||
(module-define! (current-module) '%datadir "mes"))
|
||||
|
||||
(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.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 boot-6))
|
||||
(top-main)
|
||||
(primitive-load 0)
|
||||
(primitive-load (open-input-string %main))
|
File diff suppressed because it is too large
Load Diff
|
@ -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))
|
||||
|
|
|
@ -0,0 +1,111 @@
|
|||
;;; -*-scheme-*-
|
||||
|
||||
;;; GNU Mes --- Maxwell Equations of Software
|
||||
;;; Copyright © 2016,2017,2018,2019 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:
|
||||
|
||||
;;; 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: <http://gnu.org/software/mes/>
|
||||
General help using GNU software: <http://gnu.org/gethelp/>
|
||||
" (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)))))
|
||||
|
||||
(define (top-load *undefined*)
|
||||
(primitive-load 0)
|
||||
(primitive-load (open-input-string %main)))
|
|
@ -24,6 +24,9 @@
|
|||
|
||||
;;; Code:
|
||||
|
||||
(define-module (srfi srfi-1)
|
||||
#:export (find))
|
||||
|
||||
(define (find pred lst)
|
||||
(let loop ((lst lst))
|
||||
(if (null? lst) #f
|
||||
|
|
|
@ -25,6 +25,7 @@
|
|||
|
||||
;; Internal helper procedure. Map `f' over the single list `ls'.
|
||||
;;
|
||||
|
||||
(define map1 map)
|
||||
|
||||
(define (any pred ls . lists)
|
||||
|
|
|
@ -28,7 +28,7 @@
|
|||
(if (null? lst) (list)
|
||||
(cons (f (car lst)) (map f (cdr lst)))))
|
||||
(define (closure x)
|
||||
(map car (cdr (core:cdr (core:car (core:cdr (cdr (lookup-variable 'x #f))))))))))
|
||||
(map car (cdr (core:cdr (core:car (core:cdr (cdr (lookup-handle 'x #f))))))))))
|
||||
|
||||
(define (x t) #t)
|
||||
(define (xx x1 x2)
|
||||
|
|
|
@ -20,7 +20,7 @@
|
|||
(define mes %version)
|
||||
|
||||
(define (defined? x)
|
||||
(lookup-variable x #f))
|
||||
(lookup-handle x #f))
|
||||
|
||||
(define (cond-expand-expander clauses)
|
||||
(if (defined? (car (car clauses)))
|
||||
|
|
|
@ -173,7 +173,7 @@ mes_builtins (struct scm *a) /*:((internal)) */
|
|||
/* src/hash.c */
|
||||
a = init_builtin (builtin_type, "hashq", 2, &hashq, a);
|
||||
a = init_builtin (builtin_type, "hash", 2, &hash, a);
|
||||
a = init_builtin (builtin_type, "core:hashq-get-handle", 3, &hashq_get_handle_, a);
|
||||
a = init_builtin (builtin_type, "core:hashq-get-handle", 2, &hashq_get_handle_, a);
|
||||
a = init_builtin (builtin_type, "core:hashq-ref", 3, &hashq_ref_, a);
|
||||
a = init_builtin (builtin_type, "core:hash-ref", 3, &hash_ref_, a);
|
||||
a = init_builtin (builtin_type, "hashq-set-handle!", 3, &hashq_set_handle_x, a);
|
||||
|
@ -284,8 +284,8 @@ mes_builtins (struct scm *a) /*:((internal)) */
|
|||
a = init_builtin (builtin_type, "variable-ref", 1, &variable_ref, a);
|
||||
a = init_builtin (builtin_type, "variable-set!", 2, &variable_set_x, a);
|
||||
a = init_builtin (builtin_type, "variable-bound?", 1, &variable_bound_p, a);
|
||||
a = init_builtin (builtin_type, "lookup-variable", 2, &lookup_variable, a);
|
||||
a = init_builtin (builtin_type, "lookup-ref", 1, &lookup_ref, a);
|
||||
a = init_builtin (builtin_type, "lookup-handle", 2, &lookup_handle, a);
|
||||
a = init_builtin (builtin_type, "lookup-ref", 2, &lookup_ref, a);
|
||||
/* src/vector.c */
|
||||
a = init_builtin (builtin_type, "make-vector", -1, &make_vector, a);
|
||||
a = init_builtin (builtin_type, "vector-length", 1, &vector_length, a);
|
||||
|
|
|
@ -149,9 +149,9 @@ struct scm *
|
|||
error (struct scm *key, struct scm *x)
|
||||
{
|
||||
#if !__MESC_MES__ && !__M2_PLANET__
|
||||
struct scm *throw = lookup_variable (cell_symbol_throw, cell_f);
|
||||
struct scm *throw = lookup_ref (cell_symbol_throw, cell_f);
|
||||
if (throw != cell_f)
|
||||
return apply (throw->cdr, cons (key, cons (x, cell_nil)), R0);
|
||||
return apply (throw, cons (key, cons (x, cell_nil)), R0);
|
||||
#endif
|
||||
display_error_ (key);
|
||||
eputs (": ");
|
||||
|
|
|
@ -120,8 +120,8 @@ set_x (struct scm *x, struct scm *e) /*:((internal)) */
|
|||
p = x->variable;
|
||||
else
|
||||
{
|
||||
p = lookup_variable (x, cell_f);
|
||||
if (p == cell_f || p-> cdr == cell_undefined)
|
||||
p = lookup_handle (x, cell_f);
|
||||
if (p == cell_f || p->cdr == cell_undefined)
|
||||
error (cell_symbol_unbound_variable, x);
|
||||
}
|
||||
if (p->type != TPAIR)
|
||||
|
@ -148,7 +148,7 @@ struct scm *
|
|||
macro_get_handle (struct scm *name) /*:((internal)) */
|
||||
{
|
||||
if (name->type == TSYMBOL)
|
||||
return hashq_get_handle_ (g_macros, name, cell_nil);
|
||||
return hashq_get_handle_ (g_macros, name);
|
||||
return cell_f;
|
||||
}
|
||||
|
||||
|
@ -264,7 +264,7 @@ expand_variable_ (struct scm *x, struct scm *formals, int top_p) /*:((int
|
|||
&& a != cell_symbol_primitive_load
|
||||
&& formal_p (x->car, formals) == 0)
|
||||
{
|
||||
v = lookup_variable (a, cell_f);
|
||||
v = lookup_handle (a, cell_f);
|
||||
if (v != cell_f)
|
||||
x->car = make_variable (v);
|
||||
}
|
||||
|
@ -323,7 +323,7 @@ eval_apply ()
|
|||
struct scm *args;
|
||||
struct scm *body;
|
||||
struct scm *cl;
|
||||
struct scm *entry;
|
||||
struct scm *handle;
|
||||
struct scm *expanders;
|
||||
struct scm *formals;
|
||||
struct scm *input;
|
||||
|
@ -596,7 +596,8 @@ eval:
|
|||
if (R1->car == cell_symbol_define || R1->car == cell_symbol_define_macro)
|
||||
{
|
||||
global_p = 0;
|
||||
if (R0->car->car != cell_closure)
|
||||
if (R0->car->car != cell_closure
|
||||
|| R0->cdr->car->car == cell_undefined)
|
||||
global_p = 1;
|
||||
macro_p = 0;
|
||||
if (R1->car == cell_symbol_define_macro)
|
||||
|
@ -609,15 +610,15 @@ eval:
|
|||
name = name->car;
|
||||
if (macro_p != 0)
|
||||
{
|
||||
entry = cell_f;
|
||||
handle = cell_f;
|
||||
/* FIXME: dead code; no tests
|
||||
entry = assq (name, g_macros);
|
||||
if (entry == cell_f)
|
||||
handle = assq (name, g_macros);
|
||||
if (handle == cell_f)
|
||||
*/
|
||||
macro_set_x (name, entry);
|
||||
macro_set_x (name, handle);
|
||||
}
|
||||
else
|
||||
entry = lookup_variable (name, cell_t);
|
||||
lookup_handle (name, cell_t);
|
||||
}
|
||||
R2 = R1;
|
||||
aa = R1->cdr->car;
|
||||
|
@ -645,22 +646,28 @@ eval:
|
|||
name = name->car;
|
||||
if (macro_p != 0)
|
||||
{
|
||||
entry = macro_get_handle (name);
|
||||
handle = macro_get_handle (name);
|
||||
R1 = make_macro (name, R1);
|
||||
set_cdr_x (entry, R1);
|
||||
set_cdr_x (handle, R1);
|
||||
}
|
||||
else if (global_p != 0)
|
||||
{
|
||||
entry = lookup_variable (name, cell_f);
|
||||
set_cdr_x (entry, R1);
|
||||
handle = lookup_handle (name, cell_f);
|
||||
if (g_debug > 4)
|
||||
{
|
||||
eputs ("global set: ");
|
||||
write_error_ (name);
|
||||
eputs ("\n");
|
||||
}
|
||||
handle_set_x (handle, R1);
|
||||
}
|
||||
else
|
||||
{
|
||||
entry = cons (name, R1);
|
||||
aa = cons (entry, cell_nil);
|
||||
handle = cons (name, R1);
|
||||
aa = cons (handle, cell_nil);
|
||||
set_cdr_x (aa, cdr (R0));
|
||||
set_cdr_x (R0, aa);
|
||||
cl = lookup_variable (cell_closure, cell_f);
|
||||
cl = lookup_handle (cell_closure, cell_f);
|
||||
set_cdr_x (cl, aa);
|
||||
}
|
||||
R1 = cell_unspecified;
|
||||
|
@ -685,7 +692,7 @@ eval:
|
|||
goto vm_return;
|
||||
if (R1 == cell_symbol_call_with_current_continuation)
|
||||
goto vm_return;
|
||||
R1 = lookup_ref (R1);
|
||||
R1 = lookup_ref (R1, cell_t);
|
||||
goto vm_return;
|
||||
}
|
||||
else if (t == TVARIABLE)
|
||||
|
@ -758,15 +765,15 @@ macro_expand:
|
|||
macro = macro_get_handle (cell_symbol_portable_macro_expand);
|
||||
if (macro != cell_f)
|
||||
{
|
||||
expanders = lookup_ref (cell_symbol_sc_expander_alist);
|
||||
if (expanders != cell_f)
|
||||
expanders = lookup_ref (cell_symbol_sc_expander_alist, cell_f);
|
||||
if (expanders != cell_undefined)
|
||||
{
|
||||
macro = assq (R1->car, expanders);
|
||||
if (macro != cell_f)
|
||||
{
|
||||
sc_expand = lookup_ref (cell_symbol_macro_expand);
|
||||
sc_expand = lookup_ref (cell_symbol_macro_expand, cell_f);
|
||||
R2 = R1;
|
||||
if (sc_expand != cell_undefined && sc_expand != cell_f)
|
||||
if (sc_expand != cell_undefined && sc_expand != cell_undefined)
|
||||
{
|
||||
R1 = cons (sc_expand, cons (R1, cell_nil));
|
||||
goto apply;
|
||||
|
|
12
src/hash.c
12
src/hash.c
|
@ -66,7 +66,7 @@ hash (struct scm *x, struct scm *size)
|
|||
}
|
||||
|
||||
struct scm *
|
||||
hashq_get_handle_ (struct scm *table, struct scm *key, struct scm *dflt)
|
||||
hashq_get_handle_ (struct scm *table, struct scm *key)
|
||||
{
|
||||
struct scm *s = struct_ref_ (table, 3);
|
||||
long size = s->value;
|
||||
|
@ -74,8 +74,6 @@ hashq_get_handle_ (struct scm *table, struct scm *key, struct scm *dflt)
|
|||
struct scm *buckets = struct_ref_ (table, 4);
|
||||
struct scm *bucket = vector_ref_ (buckets, hash);
|
||||
struct scm *x = cell_f;
|
||||
if (dflt->type == TPAIR)
|
||||
x = dflt->car;
|
||||
if (bucket->type == TPAIR)
|
||||
x = assq (key, bucket);
|
||||
return x;
|
||||
|
@ -84,9 +82,11 @@ hashq_get_handle_ (struct scm *table, struct scm *key, struct scm *dflt)
|
|||
struct scm *
|
||||
hashq_ref_ (struct scm *table, struct scm *key, struct scm *dflt)
|
||||
{
|
||||
struct scm *x = hashq_get_handle_ (table, key, dflt);
|
||||
struct scm *x = hashq_get_handle_ (table, key);
|
||||
if (x != cell_f)
|
||||
x = x->cdr;
|
||||
else
|
||||
x = dflt;
|
||||
return x;
|
||||
}
|
||||
|
||||
|
@ -98,9 +98,7 @@ hash_ref_ (struct scm *table, struct scm *key, struct scm *dflt)
|
|||
unsigned hash = hash_ (key, size);
|
||||
struct scm *buckets = struct_ref_ (table, 4);
|
||||
struct scm *bucket = vector_ref_ (buckets, hash);
|
||||
struct scm *x = cell_f;
|
||||
if (dflt->type == TPAIR)
|
||||
x = dflt->car;
|
||||
struct scm *x = dflt;
|
||||
if (bucket->type == TPAIR)
|
||||
{
|
||||
x = assoc (key, bucket);
|
||||
|
|
76
src/module.c
76
src/module.c
|
@ -39,8 +39,82 @@ initial_module ()
|
|||
return M0;
|
||||
}
|
||||
|
||||
struct scm *
|
||||
current_module () /*:((internal)) */
|
||||
{
|
||||
struct scm *module = hashq_ref_ (M0, cstring_to_symbol ("*current-module*"), cell_f);
|
||||
if (module != cell_f)
|
||||
return module;
|
||||
return M0;
|
||||
}
|
||||
|
||||
struct scm *
|
||||
module_defines (struct scm *module) /*:((internal)) */
|
||||
{
|
||||
if (module != cell_f && module != M0)
|
||||
return struct_ref_ (module, MODULE_DEFINES);
|
||||
return M0;
|
||||
}
|
||||
|
||||
struct scm *
|
||||
module_define_x (struct scm *module, struct scm *name, struct scm *value)
|
||||
{
|
||||
return hashq_set_x (M0, name, value);
|
||||
struct scm *table = module_defines (module);
|
||||
return hashq_set_x (table, name, value);
|
||||
}
|
||||
|
||||
struct scm *
|
||||
module_handle (struct scm *module, struct scm *name) /*:((internal)) */
|
||||
{
|
||||
/* 1. Check module defines. */
|
||||
struct scm *table = module_defines (module);
|
||||
if (g_debug > 4)
|
||||
{
|
||||
eputs ("module_handle:");
|
||||
eputs (" name = ");
|
||||
write_error_ (name);
|
||||
// eputs (" defines = ");
|
||||
// write_error_ (table);
|
||||
eputs ("\n");
|
||||
}
|
||||
|
||||
struct scm *handle = hashq_get_handle_ (table, name);
|
||||
if (handle != cell_f)
|
||||
return handle;
|
||||
|
||||
/* 2. Custom binder. */
|
||||
/*
|
||||
struct scm *binder = struct_ref (module, MODULE_BINDER);
|
||||
if (binder != cell_f)
|
||||
{
|
||||
b = apply (binder->cdr, (cons (module, cons (name, cons (cell_f, cell_nil)))), cell_f);
|
||||
if (b != cell_f)
|
||||
return b;
|
||||
}
|
||||
*/
|
||||
|
||||
/* 3. Search the use list. */
|
||||
struct scm *uses = struct_ref_ (module, MODULE_USES);
|
||||
while (uses->type == TPAIR)
|
||||
{
|
||||
handle = module_handle (uses->car, name);
|
||||
if (handle != cell_f)
|
||||
return handle;
|
||||
uses = uses->cdr;
|
||||
}
|
||||
|
||||
/* 4. Hack for Mes: always look in M0. */
|
||||
handle = hashq_get_handle_ (M0, name);
|
||||
|
||||
return handle;
|
||||
}
|
||||
|
||||
/* NOT USED? */
|
||||
struct scm *
|
||||
module_variable (struct scm *module, struct scm *name)
|
||||
{
|
||||
struct scm *handle = module_handle (module, name);
|
||||
if (handle != cell_f)
|
||||
return handle->cdr;
|
||||
return cell_f;
|
||||
}
|
||||
|
|
|
@ -63,31 +63,62 @@ variable_bound_p (struct scm *var)
|
|||
}
|
||||
|
||||
struct scm *
|
||||
lookup_variable (struct scm *name, struct scm *define_p)
|
||||
handle_set_x (struct scm *handle, struct scm *value)
|
||||
{
|
||||
struct scm *x = handle->cdr;
|
||||
if (x->type == TVARIABLE)
|
||||
x->variable = value;
|
||||
else
|
||||
handle->cdr = value;
|
||||
return cell_unspecified;
|
||||
}
|
||||
|
||||
/*
|
||||
GUILE has `proc': scm_current_module -> scm_module_lookup_closure -> standard-eval-closure:
|
||||
|
||||
BUT: define-p: module-make-local-var!, !define-p: module-variable
|
||||
|
||||
*/
|
||||
struct scm *
|
||||
lookup_handle (struct scm *name, struct scm *define_p)
|
||||
{
|
||||
struct scm *handle = handle = assq (name, R0);
|
||||
|
||||
if (handle == cell_f)
|
||||
{
|
||||
handle = hashq_get_handle_ (M0, name, cell_f);
|
||||
if (handle == cell_f && define_p == cell_t)
|
||||
handle = hashq_set_handle_x (M0, name, cell_f);
|
||||
struct scm *module = current_module ();
|
||||
if (define_p == cell_f)
|
||||
{
|
||||
if (module == M0)
|
||||
handle = hashq_get_handle_ (M0, name);
|
||||
else
|
||||
handle = module_handle (module, name);
|
||||
}
|
||||
else
|
||||
{
|
||||
struct scm *table = module_defines (module);
|
||||
handle = hashq_get_handle_ (table, name);
|
||||
if (handle == cell_f)
|
||||
handle = hashq_set_handle_x (table, name, cell_f);
|
||||
}
|
||||
}
|
||||
|
||||
return handle;
|
||||
}
|
||||
|
||||
struct scm *
|
||||
lookup_variable_ (char const* name)
|
||||
lookup_ref (struct scm *name, struct scm *bound_p)
|
||||
{
|
||||
return lookup_variable (cstring_to_symbol (name), cell_f);
|
||||
struct scm *handle = lookup_handle (name, cell_f);
|
||||
if (handle->type == TPAIR)
|
||||
return handle->cdr;
|
||||
if (bound_p == cell_t)
|
||||
error (cell_symbol_unbound_variable, name);
|
||||
return cell_undefined;
|
||||
}
|
||||
|
||||
struct scm *
|
||||
lookup_ref (struct scm *name)
|
||||
lookup_ref_ (char const *name)
|
||||
{
|
||||
struct scm *x = lookup_variable (name, cell_f);
|
||||
if (x == cell_f)
|
||||
error (cell_symbol_unbound_variable, name);
|
||||
return x->cdr;
|
||||
return lookup_ref (cstring_to_symbol (name), cell_f);
|
||||
}
|
||||
|
|
|
@ -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 <http://www.gnu.org/licenses/>.
|
||||
|
||||
(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))
|
||||
|
|
Loading…
Reference in New Issue