ikarus/src/ikarus-print.c

147 lines
3.8 KiB
C

/*
* Ikarus Scheme -- A compiler for R6RS Scheme.
* Copyright (C) 2006,2007 Abdulaziz Ghuloum
*
* This program is free software: you can redistribute it and/or modify
* it under the terms of the GNU General Public License version 3 as
* published by the Free Software Foundation.
*
* This program 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 this program. If not, see <http://www.gnu.org/licenses/>.
*/
#include "ikarus-data.h"
#include <stdio.h>
#include <stdlib.h>
static void print(FILE* fh, ikp x);
void ik_fprint(FILE* fh, ikp x){
print(fh, x);
}
void ik_print(ikp x){
print(stdout, x);
fprintf(stdout, "\n");
}
static char* char_string[128] = {
"#\\nul","#\\soh","#\\stx","#\\etx","#\\eot","#\\enq","#\\ack","#\\bel",
"#\\bs", "#\\tab","#\\newline", "#\\vt", "#\\ff", "#\\return", "#\\so",
"#\\si",
"#\\dle","#\\dc1","#\\dc2","#\\dc3","#\\dc4","#\\nak","#\\syn","#\\etb",
"#\\can","#\\em", "#\\sub","#\\esc","#\\fs", "#\\gs", "#\\rs", "#\\us",
"#\\space","#\\!","#\\\"","#\\#","#\\$","#\\%","#\\&","#\\'",
"#\\(","#\\)","#\\*","#\\+","#\\,","#\\-","#\\.","#\\/",
"#\\0","#\\1","#\\2","#\\3","#\\4","#\\5","#\\6","#\\7",
"#\\8","#\\9","#\\:","#\\;","#\\<","#\\=","#\\>","#\\?",
"#\\@","#\\A","#\\B","#\\C","#\\D","#\\E","#\\F","#\\G",
"#\\H","#\\I","#\\J","#\\K","#\\L","#\\M","#\\N","#\\O",
"#\\P","#\\Q","#\\R","#\\S","#\\T","#\\U","#\\V","#\\W",
"#\\X","#\\Y","#\\Z","#\\[","#\\\\","#\\]","#\\^","#\\_",
"#\\`","#\\a","#\\b","#\\c","#\\d","#\\e","#\\f","#\\g",
"#\\h","#\\i","#\\j","#\\k","#\\l","#\\m","#\\n","#\\o",
"#\\p","#\\q","#\\r","#\\s","#\\t","#\\u","#\\v","#\\w",
"#\\x","#\\y","#\\z","#\\{","#\\|","#\\}","#\\~","#\\del"};
static void
print(FILE* fh, ikp x){
if(IK_FIXNUMP(x)){
fprintf(fh, "%d", IK_UNFIX(x));
}
else if(x == IK_FALSE_OBJECT){
fprintf(fh, "#f");
}
else if(x == IK_TRUE_OBJECT){
fprintf(fh, "#t");
}
else if(x == IK_NULL_OBJECT){
fprintf(fh, "()");
}
else if(IK_CHARP(x)){
fprintf(fh, "%s", char_string[IK_CHAR_VAL(x)]);
}
#if 0
else if(tagof(x) == symbol_tag){
ikp str = ref(x, off_symbol_string);
fprintf(fh, "%s", str+off_string_data);
}
#endif
else if(tagof(x) == vector_tag){
ikp len = ref(x, off_vector_length);
if(len == 0){
fprintf(fh, "#()");
} else {
fprintf(fh, "#(");
ikp data = x + off_vector_data;
print(fh, ref(data, 0));
ikp i = (ikp)wordsize;
while(i<len){
fprintf(fh, " ");
print(fh, ref(data,i));
i += wordsize;
}
fprintf(fh, ")");
}
}
else if(is_closure(x)){
fprintf(fh, "#<procedure>");
}
else if(IK_PAIRP(x)){
fprintf(fh, "(");
print(fh, REF(x, IK_OFF_CAR));
ikp d = REF(x, IK_OFF_CDR);
fprintf(stderr, "d=0x%08x\n", (int)d);
while(1){
if(IK_PAIRP(d)){
fprintf(fh, " ");
print(fh, REF(d, IK_OFF_CAR));
d = REF(d, IK_OFF_CDR);
}
else if(d == IK_NULL_OBJECT){
fprintf(fh, ")");
return;
}
else {
fprintf(fh, " . ");
print(fh, d);
fprintf(fh, ")");
return;
}
}
}
else if(tagof(x) == string_tag){
ikp fxlen = ref(x, off_string_length);
int len = unfix(fxlen);
fprintf(stderr, "bug: printer busted!\n");
exit(-1);
char* data = 0; //string_data(x);
fprintf(fh, "\"");
int i;
for(i=0; i<len; i++){
char c = data[i];
if((c == '\\') || (c == '"')){
fprintf(fh, "\\");
}
fprintf(fh, "%c", c);
}
fprintf(fh, "\"");
}
else {
fprintf(fh, "#<unknown>");
}
}