core: Remove display.
* posix.c (stderr_): New function. * display.c: Remove. * mes.c: Remove includes. Use stderr_ instead of display_. (gc_loop): Preserve function's name. (arity_): New function. * GNUmakefile (mes.o): Remove dependency on display. * module/mes/read-0.mes: Use core:stderr instead of display, newline. (newline): New function. * module/mes/base-0.mes: Use core:stderr instead of display. Include (mes display). * module/mes/display.mes: New file. * lib.c (assert_defined): Move from mes.c. (string_to_cstring): Move from posix.c * build-aux/mes-snarf.scm (function-environment): Initialize function name with scheme string.
This commit is contained in:
Jan Nieuwenhuizen
parent
d295ee5668
commit
16e3caafcd
|
|
@ -29,7 +29,6 @@ all: mes module/mes/read-0.mo
|
|||
mes.o: GNUmakefile
|
||||
mes.o: mes.c
|
||||
mes.o: mes.c mes.h mes.i mes.environment.i mes.symbols.i
|
||||
mes.o: display.c display.h display.i display.environment.i
|
||||
mes.o: lib.c lib.h lib.i lib.environment.i
|
||||
mes.o: math.c math.h math.i math.environment.i
|
||||
mes.o: posix.c posix.h posix.i posix.environment.i
|
||||
|
|
|
|||
|
|
@ -106,6 +106,7 @@ exec ${GUILE-guile} --no-auto-compile -L $HOME/src/mes/build-aux -L build-aux -e
|
|||
(define (function->environment f i)
|
||||
(string-append
|
||||
(format #f "scm_~a.string = cstring_to_list (scm_~a.name);\n" (.name f) (.name f))
|
||||
(format #f "g_cells[cell_~a].string = MAKE_STRING (scm_~a.string);\n" (.name f) (.name f))
|
||||
(format #f "a = acons (make_symbol (scm_~a.string), ~a, a);\n" (.name f) (function-cell-name f))
|
||||
;;(format #f "a = add_environment (a, ~S, ~a);\n" (function-scm-name f) (function-cell-name f))
|
||||
))
|
||||
|
|
|
|||
166
display.c
166
display.c
|
|
@ -1,166 +0,0 @@
|
|||
/* -*-comment-start: "//";comment-end:""-*-
|
||||
* Mes --- Maxwell Equations of Software
|
||||
* Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
|
||||
*
|
||||
* This file is part of Mes.
|
||||
*
|
||||
* 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.
|
||||
*
|
||||
* 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 Mes. If not, see <http://www.gnu.org/licenses/>.
|
||||
*/
|
||||
|
||||
SCM display_helper (FILE*, SCM , bool, char const*, bool);
|
||||
|
||||
SCM
|
||||
display (SCM x) ///((arity . n))
|
||||
{
|
||||
SCM e = car (x);
|
||||
SCM p = cdr (x);
|
||||
int fd = 1;
|
||||
if (TYPE (p) == PAIR && TYPE (car (p)) == NUMBER) fd = HITS (car (p));
|
||||
FILE *f = fd == 1 ? stdout : stderr;
|
||||
return display_helper (f, e, false, "", false);
|
||||
}
|
||||
|
||||
SCM
|
||||
newline (SCM p) ///((arity . n))
|
||||
{
|
||||
int fd = 1;
|
||||
if (TYPE (p) == PAIR && TYPE (car (p)) == NUMBER) fd = VALUE (car (p));
|
||||
FILE *f = fd == 1 ? stdout : stderr;
|
||||
fputs ("\n", f);
|
||||
return cell_unspecified;
|
||||
}
|
||||
|
||||
SCM
|
||||
display_ (FILE* f, SCM x)
|
||||
{
|
||||
return display_helper (f, x, false, "", false);
|
||||
}
|
||||
|
||||
SCM
|
||||
display_helper (FILE* f, SCM x, bool cont, char const *sep, bool quote)
|
||||
{
|
||||
SCM r;
|
||||
fprintf (f, "%s", sep);
|
||||
switch (TYPE (x))
|
||||
{
|
||||
case CHAR:
|
||||
{
|
||||
char const *name = 0;
|
||||
if (VALUE (x) == char_nul.value) name = char_nul.name;
|
||||
else if (VALUE (x) == char_alarm.value) name = char_alarm.name;
|
||||
else if (VALUE (x) == char_backspace.value) name = char_backspace.name;
|
||||
else if (VALUE (x) == char_tab.value) name = char_tab.name;
|
||||
else if (VALUE (x) == char_newline.value) name = char_newline.name;
|
||||
else if (VALUE (x) == char_vtab.value) name = char_vtab.name;
|
||||
else if (VALUE (x) == char_page.value) name = char_page.name;
|
||||
else if (VALUE (x) == char_return.value) name = char_return.name;
|
||||
else if (VALUE (x) == char_space.value) name = char_space.name;
|
||||
if (name) fprintf (f, "#\\%s", name);
|
||||
else fprintf (f, "#\\%c", VALUE (x));
|
||||
break;
|
||||
}
|
||||
case CLOSURE:
|
||||
{
|
||||
fprintf (f, "#<procedure #f ");
|
||||
display_ (f, (cadr (CLOSURE (x))));
|
||||
fprintf (f, ">");
|
||||
return cell_unspecified;
|
||||
}
|
||||
case MACRO:
|
||||
fprintf (f, "(*macro* ");
|
||||
display_helper (f, g_cells[x].macro, cont, sep, quote);
|
||||
fprintf (f, ")");
|
||||
break;
|
||||
case NUMBER: fprintf (f, "%d", VALUE (x)); break;
|
||||
case PAIR:
|
||||
{
|
||||
if (car (x) == cell_circular) {
|
||||
fprintf (f, "(*circ* . #-1#)");
|
||||
return cell_unspecified;
|
||||
}
|
||||
if (car (x) == cell_closure) {
|
||||
fprintf (f, "(*closure* . #-1#)");
|
||||
return cell_unspecified;
|
||||
}
|
||||
if (car (x) == cell_symbol_quote && TYPE (cdr (x)) != PAIR) {
|
||||
fprintf (f, "'");
|
||||
x = cdr (x);
|
||||
if (TYPE (x) != FUNCTION)
|
||||
x = car (x);
|
||||
return display_helper (f, x, cont, "", true);
|
||||
}
|
||||
if (!cont) fprintf (f, "(");
|
||||
if (x && x!= cell_nil) display_ (f, car (x));
|
||||
if (cdr (x) && TYPE (cdr (x)) == PAIR)
|
||||
display_helper (f, cdr (x), true, " ", false);
|
||||
else if (cdr (x) && cdr (x) != cell_nil) {
|
||||
fprintf (f, " . ");
|
||||
display_ (f, cdr (x));
|
||||
}
|
||||
if (!cont) fprintf (f, ")");
|
||||
break;
|
||||
}
|
||||
case VECTOR:
|
||||
{
|
||||
fprintf (f, "#(");
|
||||
for (int i = 0; i < LENGTH (x); i++) {
|
||||
if (TYPE (VECTOR (x)+i) == VECTOR
|
||||
|| (TYPE (VECTOR (x)+i) == REF
|
||||
&& TYPE (REF (VECTOR (x)+i)) == VECTOR))
|
||||
fprintf (f, "%s#(...)", i ? " " : "");
|
||||
else
|
||||
display_helper (f,VECTOR (x)+i, false, i ? " " : "", false);
|
||||
}
|
||||
fprintf (f, ")");
|
||||
break;
|
||||
}
|
||||
case REF: display_helper (f, g_cells[x].ref, cont, "", true); break;
|
||||
case FUNCTION:
|
||||
{
|
||||
fprintf (f, "#<procedure ");
|
||||
SCM p = STRING (x);
|
||||
if (p < 0 || p >= g_free.value || TYPE (p) != PAIR)
|
||||
fprintf (f, "%s", NAME (x));
|
||||
else
|
||||
display_ (f, STRING (x));
|
||||
fprintf (f, " ");
|
||||
switch (FUNCTION (x).arity)
|
||||
{
|
||||
case -1: fprintf (f, "(. x)"); break;
|
||||
case 0: fprintf (f, "()"); break;
|
||||
case 1: fprintf (f, "(x)"); break;
|
||||
case 2: fprintf (f, "(x y)"); break;
|
||||
case 3: fprintf (f, "(x y z)"); break;
|
||||
}
|
||||
fprintf (f, ">");
|
||||
break;
|
||||
}
|
||||
case BROKEN_HEART: fprintf (f, "<3"); break;
|
||||
case KEYWORD:
|
||||
fprintf (f, "#:");
|
||||
default:
|
||||
if (STRING (x))
|
||||
{
|
||||
SCM p = STRING (x);
|
||||
assert (p);
|
||||
while (p != cell_nil) {
|
||||
assert (TYPE (car (p)) == CHAR);
|
||||
fputc (VALUE (car (p)), f);
|
||||
p = cdr (p);
|
||||
}
|
||||
}
|
||||
else if (TYPE (x) != PAIR && NAME (x)) fprintf (f, "%s", NAME (x));
|
||||
}
|
||||
return cell_unspecified;
|
||||
}
|
||||
27
lib.c
27
lib.c
|
|
@ -55,3 +55,30 @@ exit_ (SCM x) ///((name . "exit"))
|
|||
assert (TYPE (x) == NUMBER);
|
||||
exit (VALUE (x));
|
||||
}
|
||||
|
||||
char const*
|
||||
string_to_cstring (SCM s)
|
||||
{
|
||||
static char buf[1024];
|
||||
char *p = buf;
|
||||
s = STRING (s);
|
||||
while (s != cell_nil)
|
||||
{
|
||||
*p++ = VALUE (car (s));
|
||||
s = cdr (s);
|
||||
}
|
||||
*p = 0;
|
||||
return buf;
|
||||
}
|
||||
|
||||
SCM
|
||||
assert_defined (SCM x, SCM e)
|
||||
{
|
||||
if (e == cell_undefined)
|
||||
{
|
||||
fprintf (stderr, "eval: unbound variable:");
|
||||
stderr_ (x);
|
||||
assert (!"unbound variable");
|
||||
}
|
||||
return e;
|
||||
}
|
||||
|
|
|
|||
44
mes.c
44
mes.c
|
|
@ -111,6 +111,7 @@ scm scm_symbol_call_with_values = {SYMBOL, "call-with-values"};
|
|||
scm scm_symbol_current_module = {SYMBOL, "current-module"};
|
||||
scm scm_symbol_primitive_load = {SYMBOL, "primitive-load"};
|
||||
scm scm_symbol_read_input_file = {SYMBOL, "read-input-file"};
|
||||
scm scm_symbol_display = {SYMBOL, "display"};
|
||||
|
||||
scm scm_symbol_car = {SYMBOL, "car"};
|
||||
scm scm_symbol_cdr = {SYMBOL, "cdr"};
|
||||
|
|
@ -118,17 +119,6 @@ scm scm_symbol_null_p = {SYMBOL, "null?"};
|
|||
scm scm_symbol_eq_p = {SYMBOL, "eq?"};
|
||||
scm scm_symbol_cons = {SYMBOL, "cons"};
|
||||
|
||||
scm char_eof = {CHAR, .name="*eof*", .value=-1};
|
||||
scm char_nul = {CHAR, .name="nul", .value=0};
|
||||
scm char_alarm = {CHAR, .name="alarm", .value=8};
|
||||
scm char_backspace = {CHAR, .name="backspace", .value=8};
|
||||
scm char_tab = {CHAR, .name="tab", .value=9};
|
||||
scm char_newline = {CHAR, .name="newline", .value=10};
|
||||
scm char_vtab = {CHAR, .name="vtab", .value=11};
|
||||
scm char_page = {CHAR, .name="page", .value=12};
|
||||
scm char_return = {CHAR, .name="return", .value=13};
|
||||
scm char_space = {CHAR, .name="space", .value=32};
|
||||
|
||||
scm g_free = {NUMBER, .value=0};
|
||||
scm *g_cells;
|
||||
scm *g_news = 0;
|
||||
|
|
@ -151,7 +141,6 @@ SCM r1 = 0; // param 1
|
|||
SCM r2 = 0; // param 2
|
||||
SCM r3 = 0; // param 3
|
||||
|
||||
#include "display.h"
|
||||
#include "lib.h"
|
||||
#include "math.h"
|
||||
#include "mes.h"
|
||||
|
|
@ -187,7 +176,6 @@ SCM r3 = 0; // param 3
|
|||
#define MAKE_REF(n) make_cell (tmp_num_ (REF), n, 0);
|
||||
#define MAKE_STRING(x) make_cell (tmp_num_ (STRING), x, 0);
|
||||
|
||||
SCM display_ (FILE* f, SCM x);
|
||||
SCM vm_call (function0_t f, SCM p1, SCM p2, SCM a);
|
||||
|
||||
SCM
|
||||
|
|
@ -344,19 +332,6 @@ assq_ref_cache (SCM x, SCM a)
|
|||
return cdr (x);
|
||||
}
|
||||
|
||||
SCM
|
||||
assert_defined (SCM x, SCM e)
|
||||
{
|
||||
if (e == cell_undefined)
|
||||
{
|
||||
fprintf (stderr, "eval: unbound variable:");
|
||||
display_ (stderr, x);
|
||||
fprintf (stderr, "\n");
|
||||
assert (!"unbound variable");
|
||||
}
|
||||
return e;
|
||||
}
|
||||
|
||||
enum eval_apply_t {EVLIS, APPLY, EVAL, MACRO_EXPAND, BEGIN, IF, CALL_WITH_VALUES};
|
||||
enum eval_apply_t g_target;
|
||||
|
||||
|
|
@ -452,9 +427,9 @@ eval_apply ()
|
|||
if (type)
|
||||
{
|
||||
fprintf (stderr, "cannot apply: %s: ", type);
|
||||
display_ (stderr, e);
|
||||
stderr_ (e);
|
||||
fprintf (stderr, " [");
|
||||
display_ (stderr, r1);
|
||||
stderr_ (r1);
|
||||
fprintf (stderr, "]\n");
|
||||
assert (!"cannot apply");
|
||||
}
|
||||
|
|
@ -747,6 +722,13 @@ make_vector (SCM n)
|
|||
return x;
|
||||
}
|
||||
|
||||
SCM
|
||||
arity_ (SCM x)
|
||||
{
|
||||
assert (TYPE (x) == FUNCTION);
|
||||
return MAKE_NUMBER (FUNCTION (x).arity);
|
||||
}
|
||||
|
||||
SCM
|
||||
values (SCM x) ///((arity . n))
|
||||
{
|
||||
|
|
@ -924,6 +906,7 @@ gc_loop (SCM scan)
|
|||
while (scan < g_free.value)
|
||||
{
|
||||
if (NTYPE (scan) == CLOSURE
|
||||
|| NTYPE (scan) == FUNCTION
|
||||
|| NTYPE (scan) == KEYWORD
|
||||
|| NTYPE (scan) == MACRO
|
||||
|| NTYPE (scan) == PAIR
|
||||
|
|
@ -1057,13 +1040,11 @@ mes_builtins (SCM a)
|
|||
{
|
||||
#include "mes.i"
|
||||
|
||||
#include "display.i"
|
||||
#include "lib.i"
|
||||
#include "math.i"
|
||||
#include "posix.i"
|
||||
#include "reader.i"
|
||||
|
||||
#include "display.environment.i"
|
||||
#include "lib.environment.i"
|
||||
#include "math.environment.i"
|
||||
#include "mes.environment.i"
|
||||
|
|
@ -1179,7 +1160,6 @@ dump ()
|
|||
return 0;
|
||||
}
|
||||
|
||||
#include "display.c"
|
||||
#include "lib.c"
|
||||
#include "math.c"
|
||||
#include "posix.c"
|
||||
|
|
@ -1197,7 +1177,7 @@ main (int argc, char *argv[])
|
|||
SCM program = (argc > 1 && !strcmp (argv[1], "--load"))
|
||||
? bload_env (r0) : load_env (r0);
|
||||
if (argc > 1 && !strcmp (argv[1], "--dump")) return dump ();
|
||||
display_ (stderr, begin_env (program, r0));
|
||||
stderr_ (begin_env (program, r0));
|
||||
fputs ("", stderr);
|
||||
gc (stack);
|
||||
if (g_debug) fprintf (stderr, "\nstats: [%d]\n", g_free.value);
|
||||
|
|
|
|||
|
|
@ -108,6 +108,9 @@
|
|||
'o))
|
||||
(define-macro (load file)
|
||||
(list 'begin
|
||||
(list core:stderr "read ")
|
||||
(list core:stderr file)
|
||||
(list core:stderr "\n")
|
||||
(list 'push! '*input-ports* (list current-input-port))
|
||||
(list 'set-current-input-port (list open-input-file file))
|
||||
(list 'primitive-load)
|
||||
|
|
@ -150,12 +153,13 @@
|
|||
(list
|
||||
'begin
|
||||
(list 'set! '*modules* (list cons (list string->symbol (module->file module)) '*modules*))
|
||||
;; (list display "loading file=" (list current-error-port))
|
||||
;; (list display (module->file module) (list current-error-port))
|
||||
;; (list newline (list current-error-port))
|
||||
;; (list core:stderr "read ")
|
||||
;; (list core:stderr file)
|
||||
;; (list core:stderr "\n")
|
||||
(list 'load (list string-append '*mes-prefix* (module->file module)))))))
|
||||
|
||||
(mes-use-module (srfi srfi-0))
|
||||
(mes-use-module (mes base))
|
||||
(mes-use-module (mes quasiquote))
|
||||
(mes-use-module (mes scm))
|
||||
(mes-use-module (mes display))
|
||||
|
|
|
|||
113
module/mes/display.mes
Normal file
113
module/mes/display.mes
Normal file
|
|
@ -0,0 +1,113 @@
|
|||
;;; -*-scheme-*-
|
||||
|
||||
;;; Mes --- Maxwell Equations of Software
|
||||
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
|
||||
;;;
|
||||
;;; This file is part of Mes.
|
||||
;;;
|
||||
;;; 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.
|
||||
;;;
|
||||
;;; 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 Mes. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;;; Code:
|
||||
|
||||
(mes-use-module (mes scm))
|
||||
|
||||
(define (newline . rest)
|
||||
(apply display (cons "\n" rest)))
|
||||
|
||||
(define (display x . rest)
|
||||
(let* ((port (if (null? rest) (current-output-port) (car rest)))
|
||||
(write? (and (pair? rest) (pair? (cdr rest)))))
|
||||
|
||||
(define-macro (cut f slot port)
|
||||
`(lambda (slot) (,f slot ,port)))
|
||||
|
||||
(define (d x cont? sep)
|
||||
(for-each (cut write-char <> port) (string->list sep))
|
||||
(cond
|
||||
((char? x)
|
||||
(write-char #\# port)
|
||||
(write-char #\\ port)
|
||||
(let ((name (and=> (assq x '((#\*eof* . *eof*)
|
||||
(#\nul . nul)
|
||||
(#\alarm . alarm)
|
||||
(#\backspace . backspace)
|
||||
(#\tab . tab)
|
||||
(#\newline . newline)
|
||||
(#\vtab . vtab)
|
||||
(#\page . page)
|
||||
(#\return . return)
|
||||
(#\space . space)))
|
||||
cdr)))
|
||||
(if name (display name)
|
||||
(write-char x port))))
|
||||
((closure? x)
|
||||
(display "<#procedure #f " port)
|
||||
(display (cadr (core:cdr x)) port)
|
||||
(display ">" port))
|
||||
((macro? x)
|
||||
(display "<#macro " port)
|
||||
(display (core:cdr x) port)
|
||||
(display ">" port))
|
||||
((number? x) (display (number->string x) port))
|
||||
((pair? x)
|
||||
(if (not cont?) (write-char #\( port))
|
||||
(cond ((eq? (car x) '*circular*)
|
||||
(display "(*circ* . #-1#)" port))
|
||||
((eq? (car x) '*closure*)
|
||||
(display "(*closure* . #-1#)" port))
|
||||
(#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)
|
||||
(display (cdr x) port write?))))
|
||||
(if (not cont?) (write-char #\) port)))))
|
||||
((or (keyword? x) (special? x) (string? x) (symbol? x))
|
||||
(if (and (string? x) write?) (write-char #\" port))
|
||||
(if (keyword? x) (display "#:" port))
|
||||
(for-each (cut write-char <> port) (string->list x))
|
||||
(if (and (string? x) write?) (write-char #\" port)))
|
||||
((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))
|
||||
((function? x)
|
||||
(display "<#procedure " port)
|
||||
(display (core:car x) port)
|
||||
(display " " port)
|
||||
(display
|
||||
(case (core:arity x)
|
||||
((-1) "(. x)")
|
||||
((0) "()")
|
||||
((1) "(x)")
|
||||
((2) "(x y)")
|
||||
((3) "(x y z)"))
|
||||
port)
|
||||
(display ">" port))
|
||||
((broken-heart? x)
|
||||
(display "<3" port))
|
||||
(#t
|
||||
(display "TODO type=") (display (cell:type-name x)) (newline)))
|
||||
*unspecified*)
|
||||
(d x #f "")))
|
||||
|
|
@ -108,6 +108,9 @@
|
|||
(define <cell:keyword> 3)
|
||||
(define <cell:string> 9)
|
||||
|
||||
(define (newline) (core:stderr (integer->char 10)))
|
||||
(define (display x . reset) #f)
|
||||
|
||||
(define (list->symbol lst) (make-symbol lst))
|
||||
|
||||
(define (symbol->list s)
|
||||
|
|
@ -219,7 +222,7 @@
|
|||
(egap . 12)
|
||||
(nruter . 13)
|
||||
(ecaps . 32)))) => cdr)
|
||||
(#t (display (quote char-not-supported:)) (display n) (newline) (exit 1))))
|
||||
(#t (core:stderr (quote char-not-supported:)) (core:stderr n) (newline) (exit 1))))
|
||||
(if (not (and (> p 96) (< p 123))) (integer->char (lookup-char (list->symbol (cons (integer->char c) n))))
|
||||
(read-name (read-byte) (peek-byte) (cons (integer->char c) n))))
|
||||
|
||||
|
|
@ -258,7 +261,7 @@
|
|||
(read-byte)
|
||||
(read-string (read-byte) (peek-byte) (append-char s 10)))
|
||||
((eq? c 34) s)
|
||||
((eq? c -1) (display (quote EOF-in-string)) (newline) (exit 1))
|
||||
((eq? c -1) (core:stderr (quote EOF-in-string)) (newline) (exit 1))
|
||||
(#t (read-string (read-byte) (peek-byte) (append-char s c)))))
|
||||
(list->string (read-string (read-byte) (peek-byte) (list))))
|
||||
|
||||
|
|
|
|||
22
posix.c
22
posix.c
|
|
@ -20,19 +20,17 @@
|
|||
|
||||
#include <fcntl.h>
|
||||
|
||||
char const*
|
||||
string_to_cstring (SCM s)
|
||||
SCM
|
||||
stderr_ (SCM x)
|
||||
{
|
||||
static char buf[1024];
|
||||
char *p = buf;
|
||||
s = STRING (s);
|
||||
while (s != cell_nil)
|
||||
{
|
||||
*p++ = VALUE (car (s));
|
||||
s = cdr (s);
|
||||
}
|
||||
*p = 0;
|
||||
return buf;
|
||||
SCM display;
|
||||
if ((display = assq_ref_cache (cell_symbol_display, r0)) != cell_undefined)
|
||||
apply_env (assq_ref_cache (cell_symbol_display, r0), cons (x, cons (MAKE_NUMBER (2), cell_nil)), r0);
|
||||
else if (TYPE (x) == SPECIAL || TYPE (x) == STRING || TYPE (x) == SYMBOL)
|
||||
fprintf (stderr, string_to_cstring (x));
|
||||
else
|
||||
fprintf (stderr, "display: undefined\n");
|
||||
return cell_unspecified;
|
||||
}
|
||||
|
||||
SCM
|
||||
|
|
|
|||
Loading…
Reference in a new issue