2016-12-24 00:23:50 +00:00
|
|
|
;;; -*-scheme-*-
|
|
|
|
|
2018-07-22 13:24:36 +01:00
|
|
|
;;; GNU Mes --- Maxwell Equations of Software
|
2019-07-19 14:36:36 +01:00
|
|
|
;;; Copyright © 2016,2017,2018,2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
|
2016-12-24 00:23:50 +00:00
|
|
|
;;;
|
2018-07-22 13:24:36 +01:00
|
|
|
;;; This file is part of GNU Mes.
|
2016-12-24 00:23:50 +00:00
|
|
|
;;;
|
2018-07-22 13:24:36 +01:00
|
|
|
;;; GNU Mes is free software; you can redistribute it and/or modify it
|
2016-12-24 00:23:50 +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-12-24 00:23:50 +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-12-24 00:23:50 +00:00
|
|
|
|
|
|
|
;;; Commentary:
|
|
|
|
|
|
|
|
;;; Code:
|
|
|
|
|
|
|
|
(mes-use-module (mes scm))
|
2016-12-26 09:00:17 +00:00
|
|
|
|
|
|
|
(define (srfi-1:member x lst eq)
|
|
|
|
(if (null? lst) #f
|
|
|
|
(if (eq x (car lst)) lst
|
|
|
|
(srfi-1:member x (cdr lst) eq))))
|
|
|
|
|
|
|
|
(define (next-xassq x a)
|
|
|
|
(and=> (srfi-1:member x a (lambda (x e) (eq? x (cdr e))))
|
|
|
|
(lambda (a) (xassq x (cdr a)))))
|
|
|
|
|
|
|
|
(define (next-xassq2 x a)
|
|
|
|
(and=> (srfi-1:member x a (lambda (x e) (eq? x (cdr e))))
|
|
|
|
(lambda (a)
|
|
|
|
(and=> (srfi-1:member x (cdr a) (lambda (x e) (eq? x (cdr e))))
|
|
|
|
(lambda (a) (xassq x (cdr a)))))))
|
2016-12-24 00:23:50 +00:00
|
|
|
|
2018-03-04 09:05:55 +00:00
|
|
|
(define-macro (display-cut f slot n1)
|
|
|
|
`(lambda (slot) (,f slot ,n1)))
|
|
|
|
|
|
|
|
(define-macro (display-cut2 f slot n1 n2)
|
|
|
|
`(lambda (slot) (,f slot ,n1 ,n2)))
|
|
|
|
|
2016-12-24 00:23:50 +00:00
|
|
|
(define (display x . rest)
|
|
|
|
(let* ((port (if (null? rest) (current-output-port) (car rest)))
|
2017-04-03 06:19:38 +01:00
|
|
|
(write? (and (pair? rest) (pair? (cdr rest)) (cadr rest))))
|
2016-12-24 10:10:11 +00:00
|
|
|
|
2017-04-03 06:19:38 +01:00
|
|
|
(define (display-char x port write?)
|
2018-11-11 15:25:36 +00:00
|
|
|
(if write?
|
|
|
|
(cond ((or (eq? x #\") (eq? x #\\))
|
|
|
|
(write-char #\\ port)
|
|
|
|
(write-char x port))
|
|
|
|
((eq? x #\nul)
|
|
|
|
(write-char #\\ port)
|
|
|
|
(write-char #\0 port))
|
|
|
|
((eq? x #\alarm)
|
|
|
|
(write-char #\\ port)
|
|
|
|
(write-char #\a port))
|
|
|
|
((eq? x #\backspace)
|
|
|
|
(write-char #\\ port)
|
|
|
|
(write-char #\b port))
|
|
|
|
((eq? x #\tab)
|
|
|
|
(write-char #\\ port)
|
|
|
|
(write-char #\t port))
|
|
|
|
((eq? x #\newline)
|
|
|
|
(write-char #\\ port)
|
|
|
|
(write-char #\n port))
|
|
|
|
((eq? x #\vtab)
|
|
|
|
(write-char #\\ port)
|
|
|
|
(write-char #\v port))
|
|
|
|
((eq? x #\page)
|
|
|
|
(write-char #\\ port)
|
|
|
|
(write-char #\f port))
|
|
|
|
(#t (write-char x port)))
|
|
|
|
(write-char x port)))
|
2016-12-24 00:23:50 +00:00
|
|
|
|
|
|
|
(define (d x cont? sep)
|
2018-03-04 09:05:55 +00:00
|
|
|
(for-each (display-cut write-char <> port) (string->list sep))
|
2016-12-24 00:23:50 +00:00
|
|
|
(cond
|
2018-01-04 20:36:46 +00:00
|
|
|
((eof-object? x)
|
|
|
|
(display "#<eof>" port))
|
2016-12-24 00:23:50 +00:00
|
|
|
((char? x)
|
2016-12-24 10:10:11 +00:00
|
|
|
(if (not write?) (write-char x port)
|
2018-01-04 20:36:46 +00:00
|
|
|
(let ((name (and=> (assq x '((#\nul . nul)
|
2016-12-24 10:10:11 +00:00
|
|
|
(#\alarm . alarm)
|
|
|
|
(#\backspace . backspace)
|
|
|
|
(#\tab . tab)
|
|
|
|
(#\newline . newline)
|
|
|
|
(#\vtab . vtab)
|
|
|
|
(#\page . page)
|
|
|
|
(#\return . return)
|
|
|
|
(#\space . space)))
|
|
|
|
cdr)))
|
|
|
|
(write-char #\# port)
|
2018-11-11 15:25:36 +00:00
|
|
|
(when (or name
|
|
|
|
(and (>= (char->integer 32))
|
|
|
|
(<= (char->integer 127))))
|
|
|
|
(write-char #\\ port))
|
2017-03-27 20:41:44 +01:00
|
|
|
(if name (display name port)
|
2016-12-24 10:10:11 +00:00
|
|
|
(write-char x port)))))
|
2016-12-24 00:23:50 +00:00
|
|
|
((closure? x)
|
2016-12-26 09:00:17 +00:00
|
|
|
(display "#<procedure " port)
|
|
|
|
(let ((name (and=> (next-xassq2 x (current-module)) car)))
|
|
|
|
(display name port))
|
|
|
|
(display " " port)
|
2016-12-24 00:23:50 +00:00
|
|
|
(display (cadr (core:cdr x)) port)
|
|
|
|
(display ">" port))
|
2016-12-28 21:04:57 +00:00
|
|
|
((continuation? x)
|
|
|
|
(display "#<continuation " port)
|
|
|
|
(display (core:car x) port)
|
|
|
|
(display ">" port))
|
2016-12-24 00:23:50 +00:00
|
|
|
((macro? x)
|
2016-12-24 10:10:11 +00:00
|
|
|
(display "#<macro " port)
|
2016-12-24 00:23:50 +00:00
|
|
|
(display (core:cdr x) port)
|
|
|
|
(display ">" port))
|
2018-04-29 16:48:38 +01:00
|
|
|
((port? x)
|
|
|
|
(display "#<port " port)
|
|
|
|
(display (core:cdr x) port)
|
2018-10-15 11:28:02 +01:00
|
|
|
(display " ")
|
2018-04-29 16:48:38 +01:00
|
|
|
(display (core:car x) port)
|
|
|
|
(display ">" port))
|
2017-12-09 07:33:50 +00:00
|
|
|
((variable? x)
|
|
|
|
(display "#<variable " port)
|
2018-04-29 16:48:38 +01:00
|
|
|
(write (list->string (car (core:car x))) port)
|
2017-12-09 07:33:50 +00:00
|
|
|
(display ">" port))
|
mescc: Run module/base-0.mes.
* gc.c: New file.
* vector.c: New file.
* mes.c: Remove vector and gc functions, include vector.c, gc.c.
* GNUmakefile (mes.o): Add gc, vector dependencies.
* scaffold/mini-mes.c (eval_apply): Support primitive-load through
read_input_file.
(getenv_, open_input_file, current_input_port,
set_current_input_port force_output, exit_, values, arity_, xassq,
is_p, minus, plus, divide, modulo multiply, logior, ash): New function.
(mes_symbols): Add symbols %gnuc, %mesc.
* scaffold/mini-mes.c (): New functions.
* scaffold/b-0.mes: New file.
* scaffold/t-0.mes: New file.
2017-03-26 20:13:01 +01:00
|
|
|
((number? x)
|
|
|
|
(display (number->string x) port))
|
2016-12-24 00:23:50 +00:00
|
|
|
((pair? x)
|
|
|
|
(if (not cont?) (write-char #\( port))
|
|
|
|
(cond ((eq? (car x) '*circular*)
|
2017-12-11 06:06:21 +00:00
|
|
|
(display "*circ* . #-1#)" port))
|
2016-12-24 00:23:50 +00:00
|
|
|
((eq? (car x) '*closure*)
|
2017-12-11 06:06:21 +00:00
|
|
|
(display "*closure* . #-1#)" port))
|
2016-12-24 00:23:50 +00:00
|
|
|
(#t
|
|
|
|
(display (car x) port write?)
|
|
|
|
(if (pair? (cdr x)) (d (cdr x) #t " ")
|
|
|
|
(if (and (cdr x) (not (null? (cdr x))))
|
|
|
|
(begin
|
|
|
|
(display " . " port)
|
2017-12-11 06:06:21 +00:00
|
|
|
(display (cdr x) port write?))))))
|
|
|
|
(if (not cont?) (write-char #\) port)))
|
2016-12-24 00:23:50 +00:00
|
|
|
((or (keyword? x) (special? x) (string? x) (symbol? x))
|
|
|
|
(if (and (string? x) write?) (write-char #\" port))
|
|
|
|
(if (keyword? x) (display "#:" port))
|
2018-03-04 09:05:55 +00:00
|
|
|
(for-each (display-cut2 display-char <> port write?) (string->list x))
|
2016-12-24 00:23:50 +00:00
|
|
|
(if (and (string? x) write?) (write-char #\" port)))
|
core: Remove struct definitions for builtins, drop snarfing.
After making a change to the list of builtin functions, run
cat src/*.i
and move the into
src/mes.c:mes_builtins ()
and, or also after changing the list of fixed symbols in src/mes.c:mes_symbols (), do
cat src/*.h > src/builtins.h
* build-aux/build.sh.in: Remove snarfing.
* build-aux/bootstrap.sh.in: Likewise.
* mes/module/mes/display.mes (display):
* mes/module/mes/type-0.mes (cell:type-alist): Remove <cell:function>.
(function?, builtin?): Remove.
* src/builtins.h: New file.
* src/mes.c (TFUNCTION): Remove.
(struct function): Remove.
(apply_builtin): Rewrite from call.
(mes_builtins): Rewrite.
(init_builtin, make_builtin_type, make_builtin, builtin_name,
builtin_arity, builtin, builtin_p, builtin_printer): New function.
2019-01-04 08:55:16 +00:00
|
|
|
((builtin? x)
|
|
|
|
(display "#<procedure " port)
|
|
|
|
(display (builtin-name x) port)
|
|
|
|
(display " " port)
|
|
|
|
(display
|
|
|
|
(case (builtin-arity x)
|
|
|
|
((-1) "_")
|
|
|
|
((0) "()")
|
|
|
|
((1) "(_)")
|
|
|
|
((2) "(_ _)")
|
|
|
|
((3) "(_ _ _)"))
|
|
|
|
port)
|
|
|
|
(display ">" port))
|
2018-10-13 16:34:27 +01:00
|
|
|
((struct? x)
|
core: Remove struct definitions for builtins, drop snarfing.
After making a change to the list of builtin functions, run
cat src/*.i
and move the into
src/mes.c:mes_builtins ()
and, or also after changing the list of fixed symbols in src/mes.c:mes_symbols (), do
cat src/*.h > src/builtins.h
* build-aux/build.sh.in: Remove snarfing.
* build-aux/bootstrap.sh.in: Likewise.
* mes/module/mes/display.mes (display):
* mes/module/mes/type-0.mes (cell:type-alist): Remove <cell:function>.
(function?, builtin?): Remove.
* src/builtins.h: New file.
* src/mes.c (TFUNCTION): Remove.
(struct function): Remove.
(apply_builtin): Rewrite from call.
(mes_builtins): Rewrite.
(init_builtin, make_builtin_type, make_builtin, builtin_name,
builtin_arity, builtin, builtin_p, builtin_printer): New function.
2019-01-04 08:55:16 +00:00
|
|
|
(let* ((printer (struct-ref x 1)))
|
|
|
|
(if (or (builtin? printer) (closure? printer))
|
|
|
|
(printer x)
|
|
|
|
(begin
|
|
|
|
(display "#<" port)
|
|
|
|
(for-each (lambda (i)
|
|
|
|
(let ((x (struct-ref x i)))
|
|
|
|
(d x #f (if (= i 0) "" " "))))
|
|
|
|
(iota (struct-length x)))
|
|
|
|
(display ")" port)))))
|
2016-12-24 00:23:50 +00:00
|
|
|
((vector? x)
|
|
|
|
(display "#(" port)
|
|
|
|
(for-each (lambda (i)
|
|
|
|
(let ((x (vector-ref x i)))
|
|
|
|
(if (vector? x)
|
|
|
|
(begin
|
|
|
|
(display (if (= i 0) "" " ") port)
|
|
|
|
(display "#(...)" port))
|
|
|
|
(d x #f (if (= i 0) "" " ")))))
|
|
|
|
(iota (vector-length x)))
|
|
|
|
(display ")" port))
|
|
|
|
((broken-heart? x)
|
|
|
|
(display "<3" port))
|
|
|
|
(#t
|
|
|
|
(display "TODO type=") (display (cell:type-name x)) (newline)))
|
|
|
|
*unspecified*)
|
|
|
|
(d x #f "")))
|
2016-12-24 10:10:11 +00:00
|
|
|
|
|
|
|
(define (write-char x . rest)
|
|
|
|
(apply write-byte (cons (char->integer x) rest)))
|
|
|
|
|
|
|
|
(define (write x . rest)
|
|
|
|
(let ((port (if (null? rest) (current-output-port) (car rest))))
|
|
|
|
(display x port #t)))
|
|
|
|
|
|
|
|
(define (newline . rest)
|
|
|
|
(apply display (cons "\n" rest)))
|