ikarus/src/ikarus-print.c

152 lines
3.9 KiB
C

/*
* Ikarus Scheme -- A compiler for R6RS Scheme.
* Copyright (C) 2006,2007,2008 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, ikptr x);
void ik_fprint(FILE* fh, ikptr x){
print(fh, x);
}
void ik_print(ikptr x){
print(stdout, x);
fprintf(stdout, "\n");
}
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, ikptr x){
if(is_fixnum(x)){
fprintf(fh, "%ld", unfix(x));
}
else if(x == false_object){
fprintf(fh, "#f");
}
else if(x == true_object){
fprintf(fh, "#t");
}
else if(x == null_object){
fprintf(fh, "()");
}
else if(is_char(x)){
unsigned long int i = ((long int)x) >> char_shift;
if(i < 128){
fprintf(fh, "%s", char_string[i]);
} else {
fprintf(fh, "#\\x%lx", i);
}
}
#if 0
else if(tagof(x) == symbol_tag){
ikptr str = ref(x, off_symbol_string);
fprintf(fh, "%s", str+off_string_data);
}
#endif
else if(tagof(x) == vector_tag){
ikptr len = ref(x, off_vector_length);
if(len == 0){
fprintf(fh, "#()");
} else {
fprintf(fh, "#(");
ikptr data = x + off_vector_data;
print(fh, ref(data, 0));
ikptr i = (ikptr)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(is_pair(x)){
fprintf(fh, "(");
print(fh, ref(x, off_car));
ikptr d = ref(x, off_cdr);
fprintf(stderr, "d=0x%016lx\n", (long int)d);
while(1){
if(is_pair(d)){
fprintf(fh, " ");
print(fh, ref(d, off_car));
d = ref(d, off_cdr);
}
else if(d == null_object){
fprintf(fh, ")");
return;
}
else {
fprintf(fh, " . ");
print(fh, d);
fprintf(fh, ")");
return;
}
}
}
else if(tagof(x) == string_tag){
ikptr 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>");
}
}