File: libcig1.c

package info (click to toggle)
scsh 0.5.1-2
  • links: PTS
  • area: non-free
  • in suites: potato, slink
  • size: 6,540 kB
  • ctags: 8,656
  • sloc: lisp: 39,346; ansic: 13,466; sh: 1,669; makefile: 624
file content (149 lines) | stat: -rw-r--r-- 3,910 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
/* Generic routines for Scheme48/C interfacing -- mostly for converting
** strings and null-terminated vectors back and forth.
** Copyright (c) 1993 by Olin Shivers.
*/

#include "libcig.h"
#include <string.h>
#include <stddef.h>
#include <stdio.h>
#include <stdlib.h>

#define Malloc(type,n)	((type *) malloc(sizeof(type)*(n)))
#define Free(p)		(free((char *)(p)))

/* (c2scheme_strcpy dest_scheme_string source_C_string)
** Copies C string's chars into Scheme string. Return #t.
** If C string is NULL, do nothing and return #f.
*/

int c2scheme_strcpy(scheme_value sstr, const char *cstr)
{
    if( cstr ) {
	strncpy( (char*) StobData(sstr), cstr, STRING_LENGTH(sstr) );
	return 1;
	}
    else return 0;
    }


/* Same as above, but free the C string when we are done. */
int c2scheme_strcpy_free(scheme_value sstr, const char *cstr)
{
    if( cstr ) {
	strncpy( (char*) StobData(sstr), cstr, STRING_LENGTH(sstr) );
	Free(cstr);
	return 1;
	}
    else return 0;
    }

char *scheme2c_strcpy(scheme_value sstr)
{
    char *result;
    int slen;
    extern int errno;

    slen = STRING_LENGTH(sstr);
    result = Malloc(char, slen+1);

    if( result == NULL ) {
        fprintf(stderr,
		"Fatal error: C stub tried to copy Scheme string,\n"
		"but malloc failed on arg 0x%x, errno %d.\n",
		sstr, errno);
	exit(-1);
	}

    memcpy(result, cig_string_body(sstr), slen);
    result[slen] = '\000';
    return result;
    }


/*  One arg, a zero-terminated C word vec. Returns length.
**  The terminating null is not counted. Returns #f on NULL.
*/

scheme_value c_veclen(const long *vec)
{
    const long *vptr = vec;
    if( !vptr ) return SCHFALSE;
    while( *vptr ) vptr++;
    return ENTER_FIXNUM(vptr - vec);
    }
    

/* Copy string from into string to. If to is NULL, malloc a fresh string
** (if the malloc loses, return NULL).
** If from is NULL, then
** - if to is NULL, do nothing and return NULL.
** - Otherwise, deposit a single nul byte.
** Under normal conditions, this routine returns the destination string.
**
** The little boundary cases of this procedure are a study in obfuscation
** because C doesn't have a reasonable string data type. Give me a break.
*/
char *copystring(char *to, const char *from)
{
    if( from ) {
	int slen = strlen(from)+1;
	if( !to && !(to = Malloc(char, slen)) ) return NULL;
	else return memcpy(to, from, slen);
	}

    else
	return to ? *to = '\000', to : NULL;
    }

/* As in copystring, but if malloc loses, print out an error msg and croak. */
char *copystring_or_die(const char *str ) /* Note: NULL -> NULL. */
{
    if( str ) {
	int len = strlen(str)+1;
	char *new_str = Malloc(char, len);
	if( ! new_str ) {
	    fprintf(stderr, "copystring: Malloc failed.\n");
	    exit(-1);
	    }
	return memcpy(new_str, str, len);
	}
    else return NULL;
    }

int cstring_nullp( const char *s ) { return ! s; }

scheme_value strlen_or_false(const char *s)
{ return s ?  ENTER_FIXNUM(strlen(s)) : SCHFALSE; }



/* svec is a Scheme vector of C string carriers. Scan over the C strings
** in cvec, and initialise the corresponding string carriers in svec.
*/
void set_strvec_carriers(scheme_value svec, char const * const * cvec)
{
    int svec_len = VECTOR_LENGTH(svec);
    char const * const * cv = cvec;
    scheme_value *sv = &VECTOR_REF(svec,0);

    for(; svec_len > 0; cv++, sv++, svec_len-- ) {
	/* *sv is a (cons (make-alien <c-string>) <string-length>). */
	scheme_value carrier = *sv;
	scheme_value alien = CAR(carrier);
	CDR(carrier) = ENTER_FIXNUM(strlen(*cv));
	AlienVal(alien) = (long) *cv;
	}
    }

/* Helper function for arg checking. Why bother, actually? */
void cig_check_nargs(int arity, int nargs, const char *fn)
{
   if( arity != nargs ) {
       fprintf(stderr,
	       "Cig fatal error (%s) -- C stub expected %d arg%s, "
	       "but got %d.\n",
	       fn, arity, (arity == 1) ? "" : "s", nargs);
       exit(-1);
       }
   }