115 lines
3.6 KiB
Scheme
115 lines
3.6 KiB
Scheme
;;; -*-scheme-*-
|
|
|
|
;;; GNU Mes --- Maxwell Equations of Software
|
|
;;; Copyright © 2016 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/>.
|
|
|
|
(define (interaction-environment) (current-module))
|
|
|
|
(define (eval x . environment)
|
|
(core:eval (if (and (pair? x) (equal? (car x) "noexpand")) (cadr x) x)
|
|
(if (null? environment) (current-module) (car environment))))
|
|
|
|
(define annotation? (lambda (x) #f))
|
|
(define (self-evaluating? x)
|
|
(or (null? x) (boolean? x) (char? x) (closure? x) (keyword? x) (number? x) (string? x)))
|
|
|
|
(define (void) (if #f #f))
|
|
|
|
(define macro-expand #f)
|
|
(define sc-expand #f)
|
|
(define sc-chi #f)
|
|
(define sc-expand3 #f)
|
|
(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)
|
|
(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)
|
|
(define remprop #f)
|
|
(define properties-alist #f)
|
|
|
|
(let ((properties '()))
|
|
(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))
|
|
#f))))
|
|
(set! remprop
|
|
(lambda (symbol key)
|
|
(putprop symbol key #f)))
|
|
(set! properties-alist (lambda () *sc-expander-alist*)))
|
|
|
|
;; (define fx+ +)
|
|
;; (define fx- -)
|
|
;; (define fx= =)
|
|
;; (define fx< <)
|