------------------------------------------------------------------------------ -- BUSH Calendar Package Parser -- -- -- -- Part of BUSH -- ------------------------------------------------------------------------------ -- -- -- Copyright (C) 2001-2005 Ken O. Burtch & FSF -- -- -- -- This is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. This is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- -- for more details. You should have received a copy of the GNU General -- -- Public License distributed with this; see file COPYING. If not, write -- -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- -- MA 02111-1307, USA. -- -- -- -- This is maintained at http://www.pegasoft.ca -- -- -- ------------------------------------------------------------------------------ with text_io;use text_io; with world, scanner.calendar, string_util, parser_aux, parser, bush_os; use world, scanner, scanner.calendar, string_util, parser_aux, parser, bush_os; package body parser_cal is procedure ParseCalClock( result : out unbounded_string ) is begin expect( cal_clock_t ); result := to_unbounded_string( clock'img ); end ParseCalClock; procedure ParseCalYear( result : out unbounded_string ) is expr_val : unbounded_string; expr_type : identifier; begin expect( cal_year_t ); expect( symbol_t, "(" ); ParseExpression( expr_val, expr_type ); if baseTypesOK( expr_type, cal_time_t ) then null; end if; expect( symbol_t, ")" ); if isExecutingCommand then begin result := to_unbounded_string( year( time( to_numeric( expr_val ) ) )'img ); exception when others => err( "exception raised" ); end; end if; end ParseCalYear; procedure ParseCalMonth( result : out unbounded_string ) is expr_val : unbounded_string; expr_type : identifier; begin expect( cal_month_t ); expect( symbol_t, "(" ); ParseExpression( expr_val, expr_type ); if baseTypesOK( expr_type, cal_time_t ) then null; end if; expect( symbol_t, ")" ); if isExecutingCommand then begin result := to_unbounded_string( month( time( to_numeric( expr_val ) ) )'img ); exception when others => err( "exception raised" ); end; end if; end ParseCalMonth; procedure ParseCalDay( result : out unbounded_string ) is expr_val : unbounded_string; expr_type : identifier; begin expect( cal_day_t ); expect( symbol_t, "(" ); ParseExpression( expr_val, expr_type ); if baseTypesOK( expr_type, cal_time_t ) then null; end if; expect( symbol_t, ")" ); if isExecutingCommand then begin result := to_unbounded_string( day( time( to_numeric( expr_val ) ) )'img ); exception when others => err( "exception raised" ); end; end if; end ParseCalDay; procedure ParseCalSeconds( result : out unbounded_string ) is expr_val : unbounded_string; expr_type : identifier; begin expect( cal_seconds_t ); expect( symbol_t, "(" ); ParseExpression( expr_val, expr_type ); if baseTypesOK( expr_type, cal_time_t ) then null; end if; expect( symbol_t, ")" ); if isExecutingCommand then begin result := to_unbounded_string( long_float( seconds( time( to_numeric( expr_val ) ) ) )'img ); exception when others => err( "exception raised" ); end; end if; end ParseCalSeconds; procedure ParseCalSplit is date_val : unbounded_string; date_type : identifier; id1_ref : reference; id2_ref : reference; id3_ref : reference; id4_ref : reference; year : year_number; month : month_number; day : day_number; seconds : day_duration; begin expect( cal_split_t ); expect( symbol_t, "(" ); ParseExpression( date_val, date_type ); if baseTypesOK( date_type, cal_time_t ) then expect( symbol_t, "," ); ParseOutParameter( id1_ref, cal_year_number_t ); if baseTypesOK( id1_ref.kind, cal_year_number_t ) then null; end if; expect( symbol_t, "," ); ParseOutParameter( id2_ref, cal_month_number_t ); if baseTypesOK( id2_ref.kind, cal_month_number_t ) then null; end if; expect( symbol_t, "," ); ParseOutParameter( id3_ref, cal_day_number_t ); if baseTypesOK( id3_ref.kind, cal_day_number_t ) then null; end if; expect( symbol_t, "," ); ParseOutParameter( id4_ref, cal_day_duration_t ); if baseTypesOK( id4_ref.kind, cal_day_duration_t ) then null; end if; end if; if isExecutingCommand then begin Split( time( to_numeric( date_val ) ), year, month, day, seconds ); AssignParameter( id1_ref, to_unbounded_string( year'img ) ); AssignParameter( id2_ref, to_unbounded_string( month'img ) ); AssignParameter( id3_ref, to_unbounded_string( day'img ) ); AssignParameter( id4_ref, to_unbounded_string( seconds'img ) ); exception when others => err( "exception raised" ); end; end if; expect( symbol_t, ")" ); end ParseCalSplit; procedure ParseCalTimeOf( result : out unbounded_string ) is year_val : unbounded_string; year_type : identifier; month_val : unbounded_string; month_type : identifier; day_val : unbounded_string; day_type : identifier; secs_val : unbounded_string; secs_type : identifier; begin expect( cal_time_of_t ); expect( symbol_t, "(" ); ParseExpression( year_val, year_type ); if baseTypesOK( year_type, cal_year_number_t ) then null; end if; expect( symbol_t, "," ); ParseExpression( month_val, month_type ); if baseTypesOK( month_type, cal_month_number_t ) then null; end if; expect( symbol_t, "," ); ParseExpression( day_val, day_type ); if baseTypesOK( day_type, cal_day_number_t ) then null; end if; expect( symbol_t, "," ); ParseExpression( secs_val, secs_type ); if baseTypesOK( secs_type, cal_day_duration_t ) then null; end if; if isExecutingCommand then begin result := to_unbounded_string( Time_Of( year_number( to_numeric( year_val ) ), month_number( to_numeric( month_val ) ), day_number( to_numeric( day_val ) ), day_duration( to_numeric( secs_val ) ) )'img ); exception when time_error => err( "time error: illegal time value" ); when constraint_error => err( "constraint error: values out of range" ); when others => err( "exception raised" ); end; end if; expect( symbol_t, ")" ); end ParseCalTimeOf; procedure ParseCalToJulian( result : out unbounded_string ) is expr_val : unbounded_string; expr_type : identifier; begin expect( cal_to_julian_t ); expect( symbol_t, "(" ); ParseExpression( expr_val, expr_type ); if baseTypesOK( expr_type, cal_time_t ) then null; end if; expect( symbol_t, ")" ); if isExecutingCommand then declare -- Communications of the ACM, October 1968 Year : year_number; Month : month_number; day : day_number; DayDur : day_duration; I : long_float; J : long_float; K : long_float; Julian : long_float; Term1 : long_float; Term2 : long_float; Term3 : long_float; begin Split( time( to_numeric( expr_val ) ), Year, Month, Day, DayDur ); I := long_float( Year ); J := long_float( Month ); K := long_float( Day ); Term1 := long_float'truncation( I + 4800.0 + long_float'truncation( (J-14.0) / 12.0 ) / 4.0 ); Term2 := 367.0 * long_float'truncation( ( J - 2.0 - long_float'truncation( ( J-14.0 ) / 12.0 ) * 12.0 ) / 12.0 ); Term3 := 3.0 * long_float'truncation( ( long_float'truncation( ( I + 4900.0 + long_float'truncation( ( J-14.0 ) / 12.0 ) ) / 100.0 ) ) / 4.0 ); Julian := K - 32075.0 + 1461.0 * Term1 + Term2 - Term3; result := to_unbounded_string( long_integer( Julian )'img ); exception when others => err( "exception raised" ); end; end if; end ParseCalToJulian; procedure ParseCalToTime( result : out unbounded_string ) is expr_val : unbounded_string; expr_type : identifier; begin expect( cal_to_time_t ); expect( symbol_t, "(" ); ParseExpression( expr_val, expr_type ); if baseTypesOK( expr_type, long_integer_t ) then null; end if; expect( symbol_t, ")" ); if isExecutingCommand then declare -- Communications of the ACM, October 1968 Julian : long_float; Year : Year_Number; Month : Month_Number; Day : Day_Number; I : long_float; J : long_float; K : long_float; L : long_float; N : long_float; begin Julian := long_float( to_numeric( expr_val ) ); L := Julian + 68569.0; N := 4.0 * long_float'truncation( L / 146097.0 ); L := L - long_float'truncation( ( 146097.0 * N + 3.0 ) / 4.0 ); I := 4000.0 * long_float'truncation( ( L+1.0 ) / 1461001.0 ); L := L - 1461.0 * long_float'truncation( I / 4.0) + 31.0; J := 80.0 * long_float'truncation( L / 2447.0 ); K := L - 2447.0 * long_float'truncation( J / 80.0 ); L := long_float'truncation( J / 11.0 ); J := J+2.0-12.0*L; I := 100.0 * (N-49.0) + I + L; Year := Year_Number( I ); Month := Month_Number( J ); Day := Day_Number( K ); result := to_unbounded_string( long_integer( time_of( Year, Month, Day, 0.0 ) ) 'img ); exception when others => err( "exception raised" ); end; end if; end ParseCalToTime; procedure ParseCalDayOfWeek( result : out unbounded_string ) is expr_val : unbounded_string; expr_type : identifier; begin expect( cal_day_of_week_t ); expect( symbol_t, "(" ); ParseExpression( expr_val, expr_type ); if baseTypesOK( expr_type, cal_time_t ) then null; end if; expect( symbol_t, ")" ); if isExecutingCommand then declare Year : year_number; Month : month_number; day : day_number; DayDur : day_duration; wday : integer; begin Split( time( to_numeric( expr_val ) ), Year, Month, Day, DayDur ); C_day_of_week( wday, Year, Month, Day ); result := to_unbounded_string( wday'img ); exception when others => err( "exception raised" ); end; end if; end ParseCalDayOfWeek; procedure StartupCalendar is begin declareIdent( cal_time_t, "calendar.time", variable_t, typeClass ); declareIdent( cal_year_number_t, "calendar.year_number", integer_t, typeClass ); declareIdent( cal_month_number_t, "calendar.month_number", integer_t, typeClass ); declareIdent( cal_day_number_t, "calendar.day_number", integer_t, typeClass ); declareIdent( cal_day_duration_t, "calendar.day_duration", duration_t, typeClass ); declareFunction( cal_clock_t, "calendar.clock" ); declareFunction( cal_year_t, "calendar.year" ); declareFunction( cal_month_t, "calendar.month" ); declareFunction( cal_day_t, "calendar.day" ); declareFunction( cal_seconds_t, "calendar.seconds" ); declareProcedure( cal_split_t, "calendar.split" ); declareFunction( cal_time_of_t, "calendar.time_of" ); declareFunction( cal_to_julian_t, "calendar.to_julian" ); declareFunction( cal_to_time_t, "calendar.to_time" ); declareFunction( cal_day_of_week_t, "calendar.day_of_week" ); end StartupCalendar; procedure ShutdownCalendar is begin null; end ShutdownCalendar; end parser_cal;