void
TestRealloc(void) {
void *p=0;
// see: http://pubs.opengroup.org/onlinepubs/7999959899/functions/realloc.html
free(0); // defined: no action shall occur.
free(0);
free(0);
if (p=realloc(0, 0), p!=0) // NOTE: result need not be 0, but 0 would be good practice.
runtime·panicstring("realloc failed 1");
if (p=realloc(0, 10), p==0)
runtime·panicstring("realloc failed 2");
CHARP(p)[9] = 9; // trying to check here that no segfault occurs
CHARP(p)[8] = 8;
if (p=realloc(p, 9), CHARP(p)[8]!=8)
runtime·panicstring("realloc failed 3");
if (p=realloc(p, 10), p==0)
runtime·panicstring("realloc failed 4");
if (CHARP(p)[8]!=8)
runtime·panicstring("realloc failed 5");
if (p=realloc(p, 0), p!=0) // NOTE: result need not be 0, but 0 would be good practice.
runtime·panicstring("realloc failed 6");
}
LObject *
lisp_char_smallerp (LObject *args)
{
if (!lipa_list_at_least (args, 2) || !CHARP (lipa_car (args)))
{
fputs ("char<? wants at least two arguments\n", stderr);
return NULL;
}
while (lipa_cdr (args))
{
if (!CHARP (lipa_cadr (args)))
{
fputs ("char<? wants char arguments!\n", stderr);
return NULL;
}
else if (L_CHAR (lipa_car (args)) >= (L_CHAR (lipa_cadr (args))))
{
return lisp_false;
}
else
args = (lipa_cdr (args));
}
return lisp_true;
}
LObject *
lisp_char_greater_or_equalp_ci (LObject *args)
{
if (!lipa_list_at_least (args, 2) || !CHARP (lipa_car (args)))
{
fputs ("char-ci>=? wants at least two arguments\n", stderr);
return NULL;
}
while (lipa_cdr (args))
{
if (!CHARP (lipa_cadr (args)))
{
fputs ("char-ci>=? wants char arguments!\n", stderr);
return NULL;
}
else if (tolower (L_CHAR (lipa_car (args))) <
(tolower (L_CHAR (lipa_cadr (args)))))
{
return lisp_false;
}
else
args = (lipa_cdr (args));
}
return lisp_true;
}
/* <anonymous:1901> */
obj_t BGl_zc3anonymousza31901ze3z83zz__rgc_configz00(obj_t BgL_envz00_1603,
obj_t BgL_xz00_1604)
{
AN_OBJECT;
{ /* Rgc/rgcconfig.scm 115 */
{
obj_t BgL_xz00_807;
{ /* Rgc/rgcconfig.scm 116 */
bool_t BgL_auxz00_1730;
BgL_xz00_807 = BgL_xz00_1604;
if (BGl_2ze3ze3zz__r4_numbers_6_5z00(BgL_xz00_807, BINT(((long) 0))))
{ /* Rgc/rgcconfig.scm 116 */
if (BGl_2zc3zc3zz__r4_numbers_6_5z00(BgL_xz00_807,
BINT(((long) 256))))
{ /* Rgc/rgcconfig.scm 116 */
BgL_auxz00_1730 = CHARP(BgL_xz00_807);
}
else
{ /* Rgc/rgcconfig.scm 116 */
BgL_auxz00_1730 = ((bool_t) 0);
}
}
else
{ /* Rgc/rgcconfig.scm 116 */
BgL_auxz00_1730 = ((bool_t) 0);
}
return BBOOL(BgL_auxz00_1730);
}
}
}
}
CELL func_char_to_integer(CELL frame)
{
if (!CHARP(FV0)) {
return make_exception("expects a <character> argument");
}
return make_int((unsigned char)GET_CHAR(FV0));
}
lref_t lwrite_strings(size_t argc, lref_t argv[])
{
if (argc < 1)
vmerror_unsupported(_T("Must specify port to write-strings"));
lref_t port = argv[0];
if (!TEXT_PORTP(port))
vmerror_wrong_type_n(1, port);
if (PORT_INPUTP(port))
vmerror_unsupported(_T("cannot write-strings to input ports"));
for (size_t ii = 1; ii < argc; ii++) {
lref_t str = argv[ii];
if (STRINGP(str)) {
write_text(port, str->as.string.data, str->as.string.dim);
} else if (CHARP(str)) {
_TCHAR ch = CHARV(str);
write_text(port, &ch, 1);
} else
vmerror_wrong_type_n(ii, str);
}
return port;
}
CELL func_char_downcase(CELL frame)
{
if (!CHARP(FV0)) {
return make_exception("expects a <character> argument");
}
return make_char(tolower(GET_CHAR(FV0)));
}
CELL func_make_string(CELL frame)
{
if (!(INTP(FV0) && GET_INT(FV0) >= 0)) {
return make_exception("1st argument expects non-negative integer");
}
if (FC == 2 && !CHARP(FV1)) {
return make_exception("2nd argument expects character");
}
return make_string_filled(GET_INT(FV0), (FC == 2) ? GET_CHAR(FV1) : -1);
}
static PyObject *
imageop_crop(PyObject *self, PyObject *args)
{
char *cp, *ncp;
short *nsp;
Py_Int32 *nlp;
int len, size, x, y, newx1, newx2, newy1, newy2, nlen;
int ix, iy, xstep, ystep;
PyObject *rv;
if ( !PyArg_ParseTuple(args, "s#iiiiiii", &cp, &len, &size, &x, &y,
&newx1, &newy1, &newx2, &newy2) )
return 0;
if ( size != 1 && size != 2 && size != 4 ) {
PyErr_SetString(ImageopError, "Size should be 1, 2 or 4");
return 0;
}
if ( !check_multiply_size(len, x, "x", y, "y", size) )
return 0;
xstep = (newx1 < newx2)? 1 : -1;
ystep = (newy1 < newy2)? 1 : -1;
nlen = (abs(newx2-newx1)+1)*(abs(newy2-newy1)+1)*size;
if ( !check_multiply_size(nlen, abs(newx2-newx1)+1, "abs(newx2-newx1)+1", abs(newy2-newy1)+1, "abs(newy2-newy1)+1", size) )
return 0;
rv = PyString_FromStringAndSize(NULL, nlen);
if ( rv == 0 )
return 0;
ncp = (char *)PyString_AsString(rv);
nsp = (short *)ncp;
nlp = (Py_Int32 *)ncp;
newy2 += ystep;
newx2 += xstep;
for( iy = newy1; iy != newy2; iy+=ystep ) {
for ( ix = newx1; ix != newx2; ix+=xstep ) {
if ( iy < 0 || iy >= y || ix < 0 || ix >= x ) {
if ( size == 1 )
*ncp++ = 0;
else
*nlp++ = 0;
} else {
if ( size == 1 )
*ncp++ = *CHARP(cp, x, ix, iy);
else if ( size == 2 )
*nsp++ = *SHORTP(cp, x, ix, iy);
else
*nlp++ = *LONGP(cp, x, ix, iy);
}
}
}
return rv;
}
LObject *
lisp_char_lowerp (LObject *args)
{
if (!lipa_list_length (args, 1) || !CHARP (lipa_car (args)))
{
fputs ("char-lower? wants 1 character argument\n", stderr);
return NULL;
}
return (islower (L_CHAR (lipa_car (args))) ? lisp_true : lisp_false);
}
CELL func_string_fill(CELL frame)
{
CELL string = FV0;
CELL ch = FV1;
if (!STRINGP(string)) {
return make_exception("expects a string for 1st argument");
}
if (!CHARP(ch)) {
return make_exception("expects a character for 2nd argument");
}
STRING *str = GET_STRING(string);
memset(str->data, GET_CHAR(ch), str->len);
return V_VOID;
}
static PyObject *
imageop_scale(PyObject *self, PyObject *args)
{
char *cp, *ncp;
short *nsp;
Py_Int32 *nlp;
int len, size, x, y, newx, newy, nlen;
int ix, iy;
int oix, oiy;
PyObject *rv;
if ( !PyArg_ParseTuple(args, "s#iiiii",
&cp, &len, &size, &x, &y, &newx, &newy) )
return 0;
if ( size != 1 && size != 2 && size != 4 ) {
PyErr_SetString(ImageopError, "Size should be 1, 2 or 4");
return 0;
}
if ( !check_multiply_size(len, x, "x", y, "y", size) )
return 0;
nlen = newx*newy*size;
if ( !check_multiply_size(nlen, newx, "newx", newy, "newy", size) )
return 0;
rv = PyString_FromStringAndSize(NULL, nlen);
if ( rv == 0 )
return 0;
ncp = (char *)PyString_AsString(rv);
nsp = (short *)ncp;
nlp = (Py_Int32 *)ncp;
for( iy = 0; iy < newy; iy++ ) {
for ( ix = 0; ix < newx; ix++ ) {
oix = ix * x / newx;
oiy = iy * y / newy;
if ( size == 1 )
*ncp++ = *CHARP(cp, x, oix, oiy);
else if ( size == 2 )
*nsp++ = *SHORTP(cp, x, oix, oiy);
else
*nlp++ = *LONGP(cp, x, oix, oiy);
}
}
return rv;
}
lref_t lwrite_char(lref_t ch, lref_t port)
{
if (NULLP(port))
port = CURRENT_OUTPUT_PORT();
if (!TEXT_PORTP(port))
vmerror_wrong_type_n(2, port);
if (PORT_INPUTP(port))
vmerror_unsupported(_T("cannot write-char to input ports"));
if (!CHARP(ch))
vmerror_wrong_type_n(1, ch);
write_char(port, CHARV(ch));
return port;
}
CELL func_string(CELL frame)
{
CELL s = V_EMPTY;
gc_root_2("func_string", frame, s);
s = make_string_raw(FC);
CHAR* data = GET_STRING(s)->data;
int argi;
for(argi = 0; argi < FC; ++argi) {
if (!CHARP(FV[argi])) {
gc_unroot();
return make_exception("expects character arguments");
}
data[argi] = GET_CHAR(FV[argi]);
}
gc_unroot();
return s;
}
/*---------------------------------------------------------------------*/
BGL_EXPORTED_DEF
long
obj_to_cobj( obj_t obj ) {
if( INTEGERP( obj ) )
return (long)CINT( obj );
if( BOOLEANP( obj ) )
return (long)((long)CBOOL( obj ));
if( STRINGP( obj ) )
return (long)BSTRING_TO_STRING( obj );
if( CHARP( obj ) )
return (long)((long)CCHAR( obj ));
if( FOREIGNP( obj ) )
return (long)FOREIGN_TO_COBJ( obj );
if( REALP( obj ) )
return (long)the_failure( string_to_bstring( "obj->cobj" ),
string_to_bstring( "Can't cast a real to foreign" ),
obj);
else
return (long)the_failure( string_to_bstring( "obj->cobj" ),
string_to_bstring( "Illegal object type" ),
obj);
}
// FIXME - should typecheck all list elements before allocating storage?
CELL func_list_to_string(CELL frame)
{
CELL list = FV0;
int n = proper_list_length(list);
if (n == -1) {
return make_exception("expects list of characters");
}
gc_root_1("func_list_to_string", list);
CELL result = make_string_raw(n);
gc_unroot();
CHAR* data = GET_STRING(result)->data;
int i;
for(i = 0; i < n; ++i) {
CELL ch = CAR(list);
list = CDR(list);
if (!CHARP(ch)) {
return make_exception("expects list of characters");
}
data[i] = GET_CHAR(ch);
}
return result;
}
// FIXME does not support immutable strings
CELL func_string_set(CELL frame)
{
CELL string = FV0;
CELL k = FV1;
CELL ch = FV2;
if (!STRINGP(string)) {
return make_exception("expects a string");
}
if (!INTP(k)) {
return make_exception("expects a non-negative integer index");
}
if (!CHARP(ch)) {
return make_exception("expects a character for 3rd argument");
}
STRING *str = GET_STRING(string);
size_t kth = GET_INT(k);
if (! (kth >= 0 && kth < str->len) ) {
return make_exception("index %d out of range [0,%d]", kth, str->len - 1);
}
str->data[kth] = GET_CHAR(ch);
return V_VOID;
}
CELL func_charp(CELL frame)
{
return MKBOOL(CHARP(FV0));
}
/* <anonymous:1896> */
obj_t BGl_zc3anonymousza31896ze3z83zz__lalr_driverz00(obj_t BgL_envz00_1579,
obj_t BgL_rgcz00_1582, obj_t BgL_inputzd2portzd2_1583,
obj_t BgL_iszd2eofzf3z21_1584)
{
AN_OBJECT;
{ /* Lalr/driver.scm 61 */
{ /* Lalr/driver.scm 69 */
obj_t BgL_actionzd2tablezd2_1580;
obj_t BgL_reductionzd2functionzd2_1581;
BgL_actionzd2tablezd2_1580 =
PROCEDURE_REF(BgL_envz00_1579, (int) (((long) 0)));
BgL_reductionzd2functionzd2_1581 =
PROCEDURE_REF(BgL_envz00_1579, (int) (((long) 1)));
{
obj_t BgL_rgcz00_782;
obj_t BgL_inputzd2portzd2_783;
obj_t BgL_iszd2eofzf3z21_784;
BgL_rgcz00_782 = BgL_rgcz00_1582;
BgL_inputzd2portzd2_783 = BgL_inputzd2portzd2_1583;
BgL_iszd2eofzf3z21_784 = BgL_iszd2eofzf3z21_1584;
{ /* Lalr/driver.scm 69 */
obj_t BgL_stackz00_787;
obj_t BgL_statez00_788;
obj_t BgL_inputz00_789;
obj_t BgL_inz00_790;
obj_t BgL_attrz00_791;
obj_t BgL_actsz00_792;
obj_t BgL_actz00_793;
bool_t BgL_eofzf3zf3_794;
bool_t BgL_debugz00_795;
BgL_stackz00_787 =
make_vector(
(int) (BGl_za2maxzd2stackzd2siza7eza2za7zz__lalr_driverz00),
BINT(((long) 0)));
BgL_statez00_788 = BFALSE;
BgL_inputz00_789 = BFALSE;
BgL_inz00_790 = BFALSE;
BgL_attrz00_791 = BFALSE;
BgL_actsz00_792 = BFALSE;
BgL_actz00_793 = BFALSE;
BgL_eofzf3zf3_794 = ((bool_t) 0);
{ /* Lalr/driver.scm 77 */
int BgL_arg1940z00_840;
BgL_arg1940z00_840 = bgl_debug();
BgL_debugz00_795 = ((long) (BgL_arg1940z00_840) >= ((long) 100));
}
{
obj_t BgL_spz00_797;
BgL_spz00_797 = BINT(((long) 0));
BgL_zc3anonymousza31897ze3z83_798:
BgL_statez00_788 =
VECTOR_REF(BgL_stackz00_787, CINT(BgL_spz00_797));
BgL_actsz00_792 =
VECTOR_REF(BgL_actionzd2tablezd2_1580, CINT(BgL_statez00_788));
if (NULLP(CDR(BgL_actsz00_792)))
{ /* Lalr/driver.scm 84 */
obj_t BgL_pairz00_1311;
BgL_pairz00_1311 = BgL_actsz00_792;
BgL_actz00_793 = CDR(CAR(BgL_pairz00_1311));
}
else
{ /* Lalr/driver.scm 83 */
if (CBOOL(BgL_inputz00_789))
{ /* Lalr/driver.scm 86 */
BFALSE;
}
else
{ /* Lalr/driver.scm 86 */
BgL_inputz00_789 =
PROCEDURE_ENTRY(BgL_rgcz00_782) (BgL_rgcz00_782,
BgL_inputzd2portzd2_783, BEOA);
}
if (CBOOL(BgL_inputz00_789))
{ /* Lalr/driver.scm 88 */
((bool_t) 0);
}
else
{ /* Lalr/driver.scm 88 */
bgl_system_failure(BGL_IO_PARSE_ERROR,
BGl_symbol2208z00zz__lalr_driverz00,
BGl_string2210z00zz__lalr_driverz00, BFALSE);
}
if (CBOOL(PROCEDURE_ENTRY(BgL_iszd2eofzf3z21_784)
(BgL_iszd2eofzf3z21_784, BgL_inputz00_789, BEOA)))
{ /* Lalr/driver.scm 94 */
BgL_inz00_790 = BGl_symbol2211z00zz__lalr_driverz00;
BgL_attrz00_791 = BFALSE;
BgL_eofzf3zf3_794 = ((bool_t) 1);
}
else
{ /* Lalr/driver.scm 94 */
if (PAIRP(BgL_inputz00_789))
{ /* Lalr/driver.scm 98 */
BgL_inz00_790 = CAR(BgL_inputz00_789);
BgL_attrz00_791 = CDR(BgL_inputz00_789);
}
else
{ /* Lalr/driver.scm 98 */
BgL_inz00_790 = BgL_inputz00_789;
BgL_attrz00_791 = BFALSE;
}
}
{ /* Lalr/driver.scm 105 */
obj_t BgL_xz00_1318;
obj_t BgL_lz00_1319;
BgL_xz00_1318 = BgL_inz00_790;
BgL_lz00_1319 = BgL_actsz00_792;
{ /* Lalr/driver.scm 105 */
obj_t BgL_yz00_1320;
BgL_yz00_1320 =
BGl_assqz00zz__r4_pairs_and_lists_6_3z00(BgL_xz00_1318,
BgL_lz00_1319);
if (CBOOL(BgL_yz00_1320))
{ /* Lalr/driver.scm 105 */
BgL_actz00_793 = CDR(BgL_yz00_1320);
}
else
{ /* Lalr/driver.scm 105 */
obj_t BgL_pairz00_1322;
BgL_pairz00_1322 = BgL_lz00_1319;
BgL_actz00_793 = CDR(CAR(BgL_pairz00_1322));
}
}
}
}
if (BgL_debugz00_795)
{ /* Lalr/driver.scm 107 */
{ /* Lalr/driver.scm 108 */
obj_t BgL_arg1903z00_804;
{ /* Lalr/driver.scm 108 */
obj_t BgL_res2190z00_1327;
{ /* Lalr/driver.scm 108 */
obj_t BgL_auxz00_1662;
BgL_auxz00_1662 = BGL_CURRENT_DYNAMIC_ENV();
BgL_res2190z00_1327 =
BGL_ENV_CURRENT_ERROR_PORT(BgL_auxz00_1662);
}
BgL_arg1903z00_804 = BgL_res2190z00_1327;
}
bgl_display_string(BGl_string2213z00zz__lalr_driverz00,
BgL_arg1903z00_804);
}
{ /* Lalr/driver.scm 109 */
obj_t BgL_arg1904z00_805;
{ /* Lalr/driver.scm 109 */
obj_t BgL_res2191z00_1331;
{ /* Lalr/driver.scm 109 */
obj_t BgL_auxz00_1666;
BgL_auxz00_1666 = BGL_CURRENT_DYNAMIC_ENV();
BgL_res2191z00_1331 =
BGL_ENV_CURRENT_ERROR_PORT(BgL_auxz00_1666);
}
BgL_arg1904z00_805 = BgL_res2191z00_1331;
}
{ /* Lalr/driver.scm 109 */
obj_t BgL_list1905z00_806;
BgL_list1905z00_806 = MAKE_PAIR(BgL_arg1904z00_805, BNIL);
BGl_writez00zz__r4_output_6_10_3z00(BgL_inz00_790,
BgL_list1905z00_806);
}
}
{ /* Lalr/driver.scm 110 */
obj_t BgL_arg1907z00_808;
{ /* Lalr/driver.scm 110 */
obj_t BgL_res2192z00_1333;
{ /* Lalr/driver.scm 110 */
obj_t BgL_auxz00_1671;
BgL_auxz00_1671 = BGL_CURRENT_DYNAMIC_ENV();
BgL_res2192z00_1333 =
BGL_ENV_CURRENT_ERROR_PORT(BgL_auxz00_1671);
}
BgL_arg1907z00_808 = BgL_res2192z00_1333;
}
bgl_display_string(BGl_string2214z00zz__lalr_driverz00,
BgL_arg1907z00_808);
}
{ /* Lalr/driver.scm 111 */
obj_t BgL_arg1908z00_809;
{ /* Lalr/driver.scm 111 */
obj_t BgL_res2193z00_1337;
{ /* Lalr/driver.scm 111 */
obj_t BgL_auxz00_1675;
BgL_auxz00_1675 = BGL_CURRENT_DYNAMIC_ENV();
BgL_res2193z00_1337 =
BGL_ENV_CURRENT_ERROR_PORT(BgL_auxz00_1675);
}
BgL_arg1908z00_809 = BgL_res2193z00_1337;
}
{ /* Lalr/driver.scm 111 */
obj_t BgL_list1909z00_810;
BgL_list1909z00_810 = MAKE_PAIR(BgL_arg1908z00_809, BNIL);
BGl_writez00zz__r4_output_6_10_3z00(BgL_statez00_788,
BgL_list1909z00_810);
}
}
{ /* Lalr/driver.scm 112 */
obj_t BgL_arg1911z00_812;
{ /* Lalr/driver.scm 112 */
obj_t BgL_res2194z00_1339;
{ /* Lalr/driver.scm 112 */
obj_t BgL_auxz00_1680;
BgL_auxz00_1680 = BGL_CURRENT_DYNAMIC_ENV();
BgL_res2194z00_1339 =
BGL_ENV_CURRENT_ERROR_PORT(BgL_auxz00_1680);
}
BgL_arg1911z00_812 = BgL_res2194z00_1339;
}
bgl_display_string(BGl_string2215z00zz__lalr_driverz00,
BgL_arg1911z00_812);
}
{ /* Lalr/driver.scm 113 */
obj_t BgL_arg1912z00_813;
{ /* Lalr/driver.scm 113 */
obj_t BgL_res2195z00_1343;
{ /* Lalr/driver.scm 113 */
obj_t BgL_auxz00_1684;
BgL_auxz00_1684 = BGL_CURRENT_DYNAMIC_ENV();
BgL_res2195z00_1343 =
BGL_ENV_CURRENT_ERROR_PORT(BgL_auxz00_1684);
}
BgL_arg1912z00_813 = BgL_res2195z00_1343;
}
{ /* Lalr/driver.scm 113 */
obj_t BgL_list1913z00_814;
BgL_list1913z00_814 = MAKE_PAIR(BgL_arg1912z00_813, BNIL);
BGl_writez00zz__r4_output_6_10_3z00(BgL_spz00_797,
BgL_list1913z00_814);
}
}
{ /* Lalr/driver.scm 114 */
obj_t BgL_arg1914z00_815;
{ /* Lalr/driver.scm 114 */
obj_t BgL_res2196z00_1345;
{ /* Lalr/driver.scm 114 */
obj_t BgL_auxz00_1689;
BgL_auxz00_1689 = BGL_CURRENT_DYNAMIC_ENV();
BgL_res2196z00_1345 =
BGL_ENV_CURRENT_ERROR_PORT(BgL_auxz00_1689);
}
BgL_arg1914z00_815 = BgL_res2196z00_1345;
}
bgl_display_char(((unsigned char) '\n'),
BgL_arg1914z00_815);
}}
else
{ /* Lalr/driver.scm 107 */
BFALSE;
}
if ((BgL_actz00_793 == BGl_symbol2216z00zz__lalr_driverz00))
{ /* Lalr/driver.scm 119 */
return VECTOR_REF(BgL_stackz00_787, (int) (((long) 1)));
}
else
{ /* Lalr/driver.scm 123 */
bool_t BgL_testz00_1697;
if ((BgL_actz00_793 == BGl_symbol2218z00zz__lalr_driverz00))
{ /* Lalr/driver.scm 123 */
BgL_testz00_1697 = ((bool_t) 1);
}
else
{ /* Lalr/driver.scm 123 */
BgL_testz00_1697 =
(BgL_actz00_793 == BGl_symbol2220z00zz__lalr_driverz00);
}
if (BgL_testz00_1697)
{ /* Lalr/driver.scm 124 */
obj_t BgL_msgz00_818;
{ /* Lalr/driver.scm 124 */
obj_t BgL_arg1919z00_820;
if (SYMBOLP(BgL_inz00_790))
{ /* Lalr/driver.scm 128 */
obj_t BgL_res2197z00_1352;
{ /* Lalr/driver.scm 128 */
obj_t BgL_symbolz00_1350;
BgL_symbolz00_1350 = BgL_inz00_790;
{ /* Lalr/driver.scm 128 */
obj_t BgL_arg2113z00_1351;
BgL_arg2113z00_1351 =
SYMBOL_TO_STRING(BgL_symbolz00_1350);
BgL_res2197z00_1352 =
BGl_stringzd2copyzd2zz__r4_strings_6_7z00
(BgL_arg2113z00_1351);
}
}
BgL_arg1919z00_820 = BgL_res2197z00_1352;
}
else
{ /* Lalr/driver.scm 127 */
if (CHARP(BgL_inz00_790))
{ /* Lalr/driver.scm 130 */
obj_t BgL_list1923z00_824;
BgL_list1923z00_824 =
MAKE_PAIR(BgL_inz00_790, BNIL);
{ /* Lalr/driver.scm 130 */
obj_t BgL_res2198z00_1360;
{ /* Lalr/driver.scm 130 */
obj_t BgL_arg2107z00_1357;
BgL_arg2107z00_1357 =
CAR(BgL_list1923z00_824);
BgL_res2198z00_1360 =
make_string(((long) 1),
CCHAR(BgL_arg2107z00_1357));
}
BgL_arg1919z00_820 = BgL_res2198z00_1360;
}}
else
{ /* Lalr/driver.scm 132 */
obj_t BgL_portz00_825;
{ /* Lalr/driver.scm 132 */
{ /* Ieee/port.scm 386 */
BgL_portz00_825 =
BGl_openzd2outputzd2stringz00zz__r4_ports_6_10_1z00
(BTRUE);
}
}
{ /* Lalr/driver.scm 133 */
obj_t BgL_list1924z00_826;
BgL_list1924z00_826 =
MAKE_PAIR(BgL_portz00_825, BNIL);
BGl_writez00zz__r4_output_6_10_3z00
(BgL_inz00_790, BgL_list1924z00_826);
}
BgL_arg1919z00_820 =
bgl_close_output_port(BgL_portz00_825);
}
}
BgL_msgz00_818 =
string_append_3(BGl_string2222z00zz__lalr_driverz00,
BgL_arg1919z00_820,
BGl_string2223z00zz__lalr_driverz00);
}
return
bgl_system_failure(BGL_IO_PARSE_ERROR,
BGl_string2209z00zz__lalr_driverz00, BgL_msgz00_818,
BgL_inputz00_789);
}
else
{ /* Lalr/driver.scm 123 */
if (((long) CINT(BgL_actz00_793) >= ((long) 0)))
{ /* Lalr/driver.scm 139 */
{ /* Lalr/driver.scm 140 */
bool_t BgL_testz00_1720;
{ /* Lalr/driver.scm 140 */
long BgL_arg1927z00_830;
{ /* Lalr/driver.scm 140 */
int BgL_arg1929z00_831;
BgL_arg1929z00_831 =
VECTOR_LENGTH(BgL_stackz00_787);
BgL_arg1927z00_830 =
((long) (BgL_arg1929z00_831) - ((long) 4));
}
BgL_testz00_1720 =
(
(long) CINT(BgL_spz00_797) >=
BgL_arg1927z00_830);
}
if (BgL_testz00_1720)
{ /* Lalr/driver.scm 140 */
BgL_stackz00_787 =
BGl_growzd2stackz12zc0zz__lalr_driverz00
(BgL_stackz00_787);
}
else
{ /* Lalr/driver.scm 140 */
BFALSE;
}
}
{ /* Lalr/driver.scm 142 */
long BgL_arg1931z00_833;
BgL_arg1931z00_833 =
((long) CINT(BgL_spz00_797) + ((long) 1));
VECTOR_SET(BgL_stackz00_787,
(int) (BgL_arg1931z00_833), BgL_attrz00_791);
}
{ /* Lalr/driver.scm 143 */
long BgL_arg1932z00_834;
BgL_arg1932z00_834 =
((long) CINT(BgL_spz00_797) + ((long) 2));
VECTOR_SET(BgL_stackz00_787,
(int) (BgL_arg1932z00_834), BgL_actz00_793);
}
if (BgL_eofzf3zf3_794)
{ /* Lalr/driver.scm 144 */
BFALSE;
}
else
{ /* Lalr/driver.scm 144 */
BgL_inputz00_789 = BFALSE;
}
{ /* Lalr/driver.scm 146 */
long BgL_arg1935z00_835;
BgL_arg1935z00_835 =
((long) CINT(BgL_spz00_797) + ((long) 2));
{
obj_t BgL_spz00_1738;
BgL_spz00_1738 = BINT(BgL_arg1935z00_835);
BgL_spz00_797 = BgL_spz00_1738;
goto BgL_zc3anonymousza31897ze3z83_798;
}
}
}
else
{ /* Lalr/driver.scm 150 */
obj_t BgL_arg1937z00_836;
{ /* Lalr/driver.scm 150 */
long BgL_arg1938z00_837;
BgL_arg1938z00_837 =
NEG((long) CINT(BgL_actz00_793));
BgL_arg1937z00_836 =
PROCEDURE_ENTRY(BgL_reductionzd2functionzd2_1581)
(BgL_reductionzd2functionzd2_1581,
BINT(BgL_arg1938z00_837), BgL_stackz00_787,
BgL_spz00_797, BEOA);
}
{
obj_t BgL_spz00_1745;
BgL_spz00_1745 = BgL_arg1937z00_836;
BgL_spz00_797 = BgL_spz00_1745;
goto BgL_zc3anonymousza31897ze3z83_798;
}
}
}
}
}
}
}
}
}
}
bool print_status (int iw)
{
int i;
double x[3], V[3][3];
SimpleStatistics ss;
/* xterm_get_focus(iw); */
for (i=0; i<CONFIG_num_auxiliary; i++)
{
CalculateSimpleStatistics
(np, CHARP(CONFIG_auxiliary[i]), sizeof(double),
IOVAL_DOUBLE, &ss);
printf("\nauxiliary[%d]=%s [%s], threshold=[%g, %g]\n", i,
CONFIG_auxiliary_name[i], CONFIG_auxiliary_unit[i],
n[iw].auxiliary_threshold[i][0],
n[iw].auxiliary_threshold[i][1]);
printf("[%g(%d), %g(%d)], avg=%g, std.dev.=%g\n",
ss.min, ss.idx_min, ss.max, ss.idx_max,
ss.average, ss.standard_deviation);
}
printf("\n======================= Status of Viewport #%d "
"=======================\n",iw);
V3EQV (AX_3D[iw].x, x);
V3pr ("Viewpoint is at %M A,\n", x);
M3inv (H, V);
V3mM3 (AX_3D[iw].x, V, x);
V3pr("in reduced coordinates it is %M;\n", x);
M3EQV(AX_3D[iw].V, V); S3PR("viewport axes = %M;\n", V);
printf ("window width = %d, height = %d pixels,\n",
AX_size[iw].width, AX_size[iw].height);
printf ("and conversion factor is %g pixel/radian,\n", AX_3D[iw].k);
printf ("which converts to %g x %g degrees of field of view.\n",
RADIAN_TO_DEGREE(2*atan(AX_size[iw].width/2/AX_3D[iw].k)),
RADIAN_TO_DEGREE(2*atan(AX_size[iw].height/2/AX_3D[iw].k)));
printf ("The viewport is now anchored to %s",
(n[iw].anchor>=0)? "atom" : "hook" );
if (n[iw].anchor >= 0) print_atom(iw,n[iw].anchor);
else
{
M3inv (H, V);
V3mM3 (n[iw].hook, V, x);
printf("\nx = [%g %g %g] A, or s = [%g %g %g].\n", n[iw].hook[0],
n[iw].hook[1], n[iw].hook[2], x[0], x[1], x[2]);
}
printf("parallel projection mode is turned %s.\n",
n[iw].parallel_projection?"ON":"OFF");
printf("term printout suppression is turned %s.\n",
n[iw].suppress_printout?"ON":"OFF");
V3pr ("background color = %M.\n", n[iw].bgcolor);
printf ("atom r_ratio = %f, bond radius = %f A.\n",
n[iw].atom_r_ratio, n[iw].bond_radius);
printf("bond mode is turned %s.\n", n[iw].bond_mode?"ON":"OFF");
printf("system average IS%s subtracted off from atomistic strains.\n",
shear_strain_subtract_mean ? "" : "N'T");
printf("wireframe mode is %s.\n",
(n[iw].wireframe_mode==WIREFRAME_MODE_CONTRAST)?"CONTRAST":
(n[iw].wireframe_mode==WIREFRAME_MODE_NONE)?"NONE":
(n[iw].wireframe_mode==WIREFRAME_MODE_RGBO)?"RGBO":
(n[iw].wireframe_mode==WIREFRAME_MODE_RGBK)?"RGBK":
(n[iw].wireframe_mode==WIREFRAME_MODE_RGB)?"RGB":
"UNKNOWN");
if (n[iw].xtal_mode)
{
printf ("Xtal mode is turned ON:\n");
V3mM3 (n[iw].xtal_origin, HI, x);
V3TRIM (x, x);
V3pr ("xtal_origin = %M.\n", x);
}
else printf ("Xtal mode is turned OFF.\n");
printf ("color mode = %s.\n",
(n[iw].color_mode==COLOR_MODE_NORMAL)? "NORMAL" :
(n[iw].color_mode==COLOR_MODE_COORD)? "COORDINATION" :
(n[iw].color_mode==COLOR_MODE_AUXILIARY)? "Auxiliary Properties" :
(n[iw].color_mode==COLOR_MODE_SCRATCH)? "SCRATCH" : "UNKNOWN");
if (n[iw].shell_viewer_mode)
printf("Shell viewer auto-invoke is turned ON.\n");
else printf("Shell viewer auto-invoke is turned OFF.\n");
printf("s[%d]=%d surface is now seen or selected.\n",
n[iw].last_surface_id/2, n[iw].last_surface_id%2);
if (rcut_patching)
printf ("Neighbor distance cutoff between %s = %g.\n",
rcut_patch_pairname, rcut_patch[rcut_patch_item].rcut);
printf ("rate of change = %g.\n", n[iw].delta);
if (n[iw].color_mode==COLOR_MODE_AUXILIARY)
{
i = n[iw].auxiliary_idx;
if (i < CONFIG_num_auxiliary)
printf("auxiliary[%d] = %s [%s], threshold = [%g, %g],\n", i,
CONFIG_auxiliary_name[i], CONFIG_auxiliary_unit[i],
n[iw].auxiliary_threshold[i][0],
n[iw].auxiliary_threshold[i][1]);
else printf("auxiliary = %s, threshold = [%g, %g],\n",
geolist[i-CONFIG_MAX_AUXILIARY].token,
n[iw].auxiliary_threshold[i][0],
n[iw].auxiliary_threshold[i][1]);
CalculateSimpleStatistics
(np, CHARP(INW(n[iw].auxiliary_idx,CONFIG_num_auxiliary) ?
CONFIG_auxiliary[i] : geo[i-CONFIG_MAX_AUXILIARY]),
sizeof(double), IOVAL_DOUBLE, &ss);
printf("[%g(%d),%g(%d)], avg=%g, std.dev.=%g,\n",
ss.min, ss.idx_min, ss.max, ss.idx_max,
ss.average, ss.standard_deviation);
printf("auxiliaries' colormap = %s \"%s\".\n",
AX_cmap_funs[n[iw].auxiliary_cmap].name,
AX_cmap_funs[n[iw].auxiliary_cmap].description);
printf("invisible outside auxiliary thresholds flag = %s.\n",
n[iw].auxiliary_thresholds_saturation?"OFF":"ON");
printf("floating auxiliary thresholds flag = %s.\n",
n[iw].auxiliary_thresholds_rigid?"OFF":"ON");
}
printf ("clicked atoms = [ ");
for (i=0; i<ATOM_STACK_SIZE; i++) printf ("%d ", n[iw].atom_stack[i]);
printf ("];\n");
for (i=0; i<AX_3D_MAX_FILTER_PLANE; i++)
if (AX_V3NEZERO(AX_3D[iw].fp[i].dx))
printf("%s fp %d: dx = [%g %g %g], s = [%g %g %g]\n",
(n[iw].just_activated_fp==i) ? "*" : " ",
i, V3E(AX_3D[iw].fp[i].dx), V3E(n[iw].fp[i].s0));
printf("=============================================="
"=======================\n");
return(FALSE);
} /* end print_status() */
static void
find_context (struct buffer *buf, Bufpos pt)
{
/* This function can GC */
#ifndef emacs
#ifdef UTF2000
Lisp_Char_Table *mirrortab = XCHAR_TABLE (buf->syntax_table);
#else
Lisp_Char_Table *mirrortab = XCHAR_TABLE (buf->mirror_syntax_table);
#endif
Lisp_Object syntaxtab = buf->syntax_table;
#endif
Emchar prev_c, c;
int prev_syncode, syncode;
Bufpos target = pt;
setup_context_cache (buf, pt);
pt = context_cache.cur_point;
SCS_STATISTICS_SET_FUNCTION (scs_find_context);
SETUP_SYNTAX_CACHE (pt - 1, 1);
if (pt > BUF_BEGV (buf))
{
c = BUF_FETCH_CHAR (buf, pt - 1);
syncode = SYNTAX_CODE_FROM_CACHE (mirrortab, c);
}
else
{
c = '\n'; /* to get bol_context_cache at point-min */
syncode = Swhitespace;
}
for (; pt < target; pt++, context_cache.cur_point = pt)
{
if (context_cache.needs_its_head_reexamined)
{
if (context_cache.depth == 0
&& context_cache.context == context_none)
{
/* We've found an anchor spot.
Try to put the start of defun within 6000 chars of
the target, and the end of defun as close as possible.
6000 is also arbitrary but tries to strike a balance
between two conflicting pulls when dealing with a
file that has lots of stuff sitting outside of a top-
level form:
a) If you move past the start of defun, you will
have to recompute defun, which in this case
means that start of defun goes all the way back
to the beginning of the file; so you want
to set start of defun a ways back from the
current point.
b) If you move a line backwards but within start of
defun, you have to move back to start of defun;
so you don't want start of defun too far from
the current point.
*/
if (target - context_cache.start_point > 6000)
context_cache.start_point = pt;
context_cache.end_point = pt;
bol_context_cache = context_cache;
}
}
UPDATE_SYNTAX_CACHE_FORWARD (pt);
prev_c = c;
prev_syncode = syncode;
c = BUF_FETCH_CHAR (buf, pt);
syncode = SYNTAX_CODE_FROM_CACHE (mirrortab, c);
if (prev_c == '\n')
bol_context_cache = context_cache;
if (context_cache.backslash_p)
{
context_cache.backslash_p = 0;
continue;
}
switch (SYNTAX_FROM_CACHE (mirrortab, c))
{
case Sescape:
context_cache.backslash_p = 1;
break;
case Sopen:
if (context_cache.context == context_none)
context_cache.depth++;
break;
case Sclose:
if (context_cache.context == context_none)
context_cache.depth--;
break;
case Scomment:
if (context_cache.context == context_none)
{
context_cache.context = context_comment;
context_cache.ccontext = ccontext_none;
context_cache.style = SINGLE_SYNTAX_STYLE (syncode);
if (context_cache.style == comment_style_none) ABORT ();
}
break;
case Sendcomment:
if (context_cache.style != SINGLE_SYNTAX_STYLE (syncode))
;
else if (context_cache.context == context_comment)
{
context_cache.context = context_none;
context_cache.style = comment_style_none;
}
else if (context_cache.context == context_block_comment &&
(context_cache.ccontext == ccontext_start2 ||
context_cache.ccontext == ccontext_end1))
{
context_cache.context = context_none;
context_cache.ccontext = ccontext_none;
context_cache.style = comment_style_none;
}
break;
case Sstring:
{
if (context_cache.context == context_string &&
context_cache.scontext == c)
{
context_cache.context = context_none;
context_cache.scontext = '\000';
}
else if (context_cache.context == context_none)
{
Lisp_Object stringtermobj =
syntax_match (syntax_cache.current_syntax_table, c);
Emchar stringterm;
if (CHARP (stringtermobj))
stringterm = XCHAR (stringtermobj);
else
stringterm = c;
context_cache.context = context_string;
context_cache.scontext = stringterm;
context_cache.ccontext = ccontext_none;
}
break;
}
case Scomment_fence:
{
if (context_cache.context == context_generic_comment)
{
context_cache.context = context_none;
}
else if (context_cache.context == context_none)
{
context_cache.context = context_generic_comment;
context_cache.ccontext = ccontext_none;
}
break;
}
case Sstring_fence:
{
if (context_cache.context == context_generic_string)
{
context_cache.context = context_none;
}
else if (context_cache.context == context_none)
{
context_cache.context = context_generic_string;
context_cache.ccontext = ccontext_none;
}
break;
}
default:
;
}
/* That takes care of the characters with manifest syntax.
Now we've got to hack multi-char sequences that start
and end block comments.
*/
if ((SYNTAX_CODE_COMMENT_BITS (syncode) &
SYNTAX_SECOND_CHAR_START) &&
context_cache.context == context_none &&
context_cache.ccontext == ccontext_start1 &&
SYNTAX_CODES_START_P (prev_syncode, syncode) /* the two chars match */
)
{
context_cache.ccontext = ccontext_start2;
context_cache.style = SYNTAX_START_STYLE (prev_syncode, syncode);
if (context_cache.style == comment_style_none) ABORT ();
}
else if ((SYNTAX_CODE_COMMENT_BITS (syncode) &
SYNTAX_FIRST_CHAR_START) &&
context_cache.context == context_none &&
(context_cache.ccontext == ccontext_none ||
context_cache.ccontext == ccontext_start1))
{
context_cache.ccontext = ccontext_start1;
context_cache.style = comment_style_none; /* should be this already*/
}
else if ((SYNTAX_CODE_COMMENT_BITS (syncode) &
SYNTAX_SECOND_CHAR_END) &&
context_cache.context == context_block_comment &&
context_cache.ccontext == ccontext_end1 &&
SYNTAX_CODES_END_P (prev_syncode, syncode) &&
/* the two chars match */
context_cache.style ==
SYNTAX_END_STYLE (prev_syncode, syncode)
)
{
context_cache.context = context_none;
context_cache.ccontext = ccontext_none;
context_cache.style = comment_style_none;
}
else if ((SYNTAX_CODE_COMMENT_BITS (syncode) &
SYNTAX_FIRST_CHAR_END) &&
context_cache.context == context_block_comment &&
#if 0
/* #### pre-Matt code had: */
(context_cache.style ==
SYNTAX_END_STYLE (c, BUF_FETCH_CHAR (buf, pt+1))) &&
/* why do these differ here?! */
#endif
context_cache.style == SINGLE_SYNTAX_STYLE (syncode) &&
(context_cache.ccontext == ccontext_start2 ||
context_cache.ccontext == ccontext_end1))
/* check end1, to detect a repetition of the first char of a
comment-end sequence. ie, '/xxx foo xxx/' or '/xxx foo x/',
where 'x' = '*' -- mct */
{
if (context_cache.style == comment_style_none) ABORT ();
context_cache.ccontext = ccontext_end1;
}
else if (context_cache.ccontext == ccontext_start1)
{
if (context_cache.context != context_none) ABORT ();
context_cache.ccontext = ccontext_none;
}
else if (context_cache.ccontext == ccontext_end1)
{
if (context_cache.context != context_block_comment) ABORT ();
context_cache.context = context_none;
context_cache.ccontext = ccontext_start2;
}
if (context_cache.ccontext == ccontext_start2 &&
context_cache.context == context_none)
{
context_cache.context = context_block_comment;
if (context_cache.style == comment_style_none) ABORT ();
}
else if (context_cache.ccontext == ccontext_none &&
context_cache.context == context_block_comment)
{
context_cache.context = context_none;
}
}
context_cache.needs_its_head_reexamined = 0;
}
/* <anonymous:1965> */
obj_t BGl_zc3anonymousza31965ze3z83zz__modulez00(obj_t BgL_envz00_1666, obj_t BgL_fz00_1668)
{ AN_OBJECT;
{ /* Llib/module.scm 213 */
{ /* Llib/module.scm 214 */
obj_t BgL_abasez00_1667;
BgL_abasez00_1667 =
PROCEDURE_REF(BgL_envz00_1666,
(int)(((long)0)));
{
obj_t BgL_fz00_896;
BgL_fz00_896 = BgL_fz00_1668;
{
obj_t BgL_fz00_903;obj_t BgL_abasez00_904;
BgL_fz00_903 = BgL_fz00_896;
BgL_abasez00_904 = BgL_abasez00_1667;
if(
STRINGP(BgL_fz00_903))
{ /* Llib/module.scm 203 */
bool_t BgL_testz00_2175;
if(
bigloo_strcmp(BgL_fz00_903, BGl_string2367z00zz__modulez00))
{ /* Llib/module.scm 203 */
BgL_testz00_2175 = ((bool_t)1)
; } else
{ /* Llib/module.scm 203 */
unsigned char BgL_arg1972z00_909;obj_t BgL_arg1973z00_910;
{ /* Llib/module.scm 203 */
obj_t BgL_s2257z00_1669;
BgL_s2257z00_1669 = BgL_fz00_903;
{ /* Llib/module.scm 203 */
long BgL_l2259z00_1671;
BgL_l2259z00_1671 =
STRING_LENGTH(BgL_s2257z00_1669);
if(
BOUND_CHECK(((long)0), BgL_l2259z00_1671))
{ /* Llib/module.scm 203 */
BgL_arg1972z00_909 =
STRING_REF(BgL_s2257z00_1669, ((long)0)); } else
{
obj_t BgL_auxz00_2182;
BgL_auxz00_2182 =
BGl_indexzd2outzd2ofzd2boundszd2errorz00zz__errorz00(BGl_string2330z00zz__modulez00,
BINT(((long)7865)), BGl_string2368z00zz__modulez00,
BINT(((long)0)), BgL_s2257z00_1669);
FAILURE(BgL_auxz00_2182,BFALSE,BFALSE);} } }
BgL_arg1973z00_910 =
BGl_filezd2separatorzd2zz__osz00();
{ /* Llib/module.scm 203 */
unsigned char BgL_char2z00_1445;
{ /* Llib/module.scm 203 */
obj_t BgL_auxz00_2188;
if(
CHARP(BgL_arg1973z00_910))
{ /* Llib/module.scm 203 */
BgL_auxz00_2188 = BgL_arg1973z00_910
; } else
{
obj_t BgL_auxz00_2191;
BgL_auxz00_2191 =
BGl_typezd2errorzd2zz__errorz00(BGl_string2330z00zz__modulez00,
BINT(((long)7897)), BGl_string2369z00zz__modulez00, BGl_string2370z00zz__modulez00, BgL_arg1973z00_910);
FAILURE(BgL_auxz00_2191,BFALSE,BFALSE);}
BgL_char2z00_1445 =
CCHAR(BgL_auxz00_2188); }
BgL_testz00_2175 =
(BgL_arg1972z00_909==BgL_char2z00_1445); } }
if(BgL_testz00_2175)
{ /* Llib/module.scm 203 */
return BgL_fz00_903;} else
{ /* Llib/module.scm 204 */
obj_t BgL_auxz00_2197;
if(
STRINGP(BgL_abasez00_904))
{ /* Llib/module.scm 204 */
BgL_auxz00_2197 = BgL_abasez00_904
; } else
{
obj_t BgL_auxz00_2200;
BgL_auxz00_2200 =
BGl_typezd2errorzd2zz__errorz00(BGl_string2330z00zz__modulez00,
BINT(((long)7928)), BGl_string2369z00zz__modulez00, BGl_string2355z00zz__modulez00, BgL_abasez00_904);
FAILURE(BgL_auxz00_2200,BFALSE,BFALSE);}
return
BGl_makezd2filezd2namez00zz__osz00(BgL_auxz00_2197, BgL_fz00_903);} } else
{ /* Llib/module.scm 202 */
return BgL_fz00_903;} } } } }
}
