/**************************************************************************/
/* contents: LISP functions coded in C */
/* These include LISP primitives, numeric and boolean functions and */
/* predicates, some list-processing functions, i/o support functions */
/* and control flow functions (e.g. cont, break). */
/* There are two types of functions: lambda (prefixed "L") and nlambda */
/* Lambda's all call chkarg to insure that at least the minimum number */
/* of necessary arguments are on the namestack. */
/* All functions take their arguments from the namestack in a read- */
/* only manner, and return their results via the normal C value */
register lispval temp
, result
;
if (((typ
= TYPE(temp
)) == DTPR
) || (typ
== ATOM
))
result
= inewint(temp
->i
);
} else if(Schainp
!=nil
&& typ
==ATOM
)
return(error("BAD ARG TO CAR",FALSE
));
register lispval temp
, result
;
if(temp
==nil
) return (nil
);
if ((typ
= TYPE(temp
)) == DTPR
)
if(temp
->CDR
==0) return(nil
);
} else if(Schainp
!=nil
&& typ
==ATOM
)
return(error("BAD ARG TO CDR",FALSE
));
register lispval temp
, temp2
;
if ((typ
= TYPE(temp
)) == DTPR
)
if(temp
->CDR
==0) temp
= nil
;
else if(Schainp
!=nil
&& typ
==ATOM
)
return(errorh(Vermisc
,"BAD ARG TO CDR",nil
,FALSE
,5,temp
));
if ((typ
= TYPE(temp
)) == DTPR
)
temp2
= inewint(temp
->i
), temp
= temp2
;
else if(Schainp
!=nil
&& typ
==ATOM
)
return(errorh(Vermisc
,"BAD ARG TO CAR",nil
,FALSE
,5,temp
));
{ return(cxxr(0,2)); /* cddr */
{ return(cxxr(1,2)); /* caddr */
{ return(cxxr(0,3)); /* cdddr */
{ return(cxxr(1,3)); /* cadddr */
{ return(cxxr(0,4)); /* cddddr */
{ return(cxxr(1,4)); /* caddddr */
/*************************
* returns the num'th element of the list, by doing a caddddd...ddr
* where there are num-1 d's
* if num<=0 or greater than the length of the list, we return nil
******************************************************/
if( TYPE(temp
= lbot
->val
) != INT
)
return (error ("First arg to nthelem must be a fixnum",FALSE
));
i
= temp
->i
; /* pick up the first arg */
++lbot
; /* fix lbot for call to cxxr() 'cadddd..r' */
register struct argent
*argp
= lbot
;
register lispval retp
, handy
;
error("First arg to scons must be an int.",FALSE
);
error("Currently you may only link sdots to sdots.",FALSE
);
{ register struct argent
*argp
;
retp
-> cdr
= ((argp
= np
-1) -> val
);
retp
-> car
= (--argp
) -> val
;
{ register struct argent
*argp
;
register int typ
; register lispval first
, second
;
first
= error("Attempt to rplac[ad] nil.",TRUE
);
if (((typ
= TYPE(first
)) == DTPR
) || (typ
== ATOM
)) {
if(typ
!=INT
) error("Rplacca of a bignum will only replace INTS",FALSE
);
first
->CDR
= (lispval
) 0;
return(error("BAD ARG TO RPLA",FALSE
));
register struct argent
*mynp
= lbot
+ AD
;
if(mynp
->val
==(mynp
+1)->val
) return(tatom
);
return ((lbot
->val
== nil
) ? tatom
: nil
);
/* Lreturn **************************************************************/
/* Returns the first argument - which is nill if not specified. */
/* Lretbrk **************************************************************/
/* The first argument must be an integer and must be in the range */
contval
= (lispval
) level
;
name
= error("Please supply atom name for port.",TRUE
);
/* return nil if file couldnt be opened
if ((port = fopen(name->pname,"r")) == NULL) return(nil); */
while ((port
= fopen(name
->pname
,"r")) == NULL
)
name
= errorh(Vermisc
,"Unable to open file for reading.",nil
,TRUE
,31,name
);
return((lispval
)(xports
+ (port
- _iob
)));
FILE *port
; register lispval name
;
name
= error("Please supply atom name for port.",TRUE
);
while ((port
= fopen(name
->pname
,"w")) == NULL
)
name
= errorh(Vermisc
,"Unable to open file for writing.",nil
,TRUE
,31,name
);
return((lispval
)(xports
+ (port
- _iob
)));
port
= okport(lbot
->val
,okport(Vpoport
->clb
,stdout
));
port
= error("Close requires one argument of type port",TRUE
);
if((TYPE(port
))==PORT
) fclose(port
->p
);
port
= okport(lbot
->val
,okport(Vpoport
->clb
,stdout
));
value
= port
->_ptr
- port
->_base
;
port
= okport(lbot
->val
, okport(Vpoport
->clb
,stdout
));
if(port
->_flag
& _IOWRT
) {
if(! port
->_flag
& _IOREAD
) return(nil
);
port
->_ptr
= port
->_base
;
if(gtty(iodes
,&arg
) != -1) stty(iodes
,&arg
);
return((lispval
)(xports
+ (port
- _iob
)));
/* added for the benefit of mapping functions. */
register struct argent
*ulim
, *namptr
;
register lispval temp
, result
;
register struct argent
*lbot
, *np
;
temp
= result
= (lispval
) np
;
temp
= temp
->l
= newdot();
temp
->car
= (namptr
++)->val
;
switch(TYPE(lbot
->val
)) {
case INT
: case DOUB
: case SDOT
:
if(TYPE(lbot
->val
)==DTPR
)
switch(TYPE(lbot
->val
)) {
return(matom("port")); /* fix this when name exists */
return(typred(DTPR
,lbot
->val
));
return(typred(BCD
,lbot
->val
));
return(typred(PORT
,lbot
->val
));
return(typred(ARRAY
,lbot
->val
));
case ATOM
: return(varble
->clb
= lbot
[1].val
);
case VALUE
: return(varble
->l
= lbot
[1].val
);
error("IMPROPER USE OF SET",FALSE
);
if( lbot
[1].val
== lbot
->val
) return(tatom
);
if(Iequal(lbot
[1].val
,lbot
->val
)) return(tatom
); else return(nil
);
register lispval first
, second
;
register struct argent
*lbot
, *np
;
if((type1
==SDOT
&&type2
==INT
)||(type1
==INT
&&type2
==SDOT
))
Iequal(first
->car
,second
->car
) &&
Iequal(first
->cdr
,second
->cdr
) );
return(first
->r
==second
->r
);
return( (first
->i
==second
->i
));
return( first
->l
==second
->l
);
return(strcmp(first
,second
)==0);
chkrtab(Vreadtable
->clb
);
printr(lbot
->val
,okport(lbot
[1].val
,okport(Vpoport
->clb
,poport
)));
port
= okport(lbot
[1].val
, okport(Vpoport
->clb
,stdout
));
if ((TYPE((temp
= (lbot
)->val
)))!=ATOM
)
fputs(temp
->pname
, port
);
* (pntlen thing) returns the length it takes to print out
return(inewint(Ipntlen()));
loop
: switch(TYPE(temp
)) {
sprintf(strbuf
,"%d",temp
->i
);
sprintf(strbuf
,"%g",temp
->r
);
temp
= error("Non atom or number to pntlen\n",TRUE
);