gram.y 24 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976
  1. %{
  2. /* Copyright Nicholas B. Tufillaro, 1982-1994. All rights reserved.
  3. *
  4. * GNU enhancements Copyright (C) 1996, 1999, 2005, 2008, Free Software
  5. * Foundation, Inc.
  6. */
  7. /*
  8. * Grammar for ode:
  9. * Most things are self-explanatory.
  10. * When you're done with a lexptr-type object
  11. * you should free it with lfree. They are
  12. * used for passing constants around while parsing
  13. * (computing the value of) a cexpr. The macros
  14. * for evaluating operators and functions are the
  15. * most important thing to be familiar with before
  16. * toying with the semantics.
  17. */
  18. #include "sys-defines.h"
  19. #include "ode.h"
  20. #include "extern.h"
  21. /*
  22. * Value is true iff operands pass ONECON.
  23. */
  24. #define TWOCON(x,y) (ONECON(x) && ONECON(y))
  25. #define THREECON(x,y,z) (ONECON(x) && ONECON(y) && ONECON(z))
  26. /*
  27. * Value must be a (struct expr *). Returns true if its arg, when
  28. * evaluated, would put a constant on the stack.
  29. */
  30. #define ONECON(x) (x->ex_oper == O_CONST && x->ex_next == NULL)
  31. /*
  32. * Performs ordinary binary arithmetic, when there are two constants in an
  33. * expr (`op' is a C operator that includes an assignment, e.g., +=).
  34. */
  35. #define COMBINE(x,y,r,op) {x->ex_value op y->ex_value; efree(y); r = x;}
  36. /*
  37. * Generates stack code for a binary operation, as for a dyadic operator in
  38. * an expression. E.g., op = O_PLUS.
  39. */
  40. #define BINARY(x,y,r,op) {struct expr *ep=ealloc();\
  41. ep->ex_oper = op;\
  42. concat(y,ep);\
  43. concat(r=x,y);}
  44. /*
  45. * Generates stack code for a ternary operation, as for a triadic operator in
  46. * an expression. E.g., op = O_IBETA.
  47. */
  48. #define TERNARY(x,y,z,r,op) {struct expr *ep=ealloc();\
  49. ep->ex_oper = op;\
  50. concat(z,ep);\
  51. concat(y,z);\
  52. concat(r=x,y);}
  53. /*
  54. * Performs ordinary unary arithmetic, when there is a constant in an expr.
  55. * "-" seems to work as a monadic operator.
  56. */
  57. #define CONFUNC(x,r,f) {x->ex_value = f(x->ex_value); r = x;}
  58. /*
  59. * Generates stack code for a unary operation, as for a monadic operator in
  60. * an expression.
  61. */
  62. #define UNARY(oprnd,r,op) {struct expr *ep=ealloc();\
  63. ep->ex_oper = op;\
  64. concat(r=oprnd,ep);}
  65. /*
  66. * Performs binary arithmetic in a cexpr (`op' is a C operator that
  67. * includes an assignment, e.g. +=).
  68. */
  69. #define CEXOP(x,y,r,op) {x->lx_u.lxu_value op y->lx_u.lxu_value;\
  70. lfree(y);\
  71. r = x;}
  72. /*
  73. * Performs unary arithmetic in a cexpr.
  74. */
  75. #define CEXFUNC(x,r,f) {x->lx_u.lxu_value = f(x->lx_u.lxu_value); r=x;}
  76. /*
  77. * A hook for future upgrades in error reporting
  78. */
  79. static char *errmess = NULL;
  80. bool erritem;
  81. %}
  82. %union {
  83. struct lex *lexptr;
  84. struct expr *exprptr;
  85. struct prt *prtptr;
  86. int simple;
  87. }
  88. %token <lexptr> NUMBER IDENT SEP
  89. %token ABS SQRT EXP LOG LOG10
  90. %token SIN COS TAN ASIN ACOS ATAN
  91. %token SINH COSH TANH ASINH ACOSH ATANH
  92. %token FLOOR CEIL J0 J1 Y0 Y1
  93. %token LGAMMA GAMMA ERF ERFC INVERF NORM INVNORM
  94. %token IGAMMA IBETA
  95. %token EVERY FROM PRINT STEP EXAM
  96. %start program
  97. %type <simple> prttag
  98. %type <lexptr> cexpr
  99. %type <exprptr> expr
  100. %type <prtptr> prtitem
  101. %nonassoc '='
  102. %left '+' '-'
  103. %left '*' '/'
  104. %right '^'
  105. %right UMINUS
  106. %%
  107. program : stat
  108. | program stat
  109. ;
  110. stat : SEP
  111. { lfree($1); }
  112. | IDENT '=' expr SEP
  113. {
  114. struct sym *sp;
  115. sp = lookup($1->lx_u.lxu_name);
  116. sp->sy_value = eval($3);
  117. sp->sy_flags |= SF_INIT;
  118. lfree($1);
  119. efree($3);
  120. lfree($4);
  121. }
  122. | error SEP
  123. {
  124. if (errmess == NULL)
  125. errmess = "syntax error";
  126. fprintf (stderr, "%s:%s:%d: %s\n",
  127. progname, filename,
  128. ($2->lx_lino), errmess);
  129. errmess = NULL;
  130. lfree($2);
  131. yyerrok;
  132. yyclearin;
  133. }
  134. | IDENT '\'' '=' expr SEP
  135. {
  136. struct sym *sp;
  137. struct prt *pp, *qp;
  138. sp = lookup($1->lx_u.lxu_name);
  139. efree(sp->sy_expr);
  140. sp->sy_expr = $4;
  141. sp->sy_flags |= SF_ISEQN;
  142. if (!sawprint)
  143. {
  144. for (pp=pqueue; pp!=NULL; pp=pp->pr_link)
  145. if (pp->pr_sym == sp)
  146. goto found;
  147. pp = palloc();
  148. pp->pr_sym = sp;
  149. if (pqueue == NULL)
  150. pqueue = pp;
  151. else
  152. {
  153. for (qp=pqueue; qp->pr_link!=NULL; )
  154. qp = qp->pr_link;
  155. qp->pr_link = pp;
  156. }
  157. }
  158. found:
  159. lfree($1);
  160. lfree($5);
  161. }
  162. | PRINT prtlist optevery optfrom SEP
  163. {
  164. sawprint = true;
  165. prerr = erritem;
  166. erritem = false;
  167. lfree($5);
  168. }
  169. | STEP cexpr ',' cexpr SEP
  170. {
  171. lfree($5);
  172. tstart = $2->lx_u.lxu_value;
  173. lfree($2);
  174. tstop = $4->lx_u.lxu_value;
  175. lfree($4);
  176. if (!conflag)
  177. startstep();
  178. solve();
  179. sawstep = true;
  180. }
  181. | STEP cexpr ',' cexpr ',' cexpr SEP
  182. {
  183. double savstep;
  184. bool savconflag;
  185. lfree($7);
  186. tstart = $2->lx_u.lxu_value;
  187. lfree($2);
  188. tstop = $4->lx_u.lxu_value;
  189. lfree($4);
  190. savstep = tstep;
  191. tstep = $6->lx_u.lxu_value;
  192. lfree($6);
  193. savconflag = conflag;
  194. conflag = true;
  195. solve();
  196. tstep = savstep;
  197. conflag = savconflag;
  198. sawstep = true;
  199. }
  200. | EXAM IDENT SEP
  201. {
  202. struct sym *sp;
  203. lfree($3);
  204. sp = lookup($2->lx_u.lxu_name);
  205. lfree($2);
  206. printf ("\"%.*s\" is ",NAMMAX,sp->sy_name);
  207. switch (sp->sy_flags & SF_DEPV)
  208. {
  209. case SF_DEPV:
  210. case SF_ISEQN:
  211. printf ("a dynamic variable\n");
  212. break;
  213. case SF_INIT:
  214. printf ("an initialized constant\n");
  215. break;
  216. case 0:
  217. printf ("an uninitialized constant\n");
  218. break;
  219. default:
  220. panicn ("impossible (%d) in EXAM action",
  221. sp->sy_flags);
  222. }
  223. printf ("value:");
  224. prval (sp->sy_value);
  225. printf ("\nprime:");
  226. prval (sp->sy_prime);
  227. printf ("\nsserr:");
  228. prval (sp->sy_sserr);
  229. printf ("\naberr:");
  230. prval (sp->sy_aberr);
  231. printf ("\nacerr:");
  232. prval (sp->sy_acerr);
  233. putchar ('\n');
  234. prexq(sp->sy_expr);
  235. fflush(stdout);
  236. }
  237. ;
  238. prtlist : prtitem
  239. {
  240. pfree(pqueue);
  241. pqueue = $1;
  242. }
  243. | prtlist ',' prtitem
  244. {
  245. struct prt *pp;
  246. for (pp=pqueue; pp->pr_link!=NULL; pp=pp->pr_link)
  247. ;
  248. pp->pr_link = $3;
  249. }
  250. ;
  251. prtitem : IDENT prttag
  252. {
  253. struct prt *pp;
  254. pp = palloc();
  255. pp->pr_sym = lookup($1->lx_u.lxu_name);
  256. pp->pr_which = (ent_cell)($2);
  257. lfree($1);
  258. $$ = pp;
  259. }
  260. ;
  261. prttag : /* empty */
  262. { $$ = P_VALUE; }
  263. | '\''
  264. { $$ = P_PRIME; }
  265. | '~'
  266. {
  267. $$ = P_ACERR;
  268. erritem = true;
  269. }
  270. | '!'
  271. {
  272. $$ = P_ABERR;
  273. erritem = true;
  274. }
  275. | '?'
  276. {
  277. $$ = P_SSERR;
  278. erritem = true;
  279. }
  280. ;
  281. optevery : /* empty */
  282. { sawevery = false; }
  283. | EVERY cexpr
  284. {
  285. sawevery = true;
  286. tevery = IROUND($2->lx_u.lxu_value);
  287. lfree($2);
  288. }
  289. ;
  290. optfrom : /* empty */
  291. { sawfrom = false; }
  292. | FROM cexpr
  293. {
  294. sawfrom = true;
  295. tfrom = $2->lx_u.lxu_value;
  296. lfree($2);
  297. }
  298. ;
  299. cexpr : '(' cexpr ')'
  300. {
  301. $$ = $2;
  302. }
  303. | cexpr '+' cexpr
  304. {
  305. CEXOP($1,$3,$$,+=)
  306. }
  307. | cexpr '-' cexpr
  308. {
  309. CEXOP($1,$3,$$,-=)
  310. }
  311. | cexpr '*' cexpr
  312. {
  313. CEXOP($1,$3,$$,*=)
  314. }
  315. | cexpr '/' cexpr
  316. {
  317. CEXOP($1,$3,$$,/=)
  318. }
  319. | cexpr '^' cexpr
  320. {
  321. $1->lx_u.lxu_value =
  322. pow($1->lx_u.lxu_value,$3->lx_u.lxu_value);
  323. lfree($3);
  324. $$ = $1;
  325. }
  326. | SQRT '(' cexpr ')'
  327. {
  328. CEXFUNC($3,$$,sqrt)
  329. }
  330. | ABS '(' cexpr ')'
  331. {
  332. if ($3->lx_u.lxu_value < 0)
  333. $3->lx_u.lxu_value = -($3->lx_u.lxu_value);
  334. $$ = $3;
  335. }
  336. | EXP '(' cexpr ')'
  337. {
  338. CEXFUNC($3,$$,exp)
  339. }
  340. | LOG '(' cexpr ')'
  341. {
  342. CEXFUNC($3,$$,log)
  343. }
  344. | LOG10 '(' cexpr ')'
  345. {
  346. CEXFUNC($3,$$,log10)
  347. }
  348. | SIN '(' cexpr ')'
  349. {
  350. CEXFUNC($3,$$,sin)
  351. }
  352. | COS '(' cexpr ')'
  353. {
  354. CEXFUNC($3,$$,cos)
  355. }
  356. | TAN '(' cexpr ')'
  357. {
  358. CEXFUNC($3,$$,tan)
  359. }
  360. | ASINH '(' cexpr ')'
  361. {
  362. CEXFUNC($3,$$,asinh)
  363. }
  364. | ACOSH '(' cexpr ')'
  365. {
  366. CEXFUNC($3,$$,acosh)
  367. }
  368. | ATANH '(' cexpr ')'
  369. {
  370. CEXFUNC($3,$$,atanh)
  371. }
  372. | ASIN '(' cexpr ')'
  373. {
  374. CEXFUNC($3,$$,asin)
  375. }
  376. | ACOS '(' cexpr ')'
  377. {
  378. CEXFUNC($3,$$,acos)
  379. }
  380. | ATAN '(' cexpr ')'
  381. {
  382. CEXFUNC($3,$$,atan)
  383. }
  384. | SINH '(' cexpr ')'
  385. {
  386. CEXFUNC($3,$$,sinh)
  387. }
  388. | COSH '(' cexpr ')'
  389. {
  390. CEXFUNC($3,$$,cosh)
  391. }
  392. | TANH '(' cexpr ')'
  393. {
  394. CEXFUNC($3,$$,tanh)
  395. }
  396. | FLOOR '(' cexpr ')'
  397. {
  398. CEXFUNC($3,$$,floor)
  399. }
  400. | CEIL '(' cexpr ')'
  401. {
  402. CEXFUNC($3,$$,ceil)
  403. }
  404. | J0 '(' cexpr ')'
  405. {
  406. CEXFUNC($3,$$,j0)
  407. }
  408. | J1 '(' cexpr ')'
  409. {
  410. CEXFUNC($3,$$,j1)
  411. }
  412. | Y0 '(' cexpr ')'
  413. {
  414. CEXFUNC($3,$$,y0)
  415. }
  416. | Y1 '(' cexpr ')'
  417. {
  418. CEXFUNC($3,$$,y1)
  419. }
  420. | ERFC '(' cexpr ')'
  421. {
  422. CEXFUNC($3,$$,erfc)
  423. }
  424. | ERF '(' cexpr ')'
  425. {
  426. CEXFUNC($3,$$,erf)
  427. }
  428. | INVERF '(' cexpr ')'
  429. {
  430. CEXFUNC($3,$$,inverf)
  431. }
  432. | LGAMMA '(' cexpr ')'
  433. {
  434. CEXFUNC($3,$$,F_LGAMMA)
  435. }
  436. | GAMMA '(' cexpr ')'
  437. {
  438. CEXFUNC($3,$$,f_gamma)
  439. }
  440. | NORM '(' cexpr ')'
  441. {
  442. CEXFUNC($3,$$,norm)
  443. }
  444. | INVNORM '(' cexpr ')'
  445. {
  446. CEXFUNC($3,$$,invnorm)
  447. }
  448. | IGAMMA '(' cexpr ',' cexpr ')'
  449. {
  450. $3->lx_u.lxu_value =
  451. igamma($3->lx_u.lxu_value,$5->lx_u.lxu_value);
  452. lfree($5);
  453. $$ = $3;
  454. }
  455. | IBETA '(' cexpr ',' cexpr ',' cexpr ')'
  456. {
  457. $3->lx_u.lxu_value =
  458. ibeta($3->lx_u.lxu_value,$5->lx_u.lxu_value,$7->lx_u.lxu_value);
  459. lfree($5);
  460. lfree($7);
  461. $$ = $3;
  462. }
  463. | '-' cexpr %prec UMINUS
  464. {
  465. CEXFUNC($2,$$,-)
  466. }
  467. | NUMBER
  468. { $$ = $1; }
  469. ;
  470. expr : '(' expr ')'
  471. { $$ = $2; }
  472. | expr '+' expr
  473. {
  474. if (TWOCON($1,$3))
  475. COMBINE($1,$3,$$,+=)
  476. else
  477. BINARY($1,$3,$$,O_PLUS);
  478. }
  479. | expr '-' expr
  480. {
  481. if (TWOCON($1,$3))
  482. COMBINE($1,$3,$$,-=)
  483. else
  484. BINARY($1,$3,$$,O_MINUS);
  485. }
  486. | expr '*' expr
  487. {
  488. if (TWOCON($1,$3))
  489. COMBINE($1,$3,$$,*=)
  490. else
  491. BINARY($1,$3,$$,O_MULT);
  492. }
  493. | expr '/' expr
  494. {
  495. if (TWOCON($1,$3))
  496. COMBINE($1,$3,$$,/=)
  497. else if (ONECON($3) && $3->ex_value!=0.)
  498. {
  499. /* division by constant */
  500. $3->ex_value = 1./$3->ex_value;
  501. BINARY($1,$3,$$,O_MULT);
  502. }
  503. else
  504. BINARY($1,$3,$$,O_DIV);
  505. }
  506. | expr '^' expr
  507. {
  508. double f;
  509. bool invert = false;
  510. if (TWOCON($1,$3))
  511. {
  512. /* case const ^ const */
  513. $1->ex_value = pow($1->ex_value,$3->ex_value);
  514. efree($3);
  515. }
  516. else if (ONECON($1))
  517. {
  518. if ($1->ex_value == 1.)
  519. {
  520. /* case 1 ^ x */
  521. efree($3);
  522. $$ = $1;
  523. }
  524. else
  525. goto other;
  526. }
  527. else if (!ONECON($3))
  528. goto other;
  529. else
  530. {
  531. f = $3->ex_value;
  532. if (f < 0.)
  533. {
  534. /*
  535. * negative exponent means
  536. * to append an invert cmd
  537. */
  538. f = -f;
  539. invert = true;
  540. }
  541. if (f == 2.)
  542. {
  543. /* case x ^ 2 */
  544. $3->ex_oper = O_SQAR;
  545. concat($1,$3);
  546. $$ = $1;
  547. }
  548. else if (f == 3.)
  549. {
  550. /* case x ^ 3 */
  551. $3->ex_oper = O_CUBE;
  552. concat($1,$3);
  553. $$ = $1;
  554. }
  555. else if (f == 0.5)
  556. {
  557. /* case x ^ .5 */
  558. $3->ex_oper = O_SQRT;
  559. concat($1,$3);
  560. $$ = $1;
  561. }
  562. else if (f == 1.5)
  563. {
  564. /* case x ^ 1.5 */
  565. $3->ex_oper = O_CUBE;
  566. BINARY($1,$3,$$,O_SQRT);
  567. }
  568. else if (f == 1.)
  569. {
  570. /* case x ^ 1 */
  571. efree($3);
  572. $$ = $1;
  573. }
  574. else if (f == 0.)
  575. {
  576. /* case x ^ 0 */
  577. efree($1);
  578. $3->ex_value = 1.;
  579. $$ = $3;
  580. }
  581. else
  582. {
  583. other:
  584. /* default */
  585. invert = false;
  586. BINARY($1,$3,$$,O_POWER);
  587. }
  588. if (invert)
  589. UNARY($$,$$,O_INV)
  590. }
  591. }
  592. | SQRT '(' expr ')'
  593. {
  594. if (ONECON($3))
  595. CONFUNC($3,$$,sqrt)
  596. else
  597. UNARY($3,$$,O_SQRT);
  598. }
  599. | ABS '(' expr ')'
  600. {
  601. if (ONECON($3))
  602. {
  603. if ($3->ex_value < 0)
  604. $3->ex_value = -($3->ex_value);
  605. $$ = $3;
  606. }
  607. else
  608. UNARY($3,$$,O_ABS);
  609. }
  610. | EXP '(' expr ')'
  611. {
  612. if (ONECON($3))
  613. CONFUNC($3,$$,exp)
  614. else
  615. UNARY($3,$$,O_EXP);
  616. }
  617. | LOG '(' expr ')'
  618. {
  619. if (ONECON($3))
  620. CONFUNC($3,$$,log)
  621. else
  622. UNARY($3,$$,O_LOG);
  623. }
  624. | LOG10 '(' expr ')'
  625. {
  626. if (ONECON($3))
  627. CONFUNC($3,$$,log10)
  628. else
  629. UNARY($3,$$,O_LOG10);
  630. }
  631. | SIN '(' expr ')'
  632. {
  633. if (ONECON($3))
  634. CONFUNC($3,$$,sin)
  635. else
  636. UNARY($3,$$,O_SIN);
  637. }
  638. | COS '(' expr ')'
  639. {
  640. if (ONECON($3))
  641. CONFUNC($3,$$,cos)
  642. else
  643. UNARY($3,$$,O_COS);
  644. }
  645. | TAN '(' expr ')'
  646. {
  647. if (ONECON($3))
  648. CONFUNC($3,$$,tan)
  649. else
  650. UNARY($3,$$,O_TAN);
  651. }
  652. | ASINH '(' expr ')'
  653. {
  654. if (ONECON($3))
  655. CONFUNC($3,$$,asinh)
  656. else
  657. UNARY($3,$$,O_ASINH);
  658. }
  659. | ACOSH '(' expr ')'
  660. {
  661. if (ONECON($3))
  662. CONFUNC($3,$$,acosh)
  663. else
  664. UNARY($3,$$,O_ACOSH);
  665. }
  666. | ATANH '(' expr ')'
  667. {
  668. if (ONECON($3))
  669. CONFUNC($3,$$,atanh)
  670. else
  671. UNARY($3,$$,O_ATANH);
  672. }
  673. | ASIN '(' expr ')'
  674. {
  675. if (ONECON($3))
  676. CONFUNC($3,$$,asin)
  677. else
  678. UNARY($3,$$,O_ASIN);
  679. }
  680. | ACOS '(' expr ')'
  681. {
  682. if (ONECON($3))
  683. CONFUNC($3,$$,acos)
  684. else
  685. UNARY($3,$$,O_ACOS);
  686. }
  687. | ATAN '(' expr ')'
  688. {
  689. if (ONECON($3))
  690. CONFUNC($3,$$,atan)
  691. else
  692. UNARY($3,$$,O_ATAN);
  693. }
  694. | SINH '(' expr ')'
  695. {
  696. if (ONECON($3))
  697. CONFUNC($3,$$,sinh)
  698. else
  699. UNARY($3,$$,O_SINH);
  700. }
  701. | COSH '(' expr ')'
  702. {
  703. if (ONECON($3))
  704. CONFUNC($3,$$,cosh)
  705. else
  706. UNARY($3,$$,O_COSH);
  707. }
  708. | TANH '(' expr ')'
  709. {
  710. if (ONECON($3))
  711. CONFUNC($3,$$,tanh)
  712. else
  713. UNARY($3,$$,O_TANH);
  714. }
  715. | FLOOR '(' expr ')'
  716. {
  717. if (ONECON($3))
  718. CONFUNC($3,$$,floor)
  719. else
  720. UNARY($3,$$,O_FLOOR);
  721. }
  722. | CEIL '(' expr ')'
  723. {
  724. if (ONECON($3))
  725. CONFUNC($3,$$,ceil)
  726. else
  727. UNARY($3,$$,O_CEIL);
  728. }
  729. | J0 '(' expr ')'
  730. {
  731. if (ONECON($3))
  732. CONFUNC($3,$$,j0)
  733. else
  734. UNARY($3,$$,O_J0);
  735. }
  736. | J1 '(' expr ')'
  737. {
  738. if (ONECON($3))
  739. CONFUNC($3,$$,j1)
  740. else
  741. UNARY($3,$$,O_J1);
  742. }
  743. | Y0 '(' expr ')'
  744. {
  745. if (ONECON($3))
  746. CONFUNC($3,$$,y0)
  747. else
  748. UNARY($3,$$,O_Y0);
  749. }
  750. | Y1 '(' expr ')'
  751. {
  752. if (ONECON($3))
  753. CONFUNC($3,$$,y1)
  754. else
  755. UNARY($3,$$,O_Y1);
  756. }
  757. | LGAMMA '(' expr ')'
  758. {
  759. if (ONECON($3))
  760. CONFUNC($3,$$,F_LGAMMA)
  761. else
  762. UNARY($3,$$,O_LGAMMA);
  763. }
  764. | GAMMA '(' expr ')'
  765. {
  766. if (ONECON($3))
  767. CONFUNC($3,$$,f_gamma)
  768. else
  769. UNARY($3,$$,O_GAMMA);
  770. }
  771. | ERFC '(' expr ')'
  772. {
  773. if (ONECON($3))
  774. CONFUNC($3,$$,erfc)
  775. else
  776. UNARY($3,$$,O_ERFC);
  777. }
  778. | ERF '(' expr ')'
  779. {
  780. if (ONECON($3))
  781. CONFUNC($3,$$,erf)
  782. else
  783. UNARY($3,$$,O_ERF);
  784. }
  785. | INVERF '(' expr ')'
  786. {
  787. if (ONECON($3))
  788. CONFUNC($3,$$,inverf)
  789. else
  790. UNARY($3,$$,O_INVERF);
  791. }
  792. | NORM '(' expr ')'
  793. {
  794. if (ONECON($3))
  795. CONFUNC($3,$$,norm)
  796. else
  797. UNARY($3,$$,O_NORM);
  798. }
  799. | INVNORM '(' expr ')'
  800. {
  801. if (ONECON($3))
  802. CONFUNC($3,$$,invnorm)
  803. else
  804. UNARY($3,$$,O_INVNORM);
  805. }
  806. | IGAMMA '(' expr ',' expr ')'
  807. {
  808. if (TWOCON($3,$5))
  809. {
  810. $3->ex_value =
  811. igamma($3->ex_value,$5->ex_value);
  812. efree($5);
  813. $$ = $3;
  814. }
  815. else
  816. BINARY($3,$5,$$,O_IGAMMA);
  817. }
  818. | IBETA '(' expr ',' expr ',' expr ')'
  819. {
  820. if (THREECON($3,$5,$7))
  821. {
  822. $3->ex_value =
  823. ibeta($3->ex_value,$5->ex_value,$7->ex_value);
  824. efree($5);
  825. efree($7);
  826. $$ = $3;
  827. }
  828. else
  829. TERNARY($3,$5,$7,$$,O_IBETA);
  830. }
  831. | '-' expr %prec UMINUS
  832. {
  833. if (ONECON($2))
  834. CONFUNC($2,$$,-)
  835. else
  836. UNARY($2,$$,O_NEG);
  837. }
  838. | NUMBER
  839. {
  840. $$ = ealloc();
  841. $$->ex_oper = O_CONST;
  842. $$->ex_value = $1->lx_u.lxu_value;
  843. lfree($1);
  844. }
  845. | IDENT
  846. {
  847. $$ = ealloc();
  848. $$->ex_oper = O_IDENT;
  849. $$->ex_sym = lookup($1->lx_u.lxu_name);
  850. lfree($1);
  851. }
  852. ;
  853. %%
  854. int
  855. yyerror (const char *s)
  856. {
  857. return 0;
  858. }
  859. /*
  860. * tack two queues of stack code together
  861. * e1 is connected on the tail of e0
  862. * There is no good way to test for circular
  863. * lists, hence the silly count.
  864. */
  865. void
  866. concat (struct expr *e0, struct expr *e1)
  867. {
  868. int count;
  869. if (e0 == NULL || e1 == NULL)
  870. panic ("NULL expression queue");
  871. for (count = 0; e0->ex_next != NULL; e0 = e0->ex_next)
  872. if (++count > 10000)
  873. panic ("circular expression queue");
  874. e0->ex_next = e1;
  875. }
  876. /*
  877. * print an expression queue
  878. * called when EXAMINE is invoked on a variable (see above)
  879. */
  880. void
  881. prexq (const struct expr *ep)
  882. {
  883. const char *s;
  884. printf (" code:");
  885. if (ep == NULL)
  886. putchar ('\n');
  887. for (; ep != NULL; ep = ep->ex_next)
  888. {
  889. switch (ep->ex_oper)
  890. {
  891. case O_PLUS: s = "add"; break;
  892. case O_MINUS: s = "subtract"; break;
  893. case O_MULT: s = "multiply"; break;
  894. case O_DIV: s = "divide"; break;
  895. case O_POWER: s = "power"; break;
  896. case O_SQRT: s = "sqrt"; break;
  897. case O_EXP: s = "exp"; break;
  898. case O_LOG: s = "log"; break;
  899. case O_LOG10: s = "log10"; break;
  900. case O_SIN: s = "sin"; break;
  901. case O_COS: s = "cos"; break;
  902. case O_TAN: s = "cos"; break;
  903. case O_ASIN: s = "sin"; break;
  904. case O_ACOS: s = "cos"; break;
  905. case O_ATAN: s = "cos"; break;
  906. case O_NEG: s = "negate"; break;
  907. case O_ABS: s = "abs"; break;
  908. case O_SINH: s = "sinh"; break;
  909. case O_COSH: s = "cosh"; break;
  910. case O_TANH: s = "tanh"; break;
  911. case O_ASINH: s = "asinh"; break;
  912. case O_ACOSH: s = "acosh"; break;
  913. case O_ATANH: s = "atanh"; break;
  914. case O_SQAR: s = "square"; break;
  915. case O_CUBE: s = "cube"; break;
  916. case O_INV: s = "invert"; break;
  917. case O_FLOOR: s = "floor"; break;
  918. case O_CEIL: s = "ceil"; break;
  919. case O_J0: s = "besj0"; break;
  920. case O_J1: s = "besj1"; break;
  921. case O_Y0: s = "besy0"; break;
  922. case O_Y1: s = "besy1"; break;
  923. case O_ERF: s = "erf"; break;
  924. case O_ERFC: s = "erfc"; break;
  925. case O_INVERF: s = "inverf"; break;
  926. case O_LGAMMA: s = "lgamma"; break;
  927. case O_GAMMA: s = "gamma"; break;
  928. case O_NORM: s = "norm"; break;
  929. case O_INVNORM: s = "invnorm"; break;
  930. case O_IGAMMA: s = "igamma"; break;
  931. case O_IBETA: s = "ibeta"; break;
  932. case O_CONST:
  933. printf ("\tpush ");
  934. prval (ep->ex_value);
  935. putchar ('\n');
  936. s = NULL;
  937. break;
  938. case O_IDENT:
  939. printf ("\tpush \"%.*s\"\n",
  940. NAMMAX, ep->ex_sym->sy_name);
  941. s = NULL;
  942. break;
  943. default: s = "unknown!";
  944. }
  945. if (s != NULL)
  946. printf ("\t%s\n",s);
  947. }
  948. }