diff options
Diffstat (limited to 'noao/digiphot/photcal/parser')
25 files changed, 8522 insertions, 0 deletions
diff --git a/noao/digiphot/photcal/parser/README b/noao/digiphot/photcal/parser/README new file mode 100644 index 00000000..511483ea --- /dev/null +++ b/noao/digiphot/photcal/parser/README @@ -0,0 +1,2 @@ +This subdirectory contains the parser code and the main routine for the +CHKCONFIG task. diff --git a/noao/digiphot/photcal/parser/TODO b/noao/digiphot/photcal/parser/TODO new file mode 100644 index 00000000..33227eb0 --- /dev/null +++ b/noao/digiphot/photcal/parser/TODO @@ -0,0 +1,4 @@ +1. Generalize the pr_eval procedures to any number of recursions, with a limit + to avoid infinite loops. + +2. Allow any number of plot equations. diff --git a/noao/digiphot/photcal/parser/lexer.com b/noao/digiphot/photcal/parser/lexer.com new file mode 100644 index 00000000..76255b55 --- /dev/null +++ b/noao/digiphot/photcal/parser/lexer.com @@ -0,0 +1,13 @@ +# Lexer common. This is necessary since the parser, generated by xyacc, +# does not allow any access to the lexer to initialize it, or to get +# variable values. + +# Variables to initialize lexer +int nlines # line counter +int pos # character position in line +char line[SZ_LINE] # last line from file + +# Variables returned by lexer +char id[SZ_LINE] # last identifier from lexer + +common /lexcom/ nlines, pos, line, id diff --git a/noao/digiphot/photcal/parser/mkpkg b/noao/digiphot/photcal/parser/mkpkg new file mode 100644 index 00000000..0580f0e0 --- /dev/null +++ b/noao/digiphot/photcal/parser/mkpkg @@ -0,0 +1,43 @@ +# The MKPKG file for the PARSER subdirectory. + +$checkout libpkg.a ".." +$update libpkg.a +$checkin libpkg.a ".." +$exit + +libpkg.a: + $ifnewer (preval.gx, preval.x) + $generic -k -o preval.x preval.gx + $endif + + $ifnewer (parser.y, parser.x) + $ifeq (HOSTID, unix) + $echo "parser.x is out of date; rebuilding with XYACC:" + !xyacc -d parser.y + $move ytab.x parser.x + $move ytab.h ../lib/prtoken.h + $else + $echo "parser.x is out of date; rebuild with XYACC" + $endif + $endif + + parser.x "../lib/lexer.h" "../lib/parser.h" "../lib/prdefs.h"\ + <ctype.h> <lexnum.h> + pralloc.x "../lib/parser.h" "../lib/prstruct.h" "parser.com" + prcat.x + prcode.x "../lib/lexer.h" "../lib/parser.h" "../lib/preval.h"\ + "../lib/prtoken.h" "prcode.com" + prconv.x "../lib/parser.h" + prerror.x "../lib/parser.h" "../lib/prdefs.h" "lexer.com" + preval.x "../lib/parser.h" "../lib/preval.h" + prexit.x "../lib/parser.h" "../lib/prdefs.h" <mach.h> + prget.x "../lib/parser.h" "../lib/prstruct.h" "parser.com" + prlexer.x "../lib/lexer.h" "../lib/prtoken.h" "lexer.com"\ + <ctype.h> <lexnum.h> + prmap.x "../lib/parser.h" "../lib/prdefs.h" + prparse.x "../lib/parser.h" "../lib/prdefs.h" "lexer.com" + prput.x "../lib/parser.h" "../lib/prstruct.h" "parser.com" + prtable.x "../lib/parser.h" "../lib/prdefs.h" <mach.h> + prvtran.x + t_chkconfig.x "../lib/parser.h" + ; diff --git a/noao/digiphot/photcal/parser/parser.com b/noao/digiphot/photcal/parser/parser.com new file mode 100644 index 00000000..db47e0d8 --- /dev/null +++ b/noao/digiphot/photcal/parser/parser.com @@ -0,0 +1,49 @@ +# Parser common + +# Symbol tables +pointer symtable # parser symbol table + +# Sequential tables +pointer obstable # observational variable table +pointer cattable # catalog variable table +pointer partable # fitting and constant parameter table +pointer settable # set equation table +pointer exttable # extinction equation table +pointer trntable # transformation equation table +pointer trcattable # temporary reference eq. catalog var. table +pointer trobstable # temporary ref. eq. observational var. table +pointer tfcattable # temporary fit eq. catalog var. table +pointer tfobstable # temporary fit eq. observational var. table +pointer tpartable # temporary parameter table + +# Counters +int nerrors # number of semantic errors +int nwarnings # number of warnings +int nobsvars # number of observational input variables +int ncatvars # number of catalog input variables +int nfitpars # number of fitting parameters +int ntotpars # number of fitting and constant parameters +int nseteqs # number of set equations +int nexteqs # number of extinction equations +int ntrneqs # number of transformation equations + +# Column limits +int mincol # minumum input column +int minobscol # minumum observational column +int maxobscol # maximum observational column +int mincatcol # minumum catalog column +int maxcatcol # maximum catalog column + +# Flags +int flageqsect # equation section +int flagerrors # print error messages (YES/NO) + +common /parcom/ symtable, + obstable, cattable, partable, + settable, exttable, trntable, + trcattable, trobstable, tfcattable, tfobstable, tpartable, + nerrors, nwarnings, + nobsvars, ncatvars, nfitpars, ntotpars, + nseteqs, nexteqs, ntrneqs, + mincol, minobscol, maxobscol, mincatcol, maxcatcol, + flageqsect, flagerrors diff --git a/noao/digiphot/photcal/parser/parser.x b/noao/digiphot/photcal/parser/parser.x new file mode 100644 index 00000000..47d8ce5b --- /dev/null +++ b/noao/digiphot/photcal/parser/parser.x @@ -0,0 +1,849 @@ + +# line 2 "parser.y" + +include <ctype.h> +include <lexnum.h> +include "../lib/lexer.h" +include "../lib/parser.h" +include "../lib/prdefs.h" + +# Parser stack and structure lengths +define YYMAXDEPTH 128 +define YYOPLEN LEN_LEX + +# Redefine the name of the parser +define yyparse parse + +define OBSSECT 257 +define CATSECT 258 +define EXTSECT 259 +define TRNSECT 260 +define FITID 261 +define CONSTID 262 +define DELTAID 263 +define ERRORID 264 +define WEIGHTID 265 +define MINID 266 +define MAXID 267 +define DERIVID 268 +define PLOTID 269 +define SETID 270 +define F_ABS 271 +define F_ACOS 272 +define F_ASIN 273 +define F_ATAN 274 +define F_COS 275 +define F_EXP 276 +define F_LOG 277 +define F_LOG10 278 +define F_SIN 279 +define F_SQRT 280 +define F_TAN 281 +define IDENTIFIER 282 +define INUMBER 283 +define RNUMBER 284 +define PLUS 285 +define MINUS 286 +define STAR 287 +define SLASH 288 +define EXPON 289 +define COLON 290 +define SEMICOLON 291 +define COMMA 292 +define EQUAL 293 +define LPAR 294 +define RPAR 295 +define EOFILE 296 +define UPLUS 297 +define UMINUS 298 +define yyclearin yychar = -1 +define yyerrok yyerrflag = 0 +define YYMOVE call amovi (Memi[$1], Memi[$2], YYOPLEN) +define YYERRCODE 256 + +define YYNPROD 104 +define YYLAST 337 +# line 1 "/iraf/iraf/lib/yaccpar.x" +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# Parser for yacc output, translated to the IRAF SPP language. The contents +# of this file form the bulk of the source of the parser produced by Yacc. +# Yacc recognizes several macros in the yaccpar input source and replaces +# them as follows: +# A user suppled "global" definitions and declarations +# B parser tables +# C user supplied actions (reductions) +# The remainder of the yaccpar code is not changed. + +define yystack_ 10 # statement labels for gotos +define yynewstate_ 20 +define yydefault_ 30 +define yyerrlab_ 40 +define yyabort_ 50 + +define YYFLAG (-1000) # defs used in user actions +define YYERROR goto yyerrlab_ +define YYACCEPT return (OK) +define YYABORT return (ERR) + + +# YYPARSE -- Parse the input stream, returning OK if the source is +# syntactically acceptable (i.e., if compilation is successful), +# otherwise ERR. The parameters YYMAXDEPTH and YYOPLEN must be +# supplied by the caller in the %{ ... %} section of the Yacc source. +# The token value stack is a dynamically allocated array of operand +# structures, with the length and makeup of the operand structure being +# application dependent. + +int procedure yyparse (fd, yydebug, yylex) + +int fd # stream to be parsed +bool yydebug # print debugging information? +int yylex() # user-supplied lexical input function +extern yylex() + +short yys[YYMAXDEPTH] # parser stack -- stacks tokens +pointer yyv # pointer to token value stack +pointer yyval # value returned by action +pointer yylval # value of token +int yyps # token stack pointer +pointer yypv # value stack pointer +int yychar # current input token number +int yyerrflag # error recovery flag +int yynerrs # number of errors + +short yyj, yym # internal variables +pointer yysp, yypvt +short yystate, yyn +int yyxi, i +errchk salloc, yylex + +short yyexca[6] +data (yyexca(i),i= 1, 6) / -1, 1, 0, -1, -2, 0/ +short yyact[337] +data (yyact(i),i= 1, 8) / 131, 132, 133, 134, 135, 136, 137, 138/ +data (yyact(i),i= 9, 16) / 139, 140, 141, 130, 142, 143, 125, 126/ +data (yyact(i),i= 17, 24) / 152, 153, 154, 155, 156, 40, 161, 128/ +data (yyact(i),i= 25, 32) / 183, 112, 180, 152, 153, 154, 155, 156/ +data (yyact(i),i= 33, 40) / 60, 61, 62, 58, 59, 175, 111, 52/ +data (yyact(i),i= 41, 48) / 53, 57, 108, 86, 85, 84, 83, 159/ +data (yyact(i),i= 49, 56) / 73, 72, 70, 69, 39, 51, 38, 34/ +data (yyact(i),i= 57, 64) / 33, 24, 25, 18, 19, 198, 42, 196/ +data (yyact(i),i= 65, 72) / 35, 176, 152, 153, 154, 155, 156, 148/ +data (yyact(i),i= 73, 80) / 147, 145, 107, 23, 123, 17, 99, 97/ +data (yyact(i),i= 81, 88) / 95, 91, 98, 96, 21, 29, 15, 68/ +data (yyact(i),i= 89, 96) / 94, 154, 155, 156, 28, 60, 61, 62/ +data (yyact(i),i= 97,104) / 58, 59, 156, 32, 52, 53, 57, 116/ +data (yyact(i),i=105,112) / 117, 142, 143, 24, 25, 18, 19, 144/ +data (yyact(i),i=113,120) / 82, 79, 51, 76, 93, 92, 90, 89/ +data (yyact(i),i=121,128) / 71, 66, 65, 64, 63, 23, 194, 17/ +data (yyact(i),i=129,136) / 190, 27, 12, 3, 129, 4, 7, 106/ +data (yyact(i),i=137,144) / 5, 104, 8, 193, 10, 124, 13, 189/ +data (yyact(i),i=145,152) / 184, 114, 74, 80, 41, 20, 14, 115/ +data (yyact(i),i=153,160) / 77, 31, 127, 105, 109, 81, 78, 75/ +data (yyact(i),i=161,168) / 56, 55, 54, 166, 164, 162, 181, 30/ +data (yyact(i),i=169,176) / 150, 87, 50, 49, 36, 48, 47, 46/ +data (yyact(i),i=177,184) / 45, 37, 44, 43, 22, 9, 16, 26/ +data (yyact(i),i=185,192) / 11, 6, 2, 1, 0, 0, 0, 0/ +data (yyact(i),i=193,200) / 67, 0, 0, 0, 0, 0, 0, 0/ +data (yyact(i),i=201,208) / 0, 0, 0, 0, 88, 0, 0, 0/ +data (yyact(i),i=209,216) / 0, 0, 0, 0, 0, 0, 0, 0/ +data (yyact(i),i=217,224) / 0, 0, 0, 0, 0, 0, 0, 0/ +data (yyact(i),i=225,232) / 0, 0, 0, 110, 0, 0, 0, 118/ +data (yyact(i),i=233,240) / 0, 118, 0, 118, 0, 100, 101, 102/ +data (yyact(i),i=241,248) / 103, 113, 0, 120, 0, 122, 121, 146/ +data (yyact(i),i=249,256) / 149, 119, 0, 0, 0, 0, 0, 0/ +data (yyact(i),i=257,264) / 0, 0, 0, 151, 0, 0, 0, 0/ +data (yyact(i),i=265,272) / 0, 0, 0, 157, 158, 0, 160, 0/ +data (yyact(i),i=273,280) / 0, 0, 0, 0, 0, 0, 0, 0/ +data (yyact(i),i=281,288) / 0, 163, 0, 165, 167, 0, 0, 0/ +data (yyact(i),i=289,296) / 168, 0, 0, 0, 0, 0, 169, 170/ +data (yyact(i),i=297,304) / 171, 172, 173, 0, 177, 174, 178, 0/ +data (yyact(i),i=305,312) / 179, 0, 0, 0, 0, 0, 0, 0/ +data (yyact(i),i=313,320) / 182, 0, 185, 185, 0, 0, 0, 187/ +data (yyact(i),i=321,328) / 191, 188, 191, 0, 186, 195, 0, 0/ +data (yyact(i),i=329,336) / 195, 0, 192, 0, 197, 0, 199, 0/ +data (yyact(i),i=337,337) / 200/ +short yypact[201] +data (yypact(i),i= 1, 8) /-125,-1000,-123,-1000,-1000,-1000,-129,-205/ +data (yypact(i),i= 9, 16) /-1000,-207,-1000,-131,-199,-1000,-206,-1000/ +data (yypact(i),i= 17, 24) /-155,-184,-238,-239,-227,-1000,-157,-184/ +data (yypact(i),i= 25, 32) /-240,-242,-275,-229,-1000,-1000,-1000,-1000/ +data (yypact(i),i= 33, 40) /-1000,-158,-159,-1000,-1000,-1000,-160,-161/ +data (yypact(i),i= 41, 48) /-1000,-1000,-1000,-168,-1000,-1000,-1000,-1000/ +data (yypact(i),i= 49, 56) /-1000,-1000,-1000,-203,-243,-244,-1000,-1000/ +data (yypact(i),i= 57, 64) /-1000,-162,-245,-246,-167,-169,-170,-249/ +data (yypact(i),i= 65, 72) /-250,-251,-252,-1000,-1000,-163,-164,-212/ +data (yypact(i),i= 73, 80) /-165,-166,-1000,-204,-213,-1000,-209,-214/ +data (yypact(i),i= 81, 88) /-1000,-210,-215,-184,-184,-184,-184,-1000/ +data (yypact(i),i= 89, 96) /-1000,-218,-253,-1000,-257,-270,-167,-182/ +data (yypact(i),i= 97,104) /-169,-182,-170,-182,-1000,-1000,-1000,-1000/ +data (yypact(i),i=105,112) /-217,-271,-1000,-171,-220,-1000,-1000,-221/ +data (yypact(i),i=113,120) /-222,-1000,-1000,-178,-1000,-1000,-1000,-1000/ +data (yypact(i),i=121,128) /-1000,-1000,-1000,-1000,-219,-271,-271,-247/ +data (yypact(i),i=129,136) /-271,-1000,-1000,-1000,-1000,-1000,-1000,-1000/ +data (yypact(i),i=137,144) /-1000,-1000,-1000,-1000,-1000,-1000,-1000,-1000/ +data (yypact(i),i=145,152) /-273,-1000,-1000,-1000,-1000,-1000,-1000,-1000/ +data (yypact(i),i=153,160) /-271,-271,-271,-271,-271,-1000,-1000,-271/ +data (yypact(i),i=161,168) /-258,-228,-1000,-1000,-1000,-1000,-1000,-1000/ +data (yypact(i),i=169,176) /-1000,-198,-198,-191,-191,-1000,-269,-1000/ +data (yypact(i),i=177,184) /-1000,-268,-1000,-1000,-1000,-1000,-1000,-1000/ +data (yypact(i),i=185,192) /-138,-1000,-138,-1000,-1000,-141,-230,-1000/ +data (yypact(i),i=193,200) /-141,-1000,-232,-1000,-1000,-1000,-1000,-1000/ +data (yypact(i),i=201,201) /-1000/ +short yypgo[48] +data (yypgo(i),i= 1, 8) / 0, 187, 186, 185, 184, 183, 150, 135/ +data (yypgo(i),i= 9, 16) / 182, 153, 181, 149, 180, 148, 179, 178/ +data (yypgo(i),i= 17, 24) / 176, 175, 174, 173, 171, 170, 169, 137/ +data (yypgo(i),i= 25, 32) / 168, 166, 165, 164, 144, 143, 139, 163/ +data (yypgo(i),i= 33, 40) / 162, 161, 160, 146, 159, 145, 152, 158/ +data (yypgo(i),i= 41, 48) / 147, 157, 156, 155, 141, 154, 132, 151/ +short yyr1[104] +data (yyr1(i),i= 1, 8) / 0, 1, 1, 3, 3, 3, 3, 3/ +data (yyr1(i),i= 9, 16) / 6, 6, 8, 8, 8, 2, 2, 2/ +data (yyr1(i),i= 17, 24) / 2, 2, 10, 11, 11, 12, 12, 12/ +data (yyr1(i),i= 25, 32) / 9, 4, 4, 4, 5, 5, 5, 13/ +data (yyr1(i),i= 33, 40) / 13, 14, 14, 14, 14, 14, 14, 14/ +data (yyr1(i),i= 41, 48) / 15, 22, 24, 16, 25, 17, 26, 20/ +data (yyr1(i),i= 49, 56) / 27, 21, 31, 28, 29, 29, 30, 30/ +data (yyr1(i),i= 57, 64) / 18, 18, 18, 32, 35, 35, 36, 33/ +data (yyr1(i),i= 65, 72) / 38, 38, 39, 34, 40, 40, 41, 19/ +data (yyr1(i),i= 73, 80) / 42, 23, 43, 44, 44, 44, 44, 44/ +data (yyr1(i),i= 81, 88) / 44, 44, 44, 44, 44, 44, 45, 45/ +data (yyr1(i),i= 89, 96) / 45, 45, 45, 45, 45, 45, 45, 45/ +data (yyr1(i),i= 97,104) / 45, 37, 47, 47, 47, 46, 46, 7/ +short yyr2[104] +data (yyr2(i),i= 1, 8) / 0, 5, 1, 2, 3, 2, 1, 1/ +data (yyr2(i),i= 9, 16) / 1, 2, 2, 5, 5, 3, 4, 3/ +data (yyr2(i),i= 17, 24) / 2, 1, 1, 1, 2, 2, 5, 5/ +data (yyr2(i),i= 25, 32) / 1, 2, 1, 1, 2, 2, 1, 1/ +data (yyr2(i),i= 33, 40) / 2, 1, 1, 1, 1, 1, 1, 1/ +data (yyr2(i),i= 41, 48) / 7, 1, 1, 9, 1, 9, 1, 10/ +data (yyr2(i),i= 49, 56) / 1, 10, 1, 1, 3, 1, 3, 1/ +data (yyr2(i),i= 57, 64) / 1, 1, 1, 2, 1, 3, 3, 2/ +data (yyr2(i),i= 65, 72) / 1, 3, 3, 2, 1, 3, 3, 5/ +data (yyr2(i),i= 73, 80) / 1, 2, 1, 3, 3, 3, 3, 3/ +data (yyr2(i),i= 81, 88) / 2, 2, 4, 3, 1, 1, 1, 1/ +data (yyr2(i),i= 89, 96) / 1, 1, 1, 1, 1, 1, 1, 1/ +data (yyr2(i),i= 97,104) / 1, 2, 1, 1, 1, 1, 1, 0/ +short yychk[201] +data (yychk(i),i= 1, 8) /-1000, -1, -2, 256, 258, -7, -3, 257/ +data (yychk(i),i= 9, 16) / -7, -10, -7, -4, 259, -7, -6, 291/ +data (yychk(i),i= 17, 24) / -8, 282, 264, 265, -11, 291, -12, 282/ +data (yychk(i),i= 25, 32) / 264, 265, -5, 260, 291, 291, -6, -9/ +data (yychk(i),i= 33, 40) / 283, 294, 294, 291, -11, -9, 294, 294/ +data (yychk(i),i= 41, 48) / 296, -13, 291, -14, -15, -16, -17, -18/ +data (yychk(i),i= 49, 56) / -19, -20, -21, 282, 268, 269, -32, -33/ +data (yychk(i),i= 57, 64) / -34, 270, 264, 265, 261, 262, 263, 282/ +data (yychk(i),i= 65, 72) / 282, 282, 282, -13, 290, 294, 294, 282/ +data (yychk(i),i= 73, 80) / 294, 294, -35, -36, 282, -38, -39, 282/ +data (yychk(i),i= 81, 88) / -40, -41, 282, 295, 295, 295, 295, -22/ +data (yychk(i),i= 89, 96) / -7, 282, 282, 293, 282, 282, 292, 293/ +data (yychk(i),i= 97,104) / 292, 293, 292, 293, -9, -9, -9, -9/ +data (yychk(i),i=105,112) / -23, -43, -7, 292, 295, -42, -7, 295/ +data (yychk(i),i=113,120) / 295, -35, -37, -47, 285, 286, -7, -38/ +data (yychk(i),i=121,128) / -37, -40, -37, 293, -44, 285, 286, -45/ +data (yychk(i),i=129,136) / 294, -46, 282, 271, 272, 273, 274, 275/ +data (yychk(i),i=137,144) / 276, 277, 278, 279, 280, 281, 283, 284/ +data (yychk(i),i=145,152) / 282, 293, -23, 293, 293, -46, -24, -7/ +data (yychk(i),i=153,160) / 285, 286, 287, 288, 289, -44, -44, 294/ +data (yychk(i),i=161,168) / -44, 295, -26, -7, -27, -7, -31, -7/ +data (yychk(i),i=169,176) / -23, -44, -44, -44, -44, -44, -44, 295/ +data (yychk(i),i=177,184) / 293, -23, -23, -23, 295, -25, -7, 292/ +data (yychk(i),i=185,192) / -28, -7, -28, -23, -23, -29, 266, -7/ +data (yychk(i),i=193,200) / -29, -30, 267, -7, 293, -30, 293, -23/ +data (yychk(i),i=201,201) / -23/ +short yydef[201] +data (yydef(i),i= 1, 8) / 103, -2, 103, 2, 103, 17, 103, 6/ +data (yydef(i),i= 9, 16) / 7, 16, 18, 0, 26, 27, 3, 5/ +data (yydef(i),i= 17, 24) / 8, 0, 0, 0, 13, 15, 19, 0/ +data (yydef(i),i= 25, 32) / 0, 0, 0, 30, 25, 4, 9, 10/ +data (yydef(i),i= 33, 40) / 24, 0, 0, 14, 20, 21, 0, 0/ +data (yydef(i),i= 41, 48) / 1, 28, 29, 31, 33, 34, 35, 36/ +data (yydef(i),i= 49, 56) / 37, 38, 39, 0, 0, 0, 56, 57/ +data (yydef(i),i= 57, 64) / 58, 0, 0, 0, 0, 0, 0, 0/ +data (yydef(i),i= 65, 72) / 0, 0, 0, 32, 103, 0, 0, 0/ +data (yydef(i),i= 73, 80) / 0, 0, 59, 60, 0, 63, 64, 0/ +data (yydef(i),i= 81, 88) / 67, 68, 0, 0, 0, 0, 0, 103/ +data (yydef(i),i= 89, 96) / 41, 0, 0, 103, 0, 0, 0, 103/ +data (yydef(i),i= 97,104) / 0, 103, 0, 103, 11, 12, 22, 23/ +data (yydef(i),i=105,112) / 0, 0, 74, 0, 0, 103, 72, 0/ +data (yydef(i),i=113,120) / 0, 61, 62, 0, 98, 99, 100, 65/ +data (yydef(i),i=121,128) / 66, 69, 70, 103, 73, 0, 0, 0/ +data (yydef(i),i=129,136) / 0, 84, 85, 86, 87, 88, 89, 90/ +data (yydef(i),i=137,144) / 91, 92, 93, 94, 95, 96, 101, 102/ +data (yydef(i),i=145,152) / 0, 103, 71, 103, 103, 97, 103, 42/ +data (yydef(i),i=153,160) / 0, 0, 0, 0, 0, 80, 81, 0/ +data (yydef(i),i=161,168) / 0, 0, 103, 46, 103, 48, 103, 50/ +data (yydef(i),i=169,176) / 40, 75, 76, 77, 78, 79, 0, 83/ +data (yydef(i),i=177,184) / 103, 0, 103, 103, 82, 103, 44, 103/ +data (yydef(i),i=185,192) / 103, 51, 103, 43, 45, 103, 0, 53/ +data (yydef(i),i=193,200) / 103, 47, 0, 55, 103, 49, 103, 52/ +data (yydef(i),i=201,201) / 54/ + +begin + call smark (yysp) + call salloc (yyv, (YYMAXDEPTH+2) * YYOPLEN, TY_STRUCT) + + # Initialization. The first element of the dynamically allocated + # token value stack (yyv) is used for yyval, the second for yylval, + # and the actual stack starts with the third element. + + yystate = 0 + yychar = -1 + yynerrs = 0 + yyerrflag = 0 + yyps = 0 + yyval = yyv + yylval = yyv + YYOPLEN + yypv = yylval + +yystack_ + # SHIFT -- Put a state and value onto the stack. The token and + # value stacks are logically the same stack, implemented as two + # separate arrays. + + if (yydebug) { + call printf ("state %d, char 0%o\n") + call pargs (yystate) + call pargi (yychar) + } + yyps = yyps + 1 + yypv = yypv + YYOPLEN + if (yyps > YYMAXDEPTH) { + call sfree (yysp) + call eprintf ("yacc stack overflow\n") + return (ERR) + } + yys[yyps] = yystate + YYMOVE (yyval, yypv) + +yynewstate_ + # Process the new state. + yyn = yypact[yystate+1] + + if (yyn <= YYFLAG) + goto yydefault_ # simple state + + # The variable "yychar" is the lookahead token. + if (yychar < 0) { + yychar = yylex (fd, yylval) + if (yychar < 0) + yychar = 0 + } + yyn = yyn + yychar + if (yyn < 0 || yyn >= YYLAST) + goto yydefault_ + + yyn = yyact[yyn+1] + if (yychk[yyn+1] == yychar) { # valid shift + yychar = -1 + YYMOVE (yylval, yyval) + yystate = yyn + if (yyerrflag > 0) + yyerrflag = yyerrflag - 1 + goto yystack_ + } + +yydefault_ + # Default state action. + + yyn = yydef[yystate+1] + if (yyn == -2) { + if (yychar < 0) { + yychar = yylex (fd, yylval) + if (yychar < 0) + yychar = 0 + } + + # Look through exception table. + yyxi = 1 + while ((yyexca[yyxi] != (-1)) || (yyexca[yyxi+1] != yystate)) + yyxi = yyxi + 2 + for (yyxi=yyxi+2; yyexca[yyxi] >= 0; yyxi=yyxi+2) { + if (yyexca[yyxi] == yychar) + break + } + + yyn = yyexca[yyxi+1] + if (yyn < 0) { + call sfree (yysp) + return (OK) # ACCEPT -- all done + } + } + + + # SYNTAX ERROR -- resume parsing if possible. + + if (yyn == 0) { + switch (yyerrflag) { + case 0, 1, 2: + if (yyerrflag == 0) { # brand new error + call eprintf ("syntax error\n") +yyerrlab_ + yynerrs = yynerrs + 1 + # fall through... + } + + # case 1: + # case 2: incompletely recovered error ... try again + yyerrflag = 3 + + # Find a state where "error" is a legal shift action. + while (yyps >= 1) { + yyn = yypact[yys[yyps]+1] + YYERRCODE + if ((yyn >= 0) && (yyn < YYLAST) && + (yychk[yyact[yyn+1]+1] == YYERRCODE)) { + # Simulate a shift of "error". + yystate = yyact[yyn+1] + goto yystack_ + } + yyn = yypact[yys[yyps]+1] + + # The current yyps has no shift on "error", pop stack. + if (yydebug) { + call printf ("error recovery pops state %d, ") + call pargs (yys[yyps]) + call printf ("uncovers %d\n") + call pargs (yys[yyps-1]) + } + yyps = yyps - 1 + yypv = yypv - YYOPLEN + } + + # ABORT -- There is no state on the stack with an error shift. +yyabort_ + call sfree (yysp) + return (ERR) + + + case 3: # No shift yet; clobber input char. + + if (yydebug) { + call printf ("error recovery discards char %d\n") + call pargi (yychar) + } + + if (yychar == 0) + goto yyabort_ # don't discard EOF, quit + yychar = -1 + goto yynewstate_ # try again in the same state + } + } + + + # REDUCE -- Reduction by production yyn. + + if (yydebug) { + call printf ("reduce %d\n") + call pargs (yyn) + } + yyps = yyps - yyr2[yyn+1] + yypvt = yypv + yypv = yypv - yyr2[yyn+1] * YYOPLEN + YYMOVE (yypv + YYOPLEN, yyval) + yym = yyn + + # Consult goto table to find next state. + yyn = yyr1[yyn+1] + yyj = yypgo[yyn+1] + yys[yyps] + 1 + if (yyj >= YYLAST) + yystate = yyact[yypgo[yyn+1]+1] + else { + yystate = yyact[yyj+1] + if (yychk[yystate+1] != -yyn) + yystate = yyact[yypgo[yyn+1]+1] + } + + # Perform action associated with the grammar rule, if any. + switch (yym) { + +case 1: +# line 41 "parser.y" +{ + return (OK) + } +case 2: +# line 44 "parser.y" +{ + return (ERR) + } +case 5: +# line 55 "parser.y" +{ + call pr_error ("The observation section is empty", + PERR_WARNING) + } +case 6: +# line 59 "parser.y" +{ + call pr_error ("The observation section is empty", + PERR_WARNING) + } +case 7: +# line 63 "parser.y" +{ + call pr_error ("The observation section is undefined", + PERR_WARNING) + } +case 10: +# line 71 "parser.y" +{ + call pr_obscol (LEX_ID (yypvt-YYOPLEN), LEX_ID (yypvt)) + } +case 11: +# line 74 "parser.y" +{ + call pr_errcol (LEX_ID (yypvt-2*YYOPLEN), LEX_ID (yypvt)) + } +case 12: +# line 77 "parser.y" +{ + call pr_wtscol (LEX_ID (yypvt-2*YYOPLEN), LEX_ID (yypvt)) + } +case 15: +# line 88 "parser.y" +{ + call pr_error ("The catalog section is empty", + PERR_WARNING) + } +case 16: +# line 92 "parser.y" +{ + call pr_error ("The catalog section is empty", + PERR_WARNING) + } +case 18: +# line 99 "parser.y" +{ + call pr_puti (MINCOL, 2) + } +case 21: +# line 105 "parser.y" +{ + call pr_catcol (LEX_ID (yypvt-YYOPLEN), LEX_ID (yypvt)) + } +case 22: +# line 108 "parser.y" +{ + call pr_errcol (LEX_ID (yypvt-2*YYOPLEN), LEX_ID (yypvt)) + } +case 23: +# line 111 "parser.y" +{ + call pr_wtscol (LEX_ID (yypvt-2*YYOPLEN), LEX_ID (yypvt)) + } +case 24: +# line 117 "parser.y" +{ + YYMOVE (yypvt, yyval) + } +case 29: +# line 134 "parser.y" +{ + call pr_error ("The transformation section is empty", + PERR_WARNING) + } +case 30: +# line 138 "parser.y" +{ + call pr_error ("The transformation section is empty", + PERR_WARNING) + } +case 40: +# line 154 "parser.y" +{ + call pr_treq (LEX_ID (yypvt-6*YYOPLEN), + LEX_ID (yypvt-3*YYOPLEN), LEX_ID (yypvt), + LEX_CODE (yypvt-3*YYOPLEN), LEX_CLEN (yypvt-3*YYOPLEN), + LEX_CODE (yypvt), LEX_CLEN (yypvt)) + } +case 41: +# line 162 "parser.y" +{ + call pr_section (PRS_TRNREF) + } +case 42: +# line 167 "parser.y" +{ + call pr_section (PRS_TRNFIT) + } +case 43: +# line 175 "parser.y" +{ + call pr_trder (LEX_ID (yypvt-6*YYOPLEN), LEX_ID (yypvt-4*YYOPLEN), + LEX_ID (yypvt), LEX_CODE (yypvt), LEX_CLEN (yypvt)) + } +case 44: +# line 181 "parser.y" +{ + call pr_section (PRS_TRNDER) + } +case 45: +# line 189 "parser.y" +{ + call pr_trplot (LEX_ID (yypvt-6*YYOPLEN), + LEX_ID (yypvt-2*YYOPLEN), LEX_ID (yypvt), + LEX_CODE (yypvt-2*YYOPLEN), LEX_CLEN (yypvt-2*YYOPLEN), + LEX_CODE (yypvt), LEX_CLEN (yypvt)) + } +case 46: +# line 197 "parser.y" +{ + call pr_section (PRS_TRNPLOT) + } +case 47: +# line 207 "parser.y" +{ + call pr_erreq (LEX_ID (yypvt-7*YYOPLEN), LEX_ID (yypvt-3*YYOPLEN), + LEX_ID (yypvt-YYOPLEN), LEX_ID (yypvt), + LEX_CODE (yypvt-3*YYOPLEN), LEX_CLEN (yypvt-3*YYOPLEN), + LEX_CODE (yypvt-YYOPLEN), LEX_CLEN (yypvt-YYOPLEN), + LEX_CODE (yypvt), LEX_CLEN (yypvt)) + } +case 48: +# line 216 "parser.y" +{ + call pr_section (PRS_ERREQ) + } +case 49: +# line 226 "parser.y" +{ + call pr_wtseq (LEX_ID (yypvt-7*YYOPLEN), LEX_ID (yypvt-3*YYOPLEN), + LEX_ID (yypvt-YYOPLEN), LEX_ID (yypvt), + LEX_CODE (yypvt-3*YYOPLEN), LEX_CLEN (yypvt-3*YYOPLEN), + LEX_CODE (yypvt-YYOPLEN), LEX_CLEN (yypvt-YYOPLEN), + LEX_CODE (yypvt), LEX_CLEN (yypvt)) + } +case 50: +# line 235 "parser.y" +{ + call pr_section (PRS_WTSEQ) + } +case 51: +# line 243 "parser.y" +{ + call pr_section (PRS_LMTEQ) + } +case 52: +# line 248 "parser.y" +{ + YYMOVE (yypvt, yyval) + } +case 53: +# line 251 "parser.y" +{ + call strcpy ("", LEX_ID (yyval), LEN_ID) + LEX_CLEN (yyval) = 0 + } +case 54: +# line 257 "parser.y" +{ + YYMOVE (yypvt, yyval) + } +case 55: +# line 260 "parser.y" +{ + call strcpy ("", LEX_ID (yyval), LEN_ID) + LEX_CLEN (yyval) = 0 + } +case 62: +# line 279 "parser.y" +{ + call pr_fitpar (LEX_ID (yypvt-2*YYOPLEN), LEX_ID (yypvt)) + } +case 66: +# line 288 "parser.y" +{ + call pr_const (LEX_ID (yypvt-2*YYOPLEN), LEX_ID (yypvt)) + } +case 70: +# line 297 "parser.y" +{ + call pr_delta (LEX_ID (yypvt-2*YYOPLEN), LEX_ID (yypvt)) + } +case 71: +# line 305 "parser.y" +{ + call pr_seteq (LEX_ID (yypvt-3*YYOPLEN), LEX_ID (yypvt), + LEX_CODE (yypvt), LEX_CLEN (yypvt)) + } +case 72: +# line 311 "parser.y" +{ + call pr_section (PRS_SETEQ) + } +case 73: +# line 331 "parser.y" +{ + YYMOVE (yypvt, yyval) + call pr_cend (yyval) + } +case 74: +# line 337 "parser.y" +{ + call pr_cinit () + } +case 75: +# line 342 "parser.y" +{ + call pr_cat3 (LEX_ID (yypvt-2*YYOPLEN), LEX_ID (yypvt-YYOPLEN), LEX_ID (yypvt), + LEX_ID (yyval), LEN_ID) + call pr_cgen (PLUS, "", INDEFR) + } +case 76: +# line 347 "parser.y" +{ + call pr_cat3 (LEX_ID (yypvt-2*YYOPLEN), LEX_ID (yypvt-YYOPLEN), LEX_ID (yypvt), + LEX_ID (yyval), LEN_ID) + call pr_cgen (MINUS, "", INDEFR) + } +case 77: +# line 352 "parser.y" +{ + call pr_cat3 (LEX_ID (yypvt-2*YYOPLEN), LEX_ID (yypvt-YYOPLEN), LEX_ID (yypvt), + LEX_ID (yyval), LEN_ID) + call pr_cgen (STAR, "", INDEFR) + } +case 78: +# line 357 "parser.y" +{ + call pr_cat3 (LEX_ID (yypvt-2*YYOPLEN), LEX_ID (yypvt-YYOPLEN), LEX_ID (yypvt), + LEX_ID (yyval), LEN_ID) + call pr_cgen (SLASH, "", INDEFR) + } +case 79: +# line 362 "parser.y" +{ + call pr_cat3 (LEX_ID (yypvt-2*YYOPLEN), LEX_ID (yypvt-YYOPLEN), LEX_ID (yypvt), + LEX_ID (yyval), LEN_ID) + call pr_cgen (EXPON, "", INDEFR) + } +case 80: +# line 367 "parser.y" +{ + call pr_cat2 (LEX_ID (yypvt-YYOPLEN), LEX_ID (yypvt), LEX_ID (yyval), LEN_ID) + call pr_cgen (UPLUS, "", INDEFR) + } +case 81: +# line 371 "parser.y" +{ + call pr_cat2 (LEX_ID (yypvt-YYOPLEN), LEX_ID (yypvt), LEX_ID (yyval), LEN_ID) + call pr_cgen (UMINUS, "", INDEFR) + } +case 82: +# line 375 "parser.y" +{ + call pr_cat4 (LEX_ID (yypvt-3*YYOPLEN), LEX_ID (yypvt-2*YYOPLEN), LEX_ID (yypvt-YYOPLEN), + LEX_ID (yypvt), LEX_ID (yyval), LEN_ID) + call pr_cgen (LEX_TOK (yypvt-3*YYOPLEN), "", INDEFR) + } +case 83: +# line 380 "parser.y" +{ + call pr_cat3 (LEX_ID (yypvt-2*YYOPLEN), LEX_ID (yypvt-YYOPLEN), LEX_ID (yypvt), + LEX_ID (yyval), LEN_ID) + } +case 84: +# line 384 "parser.y" +{ + YYMOVE (yypvt, yyval) + call pr_cgen (RNUMBER, "", LEX_VAL (yypvt)) + } +case 85: +# line 388 "parser.y" +{ + call pr_chkid (LEX_ID (yypvt)) + YYMOVE (yypvt, yyval) + call pr_cgen (IDENTIFIER, LEX_ID (yypvt), INDEFR) + } +case 86: +# line 395 "parser.y" +{ + YYMOVE (yypvt, yyval) + } +case 87: +# line 398 "parser.y" +{ + YYMOVE (yypvt, yyval) + } +case 88: +# line 401 "parser.y" +{ + YYMOVE (yypvt, yyval) + } +case 89: +# line 404 "parser.y" +{ + YYMOVE (yypvt, yyval) + } +case 90: +# line 407 "parser.y" +{ + YYMOVE (yypvt, yyval) + } +case 91: +# line 410 "parser.y" +{ + YYMOVE (yypvt, yyval) + } +case 92: +# line 413 "parser.y" +{ + YYMOVE (yypvt, yyval) + } +case 93: +# line 416 "parser.y" +{ + YYMOVE (yypvt, yyval) + } +case 94: +# line 419 "parser.y" +{ + YYMOVE (yypvt, yyval) + } +case 95: +# line 422 "parser.y" +{ + YYMOVE (yypvt, yyval) + } +case 96: +# line 425 "parser.y" +{ + YYMOVE (yypvt, yyval) + } +case 97: +# line 431 "parser.y" +{ + call pr_cat2 (LEX_ID (yypvt-YYOPLEN), LEX_ID (yypvt), + LEX_ID (yyval), LEN_ID) + LEX_VAL (yyval) = LEX_VAL (yypvt) + } +case 98: +# line 438 "parser.y" +{ + YYMOVE (yypvt, yyval) + } +case 99: +# line 441 "parser.y" +{ + YYMOVE (yypvt, yyval) + } +case 100: +# line 444 "parser.y" +{ + call strcpy ("", LEX_ID (yyval), LEN_ID) + } +case 101: +# line 449 "parser.y" +{ + YYMOVE (yypvt, yyval) + } +case 102: +# line 452 "parser.y" +{ + YYMOVE (yypvt, yyval) + } } + + goto yystack_ # stack new state and value +end diff --git a/noao/digiphot/photcal/parser/parser.y b/noao/digiphot/photcal/parser/parser.y new file mode 100644 index 00000000..aaee60e0 --- /dev/null +++ b/noao/digiphot/photcal/parser/parser.y @@ -0,0 +1,461 @@ +%{ + +include <ctype.h> +include <lexnum.h> +include "../lib/lexer.h" +include "../lib/parser.h" +include "../lib/prdefs.h" + +# Parser stack and structure lengths +define YYMAXDEPTH 128 +define YYOPLEN LEN_LEX + +# Redefine the name of the parser +define yyparse parse + +%} + + +%token OBSSECT CATSECT EXTSECT TRNSECT +%token FITID CONSTID DELTAID +%token ERRORID WEIGHTID MINID MAXID +%token DERIVID PLOTID SETID +%token F_ABS F_ACOS F_ASIN F_ATAN F_COS F_EXP +%token F_LOG F_LOG10 F_SIN F_SQRT F_TAN +%token IDENTIFIER INUMBER RNUMBER +%token PLUS MINUS STAR SLASH EXPON +%token COLON SEMICOLON COMMA EQUAL LPAR RPAR +%token EOFILE + +%left PLUS MINUS +%left STAR SLASH +%left EXPON +%right UPLUS UMINUS + + +%% + + +# Configuration file. + +config : catalog observation extinction transform EOFILE { + return (OK) + } + | error { + return (ERR) + } + ; + + +# Observation variable section. Set equations are not allowed here to avoid +# a precedence problem in the parser. + +observation : OBSSECT obscols + | OBSSECT obscols SEMICOLON + | OBSSECT SEMICOLON { + call pr_error ("The observation section is empty", + PERR_WARNING) + } + | OBSSECT { + call pr_error ("The observation section is empty", + PERR_WARNING) + } + | empty { + call pr_error ("The observation section is undefined", + PERR_WARNING) + } + ; + +obscols : obscol | obscol obscols + +obscol : IDENTIFIER column { + call pr_obscol (LEX_ID ($1), LEX_ID ($2)) + } + | ERRORID LPAR IDENTIFIER RPAR column { + call pr_errcol (LEX_ID ($3), LEX_ID ($5)) + } + | WEIGHTID LPAR IDENTIFIER RPAR column { + call pr_wtscol (LEX_ID ($3), LEX_ID ($5)) + } + ; + + +# Catalog variable section. Set equations are not allowed here to avoid +# a precedence problem in the parser. + +catalog : CATSECT catminset catcols + | CATSECT catminset catcols SEMICOLON + | CATSECT catminset SEMICOLON { + call pr_error ("The catalog section is empty", + PERR_WARNING) + } + | CATSECT catminset { + call pr_error ("The catalog section is empty", + PERR_WARNING) + } + |empty + ; + +catminset : empty { + call pr_puti (MINCOL, 2) + } + +catcols : catcol | catcol catcols ; + +catcol : IDENTIFIER column { + call pr_catcol (LEX_ID ($1), LEX_ID ($2)) + } + | ERRORID LPAR IDENTIFIER RPAR column { + call pr_errcol (LEX_ID ($3), LEX_ID ($5)) + } + | WEIGHTID LPAR IDENTIFIER RPAR column { + call pr_wtscol (LEX_ID ($3), LEX_ID ($5)) + } + ; + + +column : INUMBER { + YYMOVE ($1, $$) + } + ; + + +# Extinction correction section (NOT YET IMPLEMENTED). + +extinction : EXTSECT SEMICOLON + | EXTSECT + | empty + ; + + +# Transformation section. + +transform : TRNSECT trneqlist + | TRNSECT SEMICOLON { + call pr_error ("The transformation section is empty", + PERR_WARNING) + } + | TRNSECT { + call pr_error ("The transformation section is empty", + PERR_WARNING) + } + ; + +trneqlist : trneq | trneq trneqlist ; + +trneq : trntrans | trnderiv | trnplot + |fitconstdelta + | seteq | erroreq | weighteq + ; + + +# Transformation equation + +trntrans : IDENTIFIER COLON trnrefset stmt EQUAL trnfitset stmt { + call pr_treq (LEX_ID ($1), + LEX_ID ($4), LEX_ID ($7), + LEX_CODE ($4), LEX_CLEN ($4), + LEX_CODE ($7), LEX_CLEN ($7)) + } + ; + +trnrefset : empty { + call pr_section (PRS_TRNREF) + } + ; + +trnfitset : empty { + call pr_section (PRS_TRNFIT) + } + ; + +# Transformation derivative equation. + +trnderiv : DERIVID LPAR IDENTIFIER COMMA IDENTIFIER RPAR EQUAL + trnderset stmt { + call pr_trder (LEX_ID ($3), LEX_ID ($5), + LEX_ID ($9), LEX_CODE ($9), LEX_CLEN ($9)) + } + ; + +trnderset : empty { + call pr_section (PRS_TRNDER) + } + ; + +# Transformation plot equation. + +trnplot : PLOTID LPAR IDENTIFIER RPAR EQUAL + trnplotset stmt COMMA stmt { + call pr_trplot (LEX_ID ($3), + LEX_ID ($7), LEX_ID ($9), + LEX_CODE ($7), LEX_CLEN ($7), + LEX_CODE ($9), LEX_CLEN ($9)) + } + ; + +trnplotset : empty { + call pr_section (PRS_TRNPLOT) + } + ; + + +# Error equation. This equation is optionally followed by two +# expressions for the minimum and maximum values allowed. + +erroreq : ERRORID LPAR IDENTIFIER RPAR EQUAL erroreqset stmt + limitset limitmin limitmax { + call pr_erreq (LEX_ID ($3), LEX_ID ($7), + LEX_ID ($9), LEX_ID ($10), + LEX_CODE ($7), LEX_CLEN ($7), + LEX_CODE ($9), LEX_CLEN ($9), + LEX_CODE ($10), LEX_CLEN ($10)) + } + ; + +erroreqset : empty { + call pr_section (PRS_ERREQ) + } + ; + + +# Weight equation. This equation is optionally followed by two +# expressions for the minimum and maximum values allowed. + +weighteq : WEIGHTID LPAR IDENTIFIER RPAR EQUAL weighteqset stmt + limitset limitmin limitmax { + call pr_wtseq (LEX_ID ($3), LEX_ID ($7), + LEX_ID ($9), LEX_ID ($10), + LEX_CODE ($7), LEX_CLEN ($7), + LEX_CODE ($9), LEX_CLEN ($9), + LEX_CODE ($10), LEX_CLEN ($10)) + } + ; + +weighteqset : empty { + call pr_section (PRS_WTSEQ) + } + ; + + +# Limit equations for errors and weights. + +limitset : empty { + call pr_section (PRS_LMTEQ) + } + ; + +limitmin : MINID EQUAL stmt { + YYMOVE ($3, $$) + } + | empty { + call strcpy ("", LEX_ID ($$), LEN_ID) + LEX_CLEN ($$) = 0 + } + ; + +limitmax : MAXID EQUAL stmt { + YYMOVE ($3, $$) + } + | empty { + call strcpy ("", LEX_ID ($$), LEN_ID) + LEX_CLEN ($$) = 0 + } + ; + + + +# Fitting parameter, constant parameter, and parameter deltas definition. +# Although deltas are always positive, the parser allows for negative +# values to avoid a syntax error that would stop the parsing. Check for +# this is left to the symbol table handler procedures. + +fitconstdelta : fit | const | delta ; + +fit : FITID fitinitlist ; + +fitinitlist : fitinit | fitinit COMMA fitinitlist ; + +fitinit : IDENTIFIER EQUAL signedconst { + call pr_fitpar (LEX_ID ($1), LEX_ID ($3)) + } + ; + +const : CONSTID constinitlist ; + +constinitlist : constinit | constinit COMMA constinitlist ; + +constinit : IDENTIFIER EQUAL signedconst { + call pr_const (LEX_ID ($1), LEX_ID ($3)) + } + ; + +delta : DELTAID deltainitlist ; + +deltainitlist : deltainit | deltainit COMMA deltainitlist ; + +deltainit : IDENTIFIER EQUAL signedconst { + call pr_delta (LEX_ID ($1), LEX_ID ($3)) + } + ; + + +# Set equations. + +seteq : SETID IDENTIFIER EQUAL seteqset stmt { + call pr_seteq (LEX_ID ($2), LEX_ID ($5), + LEX_CODE ($5), LEX_CLEN ($5)) + } + ; + +seteqset : empty { + call pr_section (PRS_SETEQ) + } + ; + + + +# Statement list (not used for the moment, but it probably will) +# +#stmtlist : stmt { +# YYMOVE ($1, $$) +# } +# | stmt COMMA stmtlist { +# call pr_cat3 (LEX_ID ($1), LEX_ID ($2), LEX_ID ($3), +# LEX_ID ($$), LEN_ID) +# } +# ; + +# Statement (expression). + +stmt : exprinit expr { + YYMOVE ($2, $$) + call pr_cend ($$) + } + ; + +exprinit : empty { + call pr_cinit () + } + ; + +expr : expr PLUS expr { + call pr_cat3 (LEX_ID ($1), LEX_ID ($2), LEX_ID ($3), + LEX_ID ($$), LEN_ID) + call pr_cgen (PLUS, "", INDEFR) + } + | expr MINUS expr { + call pr_cat3 (LEX_ID ($1), LEX_ID ($2), LEX_ID ($3), + LEX_ID ($$), LEN_ID) + call pr_cgen (MINUS, "", INDEFR) + } + | expr STAR expr { + call pr_cat3 (LEX_ID ($1), LEX_ID ($2), LEX_ID ($3), + LEX_ID ($$), LEN_ID) + call pr_cgen (STAR, "", INDEFR) + } + | expr SLASH expr { + call pr_cat3 (LEX_ID ($1), LEX_ID ($2), LEX_ID ($3), + LEX_ID ($$), LEN_ID) + call pr_cgen (SLASH, "", INDEFR) + } + | expr EXPON expr { + call pr_cat3 (LEX_ID ($1), LEX_ID ($2), LEX_ID ($3), + LEX_ID ($$), LEN_ID) + call pr_cgen (EXPON, "", INDEFR) + } + | PLUS expr %prec UMINUS { + call pr_cat2 (LEX_ID ($1), LEX_ID ($2), LEX_ID ($$), LEN_ID) + call pr_cgen (UPLUS, "", INDEFR) + } + | MINUS expr %prec UMINUS { + call pr_cat2 (LEX_ID ($1), LEX_ID ($2), LEX_ID ($$), LEN_ID) + call pr_cgen (UMINUS, "", INDEFR) + } + | funct LPAR expr RPAR { + call pr_cat4 (LEX_ID ($1), LEX_ID ($2), LEX_ID ($3), + LEX_ID ($4), LEX_ID ($$), LEN_ID) + call pr_cgen (LEX_TOK ($1), "", INDEFR) + } + | LPAR expr RPAR { + call pr_cat3 (LEX_ID ($1), LEX_ID ($2), LEX_ID ($3), + LEX_ID ($$), LEN_ID) + } + | constant { + YYMOVE ($1, $$) + call pr_cgen (RNUMBER, "", LEX_VAL ($1)) + } + | IDENTIFIER { + call pr_chkid (LEX_ID ($1)) + YYMOVE ($1, $$) + call pr_cgen (IDENTIFIER, LEX_ID ($1), INDEFR) + } + ; + +funct : F_ABS { + YYMOVE ($1, $$) + } + | F_ACOS { + YYMOVE ($1, $$) + } + | F_ASIN { + YYMOVE ($1, $$) + } + | F_ATAN { + YYMOVE ($1, $$) + } + | F_COS { + YYMOVE ($1, $$) + } + | F_EXP { + YYMOVE ($1, $$) + } + | F_LOG { + YYMOVE ($1, $$) + } + | F_LOG10 { + YYMOVE ($1, $$) + } + | F_SIN { + YYMOVE ($1, $$) + } + | F_SQRT { + YYMOVE ($1, $$) + } + | F_TAN { + YYMOVE ($1, $$) + } + ; + + +signedconst : sign constant { + call pr_cat2 (LEX_ID ($1), LEX_ID ($2), + LEX_ID ($$), LEN_ID) + LEX_VAL ($$) = LEX_VAL ($2) + } + ; + +sign : PLUS %prec UMINUS { + YYMOVE ($1, $$) + } + | MINUS %prec UMINUS { + YYMOVE ($1, $$) + } + | empty { + call strcpy ("", LEX_ID ($$), LEN_ID) + } + ; + +constant : INUMBER { + YYMOVE ($1, $$) + } + | RNUMBER { + YYMOVE ($1, $$) + } + ; + + +empty : ; + + +%% diff --git a/noao/digiphot/photcal/parser/pralloc.x b/noao/digiphot/photcal/parser/pralloc.x new file mode 100644 index 00000000..2147298e --- /dev/null +++ b/noao/digiphot/photcal/parser/pralloc.x @@ -0,0 +1,304 @@ +.help pralloc +Parser Memory Allocation. + +Entry points: + + pr_alloc () Allocate parser tables. + + pr_inalloc (ptr) Allocate input variable substructure. + pr_ftalloc (ptr) Allocate fitting parameter substructure. + pr_stalloc (ptr) Allocate set equation substructure. + pr_tralloc (ptr, npars) Allocate transf. equation substructure. + + pr_free () Free parser tables. +.endhelp + +include "../lib/parser.h" +include "../lib/prstruct.h" + +# Number of expected symbols in the symbol table. The table is reallocated +# automatically by the SYMTAB procedures if this value is not enough. + +define LEN_SYMTABLE 100 + + +# PR_ALLOC -- Allocate space for symbol table and sequential tables + +procedure pr_alloc () + +pointer stopen() + +include "parser.com" + +begin + # Open symbol table + symtable = stopen ("parser", 2 * LEN_SYMTABLE, LEN_SYMTABLE, + LEN_SYMTABLE * SZ_LINE) + + # Allocate space for other tables + call mct_alloc (obstable, 10, 1, TY_INT) + call mct_alloc (cattable, 10, 1, TY_INT) + call mct_alloc (partable, 30, 1, TY_INT) + call mct_alloc (exttable, 10, 1, TY_INT) + call mct_alloc (trntable, 10, 1, TY_INT) + call mct_alloc (settable, 10, 1, TY_INT) + call mct_alloc (trcattable, 20, 2, TY_INT) + call mct_alloc (trobstable, 20, 2, TY_INT) + call mct_alloc (tfcattable, 20, 2, TY_INT) + call mct_alloc (tfobstable, 20, 2, TY_INT) + call mct_alloc (tpartable, 20, 1, TY_INT) +end + + +# PR_INALLOC -- Allocate space for input variable substructure. + +procedure pr_inalloc (ptr) + +pointer ptr # substructure pointer (output) + +begin + # Allocate space + call malloc (ptr, LEN_PINP, TY_STRUCT) + + # Initialize substructure + PINP_COL (ptr) = INDEFI + PINP_ERRCOL (ptr) = INDEFI + PINP_WTSCOL (ptr) = INDEFI + PINP_SPARE (ptr) = NO +end + + +# PR_FTALLOC -- Allocate space for fitting parameter substructure. + +procedure pr_ftalloc (ptr) + +pointer ptr # substructure pointer (output) + +begin + # Allocate space + call malloc (ptr, LEN_PFIT, TY_STRUCT) + + # Initialize substructure + PFIT_VALUE (ptr) = INDEFR + PFIT_DELTA (ptr) = INDEFR +end + + +# PR_STALLOC -- Allocate and initialize a set equation substructure. +# Initialization may not be necessary for all fields in the substructure, +# but it's safer to do it anyway. + +procedure pr_stalloc (ptr) + +pointer ptr # substructure pointer (output) + +begin + # Allocate space + call malloc (ptr, LEN_PSEQ, TY_STRUCT) + + # Initialize string offsets + PSEQ_EQ (ptr) = INDEFI + PSEQ_ERROR (ptr) = INDEFI + PSEQ_ERRMIN (ptr) = INDEFI + PSEQ_ERRMAX (ptr) = INDEFI + PSEQ_WEIGHT (ptr) = INDEFI + PSEQ_WTSMIN (ptr) = INDEFI + PSEQ_WTSMAX (ptr) = INDEFI + + # Initialize code pointers + PSEQ_RPNEQ (ptr) = NULL + PSEQ_RPNERROR (ptr) = NULL + PSEQ_RPNERRMIN (ptr) = NULL + PSEQ_RPNERRMAX (ptr) = NULL + PSEQ_RPNWEIGHT (ptr) = NULL + PSEQ_RPNWTSMIN (ptr) = NULL + PSEQ_RPNWTSMAX (ptr) = NULL +end + + +# PR_TRALLOC -- Allocate space and initialize a transformation equation +# substructure. Initialization may not be necessary for all fields in the +# substructure, but it's safer to do it anyway. + +procedure pr_tralloc (ptr, nrcat, nrobs, nfcat, nfobs, npars) + +pointer ptr # substructure pointer (output) +int nrcat # number of catalog variables in reference eq. +int nrobs # number of observation variables in reference eq. +int nfcat # number of catalog variables in fit eq. +int nfobs # number of observation variables in fit eq. +int npars # number of parameters + +int nvars, nrvars, nfvars + +begin + # Total number of variables + nrvars = nrcat + nrobs + nfvars = nfcat + nfobs + nvars = nrvars + nfvars + + # Allocate space + call malloc (ptr, LEN_PTEQ (nvars, npars), TY_STRUCT) + + # Initialize counters + PTEQ_NRCAT (ptr) = nrcat + PTEQ_NROBS (ptr) = nrobs + PTEQ_NRVAR (ptr) = nrvars + PTEQ_NFCAT (ptr) = nfcat + PTEQ_NFOBS (ptr) = nfobs + PTEQ_NFVAR (ptr) = nfvars + PTEQ_NVAR (ptr) = nvars + PTEQ_NPAR (ptr) = npars + PTEQ_NFPAR (ptr) = INDEFI + + # Initialize variable offsets and counters + call amovki (INDEFI, PTEQ_AREFVAR (ptr), nrvars) + call amovki (INDEFI, PTEQ_AFITVAR (ptr), nfvars) + call aclri (PTEQ_AREFCNT (ptr), nrvars) + call aclri (PTEQ_AFITCNT (ptr), nfvars) + + # Initialize parameter offsets, values, and list + call amovki (INDEFI, PTEQ_APAR (ptr), npars) + call amovkr (INDEFR, PTEQ_APARVAL (ptr), npars) + call aclri (PTEQ_APLIST (ptr), npars) + + # Initialize string offsets + PTEQ_FIT (ptr) = INDEFI + PTEQ_REF (ptr) = INDEFI + PTEQ_ERROR (ptr) = INDEFI + PTEQ_ERRMIN (ptr) = INDEFI + PTEQ_ERRMAX (ptr) = INDEFI + PTEQ_WEIGHT (ptr) = INDEFI + PTEQ_WTSMIN (ptr) = INDEFI + PTEQ_WTSMAX (ptr) = INDEFI + PTEQ_XPLOT (ptr) = INDEFI + PTEQ_YPLOT (ptr) = INDEFI + call amovki (INDEFI, PTEQ_ADER (ptr), npars) + + # Initialize code pointers + PTEQ_RPNFIT (ptr) = NULL + PTEQ_RPNREF (ptr) = NULL + PTEQ_RPNERROR (ptr) = NULL + PTEQ_RPNERRMIN (ptr) = NULL + PTEQ_RPNERRMAX (ptr) = NULL + PTEQ_RPNWEIGHT (ptr) = NULL + PTEQ_RPNWTSMIN (ptr) = NULL + PTEQ_RPNWTSMAX (ptr) = NULL + PTEQ_RPNXPLOT (ptr) = NULL + PTEQ_RPNYPLOT (ptr) = NULL + call amovki (NULL, PTEQ_ARPNDER (ptr), npars) +end + + +# PR_FREE - Free parser symbol table and sequential tables. + +procedure pr_free () + +int n +pointer sym, ptr + +include "parser.com" + +pointer sthead(), stnext() + +begin + # Traverse the symbol table looking for symbol + # substructures before closing it. + sym = sthead (symtable) + while (sym != NULL) { + + # Get pointer to the equation substructure, + # and free it only if not NULL + ptr = PSYM_SUB (sym) + if (ptr != NULL) { + + # Free additonal buffers associated with the substructure + switch (PSYM_TYPE (sym)) { + case PTY_CATVAR, PTY_OBSVAR: + # do nothing + + case PTY_FITPAR, PTY_CONST: + # do nothing + + case PTY_TRNEQ: + + # Free transformation equation codes + if (PTEQ_RPNFIT (ptr) != NULL) + call mfree (PTEQ_RPNFIT (ptr), TY_STRUCT) + if (PTEQ_RPNREF (ptr) != NULL) + call mfree (PTEQ_RPNREF (ptr), TY_STRUCT) + + # Free error equation codes + if (PTEQ_RPNERROR (ptr) != NULL) + call mfree (PTEQ_RPNERROR (ptr), TY_STRUCT) + if (PTEQ_RPNERRMIN (ptr) != NULL) + call mfree (PTEQ_RPNERRMIN (ptr), TY_STRUCT) + if (PTEQ_RPNERRMAX (ptr) != NULL) + call mfree (PTEQ_RPNERRMAX (ptr), TY_STRUCT) + + # Free weight equation codes + if (PTEQ_RPNWEIGHT (ptr) != NULL) + call mfree (PTEQ_RPNWEIGHT (ptr), TY_STRUCT) + if (PTEQ_RPNWTSMIN (ptr) != NULL) + call mfree (PTEQ_RPNWTSMIN (ptr), TY_STRUCT) + if (PTEQ_RPNWTSMAX (ptr) != NULL) + call mfree (PTEQ_RPNWTSMAX (ptr), TY_STRUCT) + + # Free plot equation codes + if (PTEQ_RPNXPLOT (ptr) != NULL) + call mfree (PTEQ_RPNXPLOT (ptr), TY_STRUCT) + if (PTEQ_RPNYPLOT (ptr) != NULL) + call mfree (PTEQ_RPNYPLOT (ptr), TY_STRUCT) + do n = 1, PTEQ_NPAR (ptr) + call mfree (PTEQ_RPNDER (ptr, n), TY_STRUCT) + + case PTY_SETEQ: + + # Free set equation code + if (PSEQ_RPNEQ (ptr) != NULL) + call mfree (PSEQ_RPNEQ (ptr), TY_STRUCT) + + # Free error equation codes + if (PSEQ_RPNERROR (ptr) != NULL) + call mfree (PSEQ_RPNERROR (ptr), TY_STRUCT) + if (PSEQ_RPNERRMIN (ptr) != NULL) + call mfree (PSEQ_RPNERRMIN (ptr), TY_STRUCT) + if (PSEQ_RPNERRMAX (ptr) != NULL) + call mfree (PSEQ_RPNERRMAX (ptr), TY_STRUCT) + + # Free weight equation codes + if (PSEQ_RPNWEIGHT (ptr) != NULL) + call mfree (PSEQ_RPNWEIGHT (ptr), TY_STRUCT) + if (PSEQ_RPNWTSMIN (ptr) != NULL) + call mfree (PSEQ_RPNWTSMIN (ptr), TY_STRUCT) + if (PSEQ_RPNWTSMAX (ptr) != NULL) + call mfree (PSEQ_RPNWTSMAX (ptr), TY_STRUCT) + + default: + call error (0, "pr_free: unknown equation symbol type") + } + + # Free equation substructure + call mfree (ptr, TY_STRUCT) + } + + # Advance to next symbol + sym = stnext (symtable, sym) + } + + # Close symbol table + call stclose (symtable) + + # Close other tables + call mct_free (obstable) + call mct_free (cattable) + call mct_free (partable) + call mct_free (exttable) + call mct_free (trntable) + call mct_free (settable) + call mct_free (trcattable) + call mct_free (trobstable) + call mct_free (tfcattable) + call mct_free (tfobstable) + call mct_free (tpartable) +end diff --git a/noao/digiphot/photcal/parser/prcat.x b/noao/digiphot/photcal/parser/prcat.x new file mode 100644 index 00000000..d8317f73 --- /dev/null +++ b/noao/digiphot/photcal/parser/prcat.x @@ -0,0 +1,43 @@ +# PR_CAT2 - Concatenate two strings + +procedure pr_cat2 (str1, str2, outstr, maxch) + +char str1[ARB], str2[ARB] # input strings +char outstr[ARB] # output string +int maxch # max output chars + +begin + call strcpy (str1, outstr, maxch) + call strcat (str2, outstr, maxch) +end + + +# PR_CAT3 - Concatenate three strings + +procedure pr_cat3 (str1, str2, str3, outstr, maxch) + +char str1[ARB], str2[ARB], str3[ARB] # input strings +char outstr[ARB] # output string +int maxch # max output chars + +begin + call strcpy (str1, outstr, maxch) + call strcat (str2, outstr, maxch) + call strcat (str3, outstr, maxch) +end + + +# PR_CAT4 - Concatenate four strings + +procedure pr_cat4 (str1, str2, str3, str4, outstr, maxch) + +char str1[ARB], str2[ARB], str3[ARB], str4[ARB] # input strings +char outstr[ARB] # output string +int maxch # max output chars + +begin + call strcpy (str1, outstr, maxch) + call strcat (str2, outstr, maxch) + call strcat (str3, outstr, maxch) + call strcat (str4, outstr, maxch) +end diff --git a/noao/digiphot/photcal/parser/prcode.com b/noao/digiphot/photcal/parser/prcode.com new file mode 100644 index 00000000..5b928b02 --- /dev/null +++ b/noao/digiphot/photcal/parser/prcode.com @@ -0,0 +1,8 @@ +# Evaluator common. This common handles the code counter and the code +# buffer used by the code generator routines during an expression +# code generation. + +int cp # next free instruction +pointer code # RPN code buffer + +common /prcodecom/ cp, code diff --git a/noao/digiphot/photcal/parser/prcode.x b/noao/digiphot/photcal/parser/prcode.x new file mode 100644 index 00000000..dfdb95fb --- /dev/null +++ b/noao/digiphot/photcal/parser/prcode.x @@ -0,0 +1,273 @@ +.help prcode +Parser code generator + +The parser generates code for all the equations in the symbol table in +Reverse Polish Notation (RPN). Under this notation, operands are pushed +into a stack, until an operation comes up. The operation takes as many stack +places (from the stack top) it needs as arguments, and places the result +in the top of the stack. The final result will be always in the top of +the stack. +.sp +In the current implemantation, arguments can be either constants, catalog +variables, observational variables, parameters, and equations (extinction +and transformation). The latter argument is a recursive call to other equation. +Operations can take only one or two stack places as arguments. +.sp +The instructions generated by the parser can be of one or two words. +The first word is always an integer, and identifies the operation to be +performed. If the operation is a "push" of a quantity into the stack, +the second word must contain the value (real) or index (integer) of +the quantity. The real value is used for constants, and index is used +for variables and parameters. +.sp +The RPN instructions are stored into memory as a dinamically allocated +buffer of structure type (TY_STRUCT), since it may contain integer and +real numbers. +.sp +The procedures provided here are called by the parser, to generate code +for each expression (formula) found. The following entry points are +defined: + +.nf + pr_calloc () Allocate space for temp. code buffer + pr_cfree () Deallocate code buffer + pr_cinit () Begin code generation + pr_cend (ptr) End code generation + pr_cgen (token, id, value) Generate code for parser token +pointer pr_cput (code, len) Create and copy code buffer +.endhelp + +include "../lib/lexer.h" +include "../lib/parser.h" +include "../lib/prtoken.h" +include "../lib/preval.h" + + +# PR_CALLOC - Allocate code buffer + +procedure pr_calloc () + +include "prcode.com" + +begin + # Allocate code buffer + call malloc (code, LEN_CODE, TY_STRUCT) +end + + +# PR_CFREE - Free code buffer + +procedure pr_cfree () + +include "prcode.com" + +begin + # Free buffer in common + call mfree (code, TY_STRUCT) +end + + +# PR_CINIT - Start code generation + +procedure pr_cinit () + +include "prcode.com" + +begin + # Set next free instruction be the first + cp = 1 +end + + +# PR_CEND - Finish code generation + +procedure pr_cend (ptr) + +pointer ptr # lexer symbol pointer + +include "prcode.com" + +begin + # Put the end-of-code marker in + # the next instruction + Memi[code + cp - 1] = PEV_EOC + + # Set code length + LEX_CLEN (ptr) = cp + + # Copy the code buffer into the lexer symbol + call amovi (Memi[code], Memi[LEX_CODE (ptr)], cp) + + # Reset code counter to the first + # instruction + cp = 1 +end + + +# PR_CGEN - Generate RPN code. + +procedure pr_cgen (token, id, value) + +int token # lexer token +char id[ARB] # lexer identifier +real value # lexer value + +char aux[SZ_LINE] +int offset, sym, type + +include "prcode.com" + +int pr_geti(), pr_gsymi() +pointer pr_getsym() + +begin + # Generate code for the current instruction according + # with token value returned by the lexer + switch (token) { + + case IDENTIFIER: + + # Find the identifier in the symbol table, and store + # the appropiate instruction code, and number, according + # with the symbol type. If the identifier is not found in + # the symbol table no code is generated, and no error + # action is taken. The latter is to avoid stopping the + # parser and allow some error recovery. + # Also compute an offset to add later to the symbol number. + # In catalog variables an offset is necessary because the + # expression evaluator has only ONE table with variable + # values, with catalog variables at the end. + sym = pr_getsym (id) + if (!IS_INDEFI (sym)) { + + # Get symbol type and take action acordingly + type = pr_gsymi (sym, PSYMTYPE) + switch (type) { + case PTY_OBSVAR: + Memi[code + cp - 1] = PEV_OBSVAR + offset = 0 + case PTY_CATVAR: + Memi[code + cp - 1] = PEV_CATVAR + offset = pr_geti (NOBSVARS) + case PTY_FITPAR, PTY_CONST: + Memi[code + cp - 1] = PEV_PARAM + offset = 0 + case PTY_SETEQ: + Memi[code + cp - 1] = PEV_SETEQ + offset = 0 + case PTY_EXTEQ: + Memi[code + cp - 1] = PEV_EXTEQ + offset = 0 + case PTY_TRNEQ: + Memi[code + cp - 1] = PEV_TRNEQ + offset = 0 + default: + call sprintf (aux, SZ_LINE, + "pr_cgen: Illegal symbol type (%d)") + call pargi (type) + call error (0, aux) + } + + # Store symbol number, plus the offset, in next instruction + cp = cp + 1 + Memi[code + cp - 1] = pr_gsymi (sym, PSYMNUM) + offset + + } + + case INUMBER, RNUMBER: + + # Store number instruction code and the number + # value in the next instruction + Memi[code + cp - 1] = PEV_NUMBER + cp = cp + 1 + Memr[code + cp - 1] = value + + case UPLUS: + Memi[code + cp - 1] = PEV_UPLUS + + case UMINUS: + Memi[code + cp - 1] = PEV_UMINUS + + case PLUS: + Memi[code + cp - 1] = PEV_PLUS + + case MINUS: + Memi[code + cp - 1] = PEV_MINUS + + case STAR: + Memi[code + cp - 1] = PEV_STAR + + case SLASH: + Memi[code + cp - 1] = PEV_SLASH + + case EXPON: + Memi[code + cp - 1] = PEV_EXPON + + case F_ABS: + Memi[code + cp - 1] = PEV_ABS + + case F_ACOS: + Memi[code + cp - 1] = PEV_ACOS + + case F_ASIN: + Memi[code + cp - 1] = PEV_ASIN + + case F_ATAN: + Memi[code + cp - 1] = PEV_ATAN + + case F_COS: + Memi[code + cp - 1] = PEV_COS + + case F_EXP: + Memi[code + cp - 1] = PEV_EXP + + case F_LOG: + Memi[code + cp - 1] = PEV_LOG + + case F_LOG10: + Memi[code + cp - 1] = PEV_LOG10 + + case F_SIN: + Memi[code + cp - 1] = PEV_SIN + + case F_SQRT: + Memi[code + cp - 1] = PEV_SQRT + + case F_TAN: + Memi[code + cp - 1] = PEV_TAN + + default: + call error (0, "pr_cgen: Illegal instruction") + } + + # Count codes, and check boundaries. Reserve at + # least three places: two for the next instruction, + # and one for the end-of-code marker + cp = cp + 1 + if (cp > LEN_CODE - 2) + call error (0, "pr_cgen: Too much code") +end + + +# PR_CPUT - Allocate space for a code buffer, copy given code bufer into +# it, and return pointer to it + +pointer procedure pr_cput (code, len) + +pointer code # code buffer +int len # code length + +pointer aux + +begin + # Check pointer + if (code == NULL) + call error (0, "pr_cput: Null code pointer") + + # Allocate memory for code and copy code buffer into it + call malloc (aux, len, TY_STRUCT) + call amovi (Memi[code], Memi[aux], len) + + # Return new buffer pointer + return (aux) +end diff --git a/noao/digiphot/photcal/parser/prconv.x b/noao/digiphot/photcal/parser/prconv.x new file mode 100644 index 00000000..358165a6 --- /dev/null +++ b/noao/digiphot/photcal/parser/prconv.x @@ -0,0 +1,72 @@ +.help prconv +Parser symbol conversion + +These procedures convert SYMTAB pointers into symbol offsets and viceversa, +and string offsets into character pointers (when applicable). +These procedures are called by the prget and prput procedures in order to +perform the appropiate type conversions. + +.nf +Entry points: + +int = pr_offset (sym) Convert SYMTAB pointer into symbol offset +pointer = pr_pointer (offset) Convert symbol offset into SYMTAB pointer +pointer = pr_charp (offset) Convert string offset into character pointer +.fi +.endhelp + +include "../lib/parser.h" + + +# PR_OFFSET - Convert SYMTAB pointer into an offset + +int procedure pr_offset (sym) + +pointer sym # symbol pointer + +pointer strefstab() +pointer pr_getp() + +begin + # Check pointer + if (sym == NULL) + return (INDEFI) + else + return (sym - strefstab (pr_getp (SYMTABLE), 0)) +end + + +# PR_POINTER - Convert an offset into a SYMTAB pointer + +pointer procedure pr_pointer (offset) + +int offset # symbol offset + +pointer strefstab() +pointer pr_getp() + +begin + # Check offset + if (IS_INDEFI (offset)) + return (NULL) + else + return (strefstab (pr_getp (SYMTABLE), offset)) +end + + +# PR_CHARP - Convert string offset into character pointer + +pointer procedure pr_charp (offset) + +int offset # string offset + +pointer strefsbuf() +pointer pr_getp() + +begin + # Check offset + if (IS_INDEFI (offset)) + return (NULL) + else + return (strefsbuf (pr_getp (SYMTABLE), offset)) +end diff --git a/noao/digiphot/photcal/parser/prerror.x b/noao/digiphot/photcal/parser/prerror.x new file mode 100644 index 00000000..8821810e --- /dev/null +++ b/noao/digiphot/photcal/parser/prerror.x @@ -0,0 +1,57 @@ +include "../lib/parser.h" +include "../lib/prdefs.h" + + +# PR_ERROR - Issue an error message to the standard output, and take an +# error action acording to the severity code. Error messages can be disabled +# if the error flag is set to NO. + +procedure pr_error (msg, severity) + +char msg[ARB] # error message +int severity # severity code + +include "lexer.com" + +#bool clgetb() +int pr_geti() + +begin + # Debug ? + #if (clgetb ("debug.parcode")) { + #call eprintf ("pr_error (msg=%s) (sev=%d)\n") + #call pargstr (msg) + #call pargi (severity) + #} + + # Test whether to process errors, or not + if (pr_geti (FLAGERRORS) == NO) + return + + # Branch on error severity code + switch (severity) { + case PERR_WARNING: + call pr_inci (NWARNINGS, 1) + call printf ("** Warning near line %d: %s%s\n") + call pargi (nlines) + call pargstr (line) + call pargstr (msg) + case PERR_SYNTAX: + call pr_inci (NERRORS, 1) + call printf ("** Error near line %d: %s%s at '%s'\n") + call pargi (nlines) + call pargstr (line) + call pargstr (msg) + call pargstr (id) + case PERR_SEMANTIC: + call pr_inci (NERRORS, 1) + call printf ("** Error near line %d: %s%s\n") + call pargi (nlines) + call pargstr (line) + call pargstr (msg) + case PERR_POSTPROC: + call pr_inci (NERRORS, 1) + call printf ("** Error: %s\n") + call pargstr (msg) + } +end diff --git a/noao/digiphot/photcal/parser/preval.gx b/noao/digiphot/photcal/parser/preval.gx new file mode 100644 index 00000000..24eb5e41 --- /dev/null +++ b/noao/digiphot/photcal/parser/preval.gx @@ -0,0 +1,319 @@ +include "../lib/parser.h" +include "../lib/preval.h" + +# Evaluation stack depth +define STACK_DEPTH 50 + + +# PR_EVAL - Evaluate an RPN code expression generated by the parser. This +# procedure checks for consistency in the input, although the code generated +# by the parser should be correct, and for stack underflow and overflow. +# The underflow can only happen under wrong generated code, but overflow +# can happen in complex expressions. This is not a syntactic, but related +# with the number of parenthesis used in the original source code expression. +# Illegal operations, such as division by zero, return and undefined value. + +real procedure pr_eval (code, vdata, pdata) + +pointer code # RPN code buffer +real vdata[ARB] # variables +real pdata[ARB] # parameters + +real pr_evs () + +begin + return (pr_evs (code, vdata, pdata)) +end + + +# PR_EV[SILRDX] - These procedures are called in chain, one for each indirect +# call to an equation expression (recursion). In this way it is possible to +# have up to six levels of indirection. Altough it works well, this is a patch, +# and should be replaced with a more elegant procedure that keeps a stack of +# indirect calls. + +$for (silrdx) +real procedure pr_ev$t (code, vdata, pdata) + +pointer code # RPN code buffer +real vdata[ARB] # variables +real pdata[ARB] # parameters + +char str[SZ_LINE] +int ip # instruction pointer +int sp # stack pointer +int ins # current instruction +int sym # equation symbol +real stack[STACK_DEPTH] # evaluation stack +real dummy +pointer caux, paux + +$if (datatype == s) +real pr_evi () +$endif +$if (datatype == i) +real pr_evl () +$endif +$if (datatype == l) +real pr_evr () +$endif +$if (datatype == r) +real pr_evd () +$endif +$if (datatype == d) +real pr_evx () +$endif +pointer pr_gsym(), pr_gsymp() + +begin + # Set the instruction pointer (offset from the + # beginning) to the first instruction in the buffer + ip = 0 + + # Get first instruction from the code buffer + ins = Memi[code + ip] + + # Reset execution stack pointer + sp = 0 + + # Returned value when recursion overflows + dummy = INDEFR + + # Loop reading instructions from the code buffer + # until the end-of-code instruction is found + while (ins != PEV_EOC) { + + # Branch on the instruction type + switch (ins) { + + case PEV_NUMBER: + ip = ip + 1 + sp = sp + 1 + stack[sp] = Memr[code + ip] + if (IS_INDEFR (stack[sp])) + break + + case PEV_CATVAR: + ip = ip + 1 + sp = sp + 1 + stack[sp] = vdata[Memi[code + ip]] + if (IS_INDEFR (stack[sp])) + break + + case PEV_OBSVAR: + ip = ip + 1 + sp = sp + 1 + stack[sp] = vdata[Memi[code + ip]] + if (IS_INDEFR (stack[sp])) + break + + case PEV_PARAM: + ip = ip + 1 + sp = sp + 1 + stack[sp] = pdata[Memi[code + ip]] + if (IS_INDEFR (stack[sp])) + break + + case PEV_SETEQ: + ip = ip + 1 + sp = sp + 1 + + sym = pr_gsym (Memi[code + ip], PTY_SETEQ) + caux = pr_gsymp (sym, PSEQRPNEQ) + + $if (datatype == s) + stack[sp] = pr_evi (caux, vdata, pdata) + $endif + $if (datatype == i) + stack[sp] = pr_evl (caux, vdata, pdata) + $endif + $if (datatype == l) + stack[sp] = pr_evr (caux, vdata, pdata) + $endif + $if (datatype == r) + stack[sp] = pr_evd (caux, vdata, pdata) + $endif + $if (datatype == d) + stack[sp] = pr_evx (caux, vdata, pdata) + $endif + $if (datatype == x) + stack[sp] = dummy + $endif + + if (IS_INDEFR (stack[sp])) + break + + case PEV_EXTEQ: + # not yet implemented + ip = ip + 1 + sp = sp + 1 + stack[sp] = INDEFR + if (IS_INDEFR (stack[sp])) + break + + case PEV_TRNEQ: + ip = ip + 1 + sp = sp + 1 + + sym = pr_gsym (Memi[code + ip], PTY_TRNEQ) + caux = pr_gsymp (sym, PTEQRPNFIT) + paux = pr_gsymp (sym, PTEQSPARVAL) + + $if (datatype == s) + stack[sp] = pr_evi (caux, vdata, Memr[paux]) + $endif + $if (datatype == i) + stack[sp] = pr_evl (caux, vdata, Memr[paux]) + $endif + $if (datatype == l) + stack[sp] = pr_evr (caux, vdata, Memr[paux]) + $endif + $if (datatype == r) + stack[sp] = pr_evd (caux, vdata, Memr[paux]) + $endif + $if (datatype == d) + stack[sp] = pr_evx (caux, vdata, Memr[paux]) + $endif + $if (datatype == x) + stack[sp] = dummy + $endif + + if (IS_INDEFR (stack[sp])) + break + + case PEV_UPLUS: + # do nothing + + case PEV_UMINUS: + stack[sp] = - stack[sp] + + case PEV_PLUS: + stack[sp - 1] = stack[sp - 1] + stack[sp] + sp = sp - 1 + + case PEV_MINUS: + stack[sp - 1] = stack[sp - 1] - stack[sp] + sp = sp - 1 + + case PEV_STAR: + stack[sp - 1] = stack[sp - 1] * stack[sp] + sp = sp - 1 + + case PEV_SLASH: + if (stack[sp] != 0) { + stack[sp - 1] = stack[sp - 1] / stack[sp] + sp = sp - 1 + } else { + stack[sp - 1] = INDEFR + sp = sp - 1 + break + } + + case PEV_EXPON: + if (stack[sp - 1] != 0) + stack[sp - 1] = stack[sp - 1] ** stack[sp] + else + stack[sp - 1] = 0.0 + sp = sp - 1 + + case PEV_ABS: + stack[sp] = abs (stack[sp]) + + case PEV_ACOS: + if (abs (stack[sp]) <= 1.0) + stack[sp] = acos (stack[sp]) + else { + stack[sp] = INDEFR + break + } + + case PEV_ASIN: + if (abs (stack[sp]) <= 1.0) + stack[sp] = asin (stack[sp]) + else { + stack[sp] = INDEFR + break + } + + case PEV_ATAN: + stack[sp] = atan (stack[sp]) + + case PEV_COS: + stack[sp] = cos (stack[sp]) + + case PEV_EXP: + stack[sp] = exp (stack[sp]) + + case PEV_LOG: + if (stack[sp] > 0.0) + stack[sp] = log (stack[sp]) + else { + stack[sp] = INDEFR + break + } + + case PEV_LOG10: + if (stack[sp] > 0.0) + stack[sp] = log10 (stack[sp]) + else { + stack[sp] = INDEFR + break + } + + case PEV_SIN: + stack[sp] = sin (stack[sp]) + + case PEV_SQRT: + if (stack[sp] >= 0.0) + stack[sp] = sqrt (stack[sp]) + else { + stack[sp] = INDEFR + break + } + + case PEV_TAN: + stack[sp] = tan (stack[sp]) + + default: # (just in case) + call sprintf (str, SZ_LINE, + "pr_eval: Evaluation code error (code=%d ip=%d ins=%d sp=%d)") + call pargi (code) + call pargi (ip) + call pargi (ins) + call pargi (sp) + call error (0, str) + } + + # Check for stack overflow. This is the + # only check really needed. + if (sp >= STACK_DEPTH) { + call sprintf (str, SZ_LINE, + "pr_eval: Evaluation stack overflow (code=%d ip=%d ins=%d sp=%d)") + call pargi (code) + call pargi (ip) + call pargi (ins) + call pargi (sp) + call error (0, str) + } + + # Check for stack underflow (just in case) + if (sp < 1) { + call sprintf (str, SZ_LINE, + "pr_eval: Evaluation stack underflow (code=%d ip=%d ins=%d sp=%d)") + call pargi (code) + call pargi (ip) + call pargi (ins) + call pargi (sp) + call error (0, str) + } + + # Get next instruction + ip = ip + 1 + ins = Memi[code + ip] + } + + # Return expression value + return (stack[sp]) +end + +$endfor diff --git a/noao/digiphot/photcal/parser/preval.x b/noao/digiphot/photcal/parser/preval.x new file mode 100644 index 00000000..28cb9c25 --- /dev/null +++ b/noao/digiphot/photcal/parser/preval.x @@ -0,0 +1,1448 @@ +include "../lib/parser.h" +include "../lib/preval.h" + +# Evaluation stack depth +define STACK_DEPTH 50 + + +# PR_EVAL - Evaluate an RPN code expression generated by the parser. This +# procedure checks for consistency in the input, although the code generated +# by the parser should be correct, and for stack underflow and overflow. +# The underflow can only happen under wrong generated code, but overflow +# can happen in complex expressions. This is not a syntactic, but related +# with the number of parenthesis used in the original source code expression. +# Illegal operations, such as division by zero, return and undefined value. + +real procedure pr_eval (code, vdata, pdata) + +pointer code # RPN code buffer +real vdata[ARB] # variables +real pdata[ARB] # parameters + +real pr_evs () + +begin + return (pr_evs (code, vdata, pdata)) +end + + +# PR_EV[SILRDX] - These procedures are called in chain, one for each indirect +# call to an equation expression (recursion). In this way it is possible to +# have up to six levels of indirection. Altough it works well, this is a patch, +# and should be replaced with a more elegant procedure that keeps a stack of +# indirect calls. + + +real procedure pr_evs (code, vdata, pdata) + +pointer code # RPN code buffer +real vdata[ARB] # variables +real pdata[ARB] # parameters + +char str[SZ_LINE] +int ip # instruction pointer +int sp # stack pointer +int ins # current instruction +int sym # equation symbol +real stack[STACK_DEPTH] # evaluation stack +real dummy +pointer caux, paux + +real pr_evi () +pointer pr_gsym(), pr_gsymp() + +begin + # Set the instruction pointer (offset from the + # beginning) to the first instruction in the buffer + ip = 0 + + # Get first instruction from the code buffer + ins = Memi[code + ip] + + # Reset execution stack pointer + sp = 0 + + # Returned value when recursion overflows + dummy = INDEFR + + # Loop reading instructions from the code buffer + # until the end-of-code instruction is found + while (ins != PEV_EOC) { + + # Branch on the instruction type + switch (ins) { + + case PEV_NUMBER: + ip = ip + 1 + sp = sp + 1 + stack[sp] = Memr[code + ip] + if (IS_INDEFR (stack[sp])) + break + + case PEV_CATVAR: + ip = ip + 1 + sp = sp + 1 + stack[sp] = vdata[Memi[code + ip]] + if (IS_INDEFR (stack[sp])) + break + + case PEV_OBSVAR: + ip = ip + 1 + sp = sp + 1 + stack[sp] = vdata[Memi[code + ip]] + if (IS_INDEFR (stack[sp])) + break + + case PEV_PARAM: + ip = ip + 1 + sp = sp + 1 + stack[sp] = pdata[Memi[code + ip]] + if (IS_INDEFR (stack[sp])) + break + + case PEV_SETEQ: + ip = ip + 1 + sp = sp + 1 + + sym = pr_gsym (Memi[code + ip], PTY_SETEQ) + caux = pr_gsymp (sym, PSEQRPNEQ) + + stack[sp] = pr_evi (caux, vdata, pdata) + + if (IS_INDEFR (stack[sp])) + break + + case PEV_EXTEQ: + # not yet implemented + ip = ip + 1 + sp = sp + 1 + stack[sp] = INDEFR + if (IS_INDEFR (stack[sp])) + break + + case PEV_TRNEQ: + ip = ip + 1 + sp = sp + 1 + + sym = pr_gsym (Memi[code + ip], PTY_TRNEQ) + caux = pr_gsymp (sym, PTEQRPNFIT) + paux = pr_gsymp (sym, PTEQSPARVAL) + + stack[sp] = pr_evi (caux, vdata, Memr[paux]) + + if (IS_INDEFR (stack[sp])) + break + + case PEV_UPLUS: + # do nothing + + case PEV_UMINUS: + stack[sp] = - stack[sp] + + case PEV_PLUS: + stack[sp - 1] = stack[sp - 1] + stack[sp] + sp = sp - 1 + + case PEV_MINUS: + stack[sp - 1] = stack[sp - 1] - stack[sp] + sp = sp - 1 + + case PEV_STAR: + stack[sp - 1] = stack[sp - 1] * stack[sp] + sp = sp - 1 + + case PEV_SLASH: + if (stack[sp] != 0) { + stack[sp - 1] = stack[sp - 1] / stack[sp] + sp = sp - 1 + } else { + stack[sp - 1] = INDEFR + sp = sp - 1 + break + } + + case PEV_EXPON: + if (stack[sp - 1] != 0) + stack[sp - 1] = stack[sp - 1] ** stack[sp] + else + stack[sp - 1] = 0.0 + sp = sp - 1 + + case PEV_ABS: + stack[sp] = abs (stack[sp]) + + case PEV_ACOS: + if (abs (stack[sp]) <= 1.0) + stack[sp] = acos (stack[sp]) + else { + stack[sp] = INDEFR + break + } + + case PEV_ASIN: + if (abs (stack[sp]) <= 1.0) + stack[sp] = asin (stack[sp]) + else { + stack[sp] = INDEFR + break + } + + case PEV_ATAN: + stack[sp] = atan (stack[sp]) + + case PEV_COS: + stack[sp] = cos (stack[sp]) + + case PEV_EXP: + stack[sp] = exp (stack[sp]) + + case PEV_LOG: + if (stack[sp] > 0.0) + stack[sp] = log (stack[sp]) + else { + stack[sp] = INDEFR + break + } + + case PEV_LOG10: + if (stack[sp] > 0.0) + stack[sp] = log10 (stack[sp]) + else { + stack[sp] = INDEFR + break + } + + case PEV_SIN: + stack[sp] = sin (stack[sp]) + + case PEV_SQRT: + if (stack[sp] >= 0.0) + stack[sp] = sqrt (stack[sp]) + else { + stack[sp] = INDEFR + break + } + + case PEV_TAN: + stack[sp] = tan (stack[sp]) + + default: # (just in case) + call sprintf (str, SZ_LINE, + "pr_eval: Evaluation code error (code=%d ip=%d ins=%d sp=%d)") + call pargi (code) + call pargi (ip) + call pargi (ins) + call pargi (sp) + call error (0, str) + } + + # Check for stack overflow. This is the + # only check really needed. + if (sp >= STACK_DEPTH) { + call sprintf (str, SZ_LINE, + "pr_eval: Evaluation stack overflow (code=%d ip=%d ins=%d sp=%d)") + call pargi (code) + call pargi (ip) + call pargi (ins) + call pargi (sp) + call error (0, str) + } + + # Check for stack underflow (just in case) + if (sp < 1) { + call sprintf (str, SZ_LINE, + "pr_eval: Evaluation stack underflow (code=%d ip=%d ins=%d sp=%d)") + call pargi (code) + call pargi (ip) + call pargi (ins) + call pargi (sp) + call error (0, str) + } + + # Get next instruction + ip = ip + 1 + ins = Memi[code + ip] + } + + # Return expression value + return (stack[sp]) +end + + +real procedure pr_evi (code, vdata, pdata) + +pointer code # RPN code buffer +real vdata[ARB] # variables +real pdata[ARB] # parameters + +char str[SZ_LINE] +int ip # instruction pointer +int sp # stack pointer +int ins # current instruction +int sym # equation symbol +real stack[STACK_DEPTH] # evaluation stack +real dummy +pointer caux, paux + +real pr_evl () +pointer pr_gsym(), pr_gsymp() + +begin + # Set the instruction pointer (offset from the + # beginning) to the first instruction in the buffer + ip = 0 + + # Get first instruction from the code buffer + ins = Memi[code + ip] + + # Reset execution stack pointer + sp = 0 + + # Returned value when recursion overflows + dummy = INDEFR + + # Loop reading instructions from the code buffer + # until the end-of-code instruction is found + while (ins != PEV_EOC) { + + # Branch on the instruction type + switch (ins) { + + case PEV_NUMBER: + ip = ip + 1 + sp = sp + 1 + stack[sp] = Memr[code + ip] + if (IS_INDEFR (stack[sp])) + break + + case PEV_CATVAR: + ip = ip + 1 + sp = sp + 1 + stack[sp] = vdata[Memi[code + ip]] + if (IS_INDEFR (stack[sp])) + break + + case PEV_OBSVAR: + ip = ip + 1 + sp = sp + 1 + stack[sp] = vdata[Memi[code + ip]] + if (IS_INDEFR (stack[sp])) + break + + case PEV_PARAM: + ip = ip + 1 + sp = sp + 1 + stack[sp] = pdata[Memi[code + ip]] + if (IS_INDEFR (stack[sp])) + break + + case PEV_SETEQ: + ip = ip + 1 + sp = sp + 1 + + sym = pr_gsym (Memi[code + ip], PTY_SETEQ) + caux = pr_gsymp (sym, PSEQRPNEQ) + + stack[sp] = pr_evl (caux, vdata, pdata) + + if (IS_INDEFR (stack[sp])) + break + + case PEV_EXTEQ: + # not yet implemented + ip = ip + 1 + sp = sp + 1 + stack[sp] = INDEFR + if (IS_INDEFR (stack[sp])) + break + + case PEV_TRNEQ: + ip = ip + 1 + sp = sp + 1 + + sym = pr_gsym (Memi[code + ip], PTY_TRNEQ) + caux = pr_gsymp (sym, PTEQRPNFIT) + paux = pr_gsymp (sym, PTEQSPARVAL) + + stack[sp] = pr_evl (caux, vdata, Memr[paux]) + + if (IS_INDEFR (stack[sp])) + break + + case PEV_UPLUS: + # do nothing + + case PEV_UMINUS: + stack[sp] = - stack[sp] + + case PEV_PLUS: + stack[sp - 1] = stack[sp - 1] + stack[sp] + sp = sp - 1 + + case PEV_MINUS: + stack[sp - 1] = stack[sp - 1] - stack[sp] + sp = sp - 1 + + case PEV_STAR: + stack[sp - 1] = stack[sp - 1] * stack[sp] + sp = sp - 1 + + case PEV_SLASH: + if (stack[sp] != 0) { + stack[sp - 1] = stack[sp - 1] / stack[sp] + sp = sp - 1 + } else { + stack[sp - 1] = INDEFR + sp = sp - 1 + break + } + + case PEV_EXPON: + if (stack[sp - 1] != 0) + stack[sp - 1] = stack[sp - 1] ** stack[sp] + else + stack[sp - 1] = 0.0 + sp = sp - 1 + + case PEV_ABS: + stack[sp] = abs (stack[sp]) + + case PEV_ACOS: + if (abs (stack[sp]) <= 1.0) + stack[sp] = acos (stack[sp]) + else { + stack[sp] = INDEFR + break + } + + case PEV_ASIN: + if (abs (stack[sp]) <= 1.0) + stack[sp] = asin (stack[sp]) + else { + stack[sp] = INDEFR + break + } + + case PEV_ATAN: + stack[sp] = atan (stack[sp]) + + case PEV_COS: + stack[sp] = cos (stack[sp]) + + case PEV_EXP: + stack[sp] = exp (stack[sp]) + + case PEV_LOG: + if (stack[sp] > 0.0) + stack[sp] = log (stack[sp]) + else { + stack[sp] = INDEFR + break + } + + case PEV_LOG10: + if (stack[sp] > 0.0) + stack[sp] = log10 (stack[sp]) + else { + stack[sp] = INDEFR + break + } + + case PEV_SIN: + stack[sp] = sin (stack[sp]) + + case PEV_SQRT: + if (stack[sp] >= 0.0) + stack[sp] = sqrt (stack[sp]) + else { + stack[sp] = INDEFR + break + } + + case PEV_TAN: + stack[sp] = tan (stack[sp]) + + default: # (just in case) + call sprintf (str, SZ_LINE, + "pr_eval: Evaluation code error (code=%d ip=%d ins=%d sp=%d)") + call pargi (code) + call pargi (ip) + call pargi (ins) + call pargi (sp) + call error (0, str) + } + + # Check for stack overflow. This is the + # only check really needed. + if (sp >= STACK_DEPTH) { + call sprintf (str, SZ_LINE, + "pr_eval: Evaluation stack overflow (code=%d ip=%d ins=%d sp=%d)") + call pargi (code) + call pargi (ip) + call pargi (ins) + call pargi (sp) + call error (0, str) + } + + # Check for stack underflow (just in case) + if (sp < 1) { + call sprintf (str, SZ_LINE, + "pr_eval: Evaluation stack underflow (code=%d ip=%d ins=%d sp=%d)") + call pargi (code) + call pargi (ip) + call pargi (ins) + call pargi (sp) + call error (0, str) + } + + # Get next instruction + ip = ip + 1 + ins = Memi[code + ip] + } + + # Return expression value + return (stack[sp]) +end + + +real procedure pr_evl (code, vdata, pdata) + +pointer code # RPN code buffer +real vdata[ARB] # variables +real pdata[ARB] # parameters + +char str[SZ_LINE] +int ip # instruction pointer +int sp # stack pointer +int ins # current instruction +int sym # equation symbol +real stack[STACK_DEPTH] # evaluation stack +real dummy +pointer caux, paux + +real pr_evr () +pointer pr_gsym(), pr_gsymp() + +begin + # Set the instruction pointer (offset from the + # beginning) to the first instruction in the buffer + ip = 0 + + # Get first instruction from the code buffer + ins = Memi[code + ip] + + # Reset execution stack pointer + sp = 0 + + # Returned value when recursion overflows + dummy = INDEFR + + # Loop reading instructions from the code buffer + # until the end-of-code instruction is found + while (ins != PEV_EOC) { + + # Branch on the instruction type + switch (ins) { + + case PEV_NUMBER: + ip = ip + 1 + sp = sp + 1 + stack[sp] = Memr[code + ip] + if (IS_INDEFR (stack[sp])) + break + + case PEV_CATVAR: + ip = ip + 1 + sp = sp + 1 + stack[sp] = vdata[Memi[code + ip]] + if (IS_INDEFR (stack[sp])) + break + + case PEV_OBSVAR: + ip = ip + 1 + sp = sp + 1 + stack[sp] = vdata[Memi[code + ip]] + if (IS_INDEFR (stack[sp])) + break + + case PEV_PARAM: + ip = ip + 1 + sp = sp + 1 + stack[sp] = pdata[Memi[code + ip]] + if (IS_INDEFR (stack[sp])) + break + + case PEV_SETEQ: + ip = ip + 1 + sp = sp + 1 + + sym = pr_gsym (Memi[code + ip], PTY_SETEQ) + caux = pr_gsymp (sym, PSEQRPNEQ) + + stack[sp] = pr_evr (caux, vdata, pdata) + + if (IS_INDEFR (stack[sp])) + break + + case PEV_EXTEQ: + # not yet implemented + ip = ip + 1 + sp = sp + 1 + stack[sp] = INDEFR + if (IS_INDEFR (stack[sp])) + break + + case PEV_TRNEQ: + ip = ip + 1 + sp = sp + 1 + + sym = pr_gsym (Memi[code + ip], PTY_TRNEQ) + caux = pr_gsymp (sym, PTEQRPNFIT) + paux = pr_gsymp (sym, PTEQSPARVAL) + + stack[sp] = pr_evr (caux, vdata, Memr[paux]) + + if (IS_INDEFR (stack[sp])) + break + + case PEV_UPLUS: + # do nothing + + case PEV_UMINUS: + stack[sp] = - stack[sp] + + case PEV_PLUS: + stack[sp - 1] = stack[sp - 1] + stack[sp] + sp = sp - 1 + + case PEV_MINUS: + stack[sp - 1] = stack[sp - 1] - stack[sp] + sp = sp - 1 + + case PEV_STAR: + stack[sp - 1] = stack[sp - 1] * stack[sp] + sp = sp - 1 + + case PEV_SLASH: + if (stack[sp] != 0) { + stack[sp - 1] = stack[sp - 1] / stack[sp] + sp = sp - 1 + } else { + stack[sp - 1] = INDEFR + sp = sp - 1 + break + } + + case PEV_EXPON: + if (stack[sp - 1] != 0) + stack[sp - 1] = stack[sp - 1] ** stack[sp] + else + stack[sp - 1] = 0.0 + sp = sp - 1 + + case PEV_ABS: + stack[sp] = abs (stack[sp]) + + case PEV_ACOS: + if (abs (stack[sp]) <= 1.0) + stack[sp] = acos (stack[sp]) + else { + stack[sp] = INDEFR + break + } + + case PEV_ASIN: + if (abs (stack[sp]) <= 1.0) + stack[sp] = asin (stack[sp]) + else { + stack[sp] = INDEFR + break + } + + case PEV_ATAN: + stack[sp] = atan (stack[sp]) + + case PEV_COS: + stack[sp] = cos (stack[sp]) + + case PEV_EXP: + stack[sp] = exp (stack[sp]) + + case PEV_LOG: + if (stack[sp] > 0.0) + stack[sp] = log (stack[sp]) + else { + stack[sp] = INDEFR + break + } + + case PEV_LOG10: + if (stack[sp] > 0.0) + stack[sp] = log10 (stack[sp]) + else { + stack[sp] = INDEFR + break + } + + case PEV_SIN: + stack[sp] = sin (stack[sp]) + + case PEV_SQRT: + if (stack[sp] >= 0.0) + stack[sp] = sqrt (stack[sp]) + else { + stack[sp] = INDEFR + break + } + + case PEV_TAN: + stack[sp] = tan (stack[sp]) + + default: # (just in case) + call sprintf (str, SZ_LINE, + "pr_eval: Evaluation code error (code=%d ip=%d ins=%d sp=%d)") + call pargi (code) + call pargi (ip) + call pargi (ins) + call pargi (sp) + call error (0, str) + } + + # Check for stack overflow. This is the + # only check really needed. + if (sp >= STACK_DEPTH) { + call sprintf (str, SZ_LINE, + "pr_eval: Evaluation stack overflow (code=%d ip=%d ins=%d sp=%d)") + call pargi (code) + call pargi (ip) + call pargi (ins) + call pargi (sp) + call error (0, str) + } + + # Check for stack underflow (just in case) + if (sp < 1) { + call sprintf (str, SZ_LINE, + "pr_eval: Evaluation stack underflow (code=%d ip=%d ins=%d sp=%d)") + call pargi (code) + call pargi (ip) + call pargi (ins) + call pargi (sp) + call error (0, str) + } + + # Get next instruction + ip = ip + 1 + ins = Memi[code + ip] + } + + # Return expression value + return (stack[sp]) +end + + +real procedure pr_evr (code, vdata, pdata) + +pointer code # RPN code buffer +real vdata[ARB] # variables +real pdata[ARB] # parameters + +char str[SZ_LINE] +int ip # instruction pointer +int sp # stack pointer +int ins # current instruction +int sym # equation symbol +real stack[STACK_DEPTH] # evaluation stack +real dummy +pointer caux, paux + +real pr_evd () +pointer pr_gsym(), pr_gsymp() + +begin + # Set the instruction pointer (offset from the + # beginning) to the first instruction in the buffer + ip = 0 + + # Get first instruction from the code buffer + ins = Memi[code + ip] + + # Reset execution stack pointer + sp = 0 + + # Returned value when recursion overflows + dummy = INDEFR + + # Loop reading instructions from the code buffer + # until the end-of-code instruction is found + while (ins != PEV_EOC) { + + # Branch on the instruction type + switch (ins) { + + case PEV_NUMBER: + ip = ip + 1 + sp = sp + 1 + stack[sp] = Memr[code + ip] + if (IS_INDEFR (stack[sp])) + break + + case PEV_CATVAR: + ip = ip + 1 + sp = sp + 1 + stack[sp] = vdata[Memi[code + ip]] + if (IS_INDEFR (stack[sp])) + break + + case PEV_OBSVAR: + ip = ip + 1 + sp = sp + 1 + stack[sp] = vdata[Memi[code + ip]] + if (IS_INDEFR (stack[sp])) + break + + case PEV_PARAM: + ip = ip + 1 + sp = sp + 1 + stack[sp] = pdata[Memi[code + ip]] + if (IS_INDEFR (stack[sp])) + break + + case PEV_SETEQ: + ip = ip + 1 + sp = sp + 1 + + sym = pr_gsym (Memi[code + ip], PTY_SETEQ) + caux = pr_gsymp (sym, PSEQRPNEQ) + + stack[sp] = pr_evd (caux, vdata, pdata) + + if (IS_INDEFR (stack[sp])) + break + + case PEV_EXTEQ: + # not yet implemented + ip = ip + 1 + sp = sp + 1 + stack[sp] = INDEFR + if (IS_INDEFR (stack[sp])) + break + + case PEV_TRNEQ: + ip = ip + 1 + sp = sp + 1 + + sym = pr_gsym (Memi[code + ip], PTY_TRNEQ) + caux = pr_gsymp (sym, PTEQRPNFIT) + paux = pr_gsymp (sym, PTEQSPARVAL) + + stack[sp] = pr_evd (caux, vdata, Memr[paux]) + + if (IS_INDEFR (stack[sp])) + break + + case PEV_UPLUS: + # do nothing + + case PEV_UMINUS: + stack[sp] = - stack[sp] + + case PEV_PLUS: + stack[sp - 1] = stack[sp - 1] + stack[sp] + sp = sp - 1 + + case PEV_MINUS: + stack[sp - 1] = stack[sp - 1] - stack[sp] + sp = sp - 1 + + case PEV_STAR: + stack[sp - 1] = stack[sp - 1] * stack[sp] + sp = sp - 1 + + case PEV_SLASH: + if (stack[sp] != 0) { + stack[sp - 1] = stack[sp - 1] / stack[sp] + sp = sp - 1 + } else { + stack[sp - 1] = INDEFR + sp = sp - 1 + break + } + + case PEV_EXPON: + if (stack[sp - 1] != 0) + stack[sp - 1] = stack[sp - 1] ** stack[sp] + else + stack[sp - 1] = 0.0 + sp = sp - 1 + + case PEV_ABS: + stack[sp] = abs (stack[sp]) + + case PEV_ACOS: + if (abs (stack[sp]) <= 1.0) + stack[sp] = acos (stack[sp]) + else { + stack[sp] = INDEFR + break + } + + case PEV_ASIN: + if (abs (stack[sp]) <= 1.0) + stack[sp] = asin (stack[sp]) + else { + stack[sp] = INDEFR + break + } + + case PEV_ATAN: + stack[sp] = atan (stack[sp]) + + case PEV_COS: + stack[sp] = cos (stack[sp]) + + case PEV_EXP: + stack[sp] = exp (stack[sp]) + + case PEV_LOG: + if (stack[sp] > 0.0) + stack[sp] = log (stack[sp]) + else { + stack[sp] = INDEFR + break + } + + case PEV_LOG10: + if (stack[sp] > 0.0) + stack[sp] = log10 (stack[sp]) + else { + stack[sp] = INDEFR + break + } + + case PEV_SIN: + stack[sp] = sin (stack[sp]) + + case PEV_SQRT: + if (stack[sp] >= 0.0) + stack[sp] = sqrt (stack[sp]) + else { + stack[sp] = INDEFR + break + } + + case PEV_TAN: + stack[sp] = tan (stack[sp]) + + default: # (just in case) + call sprintf (str, SZ_LINE, + "pr_eval: Evaluation code error (code=%d ip=%d ins=%d sp=%d)") + call pargi (code) + call pargi (ip) + call pargi (ins) + call pargi (sp) + call error (0, str) + } + + # Check for stack overflow. This is the + # only check really needed. + if (sp >= STACK_DEPTH) { + call sprintf (str, SZ_LINE, + "pr_eval: Evaluation stack overflow (code=%d ip=%d ins=%d sp=%d)") + call pargi (code) + call pargi (ip) + call pargi (ins) + call pargi (sp) + call error (0, str) + } + + # Check for stack underflow (just in case) + if (sp < 1) { + call sprintf (str, SZ_LINE, + "pr_eval: Evaluation stack underflow (code=%d ip=%d ins=%d sp=%d)") + call pargi (code) + call pargi (ip) + call pargi (ins) + call pargi (sp) + call error (0, str) + } + + # Get next instruction + ip = ip + 1 + ins = Memi[code + ip] + } + + # Return expression value + return (stack[sp]) +end + + +real procedure pr_evd (code, vdata, pdata) + +pointer code # RPN code buffer +real vdata[ARB] # variables +real pdata[ARB] # parameters + +char str[SZ_LINE] +int ip # instruction pointer +int sp # stack pointer +int ins # current instruction +int sym # equation symbol +real stack[STACK_DEPTH] # evaluation stack +real dummy +pointer caux, paux + +real pr_evx () +pointer pr_gsym(), pr_gsymp() + +begin + # Set the instruction pointer (offset from the + # beginning) to the first instruction in the buffer + ip = 0 + + # Get first instruction from the code buffer + ins = Memi[code + ip] + + # Reset execution stack pointer + sp = 0 + + # Returned value when recursion overflows + dummy = INDEFR + + # Loop reading instructions from the code buffer + # until the end-of-code instruction is found + while (ins != PEV_EOC) { + + # Branch on the instruction type + switch (ins) { + + case PEV_NUMBER: + ip = ip + 1 + sp = sp + 1 + stack[sp] = Memr[code + ip] + if (IS_INDEFR (stack[sp])) + break + + case PEV_CATVAR: + ip = ip + 1 + sp = sp + 1 + stack[sp] = vdata[Memi[code + ip]] + if (IS_INDEFR (stack[sp])) + break + + case PEV_OBSVAR: + ip = ip + 1 + sp = sp + 1 + stack[sp] = vdata[Memi[code + ip]] + if (IS_INDEFR (stack[sp])) + break + + case PEV_PARAM: + ip = ip + 1 + sp = sp + 1 + stack[sp] = pdata[Memi[code + ip]] + if (IS_INDEFR (stack[sp])) + break + + case PEV_SETEQ: + ip = ip + 1 + sp = sp + 1 + + sym = pr_gsym (Memi[code + ip], PTY_SETEQ) + caux = pr_gsymp (sym, PSEQRPNEQ) + + stack[sp] = pr_evx (caux, vdata, pdata) + + if (IS_INDEFR (stack[sp])) + break + + case PEV_EXTEQ: + # not yet implemented + ip = ip + 1 + sp = sp + 1 + stack[sp] = INDEFR + if (IS_INDEFR (stack[sp])) + break + + case PEV_TRNEQ: + ip = ip + 1 + sp = sp + 1 + + sym = pr_gsym (Memi[code + ip], PTY_TRNEQ) + caux = pr_gsymp (sym, PTEQRPNFIT) + paux = pr_gsymp (sym, PTEQSPARVAL) + + stack[sp] = pr_evx (caux, vdata, Memr[paux]) + + if (IS_INDEFR (stack[sp])) + break + + case PEV_UPLUS: + # do nothing + + case PEV_UMINUS: + stack[sp] = - stack[sp] + + case PEV_PLUS: + stack[sp - 1] = stack[sp - 1] + stack[sp] + sp = sp - 1 + + case PEV_MINUS: + stack[sp - 1] = stack[sp - 1] - stack[sp] + sp = sp - 1 + + case PEV_STAR: + stack[sp - 1] = stack[sp - 1] * stack[sp] + sp = sp - 1 + + case PEV_SLASH: + if (stack[sp] != 0) { + stack[sp - 1] = stack[sp - 1] / stack[sp] + sp = sp - 1 + } else { + stack[sp - 1] = INDEFR + sp = sp - 1 + break + } + + case PEV_EXPON: + if (stack[sp - 1] != 0) + stack[sp - 1] = stack[sp - 1] ** stack[sp] + else + stack[sp - 1] = 0.0 + sp = sp - 1 + + case PEV_ABS: + stack[sp] = abs (stack[sp]) + + case PEV_ACOS: + if (abs (stack[sp]) <= 1.0) + stack[sp] = acos (stack[sp]) + else { + stack[sp] = INDEFR + break + } + + case PEV_ASIN: + if (abs (stack[sp]) <= 1.0) + stack[sp] = asin (stack[sp]) + else { + stack[sp] = INDEFR + break + } + + case PEV_ATAN: + stack[sp] = atan (stack[sp]) + + case PEV_COS: + stack[sp] = cos (stack[sp]) + + case PEV_EXP: + stack[sp] = exp (stack[sp]) + + case PEV_LOG: + if (stack[sp] > 0.0) + stack[sp] = log (stack[sp]) + else { + stack[sp] = INDEFR + break + } + + case PEV_LOG10: + if (stack[sp] > 0.0) + stack[sp] = log10 (stack[sp]) + else { + stack[sp] = INDEFR + break + } + + case PEV_SIN: + stack[sp] = sin (stack[sp]) + + case PEV_SQRT: + if (stack[sp] >= 0.0) + stack[sp] = sqrt (stack[sp]) + else { + stack[sp] = INDEFR + break + } + + case PEV_TAN: + stack[sp] = tan (stack[sp]) + + default: # (just in case) + call sprintf (str, SZ_LINE, + "pr_eval: Evaluation code error (code=%d ip=%d ins=%d sp=%d)") + call pargi (code) + call pargi (ip) + call pargi (ins) + call pargi (sp) + call error (0, str) + } + + # Check for stack overflow. This is the + # only check really needed. + if (sp >= STACK_DEPTH) { + call sprintf (str, SZ_LINE, + "pr_eval: Evaluation stack overflow (code=%d ip=%d ins=%d sp=%d)") + call pargi (code) + call pargi (ip) + call pargi (ins) + call pargi (sp) + call error (0, str) + } + + # Check for stack underflow (just in case) + if (sp < 1) { + call sprintf (str, SZ_LINE, + "pr_eval: Evaluation stack underflow (code=%d ip=%d ins=%d sp=%d)") + call pargi (code) + call pargi (ip) + call pargi (ins) + call pargi (sp) + call error (0, str) + } + + # Get next instruction + ip = ip + 1 + ins = Memi[code + ip] + } + + # Return expression value + return (stack[sp]) +end + + +real procedure pr_evx (code, vdata, pdata) + +pointer code # RPN code buffer +real vdata[ARB] # variables +real pdata[ARB] # parameters + +char str[SZ_LINE] +int ip # instruction pointer +int sp # stack pointer +int ins # current instruction +int sym # equation symbol +real stack[STACK_DEPTH] # evaluation stack +real dummy +pointer caux, paux + +pointer pr_gsym(), pr_gsymp() + +begin + # Set the instruction pointer (offset from the + # beginning) to the first instruction in the buffer + ip = 0 + + # Get first instruction from the code buffer + ins = Memi[code + ip] + + # Reset execution stack pointer + sp = 0 + + # Returned value when recursion overflows + dummy = INDEFR + + # Loop reading instructions from the code buffer + # until the end-of-code instruction is found + while (ins != PEV_EOC) { + + # Branch on the instruction type + switch (ins) { + + case PEV_NUMBER: + ip = ip + 1 + sp = sp + 1 + stack[sp] = Memr[code + ip] + if (IS_INDEFR (stack[sp])) + break + + case PEV_CATVAR: + ip = ip + 1 + sp = sp + 1 + stack[sp] = vdata[Memi[code + ip]] + if (IS_INDEFR (stack[sp])) + break + + case PEV_OBSVAR: + ip = ip + 1 + sp = sp + 1 + stack[sp] = vdata[Memi[code + ip]] + if (IS_INDEFR (stack[sp])) + break + + case PEV_PARAM: + ip = ip + 1 + sp = sp + 1 + stack[sp] = pdata[Memi[code + ip]] + if (IS_INDEFR (stack[sp])) + break + + case PEV_SETEQ: + ip = ip + 1 + sp = sp + 1 + + sym = pr_gsym (Memi[code + ip], PTY_SETEQ) + caux = pr_gsymp (sym, PSEQRPNEQ) + + stack[sp] = dummy + + if (IS_INDEFR (stack[sp])) + break + + case PEV_EXTEQ: + # not yet implemented + ip = ip + 1 + sp = sp + 1 + stack[sp] = INDEFR + if (IS_INDEFR (stack[sp])) + break + + case PEV_TRNEQ: + ip = ip + 1 + sp = sp + 1 + + sym = pr_gsym (Memi[code + ip], PTY_TRNEQ) + caux = pr_gsymp (sym, PTEQRPNFIT) + paux = pr_gsymp (sym, PTEQSPARVAL) + + stack[sp] = dummy + + if (IS_INDEFR (stack[sp])) + break + + case PEV_UPLUS: + # do nothing + + case PEV_UMINUS: + stack[sp] = - stack[sp] + + case PEV_PLUS: + stack[sp - 1] = stack[sp - 1] + stack[sp] + sp = sp - 1 + + case PEV_MINUS: + stack[sp - 1] = stack[sp - 1] - stack[sp] + sp = sp - 1 + + case PEV_STAR: + stack[sp - 1] = stack[sp - 1] * stack[sp] + sp = sp - 1 + + case PEV_SLASH: + if (stack[sp] != 0) { + stack[sp - 1] = stack[sp - 1] / stack[sp] + sp = sp - 1 + } else { + stack[sp - 1] = INDEFR + sp = sp - 1 + break + } + + case PEV_EXPON: + if (stack[sp - 1] != 0) + stack[sp - 1] = stack[sp - 1] ** stack[sp] + else + stack[sp - 1] = 0.0 + sp = sp - 1 + + case PEV_ABS: + stack[sp] = abs (stack[sp]) + + case PEV_ACOS: + if (abs (stack[sp]) <= 1.0) + stack[sp] = acos (stack[sp]) + else { + stack[sp] = INDEFR + break + } + + case PEV_ASIN: + if (abs (stack[sp]) <= 1.0) + stack[sp] = asin (stack[sp]) + else { + stack[sp] = INDEFR + break + } + + case PEV_ATAN: + stack[sp] = atan (stack[sp]) + + case PEV_COS: + stack[sp] = cos (stack[sp]) + + case PEV_EXP: + stack[sp] = exp (stack[sp]) + + case PEV_LOG: + if (stack[sp] > 0.0) + stack[sp] = log (stack[sp]) + else { + stack[sp] = INDEFR + break + } + + case PEV_LOG10: + if (stack[sp] > 0.0) + stack[sp] = log10 (stack[sp]) + else { + stack[sp] = INDEFR + break + } + + case PEV_SIN: + stack[sp] = sin (stack[sp]) + + case PEV_SQRT: + if (stack[sp] >= 0.0) + stack[sp] = sqrt (stack[sp]) + else { + stack[sp] = INDEFR + break + } + + case PEV_TAN: + stack[sp] = tan (stack[sp]) + + default: # (just in case) + call sprintf (str, SZ_LINE, + "pr_eval: Evaluation code error (code=%d ip=%d ins=%d sp=%d)") + call pargi (code) + call pargi (ip) + call pargi (ins) + call pargi (sp) + call error (0, str) + } + + # Check for stack overflow. This is the + # only check really needed. + if (sp >= STACK_DEPTH) { + call sprintf (str, SZ_LINE, + "pr_eval: Evaluation stack overflow (code=%d ip=%d ins=%d sp=%d)") + call pargi (code) + call pargi (ip) + call pargi (ins) + call pargi (sp) + call error (0, str) + } + + # Check for stack underflow (just in case) + if (sp < 1) { + call sprintf (str, SZ_LINE, + "pr_eval: Evaluation stack underflow (code=%d ip=%d ins=%d sp=%d)") + call pargi (code) + call pargi (ip) + call pargi (ins) + call pargi (sp) + call error (0, str) + } + + # Get next instruction + ip = ip + 1 + ins = Memi[code + ip] + } + + # Return expression value + return (stack[sp]) +end diff --git a/noao/digiphot/photcal/parser/prexit.x b/noao/digiphot/photcal/parser/prexit.x new file mode 100644 index 00000000..eec1d53d --- /dev/null +++ b/noao/digiphot/photcal/parser/prexit.x @@ -0,0 +1,324 @@ +.help prexit +Parser Exit Handling. + +After the compilation has finished without errors, the parser runs the +pr_exit() routine in order to make sure that there are no inconsistencies in +the parser symbol table, and to perform all steps that can be done only +with the full symbol table. This procedure performs the following actions: + +- Builds the list of sequential tables for each type of variable, parameter, +and equation in the symbol table. These tables are used later to access +each type sequentially. + +- Sets the minimum and maximum values for observational and catalog variables. + +- Checks that there are no duplications in either the observational or catalog +input columns. + +- Checks that all the derivatives for transformation equations are defined. + +If an error or inconsistency is detected an error message is issued. + +Entry point: + + pr_exit() Exit procedure +.endhelp + +include <mach.h> +include "../lib/parser.h" +include "../lib/prdefs.h" + + +# PR_EXIT - Parser exit procedure. + +procedure pr_exit () + +bool derflag, dltflag +int i1, i2, incol, errcol, wtscol, mincol, maxcol, par, type +int npar, sym +pointer sp, aux, symtab, der +#real delta + +#bool clgetb() +int mct_nrows(), mct_geti(), pr_geti(), pr_gsymi(), pr_gpari() +pointer sthead(), stnext(), pr_xgetname(), pr_offset, pr_getp(), pr_gderp() +real pr_gsymr() + +begin + # Debug ? + #if (clgetb ("debug.parcode")) + #call eprintf ("pr_exit.in\n") + + # Allocate working space + call smark (sp) + call salloc (aux, SZ_LINE, TY_CHAR) + + # Initialize minimum and maximum column values. + # Check for empty sections to initialize with the + # right value. + + if (pr_geti (NOBSVARS) > 0) { + call pr_puti (MINOBSCOL, MAX_INT) + call pr_puti (MAXOBSCOL, -MAX_INT) + } else { + call pr_puti (MINOBSCOL, INDEFI) + call pr_puti (MAXOBSCOL, INDEFI) + } + if (pr_geti (NCATVARS) > 0) { + call pr_puti (MINCATCOL, MAX_INT) + call pr_puti (MAXCATCOL, -MAX_INT) + } else { + call pr_puti (MINCATCOL, INDEFI) + call pr_puti (MAXCATCOL, INDEFI) + } + + # Build sequential tables from the parser symbol table, + # and compute minimum and maximum column numbers. + + symtab = sthead (pr_getp (SYMTABLE)) + while (symtab != NULL) { + + # Convert SYMTAB pointer into symbol offset. + sym = pr_offset (symtab) + + # Get symbol type. + type = pr_gsymi (sym, PSYMTYPE) + + # Check symbol type consistency, and enter each symbol in a + # sequential table acording with its type + + switch (type) { + case PTY_OBSVAR: + call mct_sputi (pr_getp (OBSTABLE), sym) + incol = pr_gsymi (sym, PINPCOL) + mincol = incol + maxcol = incol + errcol = pr_gsymi (sym, PINPERRCOL) + if (! IS_INDEFI(errcol)) { + mincol = min (mincol, errcol) + maxcol = max (maxcol, errcol) + } + wtscol = pr_gsymi (sym, PINPWTSCOL) + if (! IS_INDEFI(wtscol)) { + mincol = min (mincol, wtscol) + maxcol = max (maxcol, wtscol) + } + if (mincol < pr_geti (MINOBSCOL)) + call pr_puti (MINOBSCOL, mincol) + if (maxcol > pr_geti (MAXOBSCOL)) + call pr_puti (MAXOBSCOL, maxcol) + case PTY_CATVAR: + call mct_sputi (pr_getp (CATTABLE), sym) + incol = pr_gsymi (sym, PINPCOL) + mincol = incol + maxcol = incol + errcol = pr_gsymi (sym, PINPERRCOL) + if (! IS_INDEFI(errcol)) { + mincol = min (mincol, errcol) + maxcol = max (maxcol, errcol) + } + wtscol = pr_gsymi (sym, PINPWTSCOL) + if (! IS_INDEFI(wtscol)) { + mincol = min (mincol, wtscol) + maxcol = max (maxcol, wtscol) + } + if (mincol < pr_geti (MINCATCOL)) + call pr_puti (MINCATCOL, mincol) + if (maxcol > pr_geti (MAXCATCOL)) + call pr_puti (MAXCATCOL, maxcol) + case PTY_FITPAR, PTY_CONST: + call mct_sputi (pr_getp (PARTABLE), sym) + case PTY_SETEQ: + call mct_sputi (pr_getp (SETTABLE), sym) + case PTY_EXTEQ: + call mct_sputi (pr_getp (EXTTABLE), sym) + case PTY_TRNEQ: + call mct_sputi (pr_getp (TRNTABLE), sym) + default: + call sprintf (Memc[aux], SZ_LINE, + "pr_exit: unknown symbol type [%d] for [%d] [%s]") + call pargi (type) + call pargi (sym) + call pargstr (Memc[pr_xgetname (sym)]) + call error (0, Memc[aux]) + } + + # Advance to next SYMTAB symbol. + symtab = stnext (pr_getp (SYMTABLE), symtab) + } + + # Check for input, error, and weight column duplications. + call pr_excol (pr_getp (CATTABLE)) + call pr_excol (pr_getp (OBSTABLE)) + + # Check transfomation equation deltas and derivatives. + do i1 = 1, mct_nrows (pr_getp (TRNTABLE)) { + + # Get equation symbol. + sym = mct_geti (pr_getp (TRNTABLE), i1, 1) + + # Get number of parameters. + npar = pr_gsymi (sym, PTEQNPAR) + + # Check if there are deltas and derivatives defined for the + # current equation. The code has been modified so that there + # will always be a defined PFITDELTA. + + derflag = false + dltflag = false + do i2 = 1, npar { + der = pr_gderp (sym, i2, PTEQRPNDER) + if (der != NULL) + derflag = true + par = pr_gpari (sym, i2, PTEQPAR) + if (IS_INDEFI (par)) + next + if (IS_INDEFR (pr_gsymr (par, PFITDELTA))) { + call pr_psymr (par, PFITDELTA, DEF_PFITDELTA) + } else if (der != NULL) { + call sprintf (Memc[aux], SZ_LINE, + "Parameter delta and derivative defined for [%s] in equation [%s]") + call pargstr (Memc[pr_xgetname (par)]) + call pargstr (Memc[pr_xgetname (sym)]) + call pr_error (Memc[aux], PERR_WARNING) + } + dltflag = true + } + + # Continue with next equation if no deltas or derivatives are + # defined. This error check should now never be tripped since the + # code has been modified so that dltflag is always true. + + if (! (derflag || dltflag) && (npar > 0)) { + call sprintf (Memc[aux], SZ_LINE, + "No parameter deltas or derivatives defined for equation [%s]") + call pargstr (Memc[pr_xgetname (sym)]) + call pr_error (Memc[aux], PERR_POSTPROC) + next + } + + # Loop over all fitting parameters of the equation. + # Comment out this code since there are now reasonable defaults + # and eventually delete. + + #do i2 = 1, npar { + + # Get parameter offset, parameter delta, and derivative + # code pointer. Skip parameters that are not used in + # the equation. + + #par = pr_gpari (sym, i2, PTEQPAR) + #if (IS_INDEFI (par)) + #next + #delta = pr_gsymr (par, PFITDELTA) + #der = pr_gderp (sym, i2, PTEQRPNDER) + + # Check for exclusion between deltas and derivatives, + # missing derivative equations, and missing deltas. + + #if (!IS_INDEFR (delta) && der != NULL) { + #call sprintf (Memc[aux], SZ_LINE, + #"Parameter delta and derivative defined for [%s] in equation [%s]") + #call pargstr (Memc[pr_xgetname (par)]) + #call pargstr (Memc[pr_xgetname (sym)]) + #call pr_error (Memc[aux], PERR_POSTPROC) + #} else if (der == NULL && derflag) { + #call sprintf (Memc[aux], SZ_LINE, + #"Missing derivative for parameter [%s] in equation [%s]") + #call pargstr (Memc[pr_xgetname (par)]) + #call pargstr (Memc[pr_xgetname (sym)]) + #call pr_error (Memc[aux], PERR_POSTPROC) + #} else if (IS_INDEFR (delta) && dltflag) { + #call sprintf (Memc[aux], SZ_LINE, + #"Missing delta for parameter [%s] in equation [%s]") + #call pargstr (Memc[pr_xgetname (par)]) + #call pargstr (Memc[pr_xgetname (sym)]) + #call pr_error (Memc[aux], PERR_POSTPROC) + #} + #} + } + + # Debug ? + #if (clgetb ("debug.parcode")) + #call eprintf ("pr_exit.out\n") + + call sfree (sp) +end + + +# PR_EXCOL -- Check for input variable column duplications. + +procedure pr_excol (table) + +pointer table # table pointer + +int i1, i2, sym1, sym2, col1, col2, errcol1, errcol2, wtscol1, wtscol2 +pointer sp, aux +int mct_nrows(), mct_geti(), pr_gsymi() +pointer pr_xgetname() + +begin + call smark (sp) + call salloc (aux, SZ_LINE, TY_CHAR) + + do i1 = 1, mct_nrows (table) - 1 { + + # Get first symbol columns. + sym1 = mct_geti (table, i1, 1) + col1 = pr_gsymi (sym1, PINPCOL) + errcol1 = pr_gsymi (sym1, PINPERRCOL) + wtscol1 = pr_gsymi (sym1, PINPWTSCOL) + + # Skip spare variable. + if (pr_gsymi (sym1, PINPSPARE) == YES) + next + + # Check the first symbol against itself. + if ((!IS_INDEFI (errcol1) && (col1 == errcol1)) || + (!IS_INDEFI (wtscol1) && (col1 == wtscol1)) || + (!IS_INDEFI (errcol1) && !IS_INDEFI (wtscol1) && + (errcol1 == wtscol1))) { + call sprintf (Memc[aux], SZ_LINE, + "Duplicate column for input variable [%s]") + call pargstr (Memc[pr_xgetname (sym1)]) + call pr_error (Memc[aux], PERR_WARNING) + } + + # Compare the first symbol against all others in the table. + do i2 = i1 + 1, mct_nrows (table) { + + # Get second symbol columns. + sym2 = mct_geti (table, i2, 1) + col2 = pr_gsymi (sym2, PINPCOL) + errcol2 = pr_gsymi (sym2, PINPERRCOL) + wtscol2 = pr_gsymi (sym2, PINPWTSCOL) + + # Skip spare variable. + if (pr_gsymi (sym2, PINPSPARE) == YES) + next + + # Check first symbol against the second symbol. + if ((col1 == col2) || + #(!IS_INDEFI (errcol2) && (col1 == errcol2)) || + #(!IS_INDEFI (wtscol2) && (col1 == wtscol2)) || + #(!IS_INDEFI (errcol1) && (col2 == errcol1)) || + #(!IS_INDEFI (wtscol1) && (col2 == wtscol1)) || + (!IS_INDEFI (errcol1) && !IS_INDEFI (errcol2) && + (errcol1 == errcol2)) || + (!IS_INDEFI (wtscol1) && !IS_INDEFI (wtscol2) && + (wtscol1 == wtscol2)) || + (!IS_INDEFI (errcol1) && !IS_INDEFI (wtscol2) && + (errcol1 == wtscol2)) || + (!IS_INDEFI (errcol2) && !IS_INDEFI (wtscol1) && + (errcol2 == wtscol1))) { + call sprintf (Memc[aux], SZ_LINE, + "Duplicate column for input variables [%s] and [%s]") + call pargstr (Memc[pr_xgetname (sym1)]) + call pargstr (Memc[pr_xgetname (sym2)]) + call pr_error (Memc[aux], PERR_WARNING) + } + } + } + + call sfree (sp) +end diff --git a/noao/digiphot/photcal/parser/prget.x b/noao/digiphot/photcal/parser/prget.x new file mode 100644 index 00000000..aa30d2e7 --- /dev/null +++ b/noao/digiphot/photcal/parser/prget.x @@ -0,0 +1,928 @@ +.help prget +Low Level Parser Retrieval + +These procedures retrieve parameters (attributes) from the parser, symbols, +symbol variables, symbol derivatives, and symbol fitting parameters, stored +in the parser common, and the parser symbol table. +.sp +These should be the ONLY procedures that access the parser common and symbol +table directly, by using the macro definitions in prtable.h. +All other procedures should try to use these procedures as the entry point to +access any common or symbol table parameter. + +.nf +Entry points: + + int = pr_getsym (name) Get symbol from name + + pointer = pr_xgetname (offset) Get charp. from symbol pointer + + int = pr_gsym (number, type) Get symbol from number and type + + value = pr_get[ip] (param) Get general integer parameter + + value = pr_gsym[cirp] (offset, param) Get symbol parameter + + value = pr_gvar[i] (offset, nv, param) Get variable parameter + value = pr_gpar[ir] (offset, np, param) Get fitting param. parameter + value = pr_gder[cp] (offset, nd, param) Get derivative parameter + +.fi +.endhelp + +include "../lib/parser.h" +include "../lib/prstruct.h" + + +# PR_GETSYM -- Get symbol offset from symbol name. + +int procedure pr_getsym (name) + +char name[ARB] # symbol name + +include "parser.com" + +int pr_offset() +pointer stfind() + +begin + # Return symbol pointer + return (pr_offset (stfind (symtable, name))) +end + + +# PR_XGETNAME -- Get symbol character pointer from symbol offset. The 'X' +# is necessary to remove a system library symbol collision. + +pointer procedure pr_xgetname (offset) + +pointer offset # symbol offset + +pointer sym + +include "parser.com" + +pointer stname() +pointer pr_pointer() + +begin + # Get symbol pointer + sym = pr_pointer (offset) + + # Check symbol pointer + if (sym != NULL) + return (stname (symtable, sym)) + else + return (NULL) +end + + +# PR_GSYM -- Get symbol by number, and type. + +int procedure pr_gsym (number, type) + +int number # quantity number +int type # type + +int aux + +include "parser.com" + +int mct_nrows() +int mct_geti() + +begin + # Brach on parameter type + switch (type) { + case PTY_OBSVAR: + aux = mct_nrows (obstable) - number + 1 + return (mct_geti (obstable, aux, 1)) + + case PTY_CATVAR: + aux = mct_nrows (cattable) - number + 1 + return (mct_geti (cattable, aux, 1)) + + case PTY_FITPAR, PTY_CONST: + aux = mct_nrows (partable) - number + 1 + return (mct_geti (partable, aux, 1)) + + case PTY_SETEQ: + aux = mct_nrows (settable) - number + 1 + return (mct_geti (settable, aux, 1)) + + case PTY_EXTEQ: + aux = mct_nrows (exttable) - number + 1 + return (mct_geti (exttable, aux, 1)) + + case PTY_TRNEQ: + aux = mct_nrows (trntable) - number + 1 + return (mct_geti (trntable, aux, 1)) + + default: + call error (type, "pr_gsym: Unknown parameter") + } +end + + +# PR_GETI -- Get parser integer parameter. + +int procedure pr_geti (param) + +int param # parameter + +include "parser.com" + +begin + # Brach on parameter type + switch (param) { + case NERRORS: + return (nerrors) + + case NWARNINGS: + return (nwarnings) + + case NOBSVARS: + return (nobsvars) + + case NCATVARS: + return (ncatvars) + + case NFITPARS: + return (nfitpars) + + case NTOTPARS: + return (ntotpars) + + case NSETEQS: + return (nseteqs) + + case NEXTEQS: + return (nexteqs) + + case NTRNEQS: + return (ntrneqs) + + case MINCOL: + return (mincol) + + case MINOBSCOL: + return (minobscol) + + case MAXOBSCOL: + return (maxobscol) + + case MINCATCOL: + return (mincatcol) + + case MAXCATCOL: + return (maxcatcol) + + case FLAGEQSECT: + return (flageqsect) + + case FLAGERRORS: + return (flagerrors) + + default: + call error (param, "pr_geti: Unknown parameter") + } +end + + +# PR_GETP -- Get parser pointer parameter. + +pointer procedure pr_getp (param) + +int param # parameter + +include "parser.com" + +begin + # Brach on parameter type + switch (param) { + case SYMTABLE: + return (symtable) + + case OBSTABLE: + return (obstable) + + case CATTABLE: + return (cattable) + + case PARTABLE: + return (partable) + + case SETTABLE: + return (settable) + + case EXTTABLE: + return (exttable) + + case TRNTABLE: + return (trntable) + + case TRCATTABLE: + return (trcattable) + + case TROBSTABLE: + return (trobstable) + + case TFCATTABLE: + return (tfcattable) + + case TFOBSTABLE: + return (tfobstable) + + case TPARTABLE: + return (tpartable) + + default: + call error (param, "pr_getp: Unknown parameter") + } +end + + +# PR_GSYMC -- Get symbol character pointer parameter. + +pointer procedure pr_gsymc (offset, param) + +int offset # symbol offset +int param # parameter + +pointer sym + +pointer pr_pointer(), pr_charp() + +begin + # Get symbol pointer + sym = pr_pointer (offset) + + # Check symbol pointer + if (sym == NULL) + call error (0, "pr_gsymc: Null symbol pointer") + + # Brach on parameter type + switch (param) { + case PSEQEQ: + if (PSYM_SUB (sym) != NULL) + return (pr_charp (PSEQ_EQ (PSYM_SUB (sym)))) + else + call error (0, "pr_gsymc: Null equation pointer (PSEQEQ)") + + case PSEQERROR: + if (PSYM_SUB (sym) != NULL) + return (pr_charp (PSEQ_ERROR (PSYM_SUB (sym)))) + else + call error (0, "pr_gsymc: Null equation pointer (PSEQERROR)") + + case PSEQERRMIN: + if (PSYM_SUB (sym) != NULL) + return (pr_charp (PSEQ_ERRMIN (PSYM_SUB (sym)))) + else + call error (0, "pr_gsymc: Null equation pointer (PSEQERRMIN)") + + case PSEQERRMAX: + if (PSYM_SUB (sym) != NULL) + return (pr_charp (PSEQ_ERRMAX (PSYM_SUB (sym)))) + else + call error (0, "pr_gsymc: Null equation pointer (PSEQERRMAX)") + + case PSEQWEIGHT: + if (PSYM_SUB (sym) != NULL) + return (pr_charp (PSEQ_WEIGHT (PSYM_SUB (sym)))) + else + call error (0, "pr_gsymc: Null equation pointer (PSEQWEIGHT)") + + case PSEQWTSMIN: + if (PSYM_SUB (sym) != NULL) + return (pr_charp (PSEQ_WTSMIN (PSYM_SUB (sym)))) + else + call error (0, "pr_gsymc: Null equation pointer (PSEQWTSMIN)") + + case PSEQWTSMAX: + if (PSYM_SUB (sym) != NULL) + return (pr_charp (PSEQ_WTSMAX (PSYM_SUB (sym)))) + else + call error (0, "pr_gsymc: Null equation pointer (PSEQWTSMAX)") + + case PTEQFIT: + if (PSYM_SUB (sym) != NULL) + return (pr_charp (PTEQ_FIT (PSYM_SUB (sym)))) + else + call error (0, "pr_gsymc: Null equation pointer (PTEQFIT)") + + case PTEQREF: + if (PSYM_SUB (sym) != NULL) + return (pr_charp (PTEQ_REF (PSYM_SUB (sym)))) + else + call error (0, "pr_gsymc: Null equation pointer (PTEQREF)") + + case PTEQERROR: + if (PSYM_SUB (sym) != NULL) + return (pr_charp (PTEQ_ERROR (PSYM_SUB (sym)))) + else + call error (0, "pr_gsymc: Null equation pointer (PTEQERROR)") + + case PTEQERRMIN: + if (PSYM_SUB (sym) != NULL) + return (pr_charp (PTEQ_ERRMIN (PSYM_SUB (sym)))) + else + call error (0, "pr_gsymc: Null equation pointer (PTEQERRMIN)") + + case PTEQERRMAX: + if (PSYM_SUB (sym) != NULL) + return (pr_charp (PTEQ_ERRMAX (PSYM_SUB (sym)))) + else + call error (0, "pr_gsymc: Null equation pointer (PTEQERRMAX)") + + case PTEQWEIGHT: + if (PSYM_SUB (sym) != NULL) + return (pr_charp (PTEQ_WEIGHT (PSYM_SUB (sym)))) + else + call error (0, "pr_gsymc: Null equation pointer (PTEQWEIGHT)") + + case PTEQWTSMIN: + if (PSYM_SUB (sym) != NULL) + return (pr_charp (PTEQ_WTSMIN (PSYM_SUB (sym)))) + else + call error (0, "pr_gsymc: Null equation pointer (PTEQWTSMIN)") + + case PTEQWTSMAX: + if (PSYM_SUB (sym) != NULL) + return (pr_charp (PTEQ_WTSMAX (PSYM_SUB (sym)))) + else + call error (0, "pr_gsymc: Null equation pointer (PTEQWTSMAX)") + + case PTEQXPLOT: + if (PSYM_SUB (sym) != NULL) + return (pr_charp (PTEQ_XPLOT (PSYM_SUB (sym)))) + else + call error (0, "pr_gsymc: Null equation pointer (PTEQXPLOT)") + + case PTEQYPLOT: + if (PSYM_SUB (sym) != NULL) + return (pr_charp (PTEQ_YPLOT (PSYM_SUB (sym)))) + else + call error (0, "pr_gsymc: Null equation pointer (PTEQYPLOT)") + + default: + call error (param, "pr_gsymc: Unknown parameter") + } +end + + +# PR_GSYMI -- Get symbol integer parameter. + +int procedure pr_gsymi (offset, param) + +int offset # symbol offset +int param # parameter + +pointer sym + +pointer pr_pointer() + +begin + # Get symbol pointer + sym = pr_pointer (offset) + + # Check symbol pointer + if (sym == NULL) + call error (0, "pr_gsymi: Null symbol offset") + + # Brach on parameter type + switch (param) { + case PSYMTYPE: + return (PSYM_TYPE (sym)) + + case PSYMNUM: + return (PSYM_NUM (sym)) + + case PINPCOL: + if (PSYM_SUB (sym) != NULL) + return (PINP_COL (PSYM_SUB (sym))) + else + call error (0, "pr_gsymi: Null equation pointer (PINPCOL)") + + case PINPERRCOL: + if (PSYM_SUB (sym) != NULL) + return (PINP_ERRCOL (PSYM_SUB (sym))) + else + call error (0, "pr_gsymi: Null equation pointer (PINPERRCOL)") + + case PINPWTSCOL: + if (PSYM_SUB (sym) != NULL) + return (PINP_WTSCOL (PSYM_SUB (sym))) + else + call error (0, "pr_gsymi: Null equation pointer (PINPWTSCOL)") + + case PINPSPARE: + if (PSYM_SUB (sym) != NULL) + return (PINP_SPARE (PSYM_SUB (sym))) + else + call error (0, "pr_gsymi: Null equation pointer (PINPSPARE)") + + case PTEQNRCAT: + if (PSYM_SUB (sym) != NULL) + return (PTEQ_NRCAT (PSYM_SUB (sym))) + else + call error (0, "pr_gsymi: Null equation pointer (PTEQNRCAT)") + + case PTEQNROBS: + if (PSYM_SUB (sym) != NULL) + return (PTEQ_NROBS (PSYM_SUB (sym))) + else + call error (0, "pr_gsymi: Null equation pointer (PTEQNROBS)") + + case PTEQNRVAR: + if (PSYM_SUB (sym) != NULL) + return (PTEQ_NRVAR (PSYM_SUB (sym))) + else + call error (0, "pr_gsymi: Null equation pointer (PTEQNRVAR)") + + case PTEQNFCAT: + if (PSYM_SUB (sym) != NULL) + return (PTEQ_NFCAT (PSYM_SUB (sym))) + else + call error (0, "pr_gsymi: Null equation pointer (PTEQNFCAT)") + + case PTEQNFOBS: + if (PSYM_SUB (sym) != NULL) + return (PTEQ_NFOBS (PSYM_SUB (sym))) + else + call error (0, "pr_gsymi: Null equation pointer (PTEQNFOBS)") + + case PTEQNFVAR: + if (PSYM_SUB (sym) != NULL) + return (PTEQ_NFVAR (PSYM_SUB (sym))) + else + call error (0, "pr_gsymi: Null equation pointer (PTEQNFVAR)") + + case PTEQNVAR: + if (PSYM_SUB (sym) != NULL) + return (PTEQ_NVAR (PSYM_SUB (sym))) + else + call error (0, "pr_gsymi: Null equation pointer (PTEQNVAR)") + + case PTEQNPAR: + if (PSYM_SUB (sym) != NULL) + return (PTEQ_NPAR (PSYM_SUB (sym))) + else + call error (0, "pr_gsymi: Null equation pointer (PTEQNPAR)") + + case PTEQNFPAR: + if (PSYM_SUB (sym) != NULL) + return (PTEQ_NFPAR (PSYM_SUB (sym))) + else + call error (0, "pr_gsymi: Null equation pointer (PTEQNFPAR)") + + default: + call error (param, "pr_gsymi: Unknown parameter") + } +end + + +# PR_GSYMR -- Get symbol real parameter. + +real procedure pr_gsymr (offset, param) + +pointer offset # symbol offset +int param # parameter + +pointer sym + +pointer pr_pointer() + +begin + # Get symbol pointer + sym = pr_pointer (offset) + + # Check symbol pointer + if (sym == NULL) + call error (0, "pr_gsymr: Null symbol pointer") + + # Brach on parameter type + switch (param) { + case PFITVALUE: + if (PSYM_SUB (sym) != NULL) + return (PFIT_VALUE (PSYM_SUB (sym))) + else + call error (0, "pr_gsymr: Null equation pointer (PFITVALUE)") + + case PFITDELTA: + if (PSYM_SUB (sym) != NULL) + return (PFIT_DELTA (PSYM_SUB (sym))) + else + call error (0, "pr_gsymr: Null equation pointer (PFITDELTA)") + + default: + call error (param, "pr_gsymr: Unknown parameter") + } +end + + +# PR_GSYMP -- Get symbol pointer parameter. + +pointer procedure pr_gsymp (offset, param) + +int offset # symbol offset +int param # parameter + +pointer sym + +pointer pr_pointer() + +begin + # Get symbol pointer + sym = pr_pointer (offset) + + # Check symbol pointer + if (sym == NULL) + call error (0, "pr_gsymp: Null symbol pointer") + + # Brach on parameter type + switch (param) { + case PSYMSUB: + return (PSYM_SUB (sym)) + + case PSEQRPNEQ: + if (PSYM_SUB (sym) != NULL) + return (PSEQ_RPNEQ (PSYM_SUB (sym))) + else + call error (0, "pr_gsymp: Null equation pointer (PSEQRPNEQ)") + + case PSEQRPNERROR: + if (PSYM_SUB (sym) != NULL) + return (PSEQ_RPNERROR (PSYM_SUB (sym))) + else + call error (0, "pr_gsymp: Null equation pointer (PSEQRPNERROR)") + + case PSEQRPNERRMIN: + if (PSYM_SUB (sym) != NULL) + return (PSEQ_RPNERRMIN (PSYM_SUB (sym))) + else + call error (0, + "pr_gsymp: Null equation pointer (PSEQRPNERRMIN)") + + case PSEQRPNERRMAX: + if (PSYM_SUB (sym) != NULL) + return (PSEQ_RPNERRMAX (PSYM_SUB (sym))) + else + call error (0, + "pr_gsymp: Null equation pointer (PSEQRPNERRMAX)") + + case PSEQRPNWEIGHT: + if (PSYM_SUB (sym) != NULL) + return (PSEQ_RPNWEIGHT (PSYM_SUB (sym))) + else + call error (0, + "pr_gsymp: Null equation pointer (PSEQRPNWEIGHT)") + + case PSEQRPNWTSMIN: + if (PSYM_SUB (sym) != NULL) + return (PSEQ_RPNWTSMIN (PSYM_SUB (sym))) + else + call error (0, + "pr_gsymp: Null equation pointer (PSEQRPNWTSMIN)") + + case PSEQRPNWTSMAX: + if (PSYM_SUB (sym) != NULL) + return (PSEQ_RPNWTSMAX (PSYM_SUB (sym))) + else + call error (0, "pr_gsymp: Null equation pointer (PSEQRPNWTSMAX") + + case PTEQRPNFIT: + if (PSYM_SUB (sym) != NULL) + return (PTEQ_RPNFIT (PSYM_SUB (sym))) + else + call error (0, "pr_gsymp: Null equation pointer (PTEQRPNFIT)") + + case PTEQRPNREF: + if (PSYM_SUB (sym) != NULL) + return (PTEQ_RPNREF (PSYM_SUB (sym))) + else + call error (0, "pr_gsymp: Null equation pointer (PTEQRPNREF)") + + case PTEQRPNERROR: + if (PSYM_SUB (sym) != NULL) + return (PTEQ_RPNERROR (PSYM_SUB (sym))) + else + call error (0, "pr_gsymp: Null equation pointer (PTEQRPNERROR)") + + case PTEQRPNERRMIN: + if (PSYM_SUB (sym) != NULL) + return (PTEQ_RPNERRMIN (PSYM_SUB (sym))) + else + call error (0, + "pr_gsymp: Null equation pointer (PTEQRPNERRMIN)") + + case PTEQRPNERRMAX: + if (PSYM_SUB (sym) != NULL) + return (PTEQ_RPNERRMAX (PSYM_SUB (sym))) + else + call error (0, + "pr_gsymp: Null equation pointer (PTEQRPNERRMAX)") + + case PTEQRPNWEIGHT: + if (PSYM_SUB (sym) != NULL) + return (PTEQ_RPNWEIGHT (PSYM_SUB (sym))) + else + call error (0, + "pr_gsymp: Null equation pointer (PTEQRPNWEIGHT)") + + case PTEQRPNWTSMIN: + if (PSYM_SUB (sym) != NULL) + return (PTEQ_RPNWTSMIN (PSYM_SUB (sym))) + else + call error (0, + "pr_gsymp: Null equation pointer (PTEQRPNWTSMIN)") + + case PTEQRPNWTSMAX: + if (PSYM_SUB (sym) != NULL) + return (PTEQ_RPNWTSMAX (PSYM_SUB (sym))) + else + call error (0, "pr_gsymp: Null equation pointer (PTEQRPNWTSMAX") + + case PTEQRPNXPLOT: + if (PSYM_SUB (sym) != NULL) + return (PTEQ_RPNXPLOT (PSYM_SUB (sym))) + else + call error (0, "pr_gsymp: Null equation pointer (PTEQRPNXPLOT)") + + case PTEQRPNYPLOT: + if (PSYM_SUB (sym) != NULL) + return (PTEQ_RPNYPLOT (PSYM_SUB (sym))) + else + call error (0, "pr_gsymp: Null equation pointer (PTEQRPNYPLOT)") + + case PTEQSREFVAR: + if (PSYM_SUB (sym) != NULL) + return (PTEQ_SREFVAR (PSYM_SUB (sym))) + else + call error (0, "pr_gsymp: Null equation pointer (PTEQSREFVAR)") + + case PTEQSREFCNT: + if (PSYM_SUB (sym) != NULL) + return (PTEQ_SREFCNT (PSYM_SUB (sym))) + else + call error (0, "pr_gsymp: Null equation pointer (PTEQSREFCNT)") + + case PTEQSFITVAR: + if (PSYM_SUB (sym) != NULL) + return (PTEQ_SFITVAR (PSYM_SUB (sym))) + else + call error (0, "pr_gsymp: Null equation pointer (PTEQSFITVAR)") + + case PTEQSFITCNT: + if (PSYM_SUB (sym) != NULL) + return (PTEQ_SFITCNT (PSYM_SUB (sym))) + else + call error (0, "pr_gsymp: Null equation pointer (PTEQSFITCNT)") + + case PTEQSPAR: + if (PSYM_SUB (sym) != NULL) + return (PTEQ_SPAR (PSYM_SUB (sym))) + else + call error (0, "pr_gsymp: Null equation pointer (PTEQSPAR)") + + case PTEQSPARVAL: + if (PSYM_SUB (sym) != NULL) + return (PTEQ_SPARVAL (PSYM_SUB (sym))) + else + call error (0, "pr_gsymp: Null equation pointer (PTEQSPARVAL)") + + case PTEQSPLIST: + if (PSYM_SUB (sym) != NULL) + return (PTEQ_SPLIST (PSYM_SUB (sym))) + else + call error (0, "pr_gsymp: Null equation pointer (PTEQSPLIST)") + + default: + call error (param, "pr_gsymp: Unknown parameter") + } +end + + +# PR_GVARI -- Get variable integer parameter. + +int procedure pr_gvari (offset, nv, param) + +int offset # variable offset +int nv # variable number +int param # parameter + +pointer sym + +pointer pr_pointer() + +begin + # Get symbol pointer + sym = pr_pointer (offset) + + # Check symbol pointer + if (sym == NULL) + call error (0, "pr_gvari: Null symbol pointer") + + # Branch on parameter + switch (param) { + case PTEQREFVAR: + if (PSYM_SUB (sym) != NULL) { + if (nv >= 1 || nv <= PTEQ_NVAR (PSYM_SUB (sym))) + return (PTEQ_REFVAR (PSYM_SUB (sym), nv)) + else + call error (0, + "pr_gvari: Not a valid parameter number (PTEQREFVAR)") + } else + call error (0, "pr_gvari: Null equation pointer (PTEQREFVAR)") + + case PTEQREFCNT: + if (PSYM_SUB (sym) != NULL) { + if (nv >= 1 || nv <= PTEQ_NVAR (PSYM_SUB (sym))) + return (PTEQ_REFCNT (PSYM_SUB (sym), nv)) + else + call error (0, + "pr_gvari: Not a valid parameter number (PTEQREFCNT)") + } else + call error (0, "pr_gvari: Null equation pointer (PTEQREFCNT)") + + case PTEQFITVAR: + if (PSYM_SUB (sym) != NULL) { + if (nv >= 1 || nv <= PTEQ_NVAR (PSYM_SUB (sym))) + return (PTEQ_FITVAR (PSYM_SUB (sym), nv)) + else + call error (0, + "pr_gvari: Not a valid parameter number (PTEQFITVAR)") + } else + call error (0, "pr_gvari: Null equation pointer (PTEQFITVAR)") + + case PTEQFITCNT: + if (PSYM_SUB (sym) != NULL) { + if (nv >= 1 || nv <= PTEQ_NVAR (PSYM_SUB (sym))) + return (PTEQ_FITCNT (PSYM_SUB (sym), nv)) + else + call error (0, + "pr_gvari: Not a valid parameter number (PTEQFITCNT)") + } else + call error (0, "pr_gvari: Null equation pointer (PTEQFITCNT)") + + default: + call error (param, "pr_gvari: Unknown parameter") + } +end + + +# PR_GPARI -- Get fitting parameter integer parameter. + +int procedure pr_gpari (offset, np, param) + +int offset # symbol offset +int np # parameter number +int param # parameter + +pointer sym + +pointer pr_pointer() + +begin + # Get symbol pointer + sym = pr_pointer (offset) + + # Check symbol pointer + if (sym == NULL) + call error (0, "pr_gpari: Null symbol pointer") + + # Brach on parameter + switch (param) { + case PTEQPAR: + if (PSYM_SUB (sym) != NULL) { + if (np >= 1 || np <= PTEQ_NPAR (PSYM_SUB (sym))) + return (PTEQ_PAR (PSYM_SUB (sym), np)) + else + call error (0, "pr_gpari: Not a valid parameter number (PTEQPAR)") + } else + call error (0, "pr_gpari: Null equation pointer (PTEQPAR)") + + case PTEQPLIST: + if (PSYM_SUB (sym) != NULL) { + if (np >= 1 || np <= PTEQ_NPAR (PSYM_SUB (sym))) + return (PTEQ_PLIST (PSYM_SUB (sym), np)) + else + call error (0, "pr_gpari: Not a valid parameter number (PTEQPLIST)") + } else + call error (0, "pr_gpari: Null equation pointer (PTEQPLIST)") + + default: + call error (param, "pr_gpari: Unknown parameter") + } +end + + +# PR_GPARR -- Get fitting parameter real parameter. + +real procedure pr_gparr (offset, np, param) + +int offset # symbol offset +int np # parameter number +int param # parameter + +pointer sym + +pointer pr_pointer() + +begin + # Get symbol pointer + sym = pr_pointer (offset) + + # Check symbol pointer + if (sym == NULL) + call error (0, "pr_gparr: Null symbol pointer") + + # Brach on parameter + switch (param) { + case PTEQPARVAL: + if (PSYM_SUB (sym) != NULL) { + if (np >= 1 || np <= PTEQ_NPAR (PSYM_SUB (sym))) + return (PTEQ_PARVAL (PSYM_SUB (sym), np)) + else + call error (0, "pr_gparr: Not a valid parameter number (PTEQPARVAL)") + } else + call error (0, "pr_gparr: Null equation pointer (PTEQPARVAL)") + + default: + call error (param, "pr_gparr: Unknown parameter") + } +end + + +# PR_GDERC -- Get derivative character pointer parameter. + +pointer procedure pr_gderc (offset, nd, param) + +pointer offset # symbol offset +int nd # derivative number +int param # parameter + +pointer sym + +pointer pr_pointer(), pr_charp() + +begin + # Get symbol pointer + sym = pr_pointer (offset) + + # Check symbol pointer + if (sym == NULL) + call error (0, "pr_gderc: Null symbol pointer") + + # Branch on parameter + switch (param) { + case PTEQDER: + if (PSYM_SUB (sym) != NULL) { + if (nd >= 1 || nd <= PTEQ_NPAR (PSYM_SUB (sym))) + return (pr_charp (PTEQ_DER (PSYM_SUB (sym), nd))) + else + call error (0, "pr_gderc: Not a valid derivative number (PTEQDER)") + } else + call error (0, "pr_gderc: Null equation pointer (PTEQDER)") + + default: + call error (param, "pr_gderc: Unknown parameter") + } +end + + +# PR_GDERP -- Get derivative pointer parameter. + +pointer procedure pr_gderp (offset, nd, param) + +int offset # symbol offset +int nd # derivative number +int param # parameter + +pointer sym + +pointer pr_pointer() + +begin + # Get symbol pointer + sym = pr_pointer (offset) + + # Check symbol pointer + if (sym == NULL) + call error (0, "pr_gderp: Null symbol pointer") + + # Branch on parameter + switch (param) { + case PTEQRPNDER: + if (PSYM_SUB (sym) != NULL) { + if (nd >= 1 || nd <= PTEQ_NPAR (PSYM_SUB (sym))) + return (PTEQ_RPNDER (PSYM_SUB (sym), nd)) + else + call error (0, "pr_gderp: Not a valid derivative number (PTEQRPNDER)") + } else + call error (0, "pr_gderp: Null equation pointer (PTEQRPNDER)") + + default: + call error (param, "pr_gderp: Unknown parameter") + } +end diff --git a/noao/digiphot/photcal/parser/prlexer.x b/noao/digiphot/photcal/parser/prlexer.x new file mode 100644 index 00000000..35e6a4c7 --- /dev/null +++ b/noao/digiphot/photcal/parser/prlexer.x @@ -0,0 +1,337 @@ +include <ctype.h> +include <lexnum.h> +include "../lib/lexer.h" +include "../lib/prtoken.h" + + +# PR_LEXER - Lexical analizer for the parser of the configuration file. + +int procedure pr_lexer (fd, yylval) + +int fd # input file descriptor +pointer yylval # YYLVAL token pointer + +char key[SZ_LINE] +int tok # next token +int ip, n + +include "lexer.com" + +bool strne() +int ctor() +int strdic(), strlen() +int lexnum() +int getline() + +begin + # Stay scanning the input file until a valid or + # error token is found + repeat { + + # Skip whitespaces and blank lines + while (line[pos] == '\n' || IS_WHITE (line[pos])) { + + # If next character is a newline count + # lines, and read a new line from file + if (line[pos] == '\n') { + nlines = nlines + 1 + pos = 1 + if (getline (fd, line) == EOF) { + call strcpy ("EOF", LEX_ID (yylval), SZ_LINE) + return (EOFILE) + } + } else + pos = pos + 1 + } + + # Test first valid character + if (IS_ALPHA (line[pos])) { # identifier or keyword + + # Read identifier + for (ip=1; IS_ALNUM (line[pos]); ip=ip+1) { + id[ip] = line[pos] + pos = pos + 1 + } + id[ip] = EOS + + # Check for keyword. Abreviations of keywords are allowed + # to up to a certain number of characters, but the + # identifier returned by the lexer should contain the full + # keyword name. + + n = strdic (id, key, SZ_LINE, KEYWORDS) + if (n > 0 && strlen (id) >= ABBREVIATE) { + call strcpy (key, id, SZ_LINE) + switch (n) { + case K_CATALOG: + tok = CATSECT + break + case K_OBSERVATION: + tok = OBSSECT + break + case K_EXTINCTION: + tok = EXTSECT + break + case K_TRANSFORMATION: + tok = TRNSECT + break + case K_FIT: + tok = FITID + break + case K_CONSTANT: + tok = CONSTID + break + case K_DELTA: + tok = DELTAID + break + case K_ERROR: + tok = ERRORID + break + case K_WEIGHT: + tok = WEIGHTID + break + case K_MIN: + tok = MINID + break + case K_MAX: + tok = MAXID + break + case K_SET: + tok = SETID + break + case K_DERIVATIVE: + tok = DERIVID + break + case K_PLOT: + tok = PLOTID + break + default: + call error (0, "pr_lexxer: Unknown keyword token") + } + } + + # Check for function. Anything abbreviated, + # or not matching is and identifier. + + n = strdic (id, key, SZ_LINE, FUNCTIONS) + if (n == 0) { + tok = IDENTIFIER + break + } else if (strne (id, key)) { + tok = IDENTIFIER + break + } + switch (n) { + case K_ABS: # absolute value + tok = F_ABS + break + case K_ACOS: # arc cosine + tok = F_ACOS + break + case K_ASIN: # arc sine + tok = F_ASIN + break + case K_ATAN: # arc tangent + tok = F_ATAN + break + case K_COS: # cosine + tok = F_COS + break + case K_EXP: # exponential + tok = F_EXP + break + case K_LOG: # natural logarithm + tok = F_LOG + break + case K_LOG10: # decimal logarithm + tok = F_LOG10 + break + case K_SIN: # sine + tok = F_SIN + break + case K_SQRT: # square root + tok = F_SQRT + break + case K_TAN: # tangent + tok = F_TAN + break + default: + call error (0, "pr_lexer: Unknown identifier") + } + + } else if (IS_DIGIT (line[pos]) || line[pos] == '.') { # number + + # Process number + switch (lexnum (line, pos, n)) { + case LEX_DECIMAL: + tok = INUMBER + case LEX_REAL: + tok = RNUMBER + default: + tok = ERR + } + + # Copy whatever was processed + # to the identifier + do ip = 1, n + id[ip] = line[pos + ip - 1] + id[n + 1] = EOS + + # Advance to next token and + # break the loop + pos = pos + n + break + + } else if (line[pos] == '(') { # left parenthesis + + # Copy input character to identifier, set + # token, and advance to next character before + # breaking the loop + call strcpy ("(", id, SZ_LINE) + tok = LPAR + pos = pos + 1 + break + + } else if (line[pos] == ')') { # right parenthesis + + # Copy input character to identifier, set + # token, and advance to next character before + # breaking the loop + call strcpy (")", id, SZ_LINE) + tok = RPAR + pos = pos + 1 + break + + } else if (line[pos] == '+') { # plus + + # Copy input character to identifier, set + # token, and advance to next character before + # breaking the loop + call strcpy ("+", id, SZ_LINE) + tok = PLUS + pos = pos + 1 + break + + } else if (line[pos] == '-') { # minus + + # Copy input character to identifier, set + # token, and advance to next character before + # breaking the loop + call strcpy ("-", id, SZ_LINE) + tok = MINUS + pos = pos + 1 + break + + } else if (line[pos] == '*') { # star and double star + + # Advance to next character to see if + # it's another star + pos = pos + 1 + if (line[pos] == '*') { + + # Copy input character to identifier, set + # token, and advance to next character before + # breaking the loop + call strcpy ("**", id, SZ_LINE) + tok = EXPON + pos = pos + 1 + break + + } else { + + # Copy input characters to identifier, set + # token, and break the loop + call strcpy ("*", id, SZ_LINE) + tok = STAR + break + } + + } else if (line[pos] == '/') { # slash + + # Copy input character to identifier, set + # token, and advance to next character before + # breaking the loop + call strcpy ("/", id, SZ_LINE) + tok = SLASH + pos = pos + 1 + break + + } else if (line[pos] == '=') { # equal + + # Copy input character to identifier, set + # token, and advance to next character before + # breaking the loop + call strcpy ("=", id, SZ_LINE) + tok = EQUAL + pos = pos + 1 + break + + } else if (line[pos] == ',') { # comma + + # Copy input character to identifier, set + # token, and advance to next character before + # breaking the loop + call strcpy (",", id, SZ_LINE) + tok = COMMA + pos = pos + 1 + break + + } else if (line[pos] == ':') { # colon + + # Copy input character to identifier, set + # token, and advance to next character before + # breaking the loop + call strcpy (":", id, SZ_LINE) + tok = COLON + pos = pos + 1 + break + + } else if (line[pos] == ';') { # semicolon + + # Copy input character to identifier, set + # token, and advance to next character before + # breaking the loop + call strcpy (";", id, SZ_LINE) + tok = SEMICOLON + pos = pos + 1 + break + + } else if (line[pos] == '#') { # comment + + # Skip current line + pos = strlen (line) + + } else { # none of the above + + # All characters not included in the previous + # categories are treated as errors + id[1] = line[pos] + id[2] = EOS + tok = ERR + + # Advance to next character before + # breaking the loop + pos = pos + 1 + break + } + + } # repeat + + # Update yylval structure + LEX_TOK (yylval) = tok + call strcpy (id, LEX_ID (yylval), SZ_LINE) + if (tok == INUMBER || tok == RNUMBER) { + ip = 1 + n = ctor (LEX_ID (yylval), ip, LEX_VAL (yylval)) + } else + LEX_VAL (yylval) = INDEFR + + # Debug + #call eprintf ("(tok=%d) (id=%s) (rval=%g)\n") + #call pargi (LEX_TOK (yylval)) + #call pargstr (LEX_ID (yylval)) + #call pargi (LEX_VAL (yylval)) + + # Return token value + return (tok) +end diff --git a/noao/digiphot/photcal/parser/prmap.x b/noao/digiphot/photcal/parser/prmap.x new file mode 100644 index 00000000..587769e4 --- /dev/null +++ b/noao/digiphot/photcal/parser/prmap.x @@ -0,0 +1,200 @@ +.help prmap +Column/variable mapping. + +These procedures map input column numbers, specified in the configuration +file, with variable numbers that are used to index information in memory +tables. Variable numbers are assigned internally by the parser. +.sp +The main goal of these routines is to provide a fast way of converting from +column number to a variable number, if any, since this kind of operation is +performed by the i/o routines for eavery column in all lines in each input +file. +.sp +First the calling program should map columns with variables in the catalog +or observation section of the configuration file, by using either pr_obsmap() +or pr_catmap(). Once the mapping is built the corresponding variable number +for a given column can be obtained with pr_findmap(). All memory allocated +by these procedures is free by calling pr_unmap(). +.nf + +Main entry points: + + pr_obsmap (table, nobs) Build observational variables map + pr_catmap (table, ncat) Build catalog variables map +int pr_findmap (table, col, nums, max_nums) Find var numbers for given column +int pr_findmap1 (table, col) Find first var number for given column + pr_unmap (table) Free space of mapped variables + +Low level entry points: + + pr_inmap (table, nvars, type) Map observational/catalog var. +.endhelp + +include "../lib/parser.h" +include "../lib/prdefs.h" + +# Table structure +define LEN_TABLE 5 # fixed section length +define TABLE_MIN Memi[$1+0] # minimum column number +define TABLE_MAX Memi[$1+1] # maximum column number +define TABLE_NVARS Memi[$1+2] # number of variables +define TABLE_PCOLS Memi[$1+3] # pointer to column indices +define TABLE_PNCOLS Memi[$1+4] # pointer to column indices count + + +# PR_OBSTAB -- Map program observational input variables. + +procedure pr_obsmap (table, nobs) + +pointer table # table pointer (output) +int nobs # number of observational variables (output) + +begin + # Tabulate the observational variables. + call pr_inmap (table, nobs, PTY_OBSVAR) +end + + +# PR_CATTAB -- Map catalog star input variables. + +procedure pr_catmap (table, ncat) + +pointer table # table pointer (output) +int ncat # number of catalog variables (output) + +begin + # Tabulate the catalog variables. + call pr_inmap (table, ncat, PTY_CATVAR) +end + + +# PR_INMAP -- Map input variables from the sequential variable table, and +# build a table with this mapping. A pointer to the map table is returned, +# for future use by pr_findmap(). + +procedure pr_inmap (table, nvars, type) + +pointer table # table pointer (output) +int nvars # number of variables (output) +int type # symbol type + +int i, mincol, maxcol, sym, col +pointer pcols, pncols, colptr +int pr_geti(), pr_gsym(), pr_gsymi() + +begin + # Get the sequential table pointer for the symbol type, and the + # maximum and minimum number of columns + if (type == PTY_OBSVAR) { + nvars = pr_geti (NOBSVARS) + mincol = pr_geti (MINOBSCOL) + maxcol = pr_geti (MAXOBSCOL) + } else if (type == PTY_CATVAR) { + nvars = pr_geti (NCATVARS) + mincol = pr_geti (MINCATCOL) + maxcol = pr_geti (MAXCATCOL) + } else + call error (0, "pr_inmap: Illegal symbol type") + + # Allocate the basic table structure. + call malloc (table, LEN_TABLE, TY_STRUCT) + TABLE_MIN (table) = mincol + TABLE_MAX (table) = maxcol + TABLE_NVARS (table) = nvars + + # Initialize. + call malloc (pcols, maxcol * nvars, TY_INT) + call amovki (INDEFI, Memi[pcols], maxcol * nvars) + call calloc (pncols, maxcol, TY_INT) + + # Traverse symbols and store variable number at the corresponding + # table location indexed by column number. There may be more than + # one symbol per column number. + + do i = 1, nvars { + sym = pr_gsym (i, type) + col = pr_gsymi (sym, PINPCOL) + colptr = pcols + (col - 1) * nvars + Memi[pncols+col-1] + Memi[colptr] = pr_gsymi (sym, PSYMNUM) + Memi[pncols+col-1] = Memi[pncols+col-1] + 1 + } + + TABLE_PCOLS(table) = pcols + TABLE_PNCOLS(table) = pncols +end + + +# PR_FINDMAP -- Find the list of symbol numbers for a given input column. + +int procedure pr_findmap (table, col, indices, max_nindices) + +pointer table # table pointer +int col # input column +int indices[ARB] # output array of indices +int max_nindices # maximum permitted number of indices + +int nvars, nindices +pointer colptr + +begin + # Check pointer. + if (table == NULL) + call error (0, "pr_findmap: Null table pointer") + + # Check the table size. + nvars = TABLE_NVARS(table) + if (max_nindices < nvars) + call error (0, "pr_findmap: The output index array is too short") + + # Look for variable number. + if (col < TABLE_MIN (table) || col > TABLE_MAX (table)) { + nindices = 0 + call amovki (INDEFI, indices, nvars) + } else { + nindices = Memi[TABLE_PNCOLS(table)+col-1] + colptr = TABLE_PCOLS(table) + (col - 1) * nvars + call amovi (Memi[colptr], indices, nindices) + } + + return (nindices) +end + + +# PR_FINDMAP1 -- Find the symbol number for a given input column. + +int procedure pr_findmap1 (table, col) + +pointer table # table pointer +int col # input column + +begin + # Check pointer. + if (table == NULL) + call error (0, "pr_findmap: Null table pointer") + + # Look for variable number. + if (col < TABLE_MIN (table) || col > TABLE_MAX (table)) + return (INDEFI) + else + return (Memi[TABLE_PCOLS(table)+(col-1)*TABLE_NVARS(table)]) +end + + +# PR_UNMAP -- Free space of mapped variables. + +procedure pr_unmap (table) + +pointer table # table pointer + +begin + # Check pointer. + if (table == NULL) + call error (0, "pr_unmap: Null table pointer") + + # Free pointer table. + call mfree (TABLE_PCOLS(table), TY_INT) + call mfree (TABLE_PNCOLS(table), TY_INT) + + # Free table structure. + call mfree (table, TY_INT) +end diff --git a/noao/digiphot/photcal/parser/prparse.x b/noao/digiphot/photcal/parser/prparse.x new file mode 100644 index 00000000..a829ce85 --- /dev/null +++ b/noao/digiphot/photcal/parser/prparse.x @@ -0,0 +1,102 @@ +include "../lib/parser.h" +include "../lib/prdefs.h" + + +# PR_PARSE - Parser driver routine for the parser generated by xyacc. This +# procedure opens the configuration file, and call the parser generated by +# xyacc. It returns ERR if errors are found in the configuration file, and +# OK for no errors. All tables allocated by this procedure MUST be freed +# by the calling program if there are no errors. Otherwise they are freed +# before exiting the procedure. + +int procedure pr_parse (fname) + +char fname[ARB] # solution file name + +int fd # input file descriptor + +include "lexer.com" + +extern pr_lexer() +int open(), parse(), pr_geti() +#pointer pr_getp() + +begin + # Open the input file. + if (fname[1] == EOS) + call error (0, "ERROR: The configuration file is undefined") + else + fd = open (fname, READ_ONLY, TEXT_FILE) + + # Initialize the lexer common variables. + nlines = 0 + pos = 1 + call strcpy ("\n", line, SZ_LINE) + call strcpy ("", id, SZ_LINE) + + # Allocate space for parser symbol tables, and code generation table. + call pr_alloc () + call pr_calloc () + + # Initialize the counters. + call pr_puti (NERRORS, 0) + call pr_puti (NWARNINGS, 0) + call pr_puti (NOBSVARS, 0) + call pr_puti (NCATVARS, 0) + call pr_puti (NFITPARS, 0) + call pr_puti (NTOTPARS, 0) + call pr_puti (NSETEQS, 0) + call pr_puti (NEXTEQS, 0) + call pr_puti (NTRNEQS, 0) + + # Initialize the flags. + call pr_puti (FLAGERRORS, YES) + + # Initialize the minimum and maximum column values. + call pr_puti (MINCOL, 1) + call pr_puti (MINOBSCOL, INDEFI) + call pr_puti (MINCATCOL, INDEFI) + call pr_puti (MAXOBSCOL, INDEFI) + call pr_puti (MAXCATCOL, INDEFI) + + # Parse the input stream. Syntax errors are flaged by an ERR parse() + # value. Semantic errors are not detected by the parser, but instead + # by the symbol table procedures. The latter, do not raise an error + # condition, but they send error messages to the standard output if + # the FLAGERR flag is set to YES. + + if (parse (fd, false, pr_lexer) == ERR) + call pr_error ("Cannot continue parsing", PERR_SYNTAX) + + # Debug ? + #call dg_prvdump ("From pr_parse before pr_exit") + #call dg_prtdump ("From pr_parse before pr_exit", pr_getp (SYMTABLE)) + + # Check consistency of the symbol table only if there + # are no errors during the parse. This check may give + # some errors undetected during the previous parse. + + if (pr_geti (NERRORS) == 0) + call pr_exit () + + # Free code buffer and and close the input file. + call pr_cfree () + call close (fd) + + # Debug ? + #call dg_prvdump ("From pr_parse") + #call dg_prtdump ("From pr_parse", pr_getp (SYMTABLE)) + + # Return value. If there are errors free all the tables + # allocated before. Otherwise, keep all tables for later + # use. They MUST be freed by the calling program. + + # Return the appropriate error code. + if (pr_geti (NERRORS) == 0) { + call pr_puti (FLAGERRORS, NO) + return (OK) + } else { + call pr_free () + return (ERR) + } +end diff --git a/noao/digiphot/photcal/parser/prput.x b/noao/digiphot/photcal/parser/prput.x new file mode 100644 index 00000000..db0afdd6 --- /dev/null +++ b/noao/digiphot/photcal/parser/prput.x @@ -0,0 +1,1020 @@ +.help prput +Low Level Parser Storage + +These procedures store parameters (attributes) to the parser, symbols, +symbol variables, symbol derivatives, and symbol fitting parameters, in +the parser common, and the parser symbol table. +.sp +These should be the ONLY procedures that access the parser common and +symbol table directly, by using the macro definitions in prtable.h. +All other procedures should try to use these procedures as the entry +point to access any common or symbol table parameter. + +.nf +Entry points: + + int = pr_putsym (name) Put symbol into table + + pr_psym (number, type, value) Put symbol pointer by number, + and type + + pr_put[ip] (param, value) Put general parameter + + pr_inc[i] (param, value) Increment general parameter + pr_dec[i] (param, value) Decrement general parameter + + pr_psym[cirp] (offset, param, value) Put symbol parameter + + pr_pvar[i] (offset, nv, param, value) Put variable parameter + pr_ppar[ir] (offset, np, param, value) Put fitting parameter parameter + pr_pder[cp] (offset, nd, param, value) Put derivative parameter +.fi +.endhelp + +include "../lib/parser.h" +include "../lib/prstruct.h" + + +# PR_PUTSYM -- Put initialized symbol in the symbol table. Does not check +# for prevoius existence of the identifier in the table. + +int procedure pr_putsym (name) + +char name[ARB] # identifier name + +int offset +pointer sym + +include "parser.com" + +int pr_offset() +pointer stenter() + +begin + # Enter symbol into table + sym = stenter (symtable, name, LEN_PSYM) + + # Get symbol offset + offset = pr_offset (sym) + + # Initialize numbers to INDEF and pointers to NULL + call pr_psymi (offset, PSYMTYPE, INDEFI) + call pr_psymi (offset, PSYMNUM, INDEFI) + call pr_psymp (offset, PSYMSUB, NULL) + + # Return symbol offset + return (offset) +end + + +# PR_PSYM -- Put symbol pointer by number, and type. + +procedure pr_psym (number, type, value) + +int number # number +int type # type +pointer value # value + +int aux + +include "parser.com" + +int mct_nrows() + +begin + # Branch on parameter type + switch (type) { + case PTY_OBSVAR: + aux = mct_nrows (obstable) - number + 1 + call mct_putp (obstable, aux, 1, value) + + case PTY_CATVAR: + aux = mct_nrows (cattable) - number + 1 + call mct_putp (cattable, aux, 1, value) + + case PTY_FITPAR, PTY_CONST: + aux = mct_nrows (partable) - number + 1 + #call mct_getp (partable, aux, 1, value) + call mct_putp (partable, aux, 1, value) + + case PTY_SETEQ: + aux = mct_nrows (settable) - number + 1 + call mct_putp (settable, aux, 1, value) + + case PTY_EXTEQ: + aux = mct_nrows (exttable) - number + 1 + call mct_putp (exttable, aux, 1, value) + + case PTY_TRNEQ: + aux = mct_nrows (trntable) - number + 1 + call mct_putp (trntable, aux, 1, value) + + default: + call error (type, "pr_psym: Unknown parameter") + } +end + + +# PR_PUTI -- Put parser integer parameter. + +procedure pr_puti (param, value) + +int param # parameter +int value # value + +include "parser.com" + +begin + # Brach on parameter type + switch (param) { + case NERRORS: + nerrors = value + + case NWARNINGS: + nwarnings = value + + case NOBSVARS: + nobsvars = value + + case NCATVARS: + ncatvars = value + + case NFITPARS: + nfitpars = value + + case NTOTPARS: + ntotpars = value + + case NSETEQS: + nseteqs = value + + case NEXTEQS: + nexteqs = value + + case NTRNEQS: + ntrneqs = value + + case MINCOL: + mincol = value + + case MINOBSCOL: + minobscol = value + + case MAXOBSCOL: + maxobscol = value + + case MINCATCOL: + mincatcol = value + + case MAXCATCOL: + maxcatcol = value + + case FLAGEQSECT: + flageqsect = value + + case FLAGERRORS: + flagerrors = value + + default: + call error (param, "pr_puti: Unknown parameter") + } +end + + +# PR_INCI -- Increment parser integer parameter. + +procedure pr_inci (param, value) + +int param # parameter +int value # value + +include "parser.com" + +begin + # Brach on parameter type + switch (param) { + case NERRORS: + nerrors = nerrors + value + + case NWARNINGS: + nwarnings = nwarnings + value + + case NOBSVARS: + nobsvars = nobsvars + value + + case NCATVARS: + ncatvars = ncatvars + value + + case NFITPARS: + nfitpars = nfitpars + value + + case NTOTPARS: + ntotpars = ntotpars + value + + case NSETEQS: + nseteqs = nseteqs + value + + case NEXTEQS: + nexteqs = nexteqs + value + + case NTRNEQS: + ntrneqs = ntrneqs + value + + case MINOBSCOL: + minobscol = minobscol + value + + case MAXOBSCOL: + maxobscol = maxobscol + value + + case MINCATCOL: + mincatcol = mincatcol + value + + case MAXCATCOL: + maxcatcol = maxcatcol + value + + default: + call error (param, "pr_inci: Unknown parameter") + } +end + + +# PR_DECI -- Decrement parser integer parameter. + +procedure pr_deci (param, value) + +int param # parameter +int value # value + +include "parser.com" + +begin + # Brach on parameter type + switch (param) { + case NERRORS: + nerrors = nerrors - value + + case NWARNINGS: + nwarnings = nwarnings - value + + case NOBSVARS: + nobsvars = nobsvars - value + + case NCATVARS: + ncatvars = ncatvars - value + + case NFITPARS: + nfitpars = nfitpars - value + + case NTOTPARS: + ntotpars = ntotpars - value + + case NSETEQS: + nseteqs = nseteqs - value + + case NEXTEQS: + nexteqs = nexteqs - value + + case NTRNEQS: + ntrneqs = ntrneqs - value + + case MINOBSCOL: + minobscol = minobscol - value + + case MAXOBSCOL: + maxobscol = maxobscol - value + + case MINCATCOL: + mincatcol = mincatcol - value + + case MAXCATCOL: + maxcatcol = maxcatcol - value + + default: + call error (param, "pr_deci: Unknown parameter") + } +end + + +# PR_PUTP -- Put parser pointer parameter. + +procedure pr_putp (param, value) + +int param # parameter +pointer value # value + +include "parser.com" + +begin + # Brach on parameter type + switch (param) { + case SYMTABLE: + symtable = value + + case OBSTABLE: + obstable = value + + case CATTABLE: + cattable = value + + case PARTABLE: + partable = value + + case SETTABLE: + settable = value + + case EXTTABLE: + exttable = value + + case TRNTABLE: + trntable = value + + case TRCATTABLE: + trcattable = value + + case TROBSTABLE: + trobstable = value + + case TFCATTABLE: + tfcattable = value + + case TFOBSTABLE: + tfobstable = value + + case TPARTABLE: + tpartable = value + + default: + call error (param, "pr_putp: Unknown parameter") + } +end + + +# PR_PSYMC -- Put a symbol character string attribute. + +procedure pr_psymc (offset, param, value) + +int offset # symbol offset +int param # parameter +char value[ARB] # value + +pointer sym + +include "parser.com" + +int stpstr() +pointer pr_pointer() + +begin + # Get symbol pointer + sym = pr_pointer (offset) + + # Check symbol pointer + if (sym == NULL) + call error (0, "pr_psymc: Null symbol pointer") + + # Brach on parameter type + switch (param) { + case PSEQEQ: + if (PSYM_SUB (sym) != NULL) + PSEQ_EQ (PSYM_SUB (sym)) = stpstr (symtable, value, 0) + else + call error (0, "pr_psymc: Null equation pointer (PSEQEQ)") + + case PSEQERROR: + if (PSYM_SUB (sym) != NULL) + PSEQ_ERROR (PSYM_SUB (sym)) = stpstr (symtable, value, 0) + else + call error (0, "pr_psymc: Null equation pointer (PSEQERROR)") + + case PSEQERRMIN: + if (PSYM_SUB (sym) != NULL) + PSEQ_ERRMIN (PSYM_SUB (sym)) = stpstr (symtable, value, 0) + else + call error (0, "pr_psymc: Null equation pointer (PSEQERRMIN)") + + case PSEQERRMAX: + if (PSYM_SUB (sym) != NULL) + PSEQ_ERRMAX (PSYM_SUB (sym)) = stpstr (symtable, value, 0) + else + call error (0, "pr_psymc: Null equation pointer (PSEQERRMAX)") + + case PSEQWEIGHT: + if (PSYM_SUB (sym) != NULL) + PSEQ_WEIGHT (PSYM_SUB (sym)) = stpstr (symtable, value, 0) + else + call error (0, "pr_psymc: Null equation pointer (PSEQWEIGHT)") + + case PSEQWTSMIN: + if (PSYM_SUB (sym) != NULL) + PSEQ_WTSMIN (PSYM_SUB (sym)) = stpstr (symtable, value, 0) + else + call error (0, "pr_psymc: Null equation pointer (PSEQWTSMIN)") + + case PSEQWTSMAX: + if (PSYM_SUB (sym) != NULL) + PSEQ_WTSMAX (PSYM_SUB (sym)) = stpstr (symtable, value, 0) + else + call error (0, "pr_psymc: Null equation pointer (PSEQWTSMAX)") + + case PTEQFIT: + if (PSYM_SUB (sym) != NULL) + PTEQ_FIT (PSYM_SUB (sym)) = stpstr (symtable, value, 0) + else + call error (0, "pr_psymc: Null equation pointer (PTEQFIT)") + + case PTEQREF: + if (PSYM_SUB (sym) != NULL) + PTEQ_REF (PSYM_SUB (sym)) = stpstr (symtable, value, 0) + else + call error (0, "pr_psymc: Null equation pointer (PTEQREF)") + + case PTEQERROR: + if (PSYM_SUB (sym) != NULL) + PTEQ_ERROR (PSYM_SUB (sym)) = stpstr (symtable, value, 0) + else + call error (0, "pr_psymc: Null equation pointer (PTEQERROR)") + + case PTEQERRMIN: + if (PSYM_SUB (sym) != NULL) + PTEQ_ERRMIN (PSYM_SUB (sym)) = stpstr (symtable, value, 0) + else + call error (0, "pr_psymc: Null equation pointer (PTEQERRMIN)") + + case PTEQERRMAX: + if (PSYM_SUB (sym) != NULL) + PTEQ_ERRMAX (PSYM_SUB (sym)) = stpstr (symtable, value, 0) + else + call error (0, "pr_psymc: Null equation pointer (PTEQERRMAX)") + + case PTEQWEIGHT: + if (PSYM_SUB (sym) != NULL) + PTEQ_WEIGHT (PSYM_SUB (sym)) = stpstr (symtable, value, 0) + else + call error (0, "pr_psymc: Null equation pointer (PTEQWEIGHT)") + + case PTEQWTSMIN: + if (PSYM_SUB (sym) != NULL) + PTEQ_WTSMIN (PSYM_SUB (sym)) = stpstr (symtable, value, 0) + else + call error (0, "pr_psymc: Null equation pointer (PTEQWTSMIN)") + + case PTEQWTSMAX: + if (PSYM_SUB (sym) != NULL) + PTEQ_WTSMAX (PSYM_SUB (sym)) = stpstr (symtable, value, 0) + else + call error (0, "pr_psymc: Null equation pointer (PTEQWTSMAX)") + + case PTEQXPLOT: + if (PSYM_SUB (sym) != NULL) + PTEQ_XPLOT (PSYM_SUB (sym)) = stpstr (symtable, value, 0) + else + call error (0, "pr_psymc: Null equation pointer (PTEQXPLOT)") + + case PTEQYPLOT: + if (PSYM_SUB (sym) != NULL) + PTEQ_YPLOT (PSYM_SUB (sym)) = stpstr (symtable, value, 0) + else + call error (0, "pr_psymc: Null equation pointer (PTEQYPLOT)") + + default: + call error (param, "pr_psymc: Unknown parameter type") + } +end + + +# PR_PSYMI -- Put symbol integer parameter. + +procedure pr_psymi (offset, param, value) + +int offset # symbol offset +int param # parameter +int value # value + +pointer sym + +pointer pr_pointer() + +begin + # Get symbol pointer + sym = pr_pointer (offset) + + # Check symbol pointer + if (sym == NULL) + call error (0, "pr_psymi: Null symbol pointer") + + # Brach on parameter type + switch (param) { + case PSYMTYPE: + PSYM_TYPE (sym) = value + + case PSYMNUM: + PSYM_NUM (sym) = value + + case PINPCOL: + if (PSYM_SUB (sym) != NULL) + PINP_COL (PSYM_SUB (sym)) = value + else + call error (0, "pr_psymi: Null equation pointer (PINPCOL)") + + case PINPERRCOL: + if (PSYM_SUB (sym) != NULL) + PINP_ERRCOL (PSYM_SUB (sym)) = value + else + call error (0, "pr_psymi: Null equation pointer (PINPERRCOL)") + + case PINPWTSCOL: + if (PSYM_SUB (sym) != NULL) + PINP_WTSCOL (PSYM_SUB (sym)) = value + else + call error (0, "pr_psymi: Null equation pointer (PINPWTSCOL)") + + case PINPSPARE: + if (PSYM_SUB (sym) != NULL) + PINP_SPARE (PSYM_SUB (sym)) = value + else + call error (0, "pr_psymi: Null equation pointer (PINPSPARE)") + + case PTEQNRCAT: + if (PSYM_SUB (sym) != NULL) + PTEQ_NRCAT (PSYM_SUB (sym)) = value + else + call error (0, "pr_psymi: Null equation pointer (PTEQNRCAT)") + + case PTEQNROBS: + if (PSYM_SUB (sym) != NULL) + PTEQ_NROBS (PSYM_SUB (sym)) = value + else + call error (0, "pr_psymi: Null equation pointer (PTEQNROBS)") + + case PTEQNRVAR: + if (PSYM_SUB (sym) != NULL) + PTEQ_NRVAR (PSYM_SUB (sym)) = value + else + call error (0, "pr_psymi: Null equation pointer (PTEQNRVAR)") + + case PTEQNFCAT: + if (PSYM_SUB (sym) != NULL) + PTEQ_NFCAT (PSYM_SUB (sym)) = value + else + call error (0, "pr_psymi: Null equation pointer (PTEQNFCAT)") + + case PTEQNFOBS: + if (PSYM_SUB (sym) != NULL) + PTEQ_NFOBS (PSYM_SUB (sym)) = value + else + call error (0, "pr_psymi: Null equation pointer (PTEQNFOBS)") + + case PTEQNFVAR: + if (PSYM_SUB (sym) != NULL) + PTEQ_NFVAR (PSYM_SUB (sym)) = value + else + call error (0, "pr_psymi: Null equation pointer (PTEQNFVAR)") + + case PTEQNVAR: + if (PSYM_SUB (sym) != NULL) + PTEQ_NVAR (PSYM_SUB (sym)) = value + else + call error (0, "pr_psymi: Null equation pointer (PTEQNVAR)") + + case PTEQNPAR: + if (PSYM_SUB (sym) != NULL) + PTEQ_NPAR (PSYM_SUB (sym)) = value + else + call error (0, "pr_psymi: Null equation pointer (PTEQNPAR)") + + case PTEQNFPAR: + if (PSYM_SUB (sym) != NULL) + PTEQ_NFPAR (PSYM_SUB (sym)) = value + else + call error (0, "pr_psymi: Null equation pointer (PTEQNFPAR)") + + default: + call error (param, "pr_psymi: Unknown parameter") + } +end + + +# PR_PSYMR -- Put symbol real parameter. + +procedure pr_psymr (offset, param, value) + +int offset # symbol offset +int param # parameter +real value # value + +pointer sym + +pointer pr_pointer() + +begin + # Get symbol pointer + sym = pr_pointer (offset) + + # Check symbol pointer + if (sym == NULL) + call error (0, "pr_psymr: Null symbol pointer") + + # Brach on parameter type + switch (param) { + case PFITVALUE: + if (PSYM_SUB (sym) != NULL) + PFIT_VALUE (PSYM_SUB (sym)) = value + else + call error (0, "pr_psymr: Null equation pointer (PFITVALUE)") + + case PFITDELTA: + if (PSYM_SUB (sym) != NULL) + PFIT_DELTA (PSYM_SUB (sym)) = value + else + call error (0, "pr_psymr: Null equation pointer (PFITDELTA)") + + default: + call error (param, "pr_psymr: Unknown parameter") + } +end + + +# PR_PSYMP -- Put symbol pointer parameter. + +procedure pr_psymp (offset, param, value) + +int offset # symbol offset +int param # parameter +pointer value # value + +pointer sym + +pointer pr_pointer() + +begin + # Get symbol pointer + sym = pr_pointer (offset) + + # Check symbol pointer + if (sym == NULL) + call error (0, "pr_psymp: Null symbol pointer") + + # Brach on parameter type + switch (param) { + case PSYMSUB: + PSYM_SUB (sym) = value + + case PSEQRPNEQ: + if (PSYM_SUB (sym) != NULL) + PSEQ_RPNEQ (PSYM_SUB (sym)) = value + else + call error (0, "pr_psymp: Null equation pointer (PSEQRPNEQ)") + + case PSEQRPNERROR: + if (PSYM_SUB (sym) != NULL) + PSEQ_RPNERROR (PSYM_SUB (sym)) = value + else + call error (0, + "pr_psymp: Null equation pointer (PSEQRPNERROR)") + + case PSEQRPNERRMIN: + if (PSYM_SUB (sym) != NULL) + PSEQ_RPNERRMIN (PSYM_SUB (sym)) = value + else + call error (0, + "pr_psymp: Null equation pointer (PSEQRPNERRMIN)") + + case PSEQRPNERRMAX: + if (PSYM_SUB (sym) != NULL) + PSEQ_RPNERRMAX (PSYM_SUB (sym)) = value + else + call error (0, + "pr_psymp: Null equation pointer (PSEQRPNERRMAX)") + + case PSEQRPNWEIGHT: + if (PSYM_SUB (sym) != NULL) + PSEQ_RPNWEIGHT (PSYM_SUB (sym)) = value + else + call error (0, + "pr_psymp: Null equation pointer (PSEQRPNWEIGHT") + + case PSEQRPNWTSMIN: + if (PSYM_SUB (sym) != NULL) + PSEQ_RPNWTSMIN (PSYM_SUB (sym)) = value + else + call error (0, + "pr_psymp: Null equation pointer (PSEQRPNWTSMIN)") + + case PSEQRPNWTSMAX: + if (PSYM_SUB (sym) != NULL) + PSEQ_RPNWTSMAX (PSYM_SUB (sym)) = value + else + call error (0, + "pr_psymp: Null equation pointer (PSEQRPNWTSMAX)") + + case PTEQRPNFIT: + if (PSYM_SUB (sym) != NULL) + PTEQ_RPNFIT (PSYM_SUB (sym)) = value + else + call error (0, "pr_psymp: Null equation pointer (PTEQRPNFIT)") + + case PTEQRPNREF: + if (PSYM_SUB (sym) != NULL) + PTEQ_RPNREF (PSYM_SUB (sym)) = value + else + call error (0, "pr_psymp: Null equation pointer (PTEQRPNREF)") + + case PTEQRPNERROR: + if (PSYM_SUB (sym) != NULL) + PTEQ_RPNERROR (PSYM_SUB (sym)) = value + else + call error (0, "pr_psymp: Null equation pointer (PTEQRPNERROR)") + + case PTEQRPNERRMIN: + if (PSYM_SUB (sym) != NULL) + PTEQ_RPNERRMIN (PSYM_SUB (sym)) = value + else + call error (0, + "pr_psymp: Null equation pointer (PTEQRPNERRMIN)") + + case PTEQRPNERRMAX: + if (PSYM_SUB (sym) != NULL) + PTEQ_RPNERRMAX (PSYM_SUB (sym)) = value + else + call error (0, + "pr_psymp: Null equation pointer (PTEQRPNERRMAX)") + + case PTEQRPNWEIGHT: + if (PSYM_SUB (sym) != NULL) + PTEQ_RPNWEIGHT (PSYM_SUB (sym)) = value + else + call error (0, + "pr_psymp: Null equation pointer (PTEQRPNWEIGHT") + + case PTEQRPNWTSMIN: + if (PSYM_SUB (sym) != NULL) + PTEQ_RPNWTSMIN (PSYM_SUB (sym)) = value + else + call error (0, + "pr_psymp: Null equation pointer (PTEQRPNWTSMIN)") + + case PTEQRPNWTSMAX: + if (PSYM_SUB (sym) != NULL) + PTEQ_RPNWTSMAX (PSYM_SUB (sym)) = value + else + call error (0, + "pr_psymp: Null equation pointer (PTEQRPNWTSMAX") + + case PTEQRPNXPLOT: + if (PSYM_SUB (sym) != NULL) + PTEQ_RPNXPLOT (PSYM_SUB (sym)) = value + else + call error (0, + "pr_psymp: Null equation pointer (PTEQRPNXPLOT)") + + case PTEQRPNYPLOT: + if (PSYM_SUB (sym) != NULL) + PTEQ_RPNYPLOT (PSYM_SUB (sym)) = value + else + call error (0, + "pr_psymp: Null equation pointer (PTEQRPNYPLOT)") + + default: + call error (param, "pr_psymp: Unknown parameter") + } +end + + +# PR_PVARI -- Put variable integer parameter. + +procedure pr_pvari (offset, nv, param, value) + +int offset # symbol offset +int nv # variable number +int param # parameter +int value # value + +pointer sym + +pointer pr_pointer() + +begin + # Get symbol pointer + sym = pr_pointer (offset) + + # Check symbol pointer + if (sym == NULL) + call error (0, "pr_pvari: Null symbol pointer") + + # Branch on parameter + switch (param) { + case PTEQREFVAR: + if (PSYM_SUB (sym) != NULL) { + if (nv >= 1 || nv <= PTEQ_NVAR (PSYM_SUB (sym))) + PTEQ_REFVAR (PSYM_SUB (sym), nv) = value + else + call error (0, + "pr_pvari: Not a valid variable number (PTEQREFVAR)") + } else + call error (0, "pr_pvari: Null equation pointer (PTEQREFVAR)") + + case PTEQREFCNT: + if (PSYM_SUB (sym) != NULL) { + if (nv >= 1 || nv <= PTEQ_NVAR (PSYM_SUB (sym))) + PTEQ_REFCNT (PSYM_SUB (sym), nv) = value + else + call error (0, + "pr_pvari: Not a valid variable number (PTEQREFCNT)") + } else + call error (0, "pr_pvari: Null equation pointer (PTEQREFCNT)") + + case PTEQFITVAR: + if (PSYM_SUB (sym) != NULL) { + if (nv >= 1 || nv <= PTEQ_NVAR (PSYM_SUB (sym))) + PTEQ_FITVAR (PSYM_SUB (sym), nv) = value + else + call error (0, + "pr_pvari: Not a valid variable number (PTEQFITVAR)") + } else + call error (0, "pr_pvari: Null equation pointer (PTEQFITVAR)") + + case PTEQFITCNT: + if (PSYM_SUB (sym) != NULL) { + if (nv >= 1 || nv <= PTEQ_NVAR (PSYM_SUB (sym))) + PTEQ_FITCNT (PSYM_SUB (sym), nv) = value + else + call error (0, + "pr_pvari: Not a valid variable number (PTEQFITCNT)") + } else + call error (0, "pr_pvari: Null equation pointer (PTEQFITCNT)") + + default: + call error (param, "pr_pvari: Unknown parameter") + } +end + + +# PR_PPARI -- Put fitting parameter integer parameter. + +procedure pr_ppari (offset, np, param, value) + +int offset # symbol offset +int np # parameter number +int param # parameter +int value # value + +pointer sym + +pointer pr_pointer() + +begin + # Get symbol pointer + sym = pr_pointer (offset) + + # Check symbol pointer + if (sym == NULL) + call error (0, "pr_ppari: Null symbol pointer") + + # Branch on parameter + switch (param) { + case PTEQPAR: + if (PSYM_SUB (sym) != NULL) { + if (np >= 1 || np <= PTEQ_NVAR (PSYM_SUB (sym))) + PTEQ_PAR (PSYM_SUB (sym), np) = value + else + call error (0, + "pr_ppari: Not a valid variable number (PTEQPAR)") + } else + call error (0, "pr_ppari: Null equation pointer (PTEQPAR)") + + case PTEQPLIST: + if (PSYM_SUB (sym) != NULL) { + if (np >= 1 || np <= PTEQ_NVAR (PSYM_SUB (sym))) + PTEQ_PLIST (PSYM_SUB (sym), np) = value + else + call error (0, + "pr_ppari: Not a valid variable number (PTEQPLIST)") + } else + call error (0, "pr_ppari: Null equation pointer (PTEQPLIST)") + + default: + call error (param, "pr_ppari: Unknown parameter") + } +end + + +# PR_PPARR -- Put fitting parameter real parameter. + +procedure pr_pparr (offset, np, param, value) + +int offset # symbol offset +int np # parameter number +int param # parameter +real value # value + +pointer sym + +pointer pr_pointer() + +begin + # Get symbol pointer + sym = pr_pointer (offset) + + # Check symbol pointer + if (sym == NULL) + call error (0, "pr_pparr: Null symbol pointer") + + # Branch on parameter + switch (param) { + case PTEQPARVAL: + if (PSYM_SUB (sym) != NULL) { + if (np >= 1 || np <= PTEQ_NVAR (PSYM_SUB (sym))) + PTEQ_PARVAL (PSYM_SUB (sym), np) = value + else + call error (0, + "pr_pparr: Not a valid variable number (PTEQPARVAL)") + } else + call error (0, "pr_pparr: Null equation pointer (PTEQPARVAL)") + + default: + call error (param, "pr_pparr: Unknown parameter") + } +end + + +# PR_PDERC -- Put derivative character string parameter. + +procedure pr_pderc (offset, nd, param, value) + +int offset # symbol offset +int nd # derivative number +int param # parameter +char value[ARB] # value + +pointer sym + +include "parser.com" + +int stpstr() +pointer pr_pointer + +begin + # Get symbol pointer + sym = pr_pointer (offset) + + # Check symbol pointer + if (sym == NULL) + call error (0, "pr_pderc: Null symbol pointer") + + # Branch on parameter + switch (param) { + case PTEQDER: + if (PSYM_SUB (sym) != NULL) { + if (nd >= 1 || nd <= PTEQ_NVAR (PSYM_SUB (sym))) + PTEQ_DER (PSYM_SUB (sym), nd) = stpstr (symtable, value, 0) + else + call error (0, + "pr_pderc: Not a valid variable number (PTEQDER)") + } else + call error (param, "pr_pderc: Null equation pointer (PTEQDER)") + + default: + call error (param, "pr_pderc: Unknown parameter") + } +end + + +# PR_PDERP -- Put derivative pointer parameter. + +procedure pr_pderp (offset, nd, param, value) + +int offset # symbol offset +int nd # derivative number +int param # parameter +pointer value # value + +pointer sym + +include "parser.com" + +pointer pr_pointer() + +begin + # Get symbol pointer + sym = pr_pointer (offset) + + # Check symbol pointer + if (sym == NULL) + call error (0, "pr_pderp: Null symbol pointer") + + # Branch on parameter + switch (param) { + case PTEQRPNDER: + if (PSYM_SUB (sym) != NULL) { + if (nd >= 1 || nd <= PTEQ_NVAR (PSYM_SUB (sym))) + PTEQ_RPNDER (PSYM_SUB (sym), nd) = value + else + call error (0, + "pr_pderp: Not a valid derivative number (PTEQRPNDER)") + } else + call error (0, "pr_pderp: Null equation pointer (PTEQRPNDER)") + + default: + call error (param, "pr_pderp: Unknown parameter") + } +end diff --git a/noao/digiphot/photcal/parser/prtable.x b/noao/digiphot/photcal/parser/prtable.x new file mode 100644 index 00000000..1b6c746f --- /dev/null +++ b/noao/digiphot/photcal/parser/prtable.x @@ -0,0 +1,1371 @@ +.help prtable +Parser Symbol Table Handling. + +.nf +Entry points: + + pr_obscol (variable, col) Enter observational var. column + pr_catcol (variable, col) Enter catalog var. column + pr_errcol (variable, col) Enter error column + pr_wtscol (variable, col) Enter weight column + + pr_fitpar (name, value) Enter fitting parameter value + pr_const (name, value) Enter constant parameter value + pr_delta (name, value) Enter delta for parameter value + + pr_seteq (name, eq, rpn, lenrpn) Enter set equation + + pr_treq (name, refeq, trneq, Enter transformation equation + rpnref, lenref, + rpntrn, lentrn) + pr_trder (name, param, equation, Enter trans. deriv. + rpneq, leneq) + pr_trplot (name, xploteq, yploteq, Enter trans. plot equations + rpnxplot, lenxplot, + rpnyplot, lenyplot) + + pr_erreq (name, erreq, mineq, maxeq, Enter error equation + rpnerr, lenerr, rpnmin, + lenmin, rpnmax, lenmax) + pr_wtseq (name, wghteq, mineq, maxeq, Enter weight equation + rpnwght, lenwght, rpnmin, + lenmin, rpnmax, lenmax) + + pr_section (section) Enter equation section + + pr_chkid (name) Check identifier type + +Low level entry points: + + pr_incol (type, variable, col, spare) Enter input column + pr_param (type, name, value) Enter parameter value + pr_trvar (sym, nrcat, nrobs, nfcat, nfobs) Update variables in eq. + pr_trpar (sym, npar) Update parameters in eq. + pr_trpnum (syme, symp) Get parameter number +.endhelp + +include <mach.h> +include "../lib/parser.h" +include "../lib/prdefs.h" + + +# PR_OBSCOL -- Enter an observational variable name and its column in the +# input file into the symbol table. + +procedure pr_obscol (variable, col) + +char variable[ARB] # variable name +char col[ARB] # column + +#bool clgetb() + +begin + # Debug ? + #if (clgetb ("debug.parcode")) { + #call eprintf ("pr_obscol (%s) (%s)\n") + #call pargstr (variable) + #call pargstr (col) + #} + + # Enter observational variable + call pr_incol (PTY_OBSVAR, variable, col, NO) +end + + +# PR_CATCOL -- Enter the name of a catalog variable for a catalog +# star, and its column in the input file into the symbol table. + +procedure pr_catcol (variable, col) + +char variable[ARB] # variable name +char col[ARB] # column + +#bool clgetb() + +begin + # Debug ? + #if (clgetb ("debug.parcode")) { + #call eprintf ("pr_catcol (%s) (%s)\n") + #call pargstr (variable) + #call pargstr (col) + #} + + # Enter catalog variable + call pr_incol (PTY_CATVAR, variable, col, NO) +end + + +# PR_INCOL -- Enter an observational or catalog variable name, and its +# column in the input file into the symbol table. + +procedure pr_incol (type, variable, col, spare) + +int type # column type (observation or catalog) +char variable[ARB] # variable name +char col[ARB] # column +int spare # spare column (YES/NO) ? + +char aux[SZ_LINE] +int sym, ip, colnum +pointer ptr +#bool clgetb() +int ctoi(), pr_geti(), pr_getsym(), pr_putsym() + +begin + # Debug ? + #if (clgetb ("debug.parcode")) { + #call eprintf ("pr_incol (%d) (%s) (%s)\n") + #call pargi (type) + #call pargstr (variable) + #call pargstr (col) + #} + + # Enter variable into the symbol table if it's not already there. + if (IS_INDEFI (pr_getsym (variable))) { + + # Get column value, and check if it's in range. + ip = 1 + if (ctoi (col, ip, colnum) <= 0) + colnum = 0 + if (colnum < pr_geti (MINCOL)) { + call sprintf (aux, SZ_LINE, + "Column out of range or reserved for matching name [%s]") + call pargstr (variable) + call pr_error (aux, PERR_SEMANTIC) + } + + # Enter and initialize variable name in the table. + sym = pr_putsym (variable) + + # Enter type. + call pr_psymi (sym, PSYMTYPE, type) + + # Allocate space for the symbol substructure, + # and store it into the symbol structure. + call pr_inalloc (ptr) + call pr_psymp (sym, PSYMSUB, ptr) + + # Enter column number and spare flag. + call pr_psymi (sym, PINPCOL, colnum) + call pr_psymi (sym, PINPSPARE, spare) + + # Count variables, and enter variable number. + if (type == PTY_OBSVAR) { + call pr_inci (NOBSVARS, 1) + call pr_psymi (sym, PSYMNUM, pr_geti (NOBSVARS)) + } else { + call pr_inci (NCATVARS, 1) + call pr_psymi (sym, PSYMNUM, pr_geti (NCATVARS)) + } + + } else { + call sprintf (aux, SZ_LINE, + "Input variable [%s] declared more than once") + call pargstr (variable) + call pr_error (aux, PERR_SEMANTIC) + } +end + + +# PR_ERRCOL -- Enter an observational or catalog variable error column in +# the input file into the symbol table. + +procedure pr_errcol (variable, col) + +char variable[ARB] # variable name +char col[ARB] # column + +char aux[SZ_LINE] +int sym, ip, colnum +#bool clgetb() +int ctoi(), pr_geti(), pr_getsym(), pr_gsymi() + +begin + # Debug ? + #if (clgetb ("debug.parcode")) { + #call eprintf ("pr_errcol (%s) (%s)\n") + #call pargstr (variable) + #call pargstr (col) + #} + + # Enter error into table if the variable is already there. + sym = pr_getsym (variable) + if (!IS_INDEFI (sym)) { + + # Get column value, and check if it's in range. + ip = 1 + if (ctoi (col, ip, colnum) <= 0) + colnum = 0 + if (colnum < pr_geti (MINCOL)) { + call sprintf (aux, SZ_LINE, + "Error column out of range or reserved for matching name [%s]") + call pargstr (variable) + call pr_error (aux, PERR_SEMANTIC) + } + + # Enter column value + call pr_psymi (sym, PINPERRCOL, colnum) + + # Enter spare value. + call sprintf (aux, SZ_LINE, "@E_%s") + call pargstr (variable) + call pr_incol (pr_gsymi (sym, PSYMTYPE), aux, col, YES) + + } else { + call sprintf (aux, SZ_LINE, + "Attempt to define error column for undefined variable [%s]") + call pargstr (variable) + call pr_error (aux, PERR_SEMANTIC) + } +end + + +# PR_WTSCOL -- Enter an observational or catalog variable weight column in +# the input file into the symbol table. + +procedure pr_wtscol (variable, col) + +char variable[ARB] # variable name +char col[ARB] # column + +char aux[SZ_LINE] +int sym, ip, colnum +#bool clgetb() +int ctoi(), pr_geti(), pr_getsym(), pr_gsymi() + +begin + # Debug ? + #if (clgetb ("debug.parcode")) { + #call eprintf ("pr_wtscol (%s) (%s)\n") + #call pargstr (variable) + #call pargstr (col) + #} + + # Enter error into table if the variable is already there. + sym = pr_getsym (variable) + if (!IS_INDEFI (sym)) { + + # Get column value, and check if it's in range. + ip = 1 + if (ctoi (col, ip, colnum) <= 0) + colnum = 0 + if (colnum < pr_geti (MINCOL)) { + call sprintf (aux, SZ_LINE, + "Weight column out of range or reserved for matching name [%s]") + call pargstr (variable) + call pr_error (aux, PERR_SEMANTIC) + } + + # Enter column value. + call pr_psymi (sym, PINPWTSCOL, colnum) + + # Enter spare value. + call sprintf (aux, SZ_LINE, "@W_%s") + call pargstr (variable) + call pr_incol (pr_gsymi (sym, PSYMTYPE), aux, col, YES) + + } else { + call sprintf (aux, SZ_LINE, + "Attempt to define weight column for undefined variable [%s]") + call pargstr (variable) + call pr_error (aux, PERR_SEMANTIC) + } +end + + +# PR_FITPAR -- Enter a variable name and its value as a fitting parameter +# into the symbol table, if it's not already there. + +procedure pr_fitpar (name, value) + +char name[ARB] # parameter name +char value[ARB] # parameter value + +#bool clgetb() + +begin + # Debug ? + #if (clgetb ("debug.parcode")) { + #call eprintf ("pr_fitpar (%s) (%s)\n") + #call pargstr (name) + #call pargstr (value) + #} + + # Enter fitting parameter. + call pr_param (PTY_FITPAR, name, value) +end + + +# PR_CONST -- Enter a variable name and its value as a constant parameter +# into the symbol table, if it's not already there. + +procedure pr_const (name, value) + +char name[ARB] # constant name +char value[ARB] # parameter value + +#bool clgetb() + +begin + # Debug ? + #if (clgetb ("debug.parcode")) { + #call eprintf ("pr_const (%s) (%s)\n") + #call pargstr (name) + #call pargstr (value) + #} + + # Enter constant parameter. + call pr_param (PTY_CONST, name, value) +end + + +# PR_PARAM -- Enter a variable name and its value as either a constant +# or fitting parameter into the symbol table, if it's not already there. + +procedure pr_param (type, name, value) + +int type # parameter type +char name[ARB] # parameter name +char value[ARB] # parameter value + +char aux[SZ_LINE] +int sym, ip, n, symtype +pointer ptr +real rval + +#bool clgetb() +int ctor(), pr_geti(), pr_gsymi(), pr_getsym(), pr_putsym() + +begin + # Debug ? + #if (clgetb ("debug.parcode")) { + #call eprintf ("pr_param (%d) (%s) (%s)\n") + #call pargi (type) + #call pargstr (name) + #call pargstr (value) + #} + + # Get parameter value, and check it. + ip = 1 + n = ctor (value, ip, rval) + if (n == 0 || IS_INDEFR (rval)) { + call sprintf (aux, SZ_LINE, + "Constant or fitting parameter value undefined for [%s]") + call pargstr (name) + call pr_error (aux, PERR_SEMANTIC) + } + + # Get symbol and symbol type. + sym = pr_getsym (name) + if (!IS_INDEFI (sym)) + symtype = pr_gsymi (sym, PSYMTYPE) + else + symtype = INDEFI + + # Enter name into the symbol table if it's not + # already there. Otherwise redefine it if possible. + # Do not enter or redefine with undefined values. + if (IS_INDEFI (sym)) { + + # Enter name into symbol table. + sym = pr_putsym (name) + + # Enter type + call pr_psymi (sym, PSYMTYPE, type) + + # Allocate space for the symbol substructure, + # and store it into the symbol structure. + call pr_ftalloc (ptr) + call pr_psymp (sym, PSYMSUB, ptr) + + # Count total number of parameters, and number + # of fitting parameters. + call pr_inci (NTOTPARS, 1) + if (type == PTY_FITPAR) + call pr_inci (NFITPARS, 1) + + # Enter number, and value. + call pr_psymi (sym, PSYMNUM, pr_geti (NTOTPARS)) + call pr_psymr (sym, PFITVALUE, rval) + + } else if (symtype == PTY_FITPAR || symtype == PTY_CONST) { + + # Update fitting parameter counter. + if (symtype == PTY_FITPAR && type == PTY_CONST) + call pr_deci (NFITPARS, 1) + else if (symtype == PTY_CONST && type == PTY_FITPAR) + call pr_inci (NFITPARS, 1) + + # Redefine type and value, but not number. + call pr_psymi (sym, PSYMTYPE, type) + call pr_psymr (sym, PFITVALUE, rval) + + # Issue warning message. + call sprintf (aux, SZ_LINE, + "Constant or fitting parameter [%s] redefined") + call pargstr (name) + call pr_error (aux, PERR_WARNING) + + } else { + call sprintf (aux, SZ_LINE, + "Constant or fitting parameter [%s] declared more than once") + call pargstr (name) + call pr_error (aux, PERR_SEMANTIC) + } +end + + +# PR_DELTA -- Enter a variable name and its value as the delta of a fitting +# or constant parameter. Check for negative or zero delta values. + +procedure pr_delta (name, value) + +char name[ARB] # parameter name +char value[ARB] # delta value + +char aux[SZ_LINE] +int sym, ip, n, symtype +real rval +#bool clgetb() +int ctor(), pr_getsym(), pr_gsymi() + +begin + # Debug ? + #if (clgetb ("debug.parcode")) { + #call eprintf ("pr_delta (%s) (%s)\n") + #call pargstr (name) + #call pargstr (value) + #} + + # Get symbol and symbol type + sym = pr_getsym (name) + if (!IS_INDEFI (sym)) { + + # Get delta value, and check it. + ip = 1 + n = ctor (value, ip, rval) + if (n == 0 || IS_INDEFR (rval)) { + call sprintf (aux, SZ_LINE, + "Delta value undefined for parameter [%s]") + call pargstr (name) + call pr_error (aux, PERR_SEMANTIC) + } else if (rval <= 0) { + call sprintf (aux, SZ_LINE, + "Delta value for parameter [%s] must be positive") + call pargstr (name) + call pr_error (aux, PERR_SEMANTIC) + } + + # Enter delta if the type is consistent. + symtype = pr_gsymi (sym, PSYMTYPE) + if (symtype == PTY_FITPAR || symtype == PTY_CONST) { + call pr_psymr (sym, PFITDELTA, rval) + } else { + call sprintf (aux, SZ_LINE, + "Attempt to define a delta for a non-parameter [%s]") + call pargstr (name) + call pr_error (aux, PERR_SEMANTIC) + } + + } else { + call sprintf (aux, SZ_LINE, + "Attempt to define delta for undefined parameter [%s]") + call pargstr (name) + call pr_error (aux, PERR_SEMANTIC) + } +end + + +# PR_SETEQ -- Enter the set equation the symbol table, if it's not already +# there. + +procedure pr_seteq (name, eq, rpn, lenrpn) + +char name[ARB] # equation name +char eq[ARB] # equation +pointer rpn # equation code +int lenrpn # code length + +char aux[SZ_LINE] +int sym +pointer ptr + +#bool clgetb() +int pr_geti(), pr_getsym(), pr_putsym() +pointer pr_cput() + +begin + # Debug ? + #if (clgetb ("debug.parcode")) { + #call eprintf ("pr_seteq (%s) (eq=%s) (rpn=%d,%d)\n") + #call pargstr (name) + #call pargstr (eq) + #call pargi (rpn) + #call pargi (lenrpn) + #} + + # Enter ser equation into the symbol table if it's not + # already there. + if (IS_INDEFI (pr_getsym (name))) { + + # Enter equation into symbol table. + sym = pr_putsym (name) + + # Count equations. + call pr_inci (NSETEQS, 1) + + # Enter equation type, and number. + call pr_psymi (sym, PSYMTYPE, PTY_SETEQ) + call pr_psymi (sym, PSYMNUM, pr_geti (NSETEQS)) + + # Allocate space for an equation substructure, + # and store it into the symbol structure. + call pr_stalloc (ptr) + call pr_psymp (sym, PSYMSUB, ptr) + + # Enter equation string offset, and code. + call pr_psymc (sym, PSEQEQ, eq) + call pr_psymp (sym, PSEQRPNEQ, pr_cput (rpn, lenrpn)) + + # Enter null strings for error, and weight equations + # because they might not be defined afterwards, and because + # they can't be initialized at allocation time. + call pr_psymc (sym, PSEQERROR, "") + call pr_psymc (sym, PSEQERRMIN, "") + call pr_psymc (sym, PSEQERRMAX, "") + call pr_psymc (sym, PSEQWEIGHT, "") + call pr_psymc (sym, PSEQWTSMIN, "") + call pr_psymc (sym, PSEQWTSMAX, "") + + } else { + call sprintf (aux, SZ_LINE, + "Set equation declared more than once [%s]") + call pargstr (name) + call pr_error (aux, PERR_SEMANTIC) + } +end + + +# PR_TREQ -- Enter the transformation equation along with its reference +# equation, and its plotting equations into the symbol table. + +procedure pr_treq (name, refeq, trneq, rpnref, lenref, rpntrn, lentrn) + +char name[ARB] # equation name +char refeq[ARB] # reference equation +char trneq[ARB] # transformation equation +pointer rpnref # reference equation code +int lenref # code length +pointer rpntrn # transformation equation code +int lentrn # code length + +char aux[SZ_LINE] +int i, nrcat, nrobs, nfcat, nfobs, npar, sym +pointer ptr +#bool clgetb() +int mct_nrows(), pr_geti(), pr_getsym(), pr_putsym() +pointer pr_getp(), pr_cput() + +begin + # Debug ? + #if (clgetb ("debug.parcode")) { + #call eprintf ("pr_treq (%s) (ref=%s) (eq=%s)\n") + #call pargstr (name) + #call pargstr (refeq) + #call pargstr (trneq) + #call eprintf ( + #"pr_treq (ref=%d,%d) (eq=%d,%d)\n") + #call pargi (rpnref) + #call pargi (lenref) + #call pargi (rpntrn) + #call pargi (lentrn) + #} + + # Enter transformation equation into the symbol table + # if it's not already there. + if (IS_INDEFI (pr_getsym (name))) { + + # Enter equation into symbol table. The symbol + # attributes are initialized to default values. + sym = pr_putsym (name) + + # Count equations. + call pr_inci (NTRNEQS, 1) + + # Enter equation type, and number. + call pr_psymi (sym, PSYMTYPE, PTY_TRNEQ) + call pr_psymi (sym, PSYMNUM, pr_geti (NTRNEQS)) + + # Get number of catalog and observational variables, + # and number of parameters for the current equation. + # All of them were stored in the temporary table during + # the parse of the expression. + nrcat = mct_nrows (pr_getp (TRCATTABLE)) + nrobs = mct_nrows (pr_getp (TROBSTABLE)) + nfcat = mct_nrows (pr_getp (TFCATTABLE)) + nfobs = mct_nrows (pr_getp (TFOBSTABLE)) + npar = mct_nrows (pr_getp (TPARTABLE)) + + # Allocate space for an equation substructure, + # and store it into the symbol structure. + call pr_tralloc (ptr, nrcat, nrobs, nfcat, nfobs, npar) + call pr_psymp (sym, PSYMSUB, ptr) + + # Update variable counters in the equation substructure. + call pr_trvar (sym, nrcat, nrobs, nfcat, nfobs) + + # Update fitting parameter data in the equation substructure. + call pr_trpar (sym, npar) + + # Enter equation string offsets. + call pr_psymc (sym, PTEQFIT, trneq) + call pr_psymc (sym, PTEQREF, refeq) + + # Enter null strings for error, weight, plot equations, and + # derivative equations, because they might not be defined + # afterwards, and because they can't be initialized at + # allocation time. + call pr_psymc (sym, PTEQERROR, "") + call pr_psymc (sym, PTEQERRMIN, "") + call pr_psymc (sym, PTEQERRMAX, "") + call pr_psymc (sym, PTEQWEIGHT, "") + call pr_psymc (sym, PTEQWTSMIN, "") + call pr_psymc (sym, PTEQWTSMAX, "") + call pr_psymc (sym, PTEQXPLOT, "") + call pr_psymc (sym, PTEQYPLOT, "") + do i = 1, npar + call pr_pderc (sym, i, PTEQDER, "") + + # Enter equation codes. + call pr_psymp (sym, PTEQRPNFIT, pr_cput (rpntrn, lentrn)) + call pr_psymp (sym, PTEQRPNREF, pr_cput (rpnref, lenref)) + + # Clear temporary tables. + call mct_reset (pr_getp (TROBSTABLE)) + call mct_reset (pr_getp (TRCATTABLE)) + call mct_reset (pr_getp (TFOBSTABLE)) + call mct_reset (pr_getp (TFCATTABLE)) + call mct_reset (pr_getp (TPARTABLE)) + + } else { + call sprintf (aux, SZ_LINE, + "Transformation equation [%s] declared more than once") + call pargstr (name) + call pr_error (aux, PERR_SEMANTIC) + } +end + + +# PR_TRPAR -- Update fitting parameters in the equation substructure. +# Fitting and constant parameters for the current equation were stored +# in the temporary table when the equation was parsed. +# Count fitting (active) parameters, and update the parameter +# values, and fitting parameter list. + +procedure pr_trpar (sym, npar) + +int sym # equation symbol +int npar # number of parameters + +int nfpar # number of fitting parameters +int symp # parameter symbol +int i + +#bool clgetb() +int pr_gsymi(), pr_gpari() +pointer pr_getp(), pr_gsymp(), mct_getbuf() +real pr_gsymr() + +begin + # Debug ? + #if (clgetb ("debug.parcode")) { + #call eprintf ("pr_trpar (sym=%d) (npar=%d)\n") + #call pargi (sym) + #call pargi (npar) + #} + + # Move parameter offsets from temporary table to + # equation substructure, if there are any. + if (npar > 0) { + call amovi (Memi[mct_getbuf (pr_getp (TPARTABLE))], + Memi[pr_gsymp (sym, PTEQSPAR)], npar) + } + + # Clear the fitting parameter list. + call aclri (Memi[pr_gsymp (sym, PTEQSPLIST)], npar) + + # Reset number of fitting parameters, and iterate + # for all the parameters in the equation. + nfpar = 0 + do i = 1, npar { + + # Get parameter symbol and process it. + symp = pr_gpari (sym, i, PTEQPAR) + if (!IS_INDEFI (symp)) { + + # Enter value. + call pr_pparr (sym, i, PTEQPARVAL, pr_gsymr (symp, PFITVALUE)) + + # Enter fitting parameter number to the list. + if (pr_gsymi (symp, PSYMTYPE) == PTY_FITPAR) { + nfpar = nfpar + 1 + call pr_ppari (sym, nfpar, PTEQPLIST, i) + } + + } else + call error (0, "pr_trpar: Undefined parameter symbol") + } + + # Enter number of fitting (active) parameters. + call pr_psymi (sym, PTEQNFPAR, nfpar) +end + + +# PR_TRVAR -- Update variable symbols and counters in the equation +# substructure. Variable symbols and counters for the reference and +# fit equations were stored in the temporary tables when the equation +# was parsed. The offsets and counters come from two different sequential +# tables, but are stored in one place in the equation substructure. + +procedure pr_trvar (sym, nrcat, nrobs, nfcat, nfobs) + +int sym # equation symbol +int nrcat, nrobs # reference eq. counters +int nfcat, nfobs # fit eq. counters + +int i +pointer table + +#bool clgetb() +int mct_geti() +pointer pr_getp() + +begin + # Debug ? + #if (clgetb ("debug.parcode")) { + #call eprintf ( + #"pr_trvar (sym=%d) (nrc=%d) (nro=%d) (nfc=%d) (nfo=%d)\n") + #call pargi (sym) + #call pargi (nrcat) + #call pargi (nrobs) + #call pargi (nfcat) + #call pargi (nfobs) + #} + + # Update reference equation symbols and counters. + table = pr_getp (TRCATTABLE) + do i = 1, nrcat { + call pr_pvari (sym, i, PTEQREFVAR, mct_geti (table, i, 1)) + call pr_pvari (sym, i, PTEQREFCNT, mct_geti (table, i, 2)) + } + table = pr_getp (TROBSTABLE) + do i = nrcat + 1, nrcat + nrobs { + call pr_pvari (sym, i, PTEQREFVAR, mct_geti (table, i - nrcat, 1)) + call pr_pvari (sym, i, PTEQREFCNT, mct_geti (table, i - nrcat, 2)) + } + + # Update fit equation symbols and counters + table = pr_getp (TFCATTABLE) + do i = 1, nfcat { + call pr_pvari (sym, i, PTEQFITVAR, mct_geti (table, i, 1)) + call pr_pvari (sym, i, PTEQFITCNT, mct_geti (table, i, 2)) + } + table = pr_getp (TFOBSTABLE) + do i = nfcat + 1, nfcat + nfobs { + call pr_pvari (sym, i, PTEQFITVAR, mct_geti (table, i - nfcat, 1)) + call pr_pvari (sym, i, PTEQFITCNT, mct_geti (table, i - nfcat, 2)) + } +end + + +# PR_TRDER -- Enter the derivative of a given equation with respect to +# a fitting parameter or constant into the symbol table. + +procedure pr_trder (name, param, equation, rpneq, leneq) + +char name[ARB] # equation name +char param[ARB] # parameter name +char equation[ARB] # derivative equation +pointer rpneq # derivative code +int leneq # code length + +char aux[SZ_LINE] +int np +int type +int syme, symp + +#bool clgetb() +int pr_gsymi() +int pr_trpnum() +int pr_getsym() +pointer pr_cput() + +begin + # Debug ? + #if (clgetb ("debug.parcode")) { + #call eprintf ("pr_trder (%s) (%s) (%s) (%d,%d)\n") + #call pargstr (name) + #call pargstr (param) + #call pargstr (equation) + #call pargi (rpneq) + #call pargi (leneq) + #} + + # Get parameter symbol from the table if it's already + # there. Otherwise issue an error message. + symp = pr_getsym (param) + if (!IS_INDEFI (symp)) { + type = pr_gsymi (symp, PSYMTYPE) + if (type != PTY_FITPAR && type != PTY_CONST) { + call sprintf (aux, SZ_LINE, + "Derivative with respect of non-parameter [%s]") + call pargstr (param) + call pr_error (aux, PERR_SEMANTIC) + return + } + } else { + call sprintf (aux, SZ_LINE, + "Derivative with respect of undefined parameter [%s]") + call pargstr (param) + call pr_error (aux, PERR_SEMANTIC) + return + } + + # Enter the derivative into the symbol table if the equation + # is already there, and if the fitting parameter belongs to + # the equation. + syme = pr_getsym (name) + if (!IS_INDEFI (syme)) { + if (pr_gsymi (syme, PSYMTYPE) == PTY_TRNEQ) { + + # Get parameter number for the equation. An undefined + # value means that it doesn't belong to it. + np = pr_trpnum (syme, symp) + + # If the parameter was found enter the derivative + # equation, and code in the substructure under the + # parameter number + if (!IS_INDEFI (np)) { + call pr_pderc (syme, np, PTEQDER, equation) + call pr_pderp (syme, np, PTEQRPNDER, pr_cput (rpneq, leneq)) + } else { + call sprintf (aux, SZ_LINE, + "Derivative with respect to unappropiate parameter [%s]") + call pargstr (param) + call pr_error (aux, PERR_WARNING) + } + + } else { + call sprintf (aux, SZ_LINE, + "Derivative of non-transformation equation [%s]") + call pargstr (name) + call pr_error (aux, PERR_SEMANTIC) + } + + } else { + call sprintf (aux, SZ_LINE, "Derivative of undefined equation [%s]") + call pargstr (name) + call pr_error (aux, PERR_SEMANTIC) + } +end + + +# PR_TRPLOT -- Enter plot equations of a given transformation equation +# into the symbol table. + +procedure pr_trplot (name, xploteq, yploteq, rpnxplot, lenxplot, + rpnyplot, lenyplot) + +char name[ARB] # equation name +char xploteq[ARB] # x plot equation +char yploteq[ARB] # y plot equation +pointer rpnxplot # x plot equation code +int lenxplot # x plot code length +pointer rpnyplot # y plot equation code +int lenyplot # y plot code length + +char aux[SZ_LINE] +int sym +#bool clgetb() +int pr_gsymi(), pr_getsym() +pointer pr_cput() + +begin + # Debug ? + #if (clgetb ("debug.parcode")) { + #call eprintf ("pr_trplot (%s) (%s) (%s)\n") + #call pargstr (name) + #call pargstr (xploteq) + #call pargstr (yploteq) + #call eprintf ( + #"pr_trplot (xplot=%d,%d) (yplot=%d,%d)\n") + #call pargi (rpnxplot) + #call pargi (lenxplot) + #call pargi (rpnyplot) + #call pargi (lenyplot) + #} + + # Enter the plot equations into the symbol table if the + # equation is already there. + sym = pr_getsym (name) + if (!IS_INDEFI (sym)) { + if (pr_gsymi (sym, PSYMTYPE) == PTY_TRNEQ) { + + # Enter equation string offsets + call pr_psymc (sym, PTEQXPLOT, xploteq) + call pr_psymc (sym, PTEQYPLOT, yploteq) + + # Enter equation codes + call pr_psymp (sym, PTEQRPNXPLOT, pr_cput (rpnxplot, lenxplot)) + call pr_psymp (sym, PTEQRPNYPLOT, pr_cput (rpnyplot, lenyplot)) + + } else { + call sprintf (aux, SZ_LINE, + "Plot of non-transformation equation [%s]") + call pargstr (name) + call pr_error (aux, PERR_SEMANTIC) + } + + } else { + call sprintf (aux, SZ_LINE, "Plot of undefined equation [%s]") + call pargstr (name) + call pr_error (aux, PERR_SEMANTIC) + } +end + + +# PR_TRPNUM -- Get parameter number for the equation. + +int procedure pr_trpnum (syme, symp) + +int syme # equation symbol +int symp # symbol symbol + +int i, np +#bool clgetb() +int pr_gsymi(), pr_gpari() + +begin + # Debug ? + #if (clgetb ("debug.parcode")) { + #call eprintf ("pr_trpnum (%d) (%d)\n") + #call pargi (syme) + #call pargi (symp) + #} + + # Initialize to undefined. + np = INDEFI + + # Search for the parameter into the equation substructure. + do i = 1, pr_gsymi (syme, PTEQNPAR) { + if (symp == pr_gpari (syme, i, PTEQPAR)) { + np = i + break + } + } + + # Return parameter number. + return (np) +end + + +# PR_ERREQ -- Enter the error equation of a given transformation or +# set equation into the symbol table. + +procedure pr_erreq (name, erreq, mineq, maxeq, rpnerr, lenerr, rpnmin, + lenmin, rpnmax, lenmax) + +char name[ARB] # equation name +char erreq[ARB] # error equation +char mineq[ARB] # min equation +char maxeq[ARB] # max equation +pointer rpnerr # error code +int lenerr # error code length +pointer rpnmin # min code +int lenmin # min code length +pointer rpnmax # max code +int lenmax # max code length + +char aux[SZ_LINE] +int sym, type +#bool clgetb() +int pr_gsymi(), pr_getsym() +pointer pr_cput() + +begin + # Debug ? + #if (clgetb ("debug.parcode")) { + #call eprintf ("pr_erreq (%s) (%s) (%s) (%s)\n") + #call pargstr (name) + #call pargstr (erreq) + #call pargstr (mineq) + #call pargstr (maxeq) + #call eprintf ( + #"pr_erreq (err=%d,%d) (min=%d,%d) (max=%d,%d)\n") + #call pargi (rpnerr) + #call pargi (lenerr) + #call pargi (rpnmin) + #call pargi (lenmin) + #call pargi (rpnmax) + #call pargi (lenmax) + #} + + # Enter the error, maximum, and minimum equations into the + # symbol table if the equation is already there. + sym = pr_getsym (name) + if (!IS_INDEFI (sym)) { + type = pr_gsymi (sym, PSYMTYPE) + if (type == PTY_SETEQ) { + + # Enter equation string offsets + call pr_psymc (sym, PSEQERROR, erreq) + call pr_psymc (sym, PSEQERRMIN, mineq) + call pr_psymc (sym, PSEQERRMAX, maxeq) + + # Enter equation codes + call pr_psymp (sym, PSEQRPNERROR, pr_cput (rpnerr, lenerr)) + if (lenmin > 0) + call pr_psymp (sym, PSEQRPNERRMIN, pr_cput (rpnmin, lenmin)) + if (lenmax > 0) + call pr_psymp (sym, PSEQRPNERRMAX, pr_cput (rpnmax, lenmax)) + + } else if (type == PTY_TRNEQ) { + + # Enter equation string offsets + call pr_psymc (sym, PTEQERROR, erreq) + call pr_psymc (sym, PTEQERRMIN, mineq) + call pr_psymc (sym, PTEQERRMAX, maxeq) + + # Enter equation codes + call pr_psymp (sym, PTEQRPNERROR, pr_cput (rpnerr, lenerr)) + if (lenmin > 0) + call pr_psymp (sym, PTEQRPNERRMIN, pr_cput (rpnmin, lenmin)) + if (lenmax > 0) + call pr_psymp (sym, PTEQRPNERRMAX, pr_cput (rpnmax, lenmax)) + + } else { + call sprintf (aux, SZ_LINE, + "Error of non transformation or set equation [%s]") + call pargstr (name) + call pr_error (aux, PERR_SEMANTIC) + } + + } else { + call sprintf (aux, SZ_LINE, "Error of undefined equation [%s]") + call pargstr (name) + call pr_error (aux, PERR_SEMANTIC) + } +end + + +# PR_WTSEQ -- Enter the weight equation of a given transformation or set +# equation into the symbol table. + +procedure pr_wtseq (name, wghteq, mineq, maxeq, rpnwght, lenwght, rpnmin, + lenmin, rpnmax, lenmax) + +char name[ARB] # equation name +char wghteq[ARB] # weight equation +char mineq[ARB] # min equation +char maxeq[ARB] # max equation +pointer rpnwght # weight code +int lenwght # weight code length +pointer rpnmin # min code +int lenmin # min code length +pointer rpnmax # max code +int lenmax # max code length + +char aux[SZ_LINE] +int sym, type +#bool clgetb() +int pr_gsymi(), pr_getsym() +pointer pr_cput() + +begin + # Debug ? + #if (clgetb ("debug.parcode")) { + #call eprintf ("pr_wtseq (%s) (%s) (%s) (%s)\n") + #call pargstr (name) + #call pargstr (wghteq) + #call pargstr (mineq) + #call pargstr (maxeq) + #call eprintf ( + #"pr_wtseq (wght=%d,%d) (min=%d,%d) (max=%d,%d)\n") + #call pargi (rpnwght) + #call pargi (lenwght) + #call pargi (rpnmin) + #call pargi (lenmin) + #call pargi (rpnmax) + #call pargi (lenmax) + #} + + # Enter the weight, maximum, and minimum equations into the + # symbol table if the equation is already there. + sym = pr_getsym (name) + if (!IS_INDEFI (sym)) { + type = pr_gsymi (sym, PSYMTYPE) + if (type == PTY_SETEQ) { + + # Enter equation string offsets + call pr_psymc (sym, PSEQWEIGHT, wghteq) + call pr_psymc (sym, PSEQWTSMIN, mineq) + call pr_psymc (sym, PSEQWTSMAX, maxeq) + + # Enter equation codes + call pr_psymp (sym, PSEQRPNWEIGHT, pr_cput (rpnwght, lenwght)) + if (lenmin > 0) + call pr_psymp (sym, PSEQRPNWTSMIN, pr_cput (rpnmin, lenmin)) + if (lenmax > 0) + call pr_psymp (sym, PSEQRPNWTSMAX, pr_cput (rpnmax, lenmax)) + + } else if (type == PTY_TRNEQ) { + + # Enter equation string offsets + call pr_psymc (sym, PTEQWEIGHT, wghteq) + call pr_psymc (sym, PTEQWTSMIN, mineq) + call pr_psymc (sym, PTEQWTSMAX, maxeq) + + # Enter equation codes + call pr_psymp (sym, PTEQRPNWEIGHT, pr_cput (rpnwght, lenwght)) + if (lenmin > 0) + call pr_psymp (sym, PTEQRPNWTSMIN, pr_cput (rpnmin, lenmin)) + if (lenmax > 0) + call pr_psymp (sym, PTEQRPNWTSMAX, pr_cput (rpnmax, lenmax)) + + } else { + call sprintf (aux, SZ_LINE, + "Weight of non transformation or set equation [%s]") + call pargstr (name) + call pr_error (aux, PERR_SEMANTIC) + } + + } else { + call sprintf (aux, SZ_LINE, "Weight of undefined equation [%s]") + call pargstr (name) + call pr_error (aux, PERR_SEMANTIC) + } +end + + +# PR_SECTION -- Set the equation section. + +procedure pr_section (section) + +int section # equation section + +#bool clgetb() + +begin + # Debug ? + #if (clgetb ("debug.parcode")) { + #call eprintf ("pr_section (%d)\n") + #call pargi (section) + #} + + # Set the type flag. + call pr_puti (FLAGEQSECT, section) +end + + +# PR_CHKID -- Check the identifier according to the equation section. + +procedure pr_chkid (name) + +char name[ARB] # identifier name + +bool found +char aux[SZ_LINE] +int row, nrows, type, sym +pointer table + +#bool clgetb() +int mct_nrows(), mct_geti() +int pr_geti(), pr_gsymi() +int pr_getsym() +pointer pr_getp() + +begin + # Debug ? + #if (clgetb ("debug.parcode")) { + #call eprintf ("pr_chkid (%s)\n") + #call pargstr (name) + #} + + # Check if identfier is in the table. + sym = pr_getsym (name) + if (!IS_INDEFI (sym)) { + + # Get symbol type. + type = pr_gsymi (sym, PSYMTYPE) + + # Check equation section. + switch (pr_geti (FLAGEQSECT)) { + case PRS_SETEQ: + if (type != PTY_OBSVAR && type != PTY_CATVAR && + type != PTY_SETEQ) { + call sprintf (aux, SZ_LINE, + "Illegal identifier in set equation [%s]") + call pargstr (name) + call pr_error (aux, PERR_SEMANTIC) + } + + case PRS_TRNREF: + if (type != PTY_OBSVAR && type != PTY_CATVAR && + type != PTY_SETEQ && type != PTY_TRNEQ) { + call sprintf (aux, SZ_LINE, + "Illegal identifier in reference equation [%s]") + call pargstr (name) + call pr_error (aux, PERR_SEMANTIC) + } + + # Enter observational or catalog variable into the + # corresponding sequential table, if it was not + # already there. Otherwise increment variable counter. + if (type == PTY_OBSVAR || type == PTY_CATVAR) { + + # Select temporary table + switch (type) { + case PTY_OBSVAR: + table = pr_getp (TROBSTABLE) + case PTY_CATVAR: + table = pr_getp (TRCATTABLE) + } + + # Search for symbol in the sequential table + found = false + nrows = mct_nrows (table) + do row = 1, nrows { + if (sym == mct_geti (table, row, 1)) { + found = true + break + } + } + + # Increment counter if the variable was found. + # Otherwise enter symbol and initialize counter + # to one. + if (found) { + call mct_puti (table, row, 2, + mct_geti (table, row, 2) + 1) + } else { + call mct_puti (table, nrows + 1, 1, sym) + call mct_puti (table, nrows + 1, 2, 1) + } + } + + case PRS_TRNFIT: + if (type != PTY_OBSVAR && type != PTY_CATVAR && + type != PTY_FITPAR && type != PTY_CONST && + type != PTY_SETEQ) { + call sprintf (aux, SZ_LINE, + "Illegal identifier in fit equation [%s]") + call pargstr (name) + call pr_error (aux, PERR_SEMANTIC) + } + + # Enter observational variable, catalog variable, + # fitting parameter, or constant parameter into the + # corresponding sequential table, if it was not already + # there. Otherwise, for variables, increment counter. + # For fitting parameters, also update the symbol number + # relative to the current equation. + if (type == PTY_OBSVAR || type == PTY_CATVAR || + type == PTY_FITPAR || type == PTY_CONST) { + + # Select temporary table + switch (type) { + case PTY_OBSVAR: + table = pr_getp (TFOBSTABLE) + case PTY_CATVAR: + table = pr_getp (TFCATTABLE) + case PTY_FITPAR, PTY_CONST: + table = pr_getp (TPARTABLE) + } + + # Search for symbol in the sequential table + found = false + nrows = mct_nrows (table) + do row = 1, nrows { + if (sym == mct_geti (table, row, 1)) { + found = true + break + } + } + + # Enter symbol into the sequential table if it was + # not found. For variables initialize counter, and + # for parameters update the symbol number. + # Otherwise, increment the variable counter. + if (found) { + if (type == PTY_CATVAR || type == PTY_OBSVAR) + call mct_puti (table, row, 2, + mct_geti (table, row, 2) + 1) + } else { + call mct_puti (table, nrows + 1, 1, sym) + if (type == PTY_CATVAR || type == PTY_OBSVAR) + call mct_puti (table, nrows + 1, 2, 1) + else if (type == PTY_FITPAR || type == PTY_CONST) + call pr_psymi (sym, PSYMNUM, nrows + 1) + } + } + + case PRS_TRNDER: + if (type != PTY_OBSVAR && type != PTY_CATVAR && + type != PTY_FITPAR && type != PTY_CONST && + type != PTY_SETEQ && type != PTY_TRNEQ) { + call sprintf (aux, SZ_LINE, + "Illegal identifier in derivative equation [%s]") + call pargstr (name) + call pr_error (aux, PERR_SEMANTIC) + } + + case PRS_TRNPLOT: + if (type != PTY_OBSVAR && type != PTY_CATVAR && + type != PTY_FITPAR && type != PTY_CONST && + type != PTY_SETEQ && type != PTY_TRNEQ) { + call sprintf (aux, SZ_LINE, + "Illegal identifier in plot equation [%s]") + call pargstr (name) + call pr_error (aux, PERR_SEMANTIC) + } + + case PRS_ERREQ: + if (type != PTY_OBSVAR && type != PTY_CATVAR && + type != PTY_FITPAR && type != PTY_CONST && + type != PTY_SETEQ) { + call sprintf (aux, SZ_LINE, + "Illegal identifier in error equation [%s]") + call pargstr (name) + call pr_error (aux, PERR_SEMANTIC) + } + + case PRS_WTSEQ: + if (type != PTY_OBSVAR && type != PTY_CATVAR && + type != PTY_FITPAR && type != PTY_CONST && + type != PTY_SETEQ) { + call sprintf (aux, SZ_LINE, + "Illegal identifier in weight equation [%s]") + call pargstr (name) + call pr_error (aux, PERR_SEMANTIC) + } + + case PRS_LMTEQ: + if (type != PTY_OBSVAR && type != PTY_CATVAR && + type != PTY_FITPAR && type != PTY_CONST && + type != PTY_SETEQ) { + call sprintf (aux, SZ_LINE, + "Illegal identifier in min or max equation [%s]") + call pargstr (name) + call pr_error (aux, PERR_SEMANTIC) + } + + default: call error (0, "pr_chkid: Unknown section type") + } + + } else { + call sprintf (aux, SZ_LINE, + "Undefined identifier in expression [%s]") + call pargstr (name) + call pr_error (aux, PERR_SEMANTIC) + } +end diff --git a/noao/digiphot/photcal/parser/prvtran.x b/noao/digiphot/photcal/parser/prvtran.x new file mode 100644 index 00000000..6119ce05 --- /dev/null +++ b/noao/digiphot/photcal/parser/prvtran.x @@ -0,0 +1,25 @@ +# PR_VTRAN -- Translate the internal parser symbol for an error or weight +# column definition into a compact user readable definition. This code is +# intended primarily for interfacing to the inlfit or other package with +# the goal of making more pleasing variable names. + +procedure pr_vtran (invname, outvname, maxch) + +char invname[ARB] # the input variable name +char outvname[ARB] # the output variable name +int maxch # maximum number of characters + +int first, last +int gstrmatch() + +begin + if (gstrmatch (invname, "@E_", first, last) != 0) { + call sprintf (outvname, maxch, "er(%s)") + call pargstr (invname[last+1]) + } else if (gstrmatch (invname, "@W_", first, last) != 0) { + call sprintf (outvname, maxch, "wt(%s)") + call pargstr (invname[last+1]) + } else { + call strcpy (invname, outvname, maxch) + } +end diff --git a/noao/digiphot/photcal/parser/t_chkconfig.x b/noao/digiphot/photcal/parser/t_chkconfig.x new file mode 100644 index 00000000..0b75c4e9 --- /dev/null +++ b/noao/digiphot/photcal/parser/t_chkconfig.x @@ -0,0 +1,228 @@ +include "../lib/parser.h" + + +# T_CHKCONFIG - Check the configuration file for syntax and semantic errors, +# and print information on the standard output about all the entities declared +# in it. + +procedure t_chkconfig () + +char input[SZ_FNAME] # input file name +bool verbose # verbose output + +bool done +int i, j, n, sym + +bool clgetb() +int pr_parse(), pr_gsym(), pr_geti(), pr_gsymi(), pr_gpari() +real pr_gsymr() +pointer pr_xgetname(), pr_gsymc(), pr_gderc(), pr_gderp() + +begin + # Get the task parameters. + call clgstr ("config", input, SZ_FNAME) + verbose = clgetb ("verbose") + + # Print the beginning of compilation message. + call printf ("\n\n** Beginning of compilation **\n\n") + + # Parse the input file. + done = (pr_parse (input) == OK) + + # Print the end of compilation message. + call printf ("\n** End of compilation **\n\n") + + # Print verbose output. + if (done && verbose) { + + # Print the catalog variables. + n = pr_geti (NCATVARS) + if (n > 0) { + + # Print section title + call printf ( + "\nCATALOG VARIABLES, COLUMNS, AND ERROR COLUMNS:\n\n") + + # Loop over all variables + do i = 1, n { + sym = pr_gsym (i, PTY_CATVAR) + if (pr_gsymi (sym, PINPSPARE) == YES) + next + call printf ("%2d %s\t%d\t%d\n") + call pargi (pr_gsymi (sym, PSYMNUM)) + call pargstr (Memc[pr_xgetname (sym)]) + call pargi (pr_gsymi (sym, PINPCOL)) + call pargi (pr_gsymi (sym, PINPERRCOL)) + } + } + + # Print input obervation variables. + n = pr_geti (NOBSVARS) + if (n > 0) { + + # Print section title + call printf ( + "\nOBSERVATIONAL VARIABLES, COLUMNS, AND ERROR COLUMNS:\n\n") + + # Loop over all variables + do i = 1, n { + sym = pr_gsym (i, PTY_OBSVAR) + if (pr_gsymi (sym, PINPSPARE) == YES) + next + call printf ("%2d %s\t%d\t%d\n") + call pargi (pr_gsymi (sym, PSYMNUM)) + call pargstr (Memc[pr_xgetname (sym)]) + call pargi (pr_gsymi (sym, PINPCOL)) + call pargi (pr_gsymi (sym, PINPERRCOL)) + } + } + + # Print the fitting and constant parameters. + n = pr_geti (NTOTPARS) + if (n > 0) { + + # Print section title + call printf ( + "\nFIT AND CONSTANT PARAMETER VALUES:\n\n") + + # Loop over all fitting parameters + do i = 1, n { + sym = pr_gsym (i, PTY_FITPAR) + call printf ("%2d %s\t%g\t%s\n") + call pargi (i) + call pargstr (Memc[pr_xgetname (sym)]) + call pargr (pr_gsymr (sym, PFITVALUE)) + if (pr_gsymi (sym, PSYMTYPE) == PTY_CONST) + call pargstr ("(constant)") + else + call pargstr ("") + } + } + + # Print the set equations. + n = pr_geti (NSETEQS) + if (n > 0) { + + # Print title + call printf ( + "\nAUXILIARY (SET) EQUATIONS:\n\n") + + # Loop over all equations + do i = 1, n { + + # Print the equation. + sym = pr_gsym (i, PTY_SETEQ) + call printf ("%2d %s = %s\n") + call pargi (pr_gsymi (sym, PSYMNUM)) + call pargstr (Memc[pr_xgetname (sym)]) + call pargstr (Memc[pr_gsymc (sym, PSEQEQ)]) + + # Print the error equation. + call printf (" error = %s, min = %s, max = %s\n") + call pargstr (Memc[pr_gsymc (sym, PSEQERROR)]) + call pargstr (Memc[pr_gsymc (sym, PSEQERRMIN)]) + call pargstr (Memc[pr_gsymc (sym, PSEQERRMAX)]) + +# # Print the weight equation. +# call printf (" weight = %s, min = %s, max = %s\n") +# call pargstr (Memc[pr_gsymc (sym, PSEQWEIGHT)]) +# call pargstr (Memc[pr_gsymc (sym, PSEQWTSMIN)]) +# call pargstr (Memc[pr_gsymc (sym, PSEQWTSMAX)]) + + call printf ("\n") + } + } + + # Print the transformation equations. + n = pr_geti (NTRNEQS) + if (n > 0) { + + # Print section title + call printf ( + "\nTRANSFORMATION EQUATIONS:\n\n") + + # Loop over all equations + do i = 1, n { + + # Print the equation. + sym = pr_gsym (i, PTY_TRNEQ) + call printf ("%2d %s: %s = %s\n") + call pargi (pr_gsymi (sym, PSYMNUM)) + call pargstr (Memc[pr_xgetname (sym)]) + call pargstr (Memc[pr_gsymc (sym, PTEQREF)]) + call pargstr (Memc[pr_gsymc (sym, PTEQFIT)]) + + # Print the derivative equations. + do j = 1, pr_gsymi (sym, PTEQNPAR) { + if (pr_gderp (sym, j, PTEQRPNDER) != NULL) { + call printf (" derivative (%s, %s) = %s\n") + call pargstr (Memc[pr_xgetname (sym)]) + call pargstr (Memc[pr_xgetname (pr_gpari (sym, + j, PTEQPAR))]) + call pargstr (Memc[pr_gderc (sym, j, PTEQDER)]) + } else { + call printf (" delta(%s, %s) = %s\n") + call pargstr (Memc[pr_xgetname (sym)]) + call pargstr (Memc[pr_xgetname (pr_gpari (sym, + j, PTEQPAR))]) + call pargr (pr_gsymr(pr_gpari (sym, j, PTEQPAR), + PFITDELTA)) + } + } + + # Print the error equation. + call printf (" error = %s, min = %s, max = %s\n") + call pargstr (Memc[pr_gsymc (sym, PTEQERROR)]) + call pargstr (Memc[pr_gsymc (sym, PTEQERRMIN)]) + call pargstr (Memc[pr_gsymc (sym, PTEQERRMAX)]) + + # Print the weight equation. + call printf (" weight = %s, min = %s, max = %s\n") + call pargstr (Memc[pr_gsymc (sym, PTEQWEIGHT)]) + call pargstr (Memc[pr_gsymc (sym, PTEQWTSMIN)]) + call pargstr (Memc[pr_gsymc (sym, PTEQWTSMAX)]) + + # Print the plot defaults. + call printf (" plot x = %s, y = %s\n") + call pargstr (Memc[pr_gsymc (sym, PTEQXPLOT)]) + call pargstr (Memc[pr_gsymc (sym, PTEQYPLOT)]) + + call printf ("\n") + } + call printf ("\n") + } + } + + # Print the counter values. + call printf ("Catalog input variables = %d\n") + call pargi (pr_geti (NCATVARS)) + call printf ("First catalog column = %d\n") + call pargi (pr_geti (MINCATCOL)) + call printf ("Last catalog column = %d\n\n") + call pargi (pr_geti (MAXCATCOL)) + call printf ("Observational input variables = %d\n") + call pargi (pr_geti (NOBSVARS)) + call printf ("First observational column = %d\n") + call pargi (pr_geti (MINOBSCOL)) + call printf ("Last observational column = %d\n\n") + call pargi (pr_geti (MAXOBSCOL)) + call printf ("Fitting parameters = %d\n") + call pargi (pr_geti (NFITPARS)) + call printf ("Constant parameters = %d\n\n") + call pargi (pr_geti (NTOTPARS) - pr_geti (NFITPARS)) +# call printf ("Extinction equations = %d\n") +# call pargi (pr_geti (NEXTEQS)) + call printf ("Auxiliary (set) equations = %d\n") + call pargi (pr_geti (NSETEQS)) + call printf ("Transformation equations = %d\n\n") + call pargi (pr_geti (NTRNEQS)) + call printf ("Warnings = %d\n") + call pargi (pr_geti (NWARNINGS)) + call printf ("Errors = %d\n") + call pargi (pr_geti (NERRORS)) + call flush (STDOUT) + + # Free the tables. + if (done) + call pr_free () +end diff --git a/noao/digiphot/photcal/parser/y.tab.h b/noao/digiphot/photcal/parser/y.tab.h new file mode 100644 index 00000000..8b3119a8 --- /dev/null +++ b/noao/digiphot/photcal/parser/y.tab.h @@ -0,0 +1,42 @@ +define OBSSECT 257 +define CATSECT 258 +define EXTSECT 259 +define TRNSECT 260 +define FITID 261 +define CONSTID 262 +define DELTAID 263 +define ERRORID 264 +define WEIGHTID 265 +define MINID 266 +define MAXID 267 +define DERIVID 268 +define PLOTID 269 +define SETID 270 +define F_ABS 271 +define F_ACOS 272 +define F_ASIN 273 +define F_ATAN 274 +define F_COS 275 +define F_EXP 276 +define F_LOG 277 +define F_LOG10 278 +define F_SIN 279 +define F_SQRT 280 +define F_TAN 281 +define IDENTIFIER 282 +define INUMBER 283 +define RNUMBER 284 +define PLUS 285 +define MINUS 286 +define STAR 287 +define SLASH 288 +define EXPON 289 +define COLON 290 +define SEMICOLON 291 +define COMMA 292 +define EQUAL 293 +define LPAR 294 +define RPAR 295 +define EOFILE 296 +define UPLUS 297 +define UMINUS 298 |