home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / XSCHEME2.ZIP / xsftab.c < prev    next >
C/C++ Source or Header  |  1990-01-08  |  14KB  |  482 lines
  1. /* xsftab.c - built-in function table */
  2. /*    Copyright (c) 1988, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include "xscheme.h"
  7.  
  8. /* external variables */
  9. extern LVAL s_stdin,s_stdout;
  10.  
  11. /* external functions */
  12. extern LVAL
  13.     xapply(),xcallcc(),xmap(),xmap1(),xforeach(),xforeach1(),
  14.     xforce(),xforce1(),xcallwi(),xcallwo(),xwithfile1(),
  15.     xload(),xloadnoisily(),xload1(),
  16.     xsendsuper(),clnew(),clisnew(),clanswer(),
  17.     obisnew(),obclass(),obshow(),
  18.     xcons(),xcar(),xcdr(),
  19.     xcaar(),xcadr(),xcdar(),xcddr(),
  20.     xcaaar(),xcaadr(),xcadar(),xcaddr(),
  21.     xcdaar(),xcdadr(),xcddar(),xcdddr(),
  22.     xcaaaar(),xcaaadr(),xcaadar(),xcaaddr(),
  23.     xcadaar(),xcadadr(),xcaddar(),xcadddr(),
  24.     xcdaaar(),xcdaadr(),xcdadar(),xcdaddr(),
  25.     xcddaar(),xcddadr(),xcdddar(),xcddddr(),
  26.     xsetcar(),xsetcdr(),xlist(),xliststar(),
  27.     xappend(),xreverse(),xlastpair(),xlength(),xlistref(),xlisttail(),
  28.     xmember(),xmemv(),xmemq(),xassoc(),xassv(),xassq(),
  29.     xsymvalue(),xsetsymvalue(),xsymplist(),xsetsymplist(),xgensym(),
  30.     xboundp(),xget(),xput(),
  31.     xtheenvironment(),xprocenvironment(),xenvp(),xenvbindings(),xenvparent(),
  32.     xvector(),xmakevector(),xvlength(),xvref(),xvset(),
  33.     xvectlist(),xlistvect(),
  34.     xmakearray(),xaref(),xaset(),
  35.     xsymstr(),xstrsym(),
  36.     xnull(),xatom(),xlistp(),xnumberp(),xbooleanp(),
  37.     xpairp(),xsymbolp(),xintegerp(),xrealp(),xcharp(),xstringp(),xvectorp(),
  38.     xprocedurep(),xobjectp(),xdefaultobjectp(),
  39.     xinputportp(),xoutputportp(),xportp(),
  40.     xeq(),xeqv(),xequal(),
  41.     xzerop(),xpositivep(),xnegativep(),xoddp(),xevenp(),
  42.     xexactp(),xinexactp(),
  43.     xadd1(),xsub1(),xabs(),xgcd(),xrandom(),
  44.     xadd(),xsub(),xmul(),xdiv(),xquo(),xrem(),xmin(),xmax(),
  45.     xsin(),xcos(),xtan(),xasin(),xacos(),xatan(),
  46.     xxexp(),xsqrt(),xexpt(),xxlog(),xtruncate(),xfloor(),xceiling(),xround(),
  47.     xlogand(),xlogior(),xlogxor(),xlognot(),
  48.     xlss(),xleq(),xeql(),xgeq(),xgtr(),
  49.     xstrlen(),xstrnullp(),xstrappend(),xstrref(),xsubstring(),
  50.     xstrlist(),xliststring(),
  51.     xstrlss(),xstrleq(),xstreql(),xstrgeq(),xstrgtr(),
  52.     xstrilss(),xstrileq(),xstrieql(),xstrigeq(),xstrigtr(),
  53.     xcharint(),xintchar(),
  54.     xchrlss(),xchrleq(),xchreql(),xchrgeq(),xchrgtr(),
  55.     xchrilss(),xchrileq(),xchrieql(),xchrigeq(),xchrigtr(),
  56.     xread(),xrdchar(),xrdbyte(),xrdshort(),xrdlong(),xeofobjectp(),
  57.     xwrite(),xwrchar(),xwrbyte(),xwrshort(),xwrlong(),
  58.     xdisplay(),xnewline(),xprint(),xprbreadth(),xprdepth(),
  59.     xopeni(),xopeno(),xopena(),xopenu(),xclosei(),xcloseo(),xclose(),
  60.     xgetfposition(),xsetfposition(),xcurinput(),xcuroutput(),
  61.     xtranson(),xtransoff(),xgetarg(),xexit(),xcompile(),xdecompile(),xgc(),
  62.     xsave(),xrestore(),xtraceon(),xtraceoff(),xreset(),xerror(),
  63.     xicar(),xicdr(),xisetcar(),xisetcdr(),xivlength(),xivref(),xivset();
  64.  
  65. /* include machine specific declarations */
  66. #include "osdefs.h"
  67.  
  68. int xsubrcnt = 12;    /* number of XSUBR functions */
  69. int csubrcnt = 17;    /* number of CSUBR functions + xsubrcnt */
  70.  
  71. /* built-in functions */
  72. FUNDEF funtab[] = {
  73.  
  74.     /* functions that call eval or apply (# must match xsubrcnt) */
  75. {    "APPLY",                xapply        },
  76. {    "CALL-WITH-CURRENT-CONTINUATION",    xcallcc        },
  77. {    "CALL/CC",                xcallcc        },
  78. {    "MAP",                    xmap        },
  79. {    "FOR-EACH",                xforeach    },
  80. {    "CALL-WITH-INPUT-FILE",            xcallwi        },
  81. {    "CALL-WITH-OUTPUT-FILE",        xcallwo        },
  82. {    "LOAD",                    xload        },
  83. {    "LOAD-NOISILY",                xloadnoisily    },
  84. {    "SEND-SUPER",                xsendsuper    },
  85. {    "%CLASS-NEW",                clnew        },
  86. {    "FORCE",                xforce        },
  87.  
  88.     /* continuations for xsubrs (# must match csubrcnt) */
  89. {    "%MAP1",                xmap1        },
  90. {    "%FOR-EACH1",                xforeach1    },
  91. {    "%WITH-FILE1",                xwithfile1    },
  92. {    "%LOAD1",                xload1        },
  93. {    "%FORCE1",                xforce1        },
  94.  
  95.     /* methods */
  96. {    "%CLASS-ISNEW",                clisnew        },
  97. {    "%CLASS-ANSWER",            clanswer    },
  98. {    "%OBJECT-ISNEW",            obisnew        },
  99. {    "%OBJECT-CLASS",            obclass        },
  100. {    "%OBJECT-SHOW",                obshow        },
  101.  
  102.     /* list functions */
  103. {    "CONS",                    xcons        },
  104. {    "CAR",                    xcar        },
  105. {    "CDR",                    xcdr        },
  106. {    "CAAR",                    xcaar        },
  107. {    "CADR",                    xcadr        },
  108. {    "CDAR",                    xcdar        },
  109. {    "CDDR",                    xcddr        },
  110. {    "CAAAR",                xcaaar        },
  111. {    "CAADR",                xcaadr        },
  112. {    "CADAR",                xcadar        },
  113. {    "CADDR",                xcaddr        },
  114. {    "CDAAR",                xcdaar        },
  115. {    "CDADR",                xcdadr        },
  116. {    "CDDAR",                xcddar        },
  117. {    "CDDDR",                xcdddr        },
  118. {    "CAAAAR",                 xcaaaar        },
  119. {    "CAAADR",                xcaaadr        },
  120. {    "CAADAR",                xcaadar        },
  121. {    "CAADDR",                xcaaddr        },
  122. {    "CADAAR",                 xcadaar        },
  123. {    "CADADR",                xcadadr        },
  124. {    "CADDAR",                xcaddar        },
  125. {    "CADDDR",                xcadddr        },
  126. {    "CDAAAR",                xcdaaar        },
  127. {    "CDAADR",                xcdaadr        },
  128. {    "CDADAR",                xcdadar        },
  129. {    "CDADDR",                xcdaddr        },
  130. {    "CDDAAR",                xcddaar        },
  131. {    "CDDADR",                xcddadr        },
  132. {    "CDDDAR",                xcdddar        },
  133. {    "CDDDDR",                xcddddr        },
  134. {    "LIST",                    xlist        },
  135. {    "LIST*",                xliststar    },
  136. {    "APPEND",                xappend        },
  137. {    "REVERSE",                xreverse    },
  138. {    "LAST-PAIR",                xlastpair    },
  139. {    "LENGTH",                xlength        },
  140. {    "MEMBER",                xmember        },
  141. {    "MEMV",                    xmemv        },
  142. {    "MEMQ",                    xmemq        },
  143. {    "ASSOC",                xassoc        },
  144. {    "ASSV",                    xassv        },
  145. {    "ASSQ",                    xassq        },
  146. {    "LIST-REF",                xlistref    },
  147. {    "LIST-TAIL",                xlisttail    },
  148.  
  149.     /* destructive list functions */
  150. {    "SET-CAR!",                xsetcar        },
  151. {    "SET-CDR!",                xsetcdr        },
  152.  
  153.  
  154.     /* symbol functions */
  155. {    "BOUND?",                xboundp        },
  156. {    "SYMBOL-VALUE",                xsymvalue    },
  157. {    "SET-SYMBOL-VALUE!",            xsetsymvalue    },
  158. {    "SYMBOL-PLIST",                xsymplist    },
  159. {    "SET-SYMBOL-PLIST!",            xsetsymplist    },
  160. {    "GENSYM",                xgensym        },
  161. {    "GET",                    xget        },
  162. {    "PUT",                    xput        },
  163.  
  164.     /* environment functions */
  165. {    "THE-ENVIRONMENT",            xtheenvironment    },
  166. {    "PROCEDURE-ENVIRONMENT",        xprocenvironment},
  167. {    "ENVIRONMENT?",                xenvp        },
  168. {    "ENVIRONMENT-BINDINGS",            xenvbindings    },
  169. {    "ENVIRONMENT-PARENT",            xenvparent    },
  170.  
  171.     /* vector functions */
  172. {    "VECTOR",                xvector        },
  173. {    "MAKE-VECTOR",                xmakevector    },
  174. {    "VECTOR-LENGTH",            xvlength    },
  175. {    "VECTOR-REF",                xvref        },
  176. {    "VECTOR-SET!",                xvset        },
  177.  
  178.     /* array functions */
  179. {    "MAKE-ARRAY",                xmakearray    },
  180. {    "ARRAY-REF",                xaref        },
  181. {    "ARRAY-SET!",                xaset        },
  182.  
  183.     /* conversion functions */
  184. {    "SYMBOL->STRING",            xsymstr        },
  185. {    "STRING->SYMBOL",            xstrsym        },
  186. {    "VECTOR->LIST",                xvectlist    },
  187. {    "LIST->VECTOR",                xlistvect    },
  188. {    "STRING->LIST",                xstrlist    },
  189. {    "LIST->STRING",                xliststring    },
  190. {    "CHAR->INTEGER",            xcharint    },
  191. {    "INTEGER->CHAR",            xintchar    },
  192.  
  193.     /* predicate functions */
  194. {    "NULL?",                xnull        },
  195. {    "ATOM?",                xatom        },
  196. {    "LIST?",                xlistp        },
  197. {    "NUMBER?",                xnumberp    },
  198. {    "BOOLEAN?",                xbooleanp    },
  199. {    "PAIR?",                xpairp        },
  200. {    "SYMBOL?",                xsymbolp    },
  201. {    "COMPLEX?",                xrealp        }, /*(1)*/
  202. {    "REAL?",                xrealp        },
  203. {    "RATIONAL?",                xintegerp    }, /*(1)*/
  204. {    "INTEGER?",                xintegerp    },
  205. {    "CHAR?",                xcharp        },
  206. {    "STRING?",                xstringp    },
  207. {    "VECTOR?",                xvectorp    },
  208. {    "PROCEDURE?",                xprocedurep    },
  209. {    "PORT?",                xportp        },
  210. {    "INPUT-PORT?",                xinputportp    },
  211. {    "OUTPUT-PORT?",                xoutputportp    },
  212. {    "OBJECT?",                xobjectp    },
  213. {    "EOF-OBJECT?",                xeofobjectp    },
  214. {    "DEFAULT-OBJECT?",            xdefaultobjectp    },
  215. {    "EQ?",                    xeq        },
  216. {    "EQV?",                    xeqv        },
  217. {    "EQUAL?",                xequal        },
  218.  
  219.     /* arithmetic functions */
  220. {    "ZERO?",                xzerop        },
  221. {    "POSITIVE?",                xpositivep    },
  222. {    "NEGATIVE?",                xnegativep    },
  223. {    "ODD?",                    xoddp        },
  224. {    "EVEN?",                xevenp        },
  225. {    "EXACT?",                xexactp        },
  226. {    "INEXACT?",                xinexactp    },
  227. {    "TRUNCATE",                xtruncate    },
  228. {    "FLOOR",                xfloor        },
  229. {    "CEILING",                xceiling    },
  230. {    "ROUND",                xround        },
  231. {    "1+",                    xadd1        },
  232. {    "-1+",                    xsub1        },
  233. {    "ABS",                    xabs        },
  234. {    "GCD",                    xgcd        },
  235. {    "RANDOM",                xrandom        },
  236. {    "+",                    xadd        },
  237. {    "-",                    xsub        },
  238. {    "*",                    xmul        },
  239. {    "/",                    xdiv        },
  240. {    "QUOTIENT",                xquo        },
  241. {    "REMAINDER",                xrem        },
  242. {    "MIN",                    xmin        },
  243. {    "MAX",                    xmax        },
  244. {    "SIN",                    xsin        },
  245. {    "COS",                    xcos        },
  246. {    "TAN",                    xtan        },
  247. {    "ASIN",                    xasin        },
  248. {    "ACOS",                    xacos        },
  249. {    "ATAN",                    xatan        },
  250. {    "EXP",                    xxexp        },
  251. {    "SQRT",                    xsqrt        },
  252. {    "EXPT",                    xexpt        },
  253. {    "LOG",                    xxlog        },
  254.  
  255.     /* bitwise logical functions */
  256. {    "LOGAND",                xlogand        },
  257. {    "LOGIOR",                xlogior        },
  258. {    "LOGXOR",                xlogxor        },
  259. {    "LOGNOT",                xlognot        },
  260.  
  261.     /* numeric comparison functions */
  262. {    "<",                    xlss        },
  263. {    "<=",                    xleq        },
  264. {    "=",                    xeql        },
  265. {    ">=",                    xgeq        },
  266. {    ">",                    xgtr        },
  267.  
  268.     /* string functions */
  269. {    "STRING-LENGTH",            xstrlen        },
  270. {    "STRING-NULL?",                xstrnullp    },
  271. {    "STRING-APPEND",            xstrappend    },
  272. {    "STRING-REF",                xstrref        },
  273. {    "SUBSTRING",                xsubstring    },
  274. {    "STRING<?",                xstrlss        },
  275. {    "STRING<=?",                xstrleq        },
  276. {    "STRING=?",                xstreql        },
  277. {    "STRING>=?",                xstrgeq        },
  278. {    "STRING>?",                xstrgtr        },
  279. {    "STRING-CI<?",                xstrilss    },
  280. {    "STRING-CI<=?",                xstrileq    },
  281. {    "STRING-CI=?",                xstrieql    },
  282. {    "STRING-CI>=?",                xstrigeq    },
  283. {    "STRING-CI>?",                xstrigtr    },
  284.  
  285.     /* character functions */
  286. {    "CHAR<?",                xchrlss        },
  287. {    "CHAR<=?",                xchrleq        },
  288. {    "CHAR=?",                xchreql        },
  289. {    "CHAR>=?",                xchrgeq        },
  290. {    "CHAR>?",                xchrgtr        },
  291. {    "CHAR-CI<?",                xchrilss    },
  292. {    "CHAR-CI<=?",                xchrileq    },
  293. {    "CHAR-CI=?",                xchrieql    },
  294. {    "CHAR-CI>=?",                xchrigeq    },
  295. {    "CHAR-CI>?",                xchrigtr    },
  296.  
  297.     /* I/O functions */
  298. {    "READ",                    xread        },
  299. {    "READ-CHAR",                xrdchar        },
  300. {    "READ-BYTE",                xrdbyte        },
  301. {    "READ-SHORT",                xrdshort    },
  302. {    "READ-LONG",                xrdlong        },
  303. {    "WRITE",                xwrite        },
  304. {    "WRITE-CHAR",                xwrchar        },
  305. {    "WRITE-BYTE",                xwrbyte        },
  306. {    "WRITE-SHORT",                xwrshort    },
  307. {    "WRITE-LONG",                xwrlong        },
  308. {    "DISPLAY",                xdisplay    },
  309. {    "PRINT",                xprint        },
  310. {    "NEWLINE",                xnewline    },
  311.  
  312.     /* print control functions */
  313. {    "PRINT-BREADTH",            xprbreadth    },
  314. {    "PRINT-DEPTH",                xprdepth    },
  315.  
  316.     /* file I/O functions */
  317. {    "OPEN-INPUT-FILE",            xopeni        },
  318. {    "OPEN-OUTPUT-FILE",            xopeno        },
  319. {    "OPEN-APPEND-FILE",            xopena        },
  320. {    "OPEN-UPDATE-FILE",            xopenu        },
  321. {    "CLOSE-PORT",                xclose        },
  322. {    "CLOSE-INPUT-PORT",            xclosei        },
  323. {    "CLOSE-OUTPUT-PORT",            xcloseo        },
  324. {    "GET-FILE-POSITION",            xgetfposition    },
  325. {    "SET-FILE-POSITION!",            xsetfposition    },
  326. {    "CURRENT-INPUT-PORT",            xcurinput    },
  327. {    "CURRENT-OUTPUT-PORT",            xcuroutput    },
  328.  
  329.     /* utility functions */
  330. {    "TRANSCRIPT-ON",            xtranson    },
  331. {    "TRANSCRIPT-OFF",            xtransoff    },
  332. {    "GETARG",                xgetarg        },
  333. {    "EXIT",                    xexit        },
  334. {    "COMPILE",                xcompile    },
  335. {    "DECOMPILE",                xdecompile    },
  336. {    "GC",                    xgc        },
  337. {    "SAVE",                    xsave        },
  338. {    "RESTORE",                xrestore    },
  339. {    "RESET",                xreset        },
  340. {    "ERROR",                xerror        },
  341.  
  342.     /* debugging functions */
  343. {    "TRACE-ON",                xtraceon    },
  344. {    "TRACE-OFF",                xtraceoff    },
  345.  
  346.     /* internal functions */
  347. {    "%CAR",                    xicar        },
  348. {    "%CDR",                    xicdr        },
  349. {    "%SET-CAR!",                xisetcar    },
  350. {    "%SET-CDR!",                xisetcdr    },
  351. {    "%VECTOR-LENGTH",            xivlength    },
  352. {    "%VECTOR-REF",                xivref        },
  353. {    "%VECTOR-SET!",                xivset        },
  354.  
  355. /* include machine specific table entries */
  356. #include "osptrs.h"
  357.  
  358. {0,0} /* end of table marker */
  359.  
  360. };
  361.  
  362. /* Notes:
  363.  
  364.    (1)    This version only supports integers and reals.
  365.  
  366. */
  367.  
  368. /* curinput - get the current input port */
  369. LVAL curinput()
  370. {
  371.     return (getvalue(s_stdin));
  372. }
  373.  
  374. /* curoutput - get the current output port */
  375. LVAL curoutput()
  376. {
  377.     return (getvalue(s_stdout));
  378. }
  379.  
  380. /* eq - internal 'eq?' function */
  381. int eq(arg1,arg2)
  382.   LVAL arg1,arg2;
  383. {
  384.     return (arg1 == arg2);
  385. }
  386.  
  387. /* eqv - internal 'eqv?' function */
  388. int eqv(arg1,arg2)
  389.   LVAL arg1,arg2;
  390. {
  391.     /* try the eq test first */
  392.     if (arg1 == arg2)
  393.     return (TRUE);
  394.  
  395.     /* compare fixnums, flonums and characters */
  396.     if (!null(arg1)) {
  397.     switch (ntype(arg1)) {
  398.     case FIXNUM:
  399.         return (fixp(arg2)
  400.              && getfixnum(arg1) == getfixnum(arg2));
  401.     case FLONUM:
  402.         return (floatp(arg2)
  403.              && getflonum(arg1) == getflonum(arg2));
  404.     case CHAR:
  405.         return (charp(arg2)
  406.              && getchcode(arg1) == getchcode(arg2));
  407.     }
  408.     }
  409.     return (FALSE);
  410. }
  411.  
  412. /* equal - internal 'equal?' function */
  413. int equal(arg1,arg2)
  414.   LVAL arg1,arg2;
  415. {
  416.     /* try the eq test first */
  417.     if (arg1 == arg2)
  418.     return (TRUE);
  419.  
  420.     /* compare fixnums, flonums, characters, strings, vectors and conses */
  421.     if (!null(arg1)) {
  422.     switch (ntype(arg1)) {
  423.     case FIXNUM:
  424.         return (fixp(arg2)
  425.              && getfixnum(arg1) == getfixnum(arg2));
  426.     case FLONUM:
  427.         return (floatp(arg2)
  428.              && getflonum(arg1) == getflonum(arg2));
  429.     case CHAR:
  430.         return (charp(arg2)
  431.              && getchcode(arg1) == getchcode(arg2));
  432.     case STRING:
  433.         return (stringp(arg2)
  434.              && strcmp(getstring(arg1),getstring(arg2)) == 0);
  435.     case VECTOR:
  436.         return (vectorp(arg2)
  437.              && vectorequal(arg1,arg2));
  438.     case CONS:
  439.         return (consp(arg2)
  440.              && equal(car(arg1),car(arg2))
  441.              && equal(cdr(arg1),cdr(arg2)));
  442.     }
  443.     }
  444.     return (FALSE);
  445. }
  446.  
  447. /* vectorequal - compare two vectors */
  448. int vectorequal(v1,v2)
  449.   LVAL v1,v2;
  450. {
  451.     int len,i;
  452.  
  453.     /* compare the vector lengths */
  454.     if ((len = getsize(v1)) != getsize(v2))
  455.     return (FALSE);
  456.  
  457.     /* compare the vector elements */
  458.     for (i = 0; i < len; ++i)
  459.     if (!equal(getelement(v1,i),getelement(v2,i)))
  460.         return (FALSE);
  461.     return (TRUE);
  462. }
  463.  
  464. /* xltoofew - too few arguments to this function */
  465. LVAL xltoofew()
  466. {
  467.     xlfail("too few arguments");
  468. }
  469.  
  470. /* xltoomany - too many arguments to this function */
  471. xltoomany()
  472. {
  473.     xlfail("too many arguments");
  474. }
  475.  
  476. /* xlbadtype - incorrect argument type */
  477. LVAL xlbadtype(val)
  478.   LVAL val;
  479. {
  480.     xlerror("incorrect type",val);
  481. }
  482.