Example #1
0
/* Symbol printer.
   NB: Uninterned symbols are treated as sharable objects (can be written
   with #n= syntax).  It is handled by upper layer (write.c) so we don't
   worry about it in this routine.
 */
static void symbol_print(ScmObj obj, ScmPort *port, ScmWriteContext *ctx)
{
    if (Scm_WriteContextMode(ctx) == SCM_WRITE_DISPLAY) {
        SCM_PUTS(SCM_SYMBOL_NAME(obj), port);
    } else {
#if !GAUCHE_UNIFY_SYMBOL_KEYWORD
        if (SCM_KEYWORDP(obj)) {
            SCM_PUTC(':', port);
            /* We basically print keyword names in the same way as symbols
               (i.e. using |-escape if necessary).  However, as a convention,
               two things are different from the default symbol writer.
               (1) We don't check the noninitials; :1 is unambiguously a
               keyword, so we don't need to print :|1|.
               (2) A keyword with an empty name can be printed just as :,
               instead of :||.
               These conventions are useful if we pass the S-expression with
               these keywords to other Scheme implementations that don't support
               CL-style keywords; they would just read those ones as symbols.
            */
            Scm_WriteSymbolName(SCM_KEYWORD(obj)->name, port, ctx,
                                (SCM_SYMBOL_WRITER_NOESCAPE_INITIAL
                                 |SCM_SYMBOL_WRITER_NOESCAPE_EMPTY));
            return;
        }
#endif /*!GAUCHE_UNIFY_SYMBOL_KEYWORD*/
        if (!SCM_SYMBOL_INTERNED(obj)) SCM_PUTZ("#:", -1, port);
        Scm_WriteSymbolName(SCM_SYMBOL_NAME(obj), port, ctx, 0);
    }
}
Example #2
0
/* Symbol printer.
   NB: Uninterned symbols are treated as sharable objects (can be written
   with #n= syntax).  It is handled by upper layer (write.c) so we don't
   worry about it in this routine.
 */
static void symbol_print(ScmObj obj, ScmPort *port, ScmWriteContext *ctx)
{
    if (Scm_WriteContextMode(ctx) == SCM_WRITE_DISPLAY) {
        SCM_PUTS(SCM_SYMBOL_NAME(obj), port);
    } else {
        if (!SCM_SYMBOL_INTERNED(obj)) SCM_PUTZ("#:", -1, port);
        Scm_WriteSymbolName(SCM_SYMBOL_NAME(obj), port, ctx, 0);
    }
}
Example #3
0
/* If symbol S has a prefix P, returns a symbol without the prefix.
   Otherwise, returns #f. */
ScmObj Scm_SymbolSansPrefix(ScmSymbol *s, ScmSymbol *p)
{
    const ScmStringBody *bp = SCM_STRING_BODY(SCM_SYMBOL_NAME(p));
    const ScmStringBody *bs = SCM_STRING_BODY(SCM_SYMBOL_NAME(s));
    int zp = SCM_STRING_BODY_SIZE(bp);
    int zs = SCM_STRING_BODY_SIZE(bs);
    const char *cp = SCM_STRING_BODY_START(bp);
    const char *cs = SCM_STRING_BODY_START(bs);

    if (zp > zs || memcmp(cp, cs, zp) != 0) return SCM_FALSE;
    return Scm_Intern(SCM_STRING(Scm_MakeString(cs + zp, zs - zp, -1,
                                                SCM_STRING_IMMUTABLE)));
}
Example #4
0
/* Symbol comparison procedure.
   Will be used via 'compare' procedure.  Following srfi-114, we compare
   by name, but takes extra care of intern/unintern distinction; if the
   names are the same, interned symbol is less, and if both are
   uninterned, we compare addresses.
 */
