2016-10-30 15:16:20 +00:00
|
|
|
;;; -*-scheme-*-
|
|
|
|
|
2018-07-22 13:24:36 +01:00
|
|
|
;;; GNU Mes --- Maxwell Equations of Software
|
2017-11-21 18:22:26 +00:00
|
|
|
;;; Copyright © 2016 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
|
2016-10-30 15:16:20 +00:00
|
|
|
;;;
|
2018-07-22 13:24:36 +01:00
|
|
|
;;; This file is part of GNU Mes.
|
2016-10-30 15:16:20 +00:00
|
|
|
;;;
|
2018-07-22 13:24:36 +01:00
|
|
|
;;; GNU Mes is free software; you can redistribute it and/or modify it
|
2016-10-30 15:16:20 +00:00
|
|
|
;;; 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.
|
|
|
|
;;;
|
2018-07-22 13:24:36 +01:00
|
|
|
;;; GNU Mes is distributed in the hope that it will be useful, but
|
2016-10-30 15:16:20 +00:00
|
|
|
;;; 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
|
2018-07-22 13:24:36 +01:00
|
|
|
;;; along with GNU Mes. If not, see <http://www.gnu.org/licenses/>.
|
2016-10-30 15:16:20 +00:00
|
|
|
|
|
|
|
(define (interaction-environment) (current-module))
|
|
|
|
|
2016-12-11 20:39:54 +00:00
|
|
|
(define (eval x . environment)
|
core: Rewrite eval_apply in continuation passing style.
* mes.c (scm_vm_evlis, scm_vm_evlis2, scm_vm_evlis3, scm_vm_apply,
scm_vm_apply2, scm_vm_eval, scm_vm_eval_set_x, scm_vm_eval_macro,
scm_vm_eval2, scm_vm_macro_expand, scm_vm_begin,
scm_vm_begin_read_input_file, scm_vm_begin2, scm_vm_if,
scm_vm_if_expr, scm_vm_call_with_values, scm_vm_call_with_values2,
scm_vm_return): New specials.
(scm_vm_eval_car, scm_vm_eval_cdr, scm_vm_eval_cons,
scm_vm_eval_null_p)[PRIMITIVE-EVAL]: New specials.
(eval_apply_t, g_target): Remove.
(push_cc): New function.
(eval_apply): Rewrite.
(vm_call, eval_env, apply_env, eval_env, macro_expand_env, begin_env,
call_with_values_env): Remove.
* posix.c (stderr_): Update.
* reader.c (read_input_file_env): Update.
* module/mes/base-0.mes: Update.
2016-12-28 20:55:42 +00:00
|
|
|
(core:eval (if (and (pair? x) (equal? (car x) "noexpand")) (cadr x) x)
|
|
|
|
(if (null? environment) (current-module) (car environment))))
|
2016-10-30 15:16:20 +00:00
|
|
|
|
|
|
|
(define annotation? (lambda (x) #f))
|
|
|
|
(define (self-evaluating? x)
|
2017-01-07 00:08:29 +00:00
|
|
|
(or (null? x) (boolean? x) (char? x) (closure? x) (keyword? x) (number? x) (string? x)))
|
2016-10-30 15:16:20 +00:00
|
|
|
|
|
|
|
(define (void) (if #f #f))
|
|
|
|
|
core: Rewrite eval_apply in continuation passing style.
* mes.c (scm_vm_evlis, scm_vm_evlis2, scm_vm_evlis3, scm_vm_apply,
scm_vm_apply2, scm_vm_eval, scm_vm_eval_set_x, scm_vm_eval_macro,
scm_vm_eval2, scm_vm_macro_expand, scm_vm_begin,
scm_vm_begin_read_input_file, scm_vm_begin2, scm_vm_if,
scm_vm_if_expr, scm_vm_call_with_values, scm_vm_call_with_values2,
scm_vm_return): New specials.
(scm_vm_eval_car, scm_vm_eval_cdr, scm_vm_eval_cons,
scm_vm_eval_null_p)[PRIMITIVE-EVAL]: New specials.
(eval_apply_t, g_target): Remove.
(push_cc): New function.
(eval_apply): Rewrite.
(vm_call, eval_env, apply_env, eval_env, macro_expand_env, begin_env,
call_with_values_env): Remove.
* posix.c (stderr_): Update.
* reader.c (read_input_file_env): Update.
* module/mes/base-0.mes: Update.
2016-12-28 20:55:42 +00:00
|
|
|
(define macro-expand #f)
|
2016-10-30 15:16:20 +00:00
|
|
|
(define sc-expand #f)
|
|
|
|
(define sc-chi #f)
|
|
|
|
(define sc-expand3 #f)
|
2016-12-11 20:39:54 +00:00
|
|
|
(define $sc-put-cte #f)
|
|
|
|
(define $make-environment #f)
|
|
|
|
(define environment? #f)
|
|
|
|
(define syntax->list #f)
|
|
|
|
(define syntax->vector #f)
|
|
|
|
(define literal-identifier=? #f)
|
|
|
|
(define $syntax-dispatch #f)
|
|
|
|
(define eval-when #f)
|
2016-10-30 15:16:20 +00:00
|
|
|
(define install-global-transformer #f)
|
|
|
|
(define syntax-dispatch #f)
|
|
|
|
(define syntax-error #f)
|
|
|
|
|
|
|
|
(define bound-identifier=? #f)
|
|
|
|
(define datum->syntax-object #f)
|
|
|
|
(define define-syntax (void))
|
|
|
|
(define fluid-let-syntax #f)
|
|
|
|
(define free-identifier=? #f)
|
|
|
|
(define generate-temporaries #f)
|
|
|
|
(define identifier? #f)
|
|
|
|
(define identifier-syntax #f)
|
|
|
|
(define let-syntax #f)
|
|
|
|
(define letrec-syntax #f)
|
|
|
|
(define syntax #f)
|
|
|
|
(define syntax-case #f)
|
|
|
|
(define syntax-object->datum #f)
|
|
|
|
(define syntax-rules #f)
|
|
|
|
(define with-syntax #f)
|
|
|
|
|
|
|
|
(define andmap
|
|
|
|
(lambda (f . lists)
|
|
|
|
(if (null? (car lists)) (and)
|
|
|
|
(if (null? (cdr (car lists))) (apply f (map car lists))
|
|
|
|
(and (apply f (map car lists))
|
|
|
|
(apply andmap f (map cdr lists)))))))
|
|
|
|
|
|
|
|
(define ormap
|
|
|
|
(lambda (proc list1)
|
|
|
|
(and (not (null? list1))
|
|
|
|
(or (proc (car list1)) (ormap proc (cdr list1))))))
|
|
|
|
|
|
|
|
(define *sc-expander-alist* '())
|
|
|
|
|
|
|
|
(define putprop #f)
|
|
|
|
(define getprop #f)
|
2016-12-11 20:39:54 +00:00
|
|
|
(define remprop #f)
|
2016-11-02 09:36:09 +00:00
|
|
|
(define properties-alist #f)
|
2016-10-30 15:16:20 +00:00
|
|
|
|
2016-11-02 09:36:09 +00:00
|
|
|
(let ((properties '()))
|
2016-10-30 15:16:20 +00:00
|
|
|
(set! putprop
|
|
|
|
(lambda (symbol key value)
|
|
|
|
(let ((plist (assq symbol *sc-expander-alist*)))
|
|
|
|
(if (pair? plist)
|
|
|
|
(let ((couple (assq key (cdr plist))))
|
|
|
|
(if (pair? couple)
|
|
|
|
(set-cdr! couple value)
|
|
|
|
(set-cdr! plist (cons (cons key value)
|
|
|
|
(cdr plist)))))
|
|
|
|
(let ((plist (list symbol (cons key value))))
|
|
|
|
(set! *sc-expander-alist* (cons plist *sc-expander-alist*)))))
|
|
|
|
value))
|
|
|
|
(set! getprop
|
|
|
|
(lambda (symbol key)
|
|
|
|
(let ((plist (assq symbol *sc-expander-alist*)))
|
|
|
|
(if (pair? plist)
|
|
|
|
(let ((couple (assq key (cdr plist))))
|
|
|
|
(if (pair? couple)
|
|
|
|
(cdr couple)
|
|
|
|
#f))
|
2016-11-02 09:36:09 +00:00
|
|
|
#f))))
|
2016-12-11 20:39:54 +00:00
|
|
|
(set! remprop
|
|
|
|
(lambda (symbol key)
|
|
|
|
(putprop symbol key #f)))
|
2016-11-02 09:36:09 +00:00
|
|
|
(set! properties-alist (lambda () *sc-expander-alist*)))
|
2016-12-11 20:39:54 +00:00
|
|
|
|
2016-10-30 15:16:20 +00:00
|
|
|
;; (define fx+ +)
|
|
|
|
;; (define fx- -)
|
|
|
|
;; (define fx= =)
|
|
|
|
;; (define fx< <)
|