static int symbol_compare(ScmObj x, ScmObj y, int equalp)
{
    if (equalp) {
        /* Symbol equality test is handled in Scm_Eq* and will never come
           here, but just in case.  */
        return SCM_EQ(x, y)? 0:1;
    } else if (SCM_EQ(x, y)) {
        return 0;
    } else {
        int r = Scm_StringCmp(SCM_SYMBOL_NAME(x), SCM_SYMBOL_NAME(y));
        if (r != 0) return r;
        if (SCM_SYMBOL_INTERNED(x)) return -1; /* y must be uninterned */
        if (SCM_SYMBOL_INTERNED(y)) return  1; /* x must be uninterned */
        return (x < y)? -1 : 1;                /* both are uninterned */
    }
}
Example #5
0
SCM_EXPORT ScmObj
scm_p_symbol2string(ScmObj sym)
{
    DECLARE_FUNCTION("symbol->string", procedure_fixed_1);

    ENSURE_SYMBOL(sym);

    return CONST_STRING(SCM_SYMBOL_NAME(sym));
}
Example #6
0
static void
show_arg(ScmObj arg, ScmObj env)
{
    if (SYMBOLP(arg) && !UNBOUNDP(arg, env)) {
        scm_format(scm_err, SCM_FMT_RAW_C, "  - [~S]: ", SCM_SYMBOL_NAME(arg));
        SCM_WRITE_SS(scm_err, scm_symbol_value(arg, env));
        scm_port_newline(scm_err);
    }
}
Example #7
0
/* Auxiliary function */
const char* Scm_GetCESName(ScmObj code, const char *argname)
{
    const char *c = NULL;
    if (SCM_UNBOUNDP(code) || SCM_FALSEP(code)) {
        c = Scm_SupportedCharacterEncodings()[0];
    } else if (SCM_STRINGP(code)) {
        c = Scm_GetStringConst(SCM_STRING(code));
    } else if (SCM_SYMBOLP(code)) {
        c = Scm_GetStringConst(SCM_SYMBOL_NAME(code));
    } else {
        Scm_Error("string, symbol or #f is required for %s, but got %S",
                  argname, code);
    }
    return c;
}
Example #8
0
static void
write_obj(ScmObj port, ScmObj obj, enum ScmOutputType otype)
{
    ScmObj sym;

#if SCM_USE_SRFI38
    if (INTERESTINGP(obj)) {
        scm_intobj_t index = get_shared_index(obj);
        if (index > 0) {
            /* defined datum */
            scm_format(port, SCM_FMT_RAW_C, "#~ZU#", (size_t)index);
            return;
        }
        if (index < 0) {
            /* defining datum, with the new index negated */
            scm_format(port, SCM_FMT_RAW_C, "#~ZU=", (size_t)-index);
            /* Print it; the next time it'll be defined. */
        }
    }
#endif
    switch (SCM_TYPE(obj)) {
#if SCM_USE_INT
    case ScmInt:
        scm_format(port, SCM_FMT_RAW_C, "~MD", SCM_INT_VALUE(obj));
        break;
#endif
    case ScmCons:
        if (ERROBJP(obj))
            write_errobj(port, obj, otype);
        else
            write_list(port, obj, otype);
        break;
    case ScmSymbol:
        scm_port_puts(port, SCM_SYMBOL_NAME(obj));
        break;
#if SCM_USE_CHAR
    case ScmChar:
        write_char(port, obj, otype);
        break;
#endif
#if SCM_USE_STRING
    case ScmString:
        write_string(port, obj, otype);
        break;
#endif
    case ScmFunc:
        scm_port_puts(port, (SCM_SYNTAXP(obj)) ? "#<syntax " : "#<subr ");
        sym = scm_symbol_bound_to(obj);
        if (TRUEP(sym))
            scm_display(port, sym);
        else
            scm_format(port, SCM_FMT_RAW_C, "~P", (void *)obj);
        scm_port_put_char(port, '>');
        break;
#if SCM_USE_HYGIENIC_MACRO
    case ScmMacro:
        scm_port_puts(port, "#<macro ");
        write_obj(port, SCM_HMACRO_RULES(obj), otype);
        scm_port_puts(port, ">");
        break;
    case ScmFarsymbol:
        write_farsymbol(port, obj, otype);
        break;
    case ScmSubpat:
        if (SCM_SUBPAT_PVARP(obj)) {
#if SCM_DEBUG_MACRO
            scm_port_puts(port, "#<pvar ");
            write_obj(port, SCM_SUBPAT_OBJ(obj), otype);
            scm_format(port, SCM_FMT_RAW_C, " ~MD>",
                       SCM_SUBPAT_PVAR_INDEX(obj));
#else  /* not SCM_DEBUG_MACRO */
            write_obj(port, SCM_SUBPAT_OBJ(obj), otype);
#endif /* not SCM_DEBUG_MACRO */
        } else {
            SCM_ASSERT(SCM_SUBPAT_REPPATP(obj));
            write_obj(port, SCM_SUBPAT_REPPAT_PAT(obj), otype);
#if SCM_DEBUG_MACRO
            scm_format(port, SCM_FMT_RAW_C, " ..[~MD]..",
                       SCM_SUBPAT_REPPAT_PVCOUNT(obj));
#else
            scm_port_puts(port, " ...");
#endif
        }
        break;
#endif /* SCM_USE_HYGIENIC_MACRO */
    case ScmClosure:
#if SCM_USE_LEGACY_MACRO
        if (SYNTACTIC_CLOSUREP(obj))
            scm_port_puts(port, "#<syntactic closure ");
        else
#endif
            scm_port_puts(port, "#<closure ");
        write_obj(port, SCM_CLOSURE_EXP(obj), otype);
        scm_port_put_char(port, '>');
        break;
#if SCM_USE_VECTOR
    case ScmVector:
        write_vector(port, obj, otype);
        break;
#endif
    case ScmPort:
        write_port(port, obj, otype);
        break;
#if SCM_USE_CONTINUATION
    case ScmContinuation:
        scm_format(port, SCM_FMT_RAW_C, "#<continuation ~P>", (void *)obj);
        break;
#endif
    case ScmValuePacket:
        scm_port_puts(port, "#<values ");
        write_obj(port, SCM_VALUEPACKET_VALUES(obj), otype);
#if SCM_USE_VALUECONS
#if SCM_USE_STORAGE_FATTY
        /* SCM_VALUEPACKET_VALUES() changes the type destructively */
        SCM_ENTYPE(obj, ScmValuePacket);
#else /* SCM_USE_STORAGE_FATTY */
#error "valuecons is not supported on this storage implementation"
#endif /* SCM_USE_STORAGE_FATTY */
#endif /* SCM_USE_VALUECONS */
        scm_port_put_char(port, '>');
        break;
    case ScmConstant:
        write_constant(port, obj, otype);
        break;
#if SCM_USE_SSCM_EXTENSIONS
    case ScmCPointer:
        scm_format(port, SCM_FMT_RAW_C,
                   "#<c_pointer ~P>", SCM_C_POINTER_VALUE(obj));
        break;
    case ScmCFuncPointer:
        scm_format(port, SCM_FMT_RAW_C,
                   "#<c_func_pointer ~P>",
                   (void *)(uintptr_t)SCM_C_FUNCPOINTER_VALUE(obj));
        break;
#endif

    case ScmRational:
    case ScmReal:
    case ScmComplex:
    default:
        SCM_NOTREACHED;
    }
}
Example #9
0
static void
free_cell(ScmCell *cell)
{
#if SCM_USE_STORAGE_COMPACT
    if (SCM_CELL_MISCP(*cell)) {
        if (SCM_CELL_SYMBOLP(*cell))
            SCM_CELL_SYMBOL_FIN(*cell);
#if SCM_USE_STRING
        else if (SCM_CELL_STRINGP(*cell))
            SCM_CELL_STRING_FIN(*cell);
#endif
#if SCM_USE_VECTOR
        else if (SCM_CELL_VECTORP(*cell))
            SCM_CELL_VECTOR_FIN(*cell);
#endif
#if SCM_USE_PORT
        else if (SCM_CELL_PORTP(*cell))
            SCM_CELL_PORT_FIN(*cell);
#endif
#if SCM_USE_CONTINUATION
        else if (SCM_CELL_CONTINUATIONP(*cell))
            SCM_CELL_CONTINUATION_FIN(*cell);
#endif
    }
#else /* SCM_USE_STORAGE_COMPACT */
    switch (SCM_TYPE(cell)) {
    case ScmCons:
#if SCM_USE_INT
    case ScmInt:
#endif
#if SCM_USE_CHAR
    case ScmChar:
#endif
        break;

    case ScmSymbol:
        free(SCM_SYMBOL_NAME(cell));
        break;

#if SCM_USE_STRING
    case ScmString:
        free(SCM_STRING_STR(cell));
        break;
#endif

    case ScmFreeCell:
    case ScmConstant:
        break;

#if SCM_USE_VECTOR
    case ScmVector:
        free(SCM_VECTOR_VEC(cell));
        break;
#endif

    /* rarely swept objects */
#if SCM_USE_PORT
    case ScmPort:
        if (SCM_PORT_IMPL(cell))
            scm_port_close(cell);
        break;
#endif

#if SCM_USE_CONTINUATION
    case ScmContinuation:
        /*
         * Since continuation object is not so many, destructing the object by
         * function call will not cost high. This function interface makes
         * continuation module substitution easy without preparing
         * module-specific header file which contains the module-specific
         * destruction macro.
         */
        scm_destruct_continuation(cell);
        break;
#endif

    case ScmClosure:
    case ScmFunc:
    case ScmMacro:
    case ScmFarsymbol:
    case ScmSubpat:
    case ScmCFuncPointer:
    case ScmCPointer:
    case ScmValuePacket:
        break;
#if SCM_DEBUG
    case ScmRational:
    case ScmReal:
    case ScmComplex:
#endif
    default:
        SCM_NOTREACHED;
    }
#endif /* SCM_USE_STORAGE_COMPACT */
}