diff --git a/doc/gapmacro.tex b/doc/gapmacro.tex index 55fc76496a..9fb82dd87f 100644 --- a/doc/gapmacro.tex +++ b/doc/gapmacro.tex @@ -26,10 +26,11 @@ %% verbatim material temporary escape character) %% \endtt %% -%% \Chapter{title} -%% \Section{title}\null\par +%% \Input{file} includes file `file.tex' (not recommended for appendices) +%% \Chapter title \par +%% \Section{title} \par %% make chapter or section title. Automatically generates table of -%% contents. \null after \Section inhibits labels and indexing. +%% contents. \null after \Section{...} inhibits labels and indexing. %% \>function( arguments )!{ index subentry } %% \>`a binop b'{binary operation}!{ index subentry } %% make a heading for a subsection explaining a function or a binary @@ -39,8 +40,8 @@ %% the same without label and index entry %% %% \FrontMatter, \Chapters, \Appendices parts of the book -%% \Bibliography, \TableOfContents make these chapters automatically -%% \Index make index without chapter head +%% \Bibliography, \Index make these chapters (w/o head) +%% \TableOfContents %% % Page dimensions and double column output. @@ -137,7 +138,7 @@ \obeyspaces \obeylines \tt} {\obeyspaces\global\let =\ } {\obeylines\gdef\obeylines{\catcode`^^M=\active}\gdef^^M{\par}% - \catcode`#=\active \catcode`&=6 \gdef#&1^^M{\char35 \hbox{\rm &1}\par}} + \catcode`#=\active \catcode`&=6 \gdef#&1^^M{\hbox{\rm\char35 &1}\par}} \outer\def\begintt{\medskip\ttverbatim \def\par{\ifvmode\allowbreak\smallskip\else\endgraf\nobreak\fi} \parskip=0pt \catcode`\|=0 \rightskip-5pc \ttfinish} @@ -155,9 +156,9 @@ % Input/output streams. Chapter and section counters. \newwrite\labelout \newwrite\indexout \newwrite\secindout -\newwrite\tocout \newwrite\citeout +\newwrite\tocout \newwrite\citeout \newwrite\ans \newread \labelin \newread \indexin \newread \tocin \newread \citein -\newcount\chapno \newcount\secno +\newcount\chapno \newcount\secno \newcount\exno % Additional active characters and their default meanings. \mathcode`.="2201 \mathchardef\.="702E @@ -166,7 +167,8 @@ \catcode`!=\active \let!=\excl \catcode`^=\active \def^{\ifmmode\sp\else{\char`\^}\fi} \catcode`_=\active \def_{\ifmmode\sb\else\_\fi} \let\_=\underscore -\catcode`*=\active \def*#1*{{\sl #1}} \chardef\*=`* +\catcode`*=\active \def*{\ifmmode\let\next=\*\else\let\next=\bold\fi\next} + \def\bold#1*{{\sl #1\/}} \chardef\*=`* \catcode`<=\active \def<#1>{{\chardef*=`*\let_=\_\it#1}}\chardef\<=`< \catcode`"=\active \def"{\begingroup\undoquotes\doref} \chardef\"=`" \chardef\\=`\\ @@ -212,26 +214,34 @@ \gdef\bibitem[#1]#2{\expandafter\gdef\csname c@#2\endcsname{#1}% \item{\sigel{#2}}}} \def\cite#1{\write\citeout{\bs citation{#1}}\sigel{#1}} -\def\atindex#1#2#3{\write\indexout{\noexpand\indexentry{#1#2#3}{\folio}}% - \write\secindout{\thechapter.\the\secno. #1#3}\ifvmode\nobreak\fi} -\def\index#1{\atindex{#1}{}{}} +\def\doindex#1#2#3{\write\indexout{\noexpand\indexentry{#1#2#3}{\folio}}% + \ifvmode\nobreak\fi} +\def\dosecindex#1#2#3{\immediate\write\secindout + {#1 \thechapter.\the\secno. #2#3}} +\def\bothindex#1#2#3#4{\doindex{#2}{#3}{#4}\dosecindex{#1}{#2}{#4}} +\def\index#1{\bothindex I{#1}{}{}} +\def\atindex#1#2{\bothindex I{#1}{#2}{}} \def\indexit#1{{\it #1}} % Macros for chapter and section headings. +\def\filename{appendix} \def\tocstrut{{\setbox0=\hbox{1}\vrule width 0pt height\ht0}} -\def\Chapter#1{\vfill\supereject \headlinefalse - \advance\chapno by1 \secno=0 \def\chapname{#1} +\outer\def\Input#1{\def\filename{#1.tex}\input #1} +\outer\long\def\Chapter#1 \par{\vfill\supereject \headlinefalse + \advance\chapno by1 \secno=0 \exno=0 \def\chapname{#1} \label{chapter:#1} \write\tocout{\noexpand\chapcontents{\thechapter}{#1}{\folio}} + \immediate\write\secindout{C \filename\space\thechapter. \chapname} \setbox0=\hbox{\inchhigh\kern-.075em\thechapter} \setbox1=\vbox{\titlefont \advance\hsize by-\wd0 \advance\hsize by-2em \leftskip 0pt plus 1fil \parfillskip 0pt \baselineskip 44pt\relax #1} \line{\box0\hfil\box1}\nobreak \vskip 40pt plus10pt \noindent} -\long\def\Section#1#2\par{\medskip \advance\secno by1 +\outer\long\def\Section#1#2\par{\medskip \advance\secno by1 {\let!=\space \mark{Section \the\secno. #1}} \edef\tempa{\thechapter.\the\secno}\expandafter\writesecline\tempa\\{#1} - \ifx#2\null\else \label{#1}\edef\tempa{#1} - \expandafter\atindex\expandafter{\tempa}{\noexpand|indexit}{}\fi + \dosecindex S{#1}{} + \ifx#2\null\else \label{#1}\edef\tempa{{#1}} + \expandafter\doindex\tempa{|indexit}{}\fi {\baselineskip 18pt\let!=\space \noindent\secfont\thechapter.\the\secno \enspace #1\par}\nobreak\medskip\noindent} \def\writesecline#1\\#2{\write\tocout{\noexpand\seccontents{#1}{#2}{\folio}}} @@ -247,8 +257,9 @@ \ifvmode \vskip -\lastskip \fi \medskip \begingroup\let\par=\fpar\fi \endgraf\futurelet\next\oporfunc} \def\subfunction#1#2{\overlay{#1}{#2}\label{#1!#2}% - \atindex{#1}{@\noexpand`#1'}{!#2}\endgroup} -\def\suboperation#1#2{\overlay{#1}{#2}\label{#1!#2}\index{#1!#2}\endgroup} + \bothindex F{#1}{@\noexpand`#1'}{!#2}\endgroup} +\def\suboperation#1#2{\overlay{#1}{#2}\label{#1!#2}% + \bothindex F{#1}{}{!#2}\endgroup} \def\overlay#1#2{\hfill{\it \ov{#1}{#2}{groups}{groups}% \ov{#1}{#2}{solvable groups}{solv\thinspace gps}% @@ -262,6 +273,37 @@ \def\beginitems{\smallskip\begingroup \parindent 0pt \catcode`&=\active} \def\enditems{\par\endgroup\smallskip\noindent\ignorespaces} +% Macros for exercises. +\outer\def\exercise{\advance\exno by1\begingroup + \def\par{\endgraf\endgroup\medskip\noindent} + \medskip\noindent\fmark{\bf Exercise \thechapter.\the\exno.}\quad} +\outer\def\answer{\immediate\write\ans{}% + \immediate\write\ans{\noexpand\textindent + {\noexpand\bf\thechapter.\the\exno.}}% + \copytoblankline} +\def\copytoblankline{\begingroup\setupcopy\copyans} +{\undoquotes +\gdef\setupcopy{\catcode`\\=\other + \catcode`\{=\other + \catcode`\}=\other + \catcode`\<=\other + \catcode`\$=\other + \catcode`\%=\other + \catcode`\~=\other + \catcode`\^=\other + \catcode`\_=\other + \catcode`\*=\other + \catcode`\`=\other + \catcode`\!=\other + \catcode`\"=\other + \catcode`\&=\other + \catcode`\#=\other + \catcode`\|=\other \obeylines \obeyspaces} +\obeylines \gdef\copyans#1 + {\def\next{#1}% + \ifx\next\empty\let\next=\endgroup % + \else\immediate\write\ans{\next}\let\next=\copyans\fi\next}} + % Macros for the active backquote character (`). \tracinglostchars=0 \hyphenchar\tentt=128 \lccode`.=`. {\catcode`.=\active \gdef.{\char'056 \penalty0}} @@ -278,11 +320,13 @@ \long\def\operation`#1'#2#3{{\def\[{\moveup\lbrack}\def\]{\moveup\rbrack}% \def\|{\vrule\relax}}\fmark{`#1'}% \ifx#3!\begingroup\undoquotes\def\next{\suboperation{#2}} - \else\overlay{#2}\null \label{#2}\index{#2}\let\next=#3\fi\next} + \else\overlay{#2}\null \label{#2}% + \bothindex F{#2}{}{}\let\next=#3\fi\next} \long\def\function#1(#2)#3{{\def\[{\moveup\lbrack}\def\]{\moveup\rbrack}% \def\|{\vrule\relax}\fmark{`#1(#2)'}}% \ifx#3!\begingroup\undoquotes\def\next{\subfunction{#1}}\else - \overlay{#1}\null\label{#1}\atindex{#1}{@\noexpand`#1'}{}\let\next=#3\fi + \overlay{#1}\null\label{#1}\bothindex F{#1}{@\noexpand`#1'}{}% + \let\next=#3\fi \next} \def`{\futurelet\next\backquote} \def\backquote{\ifx\next`\let\next=\doublebackquote @@ -308,7 +352,7 @@ \immediate\closein#1 \input\jobname.#2 \fi} % Macros for the parts of the manual. -\def\FrontMatter{\def\thechapter{\noexpand\tocstrut} +\outer\def\FrontMatter{\def\thechapter{\noexpand\tocstrut} \def\lefthead{\it\chapname} \let\righthead=\lefthead \begingroup @@ -326,31 +370,27 @@ \immediate\write\citeout{\bs bibstyle{alpha}} \immediate\write\citeout{\bs bibdata{}}} -\def\Chapters{\vfill\eject +\outer\def\Chapters{\vfill\eject \chapno=0 \def\thechapter{\the\chapno} \def\lefthead{{\it Chapter \the\chapno. \chapname}} \def\righthead{\ifx\botmark\empty\lefthead\else{\it \botmark}\fi}} -\def\Appendices{\vfill\eject - \parskip 1ex plus 0.5ex minus 0.5ex - \parindent 0pt +\outer\def\Appendices{\vfill\eject + \def\filename{appendix} \chapno=0 \def\thechapter{\noexpand\appno{\the\chapno}} \def\lefthead{{\it Appendix \appno{\the\chapno}. \chapname}} \let\righthead=\lefthead} -\def\Bibliography{\Chapter{Bibliography} - \begingroup\undoquotes\frenchspacing +\outer\def\Bibliography{\begingroup\undoquotes\frenchspacing + \parskip 1ex plus 0.5ex minus 0.5ex \def\begin##1##2{} \def\end##1{} \let\newblock=\relax \let\em=\sl - \parindent\manindent \inputaux\citein{bbl} \endgroup} -\def\Index{\bigskip +\outer\def\Index{\bigskip \begindoublecolumns - \parskip 0pt - \rightskip 0pt plus2em - \emergencystretch 2em + \parindent 0pt \parskip 0pt \rightskip 0pt plus2em \emergencystretch 2em \everypar{\hangindent\smallmanindent} \def\par{\endgraf\leftskip 0pt} \def\sub{\advance\leftskip by\smallmanindent} @@ -360,30 +400,29 @@ \enddoublecolumns \vfill\supereject + \immediate\write16{##} \immediate\closeout\citeout - \immediate\write16{Citations for BibTeX written on \jobname.aux.} + \immediate\write16{## Citations for BibTeX written on \jobname.aux.} \immediate\closeout\indexout - \immediate\write16{Index entries written on \jobname.idx.} + \immediate\write16{## Index entries written on \jobname.idx.} \immediate\closeout\secindout - \immediate\write16{Section index entries written on \jobname.six.} + \immediate\write16{## Section index entries written on \jobname.six.} \immediate\closeout\labelout - \immediate\write16{Label definitions written on \jobname.lab.} + \immediate\write16{## Label definitions written on \jobname.lab.} \immediate\closeout\tocout - \immediate\write16{Table of contents written on \jobname.toc.} - + \immediate\write16{## Table of contents written on \jobname.toc.} + \iflabundef\immediate\write16{## There were undefined labels or + references.}\fi + \iflabchanged\immediate\write16{## Labels have changed, run again. (Or + they were multiply defined.)}\fi + \immediate\write16{##} \pageno=-1 - \headlinefalse} + \headlinefalse + \def\thechapter{\noexpand\tocstrut} \def\label##1{} + \def\lefthead{\chapname} \let\righthead=\lefthead} -\def\TableOfContents{\def\thechapter{\noexpand\tocstrut} - \def\lefthead{\chapname} \let\righthead=\lefthead - \def\label##1{} - \Chapter{Contents} - - \begingroup +\outer\def\TableOfContents{\begingroup \let!=\space \inputaux\tocin{toc}\vfill\eject - \endgroup + \endgroup} - \iflabundef\immediate\write16{There were undefined labels or references.}\fi - \iflabchanged\immediate\write16{Labels have changed, run again. (Or - they were multiply defined.)}\fi} diff --git a/doc/tut/copyrigh.tex b/doc/tut/copyrigh.tex new file mode 100644 index 0000000000..b294e76344 --- /dev/null +++ b/doc/tut/copyrigh.tex @@ -0,0 +1,64 @@ +\Chapter{Copyright Notice} + +\centerline{\undoquotes Copyright {\copyright} 1997 by +\vtop{\hbox{Lehrstuhl D f\"ur Mathematik, RWTH, D-52056 Aachen, + Germany, and} + \hbox{School of Mathematical and Computational Sciences, + University of St.~Andrews,} + \hbox{\qquad North Haugh, St.~Andrews, Fife KY16 9SS, Scotland}}} +\bigskip + +\begingroup +\parindent 0pt +\parskip 1pc + +{\GAP} can be copied and distributed freely for any non-commercial +purpose. + +If you copy {\GAP} for somebody else, you may ask this person for refund +of your expenses. This should cover cost of media, copying and shipping. +You are not allowed to ask for more than this. In any case you must give +a copy of this copyright notice along with the program. + +If you obtain {\GAP} please send us a short notice to that effect, e.g., +an e-mail message to the address `gap@samson.math.rwth-aachen.de', +containing your full name and address. This allows us to keep track of +the number of {\GAP} users. + +If you publish a mathematical result that was partly obtained using +{\GAP}, please cite {\GAP}, just as you would cite another paper that you +used. Also we would appreciate it if you could inform us about such a +paper. + +You are permitted to modify and redistribute {\GAP}, but you are not +allowed to restrict further redistribution. That is to say proprietary +modifications will not be allowed. We want all versions of {\GAP} to +remain free. + +If you modify any part of {\GAP} and redistribute it, you must supply a +`README' document. This should specify what modifications you made in +which files. We do not want to take credit or be blamed for your +modifications. + +Of course we are interested in all of your modifications. In particular +we would like to see bug-fixes, improvements and new functions. So again +we would appreciate it if you would inform us about all modifications you +make. + +{\GAP} is distributed by us without any warranty, to the extent permitted +by applicable state law. We distribute {\GAP} *as is* without warranty +of any kind, either expressed or implied, including, but not limited to, +the implied warranties of merchantability and fitness for a particular +purpose. + +The entire risk as to the quality and performance of the program is with +you. Should {\GAP} prove defective, you assume the cost of all necessary +servicing, repair or correction. + +In no case unless required by applicable law will we, and/or any other +party who may modify and redistribute {\GAP} as permitted above, be +liable to you for damages, including lost profits, lost monies or other +special, incidental or consequential damages arising out of the use or +inability to use {\GAP}. + +\endgroup diff --git a/doc/tut/group.tex b/doc/tut/group.tex index e270017e79..0427a32c9d 100644 --- a/doc/tut/group.tex +++ b/doc/tut/group.tex @@ -49,9 +49,11 @@ > SylowSubgroup( a8, p ); > od; gap> ComputedSylowSubgroups( a8 ); - [ , Group( [ (1,4)(5,6), (2,7)(5,6), (3,8)(5,6), (3,5)(6,8), (1,2)(4,7), - (1,3)(2,5)(4,8)(6,7) ], ... ), Group( [ (4,6,7), (3,5,8) ], ... ),, - Group( [ (4,7,5,8,6) ], ... ),, Group( [ (2,7,5,8,6,3,4) ], ... ) ] + [ , + Group( [ (1,3)(5,8), (2,7)(5,8), (4,6)(5,8), (2,4)(6,7), (1,5)(3,8), + (1,2)(3,7)(4,5)(6,8) ], ... ), + Group( [ (4,7,8), (3,5,6) ], ... ),, Group( [ (4,7,6,8,5) ], ... ), + , Group( [ (2,4,5,8,3,6,7) ], ... ) ] \endexample Observe that the list `ComputedSylowSubgroups( a8 )' has holes in positions 1, 4 and 6. A call of `SylowSubgroup' for the cyclic group of @@ -88,14 +90,15 @@ Now that we have the subgroup `norm' of order 1344 and its subgroup `elab', we want to look at its factor group. But since we also want to find preimages of factor group elements in `norm', we really want to look -at the *natural homomorphism*\index{homomorphism!natural} defined on -`norm' with kernel `elab' and whose image is the factor group. +at the *natural homomorphism* +\index{homomorphism!natural}% +defined on `norm' with kernel `elab' and whose image is the factor group. \beginexample gap> hom := NaturalHomomorphismByNormalSubgroup( norm, elab ); gap> f := Image( hom ); - Group( [ ( 4, 5)( 6, 7), ( 4, 6)( 5, 7), ( 2, 3)( 6, 7), ( 2, 4)( 3, 5), - ( 1, 2)( 5, 6) ], ... ) + Group( [ (), (), (), (4,5)(6,7), (4,6)(5,7), (2,3)(6,7), (2,4)(3,5), + (1,2)(5,6) ], ... ) gap> Size( f ); 168 \endexample @@ -122,8 +125,8 @@ \beginexample gap> IsSimple( f ); IsomorphismTypeFiniteSimpleGroup( f ); true - "A(1,7) = L(2,7) ~ B(1,7) = O(3,7) ~ C(1,7) = S(2,7) ~ 2A(1,7) = U(2,7) ~ A(2,\ - 2) = L(3,2)" + "A(1,7) = L(2,7) ~ B(1,7) = O(3,7) ~ C(1,7) = S(2,7) ~ 2A(1,7) = U(2,7\ + ) ~ A(2,2) = L(3,2)" gap> SetName( f, "L_3(2)" ); \endexample (The simple group $L_3(2)$ also has a lot of other names.) `norm' acts on @@ -135,8 +138,8 @@ $L_3(2)$. \beginexample gap> op := Operation( norm, elab ); - Group( [ ( 5, 6)( 7, 8), ( 5, 7)( 6, 8), ( 3, 4)( 7, 8), ( 3, 5)( 4, 6), - ( 2, 3)( 6, 7) ], ... ) + Group( [ (), (), (), (5,6)(7,8), (5,7)(6,8), (3,4)(7,8), (3,5)(4,6), + (2,3)(6,7) ], ... ) gap> IsSubgroup( a8, op ); IsSubgroup( norm, op ); true true @@ -167,8 +170,8 @@ gap> List( ccl, c -> Order( Representative( c ) ) ); [ 1, 7, 7, 5, 15, 15, 3, 3, 6, 6, 2, 4, 2, 4 ] gap> List( ccl, Size ); - [ 1, 2880, 2880, 1344, 1344, 1344, 112, 1120, 1680, 3360, 105, 1260, 210, - 2520 ] + [ 1, 2880, 2880, 1344, 1344, 1344, 112, 1120, 1680, 3360, 105, 1260, + 210, 2520 ] \endexample Note the difference between `Order' (which means the element order), `Size' (which means the size of the conjugacy class) and `Length' (which @@ -196,10 +199,10 @@ true \endexample The action of `op' on the given block system gave us a new representation -on 56 points which is primitive, i.e., the point stabilizer is a maximal -subgroup. We compute its preimage in the representation on eight points +on 56 points which is primitive, i.e., the point stabilizer is a maximal +subgroup. We compute its preimage in the representation on eight points using homomorphisms (which of course are monomorphisms). We construct the -composition of two homomorphisms with the `\*' operator, reading +composition of two homomorphisms with the `*' operator, reading left-to-right. \beginexample gap> ophom := OperationHomomorphism( a8, op );; @@ -207,8 +210,8 @@ gap> composition := ophom * ophom2;; gap> stab := Stabilizer( op2, 1 );; gap> preim := PreImages( composition, stab ); - Group( [ ( 3, 7, 8), ( 1, 2)( 3, 8), ( 1, 2)( 4, 5), ( 1, 2)( 3, 8, 7)( 5, 6), - ( 2, 7, 3)( 4, 6, 5) ], ... ) + Group( [ ( 1, 3, 2), ( 4, 8, 7), ( 1, 2)( 7, 8), ( 2, 3, 5), + ( 1, 2)( 5, 6) ], ... ) \endexample The normalizer of an element in the conjugacy class `class' is a group of order 360, too. In fact, it is a conjugate of the maximal subgroup we had @@ -240,12 +243,13 @@ So far we have seen a few applications of the functions `Operation' and `OperationHomomorphism'. But perhaps even more interesting is the fact that the natural homomorphism `hom' constructed above is also an -*operation homomorphism*\index{homomorphism!operation}; this is also the -reason why its image is represented as a permutation group: it is the -natural representation for operations. We will now look at this natural -homomorphism again to find out on what objects it operates. These objects -form a so-called *external set* which is stored in the homomorphism -similar to a record component. +*operation homomorphism*; +\index{homomorphism!operation}% +this is also the reason why its image is represented as a permutation +group: it is the natural representation for operations. We will now look +at this natural homomorphism again to find out on what objects it +operates. These objects form a so-called *external set* which is stored +in the homomorphism similar to a record component. \beginexample gap> t := hom!.externalSet; RightTransversal( 2^3:L_3(2), Group( @@ -258,7 +262,7 @@ . But an external set is more than just a list of its points: Altogether three things are necessary to specify an operation: a group~, a set~, and a function $\colon \times \to $. -We can obtain these ingredients with the following functions: +We can access these ingredients with the following functions: \beginexample gap> ActingDomain(t); Enumerator(t); FunctionOperation(t)=OnRight; 2^3:L_3(2) @@ -268,12 +272,29 @@ true \endexample The function `OnRight' means multiplication from the right, which is the -usual way to operate on a right transversal. Observe that the external -set `t' and its `Enumerator' are printed the same way, but be aware that -an external set also comprises the acting domain and the operation -function. The `Enumerator' itself, i.e., the right transversal in turn -comprises knowledge about the group `norm' and the subgroup . Yet it -behaves as a list and you can ask for the position of an element in it. +usual way to operate on a right transversal. `OnRight( , )' is +defined as ` * '. + +\exercise In analogy to `OnRight' there should be `OnLeft', but actually +there are two functions `OnLeftInverse' and `OnLeftAntiOperation'. How +are they defined and why? + +\answer `OnLeftInverse( , )' means `^-1 * ', i.e. +multiplication with the inverse from the left, which defines an +operation. In constrast, the mapping $\colon (,) \mapsto +* $ does not yield an operation, but an anti-operation, i.e. $( +( , _1 ), _2 ) = ( , _2 * _1 )$, whereas +for an operation, the right hand side is required to have the product +$_1 * _2$. The {\GAP} function which performs this mapping +is therefore called `OnLeftAntiOperation', and, unlike `OnLeftInverse', +this cannot be used as last argument to an operation function. + +Observe that the external set `t' and its `Enumerator' are printed the +same way, but be aware that an external set also comprises the acting +domain and the operation function. The `Enumerator' itself, i.e., the +right transversal in turn comprises knowledge about the group `norm' and +the subgroup . Yet it behaves as a list and you can ask for the +position of an element in it. \beginexample gap> elm := (1,4)(2,7)(3,6)(5,8);; gap> Position( Enumerator(t), elm ); @@ -281,17 +302,17 @@ gap> PositionCanonical( Enumerator(t), elm ); 5 \endexample -The result `fail' means that the element was not found at all in the -list: it is not among the chosen representatives. The -difference\atindex{Position vs. PositionCanonical}{@\noexpand `Position' -vs. \noexpand `PositionCanonical'}{} between the functions `Position' and -`PositionCanonical' is that the first simply looks whether `elm' is -contained among the representatives which together form the right -transversal `t', whereas the second really looks for the position of the -coset described by the representative `elm'. In other words, it first -replaces `elm' by a canonical representative of the same coset (which -must be contained in `t') and then looks for its position, hence the -name. +The result `fail' means that the element was not found at all in the +list: it is not among the chosen representatives. The difference +\atindex{Position vs. PositionCanonical}{@\noexpand `Position' vs. +\noexpand `PositionCanonical'}% +between the functions `Position' and `PositionCanonical' is that the +first simply looks whether `elm' is contained among the representatives +which together form the right transversal `t', whereas the second really +looks for the position of the coset described by the representative +`elm'. In other words, it first replaces `elm' by a canonical +representative of the same coset (which must be contained in `t') and +then looks for its position, hence the name. The image of the natural homomorphism is the permutation group that results from the operation of `norm' on the right transversal. It can be @@ -383,20 +404,36 @@ gap> IsPrimitive( a8_56, [1..56] ); false \endexample -Note that we must specify the domain of the operation. You might think -that in the last example `IsPrimitive' could use `[1..56]' as default -domain if no domain was given. But this is not so simple, for example -would the default domain of `Group( (2,3,4) )' be `[1..4]' or `[2..4]'? -To avoid confusion, all operations package functions require that you -specify the domain of operation. - -We see that `a8\_56' is not primitive. This means of course that the -operation of `a8' on `orb[2]' is not primitive, because those two -operations are equivalent. So the stabilizer `u56' is not maximal. Let -us try to find its supergroups. We use the function `Blocks' to find a -block system. The (optional) third argument in the following example -tells `Blocks' that we want a block system where 1 and 10 lie in one -block. +Note that we must specify the domain of the operation. You might think +that in the last example `IsPrimitive' could use `[1..56]' as default +domain if no domain was given. But this is not so simple, for example +would the default domain of `Group( (2,3,4) )' be `[1..4]' or `[2..4]'? +To avoid confusion, all operations package functions require that you +specify the domain of operation. If you specify `[1..4]' in the above +example, point~`1' will be a fixpoint. + +\exercise What happens if you call a function like `Operation( , +)', where the group moves points that are not contained in the +operation domain~? + +\answer If the operation domain is closed under the action of the +group , i.e., if it is a union of orbits, `Operation' will construct +the operation only on that domain, i.e., it will compute the restriction +of to~. If the operation domain is not closed, however, {\GAP} +will fail to construct the generating permutations and return a +`MagmaWithInverses( [ fail, \dots, fail ] )', which is no good for +further computations. An exception to this rule is the function `Orbits': +if is not closed under , then `Orbits( , )' silently +replaces by its closure under and then computes the orbits. In +other words, it computes all -orbits that contain at least one point +from the original~. + +We see that `a8_56' is not primitive. This means of course that the +operation of `a8' on `orb[2]' is not primitive, because those two +operations are equivalent. So the stabilizer `u56' is not maximal. Let us +try to find its supergroups. We use the function `Blocks' to find a block +system. The (optional) third argument in the following example tells +`Blocks' that we want a block system where 1 and 10 lie in one block. \beginexample gap> blocks := Blocks( a8_56, [1..56], [1,10] ); [ [ 1, 10, 17, 20, 25, 33, 38 ], [ 2, 5, 6, 12, 14, 24, 36 ], @@ -404,9 +441,9 @@ [ 9, 16, 27, 28, 40, 52, 54 ], [ 11, 18, 21, 29, 39, 46, 53 ], [ 19, 30, 41, 42, 49, 50, 55 ], [ 22, 31, 34, 43, 45, 51, 56 ] ] \endexample -The result is a list of sets, such that `a8\_56' operates on those sets. -Now we would like the stabilizer of this operation on the sets. Because -we wanted to operate on the sets we have to pass `OnSets' as third +The result is a list of sets, such that `a8_56' operates on those sets. +Now we would like the stabilizer of this operation on the sets. Because +we wanted to operate on the sets we have to pass `OnSets' as third argument. \beginexample gap> u8_56 := Stabilizer( a8_56, blocks[1], OnSets );; @@ -424,7 +461,7 @@ argument `blocks[1]' came from the function `Blocks', which returns a list of sets, so everything was OK. -Actually there is a third block system of `a8\_56' that gives rise to a +Actually there is a third block system of `a8_56' that gives rise to a third subgroup. \beginexample gap> blocks := Blocks( a8_56, [1..56], [1,6] );; @@ -433,9 +470,9 @@ gap> Index( a8, u28 ); 28 \endexample -We know that the subgroup `u28' of index 28 is maximal, because we know -that `a8' has no subgroups of index 2, 4, or 7. However we can also -quickly verify this by checking that `a8\_56' operates primitively on the +We know that the subgroup `u28' of index 28 is maximal, because we know +that `a8' has no subgroups of index 2, 4, or 7. However we can also +quickly verify this by checking that `a8_56' operates primitively on the 28 blocks. \beginexample gap> IsPrimitive( a8_56, blocks, OnSets ); @@ -472,12 +509,12 @@ To find subgroups above `u336' we again check if the operation is primitive. \beginexample - gap> blocks := Blocks( a8_336, [1..336], [1,43] );; blocks[1]; + gap> blocks := Blocks( a8_336, [1..336], [1,43] );; blocks[1]; [ 1, 43, 85 ] \endexample -The subgroup of index 112 in `a8\_336' is the union of `u336' with its -43rd and its 85th coset. It is thus the closure of `u336' with a -representative of the 43rd coset, which is obtained as the 43rd element +The subgroup of index 112 in `a8_336' is the union of `u336' with its +43rd and its 85th coset. It is thus the closure of `u336' with a +representative of the 43rd coset, which is obtained as the 43rd element of the list~`t'. \beginexample gap> u112 := ClosureGroup( u336, t[43] );; @@ -629,10 +666,11 @@ following command: \beginexample gap> cok := CoKernelGensPermHom( inv ); - [ f.1*f.2*f.1*f.2*f.1*f.2, f.2^2, f.1^-1*f.2*f.1^2*f.2*f.1*f.2*f.1^2*f.2*f.1^2 - , f.2^-1*f.1^4*f.2, f.1^-2*f.2*f.1^4*f.2*f.1^2, f.1^2*f.2*f.1^4*f.2*f.1^2, - f.2^-1*f.1*f.2*f.1^3*f.2*f.1*f.2*f.1^2*f.2*f.1^2, - f.2^-1*f.1^-1*f.2^-1*f.1*f.2*f.1^3*f.2*f.1^2*f.2*f.1^2 ] + [ f.1*f.2*f.1*f.2*f.1*f.2, f.2^2, f.1^-1*f.2*f.1^2*f.2*f.1*f.2*f.1^ + 2*f.2*f.1^2, f.2^-1*f.1^4*f.2, f.1^-2*f.2*f.1^4*f.2*f.1^2, + f.1^2*f.2*f.1^4*f.2*f.1^2, f.2^-1*f.1*f.2*f.1^3*f.2*f.1*f.2*f.1^ + 2*f.2*f.1^2, f.2^-1*f.1^-1*f.2^-1*f.1*f.2*f.1^3*f.2*f.1^2*f.2*f.1^ + 2 ] \endexample A group general mapping like `inv' is a genuine mapping if and only if this list of Schreier generators contains at most the identity element, @@ -669,14 +707,14 @@ In this section we will construct an ugly group, namely a matrix group of degree~2 over the Gaussian rationals. Because the group of all invertible -$2\times 2$-matrices over this field is infinite, {\GAP} cannot be sure -from the beginning that our group is finite, even though it turns out to -be the quaternion group of order~8, hence finite. To investigate this -group, we will construct a monomorphism of that group into a permutation -group, which is much nicer to work with. This image of this *nice -monomorphism* is then isomorphic to our matrix group, and we can perform -calculations in this nice group and lift the the results back with the -nice monomorphism to the matrix group. +$2\times 2$-matrices over this field is infinite, {\GAP} cannot be sure +from the beginning that our group is finite, even though it turns out to +be the quaternion group of order~8, hence finite. To investigate it, we +will construct a monomorphism of the matrix group into a permutation +group, which is much nicer to work with. This image of this *nice +monomorphism* is then isomorphic to our matrix group, and we can perform +calculations in the nice group and lift the results back to the matrix +group with the nice monomorphism. \beginexample gap> i := E(4);; grp := Group([[i,0],[0,-i]],[[0,1],[-1,0]]);; gap> SetName( grp, "Q8" ); @@ -684,17 +722,16 @@ [ [ 1, 0 ], [ E(4), 0 ], [ 0, 1 ], [ -1, 0 ], [ 0, E(4) ], [ 0, -E(4) ], [ -E(4), 0 ], [ 0, -1 ] ] \endexample -The list `orb' is the union of orbits under `grp' which contain a basis -for the two-dimensional row vector space over the rationals (we which -conveniently obtain as `One( grp )', i.e., the identity matrix). We have +The list `orb' is the union of orbits under `grp' which contain a basis +for the two-dimensional row vector space over the rationals (we which +conveniently obtain as `One( grp )', i.e., the identity matrix). We have made use here of the possibility to call `Orbits' with a list that is not -closed under the operation. It will be replaced by the closure on which -the orbits are then determined (in our case, there was only one orbit). -The finiteness of `grp' implies the finiteness of `orb', and we obtain a +closed under the operation: it will be replaced by the closure on which +the orbits are then determined (in our case, there is only one orbit). +The finiteness of `grp' implies the finiteness of `orb', and we obtain a faithful permutation representation on 8~points. \beginexample - gap> hom := OperationHomomorphism( grp, orb );; - gap> IsInjective( hom ); + gap> hom := OperationHomomorphism( grp, orb );; IsInjective( hom ); true gap> p := Image( hom ); Group( [ (1,7,6,8)(2,5,3,4), (1,2,6,3)(4,8,5,7) ], ... ) @@ -707,11 +744,10 @@ \beginexample gap> pcls := ConjugacyClasses( p );; gcls := [ ];; gap> for pc in pcls do - > gc := ConjugacyClass( grp, PreImageElm( hom, Representative(pc) ) ); - > SetStabilizerOfExternalSet( gc, PreImage( hom, Centralizer(pc) ) ); + > gc := ConjugacyClass( grp, PreImageElm(hom,Representative(pc)) ); + > SetStabilizerOfExternalSet( gc, PreImage(hom,Centralizer(pc)) ); > Add( gcls, gc ); - > od; - gap> List( gcls, Size ); + > od; List( gcls, Size ); [ 1, 1, 2, 2, 2 ] \endexample Since the mapping `hom' is injective, but not surjective, we cannot use @@ -751,9 +787,9 @@ degree~4 by examining the ``nice object'' associated with that automorphism group. \beginexample - gap> aut := NiceObject( AutomorphismGroup( p ) ); + gap> aut := AutomorphismGroup( p );; niceaut := NiceObject( aut ); Group( [ (1,5)(3,4), (2,6)(3,4), (1,3,5,4), (1,2)(3,4)(5,6) ], ... ) - gap> IsomorphismGroups( aut, SymmetricGroup( 4 ) ); + gap> IsomorphismGroups( niceaut, SymmetricGroup( 4 ) ); [ (1,5)(3,4), (2,6)(3,4), (1,3,5,4), (1,2)(3,4)(5,6) ] -> [ (1,4)(2,3), (1,2)(3,4), (1,3,4,2), (2,4) ] \endexample @@ -761,6 +797,45 @@ \exercise The nice monomorphism associated with the automorphism group of `p' is an operation homomorphism. What is its underlying external set? +\answer `NiceMonomorphism( aut )!.externalSet' gives the list +\begintt + [ (1,2,5,7)(3,6,8,4), (1,3,5,8)(2,4,7,6), (1,4,5,6)(2,8,7,3), + (1,6,5,4)(2,3,7,8), (1,7,5,2)(3,4,8,6), (1,8,5,3)(2,6,7,4) ] +\endtt +which contains the six elements of order~4 in `p'. The automorphism group +must permute these elements, and the action is faithful because they +generate~`p'. + +The range of a nice monomorphism is in most cases a permutation group, +because nice monomorphisms are mostly operation homomorphisms. In some +cases, like in our last example, the group is solvable and you might +prefer a pc group as nice object. Well, you can change the nice +monomorphism by composing it with an isomorphism from the permutation +group to a pc group. Such an isomorphism is provided by the function +`IsomorphismPcGroup'. But if you change the nice monomorphism, *you must +at the same time change the nice object!* So you have to type something +like: +\beginexample + gap> SetNiceMonomorphism( aut, NiceMonomorphism( aut ) * + > IsomorphismPcGroup( niceaut ) );; + gap> SetNiceObject( aut, Image( NiceMonomorphism( aut ), aut ) );; +\endexample +The star `*' denotes composition of mappings from the left to the right, +as we have seen in "Operations!of groups" above. + +\exercise In analogy to `IsomorphismPcGroup', there is also the command +`IsomorphismPermGroup'. Continuing the example of this section, what is +the difference between `IsomorphismPermGroup( grp )' and +`NiceMonomorphism( grp )'? + +\answer `IsomorphismPermGroup( grp )' returns a bijective mapping, in +particular its `Range' (see "Range") is a permutation group of size~8, +whereas a nice monomorphism which is an operation homomorphism has as +`Range' a full symmetric group. Also a nice monomorphism could be defined +on a larger group. This is not the case in the example `grp', but the +nice monomorphism of a $d$-dimensional matrix group over the finite field +with $q$ elements is defined on the general linear group~$GL(d,q)$. + %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Local Variables: % mode: text diff --git a/doc/tut/introduc.tex b/doc/tut/introduc.tex new file mode 100644 index 0000000000..d610dc0c4f --- /dev/null +++ b/doc/tut/introduc.tex @@ -0,0 +1,511 @@ +\Chapter{A first session with GAP} + +This tutorial introduces you to the {\GAP} system. It is written with +users in mind who have just managed to start {\GAP} for the first time on +their computer and want to learn the basic facts about {\GAP} by playing +around with some instructive examples. Therefore, this tutorial contains +at many places several lines of input (which you should type on your +terminal) followed by the corresponding output (which {\GAP} produces as +an answer to your input). +\begintt + This ``session protocol'' is indented and printed in typwriter + style (like this paragraph) in this manual and should look exactly + as it looks on an 80-column terminal. +\endtt +This is to encourage you to actually run through these examples on your +computer. This will support your feeling for {\GAP} as a tool, which is +the leading aim of this tutorial. Do not believe any statement in it as +long as you cannot verify it for your own version of {\GAP}. You will +learn to distinguish between small deviations of the behavior of your +personal {\GAP} from the printed examples and serious nonsense. + +Since the printing routines of {\GAP} are in some sense machine dependent +you will for instance encounter a different layout of the printed objects +in different environments. But the contents should always be the same. +In case you encounter serious nonsense it is highly recommended that you +send a bug report to `gap-forum@samson.math.rwth-aachen.de'. + +The examples in this tutorial should explain everything you have to know +in order to be able to use {\GAP}. The reference manual then gives a more +systematic treatment of the various types of objects that {\GAP} can +manipulate. But it seems neither desirable to start this systematic +course with the most elementary (and most boring) structures, nor to +confront you with all the complex data types before you know how they are +internally represented in terms of elementary structures. For this reason +this tutorial wants to provide you with a basic understanding of {\GAP} +objects, on which the reference manual then will rely when it explains +everything in detail. So after having mastered this tutorial, you can +immediately plunge into the exciting parts of {\GAP} and only read +detailed information about elementary things (in later chapters) when you +really need it. + +\fmark Since this book should be a tutorial, we have included some +exercises. They interrupt the example session every now and then and ask +something that you might well have asked yourself when you typed the +examples printed here. You should then try to solve this question by +typing in some more examples and studying the output that {\GAP} +delivers. If you want to check whether you drew the right conclusions +from what you saw, you can look up the answer to every exercise in +appendix~A\null. On the other hand, if you want to skip all the +exercises, you can easily watch out for the black triangle that also +precedes the first line of this paragraph: it marks every exercise. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\Section{Starting and leaving GAP}\null + +\atindex{starting GAP}{@starting {\GAP}}% +\atindex{leaving GAP}{@leaving {\GAP}}% +\atindex{quit}{@\noexpand`quit'}% +If the program is correctly installed then you start {\GAP} by simply +typing `gap' at the prompt of your operating system followed by the +$return$ or the $newline$ key. +\beginexample + $ gap +\endexample +{\GAP} answers your request with its beautiful banner (which you can +avoid with the command line option `-b') and then it shows its own prompt +`gap>' asking you for further input. +\beginexample + gap> +\endexample +The usual way to end a {\GAP} session is to type `quit;' at the `gap>' +prompt. Do not omit the semicolon! +\beginexample + gap> quit; + $ +\endexample +On some systems you may as well type $ctl$-`D' to yield the same effect. +In any situation {\GAP} is ended by typing $ctl$-`C' twice within a +second. Here as always, a combination like $ctl$-`D' means that you have +to press the `D' key while you hold down the $ctl$ key. + +In most places *whitespace* +\index{whitespace}% +characters (i.e. s, s and s) are insignificant for +the meaning of {\GAP} input. Identifiers and keywords must however not +contain any whitespace. On the other hand, sometimes there must be +whitespace around identifiers and keywords to separate them from each +other and from numbers. We will use whitespace to format more complicated +commands for better readability. + +A *comment* +\index{comment}% +in {\GAP} starts with the symbol `\#' and continues to the end of the +line. Comments are treated like whitespace by {\GAP}. + +Besides of such comments which are part of the input of a {\GAP} session, +we use additional comments which are part of the manual description, but +not of the respective {\GAP} session. In the printed version of this +manual these comments will be printed in a normal font for better +readability, hence they start with the symbol~\#. + +The examples of {\GAP} sessions given in any particular chapter of this +manual have been run in one continuous session, starting with the two +commands +\beginexample + gap> SizeScreen( [ 72, ] ); LogTo( "erg.log" ); +\endexample +which are used to set the line length to 72 and to save a listing of the +session on some file. If you choose any chapter and rerun its examples +in the given order, you should be able to reproduce our results except of +a few lines of output which we have edited a little bit with respect to +blanks or line breaks in order to improve the readability. However, as +soon as random processes are involved, you may get different results if +you extract single examples and run them separately. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\Section{The read-evaluate-print loop}\null + +\atindex{read-evaluate-print loop}{|indexit}% +{\GAP} is an interactive system. It continuously executes a +read-evaluate-print loop. Each expression you type at the keyboard is +read by {\GAP}, evaluated, and then the result is printed. + +The interactive nature of {\GAP} allows you to type an expression at the +keyboard and see its value immediately. You can define a function and +apply it to arguments to see how it works. You may even write whole +programs containing lots of functions and test them without leaving the +program. + +When your program is large it will be more convenient to write it on a +file and then read that file into {\GAP}. Preparing your functions in a +file has several advantages. You can compose your functions more +carefully in a file (with your favorite text editor), you can correct +errors without retyping the whole function and you can keep a copy for +later use. Moreover you can write lots of comments into the program text, +which are ignored by {\GAP}, but are very useful for human readers of +your program text. {\GAP} treats input from a file in the same way that +it treats input from the keyboard. + +A simple calculation with {\GAP} is as easy as one can imagine. You type +the problem just after the prompt, terminate it with a semicolon and then +pass the problem to the program with the $return$ key. For example, to +multiply the difference between 9 and 7 by the sum of 5 and 6, that is to +calculate $(9 - 7) \* (5 + 6)$, you type exactly this last sequence of +symbols followed by `;' and $return$. +\beginexample + gap> (9 - 7) * (5 + 6); + 22 + gap> +\endexample +Then {\GAP} echoes the result 22 on the next line and shows with the +prompt that it is ready for the next problem. Henceforth, we will no +longer print this additional prompt. + +If you did omit the semicolon at the end of the line but have already +typed $return$, then {\GAP} has read everything you typed, but does not +know that the command is complete. The program is waiting for further +input and indicates this with a partial prompt `>'. This little problem +is solved by simply typing the missing semicolon on the next line of +input. Then the result is printed and the normal prompt returns. +\beginexample + gap> (9 - 7) * (5 + 6) + > ; + 22 +\endexample +Whenever you see this partial prompt and you cannot decide what {\GAP} is +still waiting for, then you have to type semicolons until the normal +prompt returns. In every situation this is the exact meaning of the +prompt `gap>': the program is waiting for a new problem. + +Even if you mistyped the command you do not have to type it all again as +{\GAP} permits a lot of command line editing. Maybe you mistyped or +forgot the last closing parenthesis. Then your command is syntactically +incorrect and {\GAP} will notice it, incapable of computing the desired +result. +\beginexample + gap> (9 - 7) * (5 + 6; + Syntax error: ) expected + (9 - 7) * (5 + 6; + ^ +\endexample +Instead of the result an error message occurs indicating the place where +an unexpected symbol occurred with an arrow sign `^' under it. As a +computer program cannot know what your intentions really were, this is +only a hint. But in this case {\GAP} is right by claiming that there +should be a closing parenthesis before the semicolon. Now you can type +$ctl$-`P' to recover the last line of input. It will be written after +the prompt with the cursor in the first position. Type $ctl$-`E' to take +the cursor to the end of the line, then $ctl$-`B' to move the cursor one +character back. The cursor is now on the position of the semicolon. +Enter the missing parenthesis by simply typing `)'. Now the line is +correct and may be passed to {\GAP} by hitting the $newline$ key. Note +that for this action it is not necessary to move the cursor past the last +character of the input line. + +Each line of commands you type is sent to {\GAP} for evaluation by +pressing $newline$ regardless of the position of the cursor in that line. +We will no longer mention the $newline$ key from now on. + +Sometimes a syntax error will cause {\GAP} to enter a *break loop*. This +is indicated by the special prompt `brk>'. You can leave the break loop +by either typing `return;' or by hitting $ctl$-`D'. Then {\GAP} will +return to its normal state and show its normal prompt again. + +For the definition of the {\GAP} syntax see chapter "chapter:The +Programming Language". A complete list of command line editing facilities +is found in "Line editing". The break loop is described in "Break loops". + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\Section{Constants and operators}\null + +\atindex{constants}{|indexit}\atindex{operators}{|indexit}% +In an expression like `(9 - 7) * (5 + 6)' the constants `5', `6', `7', +and `9' are being composed by the operators `+', `*' and `-' to result in +a new value. + +There are three kinds of operators in {\GAP}, arithmetical operators, +comparison operators, and logical operators. You have already seen that +it is possible to form the sum, the difference, and the product of two +integer values. There are some more operators applicable to integers in +{\GAP}. Of course integers may be divided by each other, possibly +resulting in noninteger rational values. +\beginexample + gap> 12345/25; + 2469/5 +\endexample +Note that the numerator and denominator are divided by their greatest +common divisor and that the result is uniquely represented as a division +instruction. + +We haven't met negative numbers yet. So consider the following +self-explanatory examples. +\beginexample + gap> -3; 17 - 23; + -3 + -6 +\endexample +The exponentiation operator is written as `^'. This operation in +particular might lead to very large numbers. This is no problem for +{\GAP} as it can handle numbers of (almost) arbitrary size. +\beginexample + gap> 3^132; + 955004950796825236893190701774414011919935138974343129836853841 +\endexample +The `mod' operator allows you to compute one value modulo another. +\beginexample + gap> 17 mod 3; + 2 +\endexample +Note that there must be whitespace around the keyword 'mod' in this +example since `17mod3' or `17mod' would be interpreted as identifiers. + +{\GAP} knows a precedence between operators that may be overridden by +parentheses. +\beginexample + gap> (9 - 7) * 5 = 9 - 7 * 5; + false +\endexample +Besides these arithmetical operators there are comparison operators in +{\GAP}. A comparison results in a *boolean value* which is another kind +of constant. Every two objects within {\GAP} are comparable via `=', +`\<>', `\<', `\<=', `>' and `>=', that is the tests for equality, +inequality, less than, less than or equal, greater than and greater than +or equal. {\GAP} objects belonging to one *family* +\index{family}% +are ordered in the way that one might expect. For example the integers +are ordered in the usual way. +\beginexample + gap> 10^5 < 10^4; + false +\endexample +The boolean values `true' and `false' can be manipulated via logical +operators, i.~e., the unary operator `not' and the binary operators `and' +and `or'. Of course boolean values can be compared, too. +\beginexample + gap> not true; true and false; true or false; + false + false + true + gap> 10 > 0 and 10 < 100; + true +\endexample +Another important type of constants in {\GAP} are *permutations*. They +are written in cycle notation and they can be multiplied. +\beginexample + gap> (1,2,3); + (1,2,3) + gap> (1,2,3) * (1,2); + (2,3) +\endexample +The inverse of the permutation `(1,2,3)' is denoted by `(1,2,3)^-1'. +Moreover the caret operator `^' is used to determine the image of a point +under a permutation and to conjugate one permutation by another. +\beginexample + gap> (1,2,3)^-1; + (1,3,2) + gap> 2^(1,2,3); + 3 + gap> (1,2,3)^(1,2); + (1,3,2) +\endexample +The last type of constants we want to introduce here are the +*characters*, which are simply objects in {\GAP} that represent arbitrary +characters from the character set of the operating system. Character +literals can be entered in {\GAP} by enclosing the character in +*singlequotes* `{'}'. +\beginexample + gap> 'a'; + 'a' + gap> '*'; + '*' +\endexample +There are no operators defined for characters except that characters can +be compared. + +%% Summary %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +In this section you have seen that values may be preceded by unary +operators and combined by binary operators placed between the operands. +There are rules for precedence which may be overridden by parentheses. +It is possible to compare any two objects. A comparison results in a +boolean value. Boolean values are combined via logical operators. +Moreover you have seen that {\GAP} handles numbers of arbitrary size. +Numbers and boolean values are constants. There are other types of +constants in {\GAP} like permutations. You are now in a position to use +{\GAP} as a simple desktop calculator. + +Operators are explained in more detail in "Comparisons" and "Operations". +Moreover there are sections about operators and comparisons for special +types of objects in almost every chapter of this manual. You will find +more information about boolean values in chapters "Booleans" and "Boolean +Lists". Permutations are described in chapter "Permutations" and +characters are described in chapter "Strings and Characters". + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\Section{Variables and assignments}\null + +\atindex{variables}{|indexit}\atindex{assignment}{|indexit}% +Values may be assigned to variables. A variable enables you to refer to +an object via a name. The name of a variable is called an *identifier*. +\index{identifier}% +The assignment operator is `:='. There must be no white space between +the `:' and the `='. Do not confuse the assignment operator `:=' with +the single equality sign `=' which is in {\GAP} only used for the test of +equality. +\beginexample + gap> a:= (9 - 7) * (5 + 6); + 22 + gap> a; + 22 + gap> a * (a + 1); + 506 + gap> a:= 10; + 10 + gap> a * (a + 1); + 110 +\endexample +After an assignment the assigned value is echoed on the next line. The +printing of the value of a statement may be in every case prevented by +typing a double semicolon. +\beginexample + gap> w:= 2;; +\endexample +After the assignment the variable evaluates to that value if evaluated. +Thus it is possible to refer to that value by the name of the variable in +any situation. + +This is in fact the whole secret of an assignment. An identifier is bound +to a value and from this moment points to that value. Nothing more. This +binding is changed by the next assignment to that identifier. An +identifier does not denote a block of memory as in some other programming +languages. It simply points to a value, which has been given its place in +memory by the {\GAP} storage manager. This place may change during a +{\GAP} session, but that doesn't bother the identifier. *The identifier +points to the value, not to a place in the memory.* + +For the same reason it is not the identifier that has a type but the +object. This means on the other hand that the identifier `a' which now +is bound to an integer value may in the same session point to any other +value regardless of its type. + +Identifiers may be sequences of letters and digits containing at least +one letter. For example `abc' and `a0bc1' are valid identifiers. But +also `123a' is a valid identifier as it cannot be confused with any +number. Just `1234' indicates the number 1234 and cannot be at the same +time the name of a variable. + +Since {\GAP} distinguishes upper and lower case, `a1' and `A1' are +different identifiers. Keywords such as `quit' must not be used as +identifiers. You will see more keywords in the following sections. + +In the remaining part of this manual we will ignore the difference +between variables, their names (identifiers), and the values they point +at. It may be useful to think from time to time about what is really +meant by terms such as the integer `w'. + +There are some predefined variables coming with {\GAP}. Many of them you +will find in the remaining chapters of this manual, since functions are +also referred to via identifiers. + +This seems to be the right place to state the following rule. + +The name of every function in the {\GAP} library starts with a *capital +letter.* + +Thus if you choose only names starting with a small letter for your own +variables you will not overwrite any predefined function. + +But there are some further interesting variables one of which shall be +introduced now. + +Whenever {\GAP} returns a value by printing it on the next line this +value is assigned to the variable `last'. So if you computed +\beginexample + gap> (9 - 7) * (5 + 6); + 22 +\endexample +and forgot to assign the value to the variable `a' for further use, you +can still do it by the following assignment. +\beginexample + gap> a:= last; + 22 +\endexample +Moreover there are variables `last2' and `last3', guess their values. + +%% Summary %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +In this section you have seen how to assign values to variables. These +values can later be accessed through the name of the variable, its +identifier. You have also encountered the useful concept of the `last' +variables storing the latest returned values. And you have learned that +a double semicolon prevents the result of a statement from being printed. + +Variables and assignments are described in more detail in "Variables" and +"Assignments". A complete list of keywords is contained in "Keywords". + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\Section{Functions} + +A program written in the {\GAP} language is called a *function*. +Functions are special {\GAP} objects. Most of them behave like +mathematical functions. They are applied to objects and will return a +new object depending on the input. The function `Factorial', for +example, can be applied to an integer and will return the factorial of +this integer. +\beginexample + gap> Factorial(17); + 355687428096000 +\endexample +Applying a function to arguments means to write the arguments in +parentheses following the function. Several arguments are separated by +commas, as for the function `Gcd' which computes the greatest common +divisor of two integers. +\beginexample + gap> Gcd(1234, 5678); + 2 +\endexample +There are other functions that do not return a value but only produce a +side effect. They change for example one of their arguments. These +functions are sometimes called procedures. The function `Print' is only +called for the side effect to print something on the screen. +\beginexample + gap> Print(1234, "\n"); + 1234 +\endexample +In order to be able to compose arbitrary text with `Print', this function +itself will not produce a line break after printing. Thus we had another +newline character `\"\\n\"' printed to start a new line. + +Some functions will both change an argument and return a value such as +the function `Sortex' that sorts a list and returns the permutation of +the list elements that it has performed. You will not understand right +now what it means to change an object. We will return to this subject +several times in the next sections. + +A comfortable way to define a function is given by the *maps-to* operator +\index{maps-to operator}% +`->' consisting of a minus sign and a greater sign with no whitespace +between them. The function `cubed' which maps a number to its cube is +defined on the following line. +\beginexample + gap> cubed:= x -> x^3; + function ( x ) ... end +\endexample +After the function has been defined, it can now be applied. +\beginexample + gap> cubed(5); + 125 +\endexample +Not every {\GAP} function can be defined in this way. You will see how +to write your own {\GAP} functions in a later section. + +%% Summary %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +In this section you have seen {\GAP} objects of type function. You have +learned how to apply a function to arguments. This yields as result a +new object or a side effect. A side effect may change an argument of the +function. Moreover you have seen an easy way to define a function in +{\GAP} with the maps-to operator. + +Function calls are described in "Function Calls" and in "Procedure +Calls". The functions of the {\GAP} library are described in detail in +the reference manual. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% Local Variables: +% mode: text +% mode: outline-minor +% outline-regexp: "\\\\Chapter\\|\\\\Section" +% paragraph-start: "\\\\\\(begin\\|[Ee]nd\\|Par\\|Thm\\)\\|^\\(.*\\$\\$.*\\)?\\s-*$" +% paragraph-separate: "\\\\\\(begin\\|[Ee]nd\\|Par\\|Thm\\)\\|^\\(.*\\(\\$\\$\\|\\\\\\\\\\).*\\)?\\s-*$" +% fill-column: 73 +% End: +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% diff --git a/doc/tut/lists.tex b/doc/tut/lists.tex index 08c09efae5..97452addc7 100644 --- a/doc/tut/lists.tex +++ b/doc/tut/lists.tex @@ -224,18 +224,20 @@ {\GAP} knows several special kinds of lists. A very important one is the *set*, which is a list without holes all of whose entries belong to the -same *family*, which says (more or less) that they can be compared using -the `\<' operator. The crucial property of a set is then that its entries -must be strictly sorted, i.e., entries in higher positions must be -greater with respect to~`\<'. In particular, a set cannot have -duplicates. {\GAP} calls a set also a *strictly sorted -list*\index{list!strictly sorted} and the function `IsSSortedList' tests -whether a given list is a set. It returns a boolean value. For any list -contained in one family there exists a corresponding set containing the -same elements (ignoring repitions). This set is constructed by the -function `Set' which takes the list as its argument and returns a set -obtained from this list by ignoring holes and duplicates and by sorting -the elements. +same *family*, +\index{family}% +which says (more or less) that they can be compared using the `\<' +operator. The crucial property of a set is then that its entries must be +strictly sorted, i.e., entries in higher positions must be greater with +respect to~`\<'. In particular, a set cannot have duplicates. {\GAP} +calls a set also a *strictly sorted list* +\index{list!strictly sorted}% +and the function `IsSSortedList' tests whether a given list is a set. It +returns a boolean value. For any list contained in one family there +exists a corresponding set containing the same elements (ignoring +repitions). This set is constructed by the function `Set' which takes the +list as its argument and returns a set obtained from this list by +ignoring holes and duplicates and by sorting the elements. The elements of the sets used in the examples of this section are strings. @@ -329,7 +331,7 @@ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \Section{For and while loops}\null -\index{loops!for}\index{loops!while}% +\atindex{loops!for}{|indexit}\atindex{loops!while}{|indexit}% Given a list `pp' of permutations we can form their product by means of a `for' loop instead of writing down the product explicitly. \beginexample diff --git a/doc/tut/tutorial.mst b/doc/tut/manual.mst similarity index 100% rename from doc/tut/tutorial.mst rename to doc/tut/manual.mst diff --git a/doc/tut/tutorial.tex b/doc/tut/manual.tex similarity index 72% rename from doc/tut/tutorial.tex rename to doc/tut/manual.tex index c51889a06f..84bb4c7aa3 100644 --- a/doc/tut/tutorial.tex +++ b/doc/tut/manual.tex @@ -1,20 +1,28 @@ \input ../gapmacro -\def\exercise{\begingroup\def\par{\endgraf\endgroup\medskip\noindent} - \medskip\noindent{\bf Exercise:}\quad} +\immediate\openout\ans=answers \FrontMatter %\input copyrigh -%\input preface \Chapters -\input lists -\input group +\Input{introduc} +\Input{lists} +\Input{group} \Appendices +\Chapter Answers to the Exercises + +\parskip 1ex plus 0.5ex minus 0.5ex +\immediate\closeout\ans +\input answers + +\Chapter Bibliography + \Bibliography -\Chapter{Index} +\Chapter Index + A page number in {\it italics} denotes a whole section which is named like the index entry. Keywords are sorted with case and spaces ignored, e.g., ```PermutationCharacter''' comes before ``permutation @@ -34,6 +42,8 @@ Sciences} \smallskip \centerline{\secfont University of St.~Andrews} + +\Chapter Contents \TableOfContents diff --git a/grp/basic.gd b/grp/basic.gd index 9a3713f9df..eb9dc80163 100644 --- a/grp/basic.gd +++ b/grp/basic.gd @@ -117,7 +117,15 @@ end; ############################################################################# ## +#P IsOneGeneratorGroup +## +IsOneGeneratorGroup := NewProperty( + "IsOneGeneratorGroup", + IsGroup ); + +############################################################################# +## #O CyclicGroupCons( , ) ## CyclicGroupCons := NewConstructor( diff --git a/grp/basicpcg.gi b/grp/basicpcg.gi index 66be8c5a52..bfac7fb6f2 100644 --- a/grp/basicpcg.gi +++ b/grp/basicpcg.gi @@ -50,6 +50,7 @@ function( filter, ints ) od; f := PolycyclicFactorGroup( f, r ); SetSize( f, Product(ints) ); + SetIsAbelian( f, true ); return f; end ); @@ -101,6 +102,31 @@ function( filter, n ) Add( r, g[Length(g)] ^ pi[Length(g)] ); f := PolycyclicFactorGroup( f, r ); SetSize( f, n ); + SetIsCyclic( f, true ); + return f; +end ); + + +############################################################################# +## +#M CyclicGroupCons( , ) +## +InstallMethod( CyclicGroupCons, + "pc group", + true, + [ IsPcGroup and IsFinite and IsOneGeneratorGroup, + IsInt and IsPosRat ], + 0, + +function( filter, n ) + local f, g, r; + + f := FreeGroup(1); + g := GeneratorsOfGroup(f); + r := [ g[1]^n ]; + f := PolycyclicFactorGroup( f, r ); + SetSize( f, n ); + SetIsCyclic( f, true ); return f; end ); diff --git a/grp/basicprm.gi b/grp/basicprm.gi index c58082d9c7..65fbcb40a0 100644 --- a/grp/basicprm.gi +++ b/grp/basicprm.gi @@ -26,6 +26,8 @@ InstallMethod( AbelianGroupCons, 0, function( filter, ints ) + local grp; + if not ForAll( ints, IsInt ) then Error( " must be a list of integers" ); fi; @@ -35,7 +37,10 @@ function( filter, ints ) ints := Filtered( ints, x -> 1 < x ); ints := List( ints, x -> CyclicGroupCons( IsPermGroup, x ) ); - return CallFuncList( DirectProduct, ints ); + grp := CallFuncList( DirectProduct, ints ); + SetSize( grp, Product(ints) ); + SetIsAbelian( grp, true ); + return grp; end ); @@ -146,25 +151,6 @@ function( filter, dom ) end ); -############################################################################# -## -#M IsNaturalAlternatingGroup( ) -## -InstallMethod( IsNaturalAlternatingGroup, - "size comparison", - true, - [ IsPermGroup ], - 0, - -function( alt ) - if 0 = NrMovedPoints(alt) then - return IsTrivial(alt); - else - return Size(alt) * 2 = Factorial( NrMovedPoints(alt) ); - fi; -end ); - - ############################################################################# ## #M CyclicGroupCons( , ) @@ -181,6 +167,7 @@ function( filter, n ) c := Group( PermList( Concatenation( [2..n], [1] ) ) ); SetSize( c, n ); + SetIsCyclic( c, true ); return c; end ); @@ -241,6 +228,64 @@ function( filters, dom ) end ); +############################################################################# +## +#M SymmetricGroupCons( , ) +## +InstallMethod( SymmetricGroupCons, + "regular perm group with degree", + true, + [ IsPermGroup and IsRegularProp and IsFinite, + IsInt and IsPosRat ], + 0, + +function( filter, deg ) + return SymmetricGroupCons( IsPermGroup and IsRegularProp, + [ 1 .. deg ] ); +end ); + + +############################################################################# +## +#M SymmetricGroupCons( , ) +## +InstallOtherMethod( SymmetricGroupCons, + "regular perm group with domain", + true, + [ IsPermGroup and IsRegularProp and IsFinite, + IsDenseList ], + 0, + +function( filter, dom ) + local alt; + + alt := SymmetricGroupCons( IsPermGroup, dom ); + alt := Operation( alt, AsList(alt), OnRight ); + SetIsSymmetricGroup( alt, true ); + return alt; +end ); + + +############################################################################# +## + +#M IsNaturalAlternatingGroup( ) +## +InstallMethod( IsNaturalAlternatingGroup, + "size comparison", + true, + [ IsPermGroup ], + 0, + +function( alt ) + if 0 = NrMovedPoints(alt) then + return IsTrivial(alt); + else + return Size(alt) * 2 = Factorial( NrMovedPoints(alt) ); + fi; +end ); + + ############################################################################# ## #M IsNaturalSymmetricGroup( ) @@ -327,44 +372,6 @@ function(sym) end ); -############################################################################# -## -#M SymmetricGroupCons( , ) -## -InstallMethod( SymmetricGroupCons, - "regular perm group with degree", - true, - [ IsPermGroup and IsRegularProp and IsFinite, - IsInt and IsPosRat ], - 0, - -function( filter, deg ) - return SymmetricGroupCons( IsPermGroup and IsRegularProp, - [ 1 .. deg ] ); -end ); - - -############################################################################# -## -#M SymmetricGroupCons( , ) -## -InstallOtherMethod( SymmetricGroupCons, - "regular perm group with domain", - true, - [ IsPermGroup and IsRegularProp and IsFinite, - IsDenseList ], - 0, - -function( filter, dom ) - local alt; - - alt := SymmetricGroupCons( IsPermGroup, dom ); - alt := Operation( alt, AsList(alt), OnRight ); - SetIsSymmetricGroup( alt, true ); - return alt; -end ); - - ############################################################################# ## diff --git a/lib/algebra.gd b/lib/algebra.gd index fdfddb6df3..6f2d9519bb 100644 --- a/lib/algebra.gd +++ b/lib/algebra.gd @@ -716,6 +716,16 @@ IsQuaternionCollColl := CategoryCollections( "IsQuaternionCollColl", ############################################################################# ## #F QuaternionAlgebra( ) +#F QuaternionAlgebra( , , ) +## +## is a quaternion algebra over the field with parameters and in +## , i.e., a four-dimensional associative -algebra with basis +## $(e,i,j,k)$ and multiplication defined by +## $e e = e$, $e i = i e = i$, $e j = j e = j$, $e k = k e = k$, +## $i i = e$, $i j = - j i = k$, $i k = - k i = j$, +## $j j = e$, $j k = - k j = i$, +## $k k = - e$. +## The default values for and are $-1$ in . ## ## The embedding of the field 'GaussianRationals' into a quaternion algebra ## $A$ over 'Rationals' is not uniquely determined. diff --git a/lib/alglie.gi b/lib/alglie.gi index 460af99ee7..4cc2547e31 100644 --- a/lib/alglie.gi +++ b/lib/alglie.gi @@ -5,7 +5,7 @@ ## #H @(#)$Id$ ## -#Y Copyright (C) 1996, Lehrstuhl D fuer Mathematik, RWTH Aachen, Germany +#Y Copyright (C) 1997, Lehrstuhl D fuer Mathematik, RWTH Aachen, Germany ## ## This file contains methods for Lie algebras. ## @@ -1898,6 +1898,7 @@ InstallMethod( DirectSumDecomposition, n, # The dimension of 'L'. m, # An integer. set, # A list of integers. + ready, # A boolean. C, # The centre of 'L'. bvc, # basis vectors of a basis of 'C' D, # The derived subalgebra of 'L'. @@ -1905,11 +1906,8 @@ InstallMethod( DirectSumDecomposition, H, # A Cartan subalgebra of 'L'. BH, # basis of 'H' basH, # List of basis vectors of 'H'. - B, # A List of direct summands (subspaces) of 'L'. - BBj, # basis for 'B[j]' - newB, # The new 'B' that is being constructed. - V, # List of vectors. - cf,cfs, # Coefficient list. + B, # A list of bases of subspaces of 'L'. + cf, # Coefficient list. comlist, # List of commutators. ideals, # List of ideals. bb, # List of basis vectors. @@ -1917,14 +1915,15 @@ InstallMethod( DirectSumDecomposition, sp, # A vector space. x, # An element of 'sp'. b, # A list of basis vectors. - i,j,k, # Loop variables. + bas, # Basis of the assoc. algebra generated by 'adH'. + u,i,j,k,l, # Loop variables. centralizer, # The centralizer of 'adL' in the matrix algebra. - Bc, # basis of 'centralizer' Rad, # The radical of 'centralizer'. c, # The dimension of 'centralizer'. - M, # A matrix. + r, # The dimension of 'Rad'. + M,ad,mat, # Matrices. facs, # A list of factors of a polynomial. - hlist, # + hlist, # List of polynomials. f,p,g,gcd, # Polynomials. contained, # Boolean variable. adL, # A basis of the matrix space 'ad L'. @@ -1933,15 +1932,16 @@ InstallMethod( DirectSumDecomposition, q, # Number of elements of the field of 'L'. ei,ni,e, # Elements from 'centralizer' hom, # A homomorphism. - id, # A list of idempotents. - vv; # A list of vectors. + id,ids, # A list of idempotents. + vv, # A list of vectors. + sol, # A list of vectors. + eq, # An equation system. + elts; # A list of elements. F:= LeftActingDomain( L ); n:= Dimension( L ); - if ( not Characteristic( F ) in [2,3] ) and - ( DeterminantMat( KillingMatrix( BasisOfDomain( L ) ) ) <> Zero(F) ) - then + if RankMat( KillingMatrix( BasisOfDomain( L ) ) ) = n then # The algorithm works as follows. # Let 'H' be a Cartan subalgebra of 'L'. @@ -1954,12 +1954,17 @@ InstallMethod( DirectSumDecomposition, # element in 'H'. # This is an element 'h' such that the minimum polynomial of 'ad h' # has degree 'dim L - dim H + 1'. - # There is a powerful randomised algorithm for finding such an element. - + # If the size of the field is bigger than '2*m' then there is a + # powerful randomised algorithm (Las Vegas type) for finding such an + # element. We just take a random element from 'H' and with probability + # > 1/2 this will be a splitting element. + # If the field is small, then we use decomposable elements instead. + H:= CartanSubalgebra( L ); BH:= BasisOfDomain( H ); BL:= BasisOfDomain( L ); - m:= (( n - Dimension(H) ) * ( n - Dimension(H) + 2 )) / 4; + + m:= (( n - Dimension(H) ) * ( n - Dimension(H) + 2 )) / 8; if 2*m < Size(F) then @@ -1972,6 +1977,8 @@ InstallMethod( DirectSumDecomposition, until DegreeOfUnivariateLaurentPolynomial( f ) = Dimension( L ) - Dimension( H ) + 1; + # We decompose the action of the splitting element: + facs:= Factors( f ); B:= []; for i in facs do @@ -1979,40 +1986,93 @@ InstallMethod( DirectSumDecomposition, x -> LinearCombination( BL, x ) ) ); od; + B:= Filtered( B, x -> not ( x[1] in H ) ); + else - B:= [ ShallowCopy( BasisVectors( BL ) ) ]; - basH:= ShallowCopy( BasisVectors( BH ) ); + # Here 'L' is a semisimple Lie algebra over a small field. Here + # the existence of splitting elements is not assured. So we work + # with decomposable elements rather than with splitting ones. + # A decomposable element is an element from the associative + # algebra 'T' generated by 'ad H' that has a reducible minimum + # polynomial. Let 'V' be a stable subspace (under the action of 'H') + # computed in the process. Then we proceed as follows. + # We choose a random element from 'T' and restrict it to 'V'. If this + # element has an irreducible minimum polynomial of degree equal to + # the dimension of 'V', then 'V' is irreducible. On the other hand, + # if this polynomial is reducible, then we decompose 'V'. + + # 'bas' will be a basis of the associative algebra generated by + # 'ad H'. The computation of this basis is facilitated by the fact + # that we know the dimension of this algebra. + + bas:= List( BH, x -> AdjointMatrix( Basis( L ), x ) ); + sp:= MutableBasisByGenerators( F, bas ); + + k:=1; l:=1; + while k<=Length(bas) do + if Length(bas)=Dimension(L)-Dimension(H) then break; fi; + M:= bas[ k ]*bas[ l ]; + if not IsContainedInSpan( sp, M ) then + CloseMutableBasis( sp, M ); + Add( bas, M ); + fi; + if l < Length(bas) then l:=l+1; + else k:=k+1; l:=1; + fi; + od; + Add( bas, IdentityMat( Dimension( L ), F ) ); - for i in [1..Length(basH)] do + # Now 'B' will be a list of subspaces of 'L' stable under 'H'. + # We stop once every element from 'B' is irreducible. - # We try to split every component in 'B' into subspaces - # stable under ad basH[i] and such that the minimum polynomial - # of this operator restriced to each new component is irreducible. + cf:= AsList( F ); + B:= [ ProductSpace( H, L ) ]; + k:= 1; + while k <= Length( B ) do + b:= BasisVectors( Basis( B[k] ) ); + M:= LinearCombination( bas, List( bas, x -> Random( cf ) ) ); - newB:= [ ]; + # Now we restrict 'M' to the space 'B[k]'. - for j in [1..Length(B)] do + mat:= [ ]; + for i in [1..Length(b)] do + x:= LinearCombination( BL, M*Coefficients( BL, b[i] ) ); + Add( mat, Coefficients( Basis( B[k], b ), x ) ); + od; + M:= TransposedMat( mat ); - BBj:= BasisOfDomain( VectorSpace( F, B[j], "basis" ) ); - M:= List( B[j], x -> Coefficients( BBj, basH[i]*x ) ); - f:= MinimalPolynomial( F, M ); - facs:= Factors( f ); + f:= MinimalPolynomial( F, M ); + facs:= Factors( f ); + if Length(facs)=1 then + if DegreeOfUnivariateLaurentPolynomial(f)=Dimension(B[k]) then + + # The space is irreducible. - for k in [1..Length(facs)] do - V:= NullspaceMat( Value( facs[k], M ) ); - Add( newB, List( V, x -> LinearCombination( B[j], x ) ) ); + k:=k+1; + fi; + else + + # We decompose. + + for i in facs do + vv:= List( NullspaceMat( TransposedMat( Value( i, M ) ) ), + x -> LinearCombination( b, x ) ); + sp:= VectorSpace( F, vv ); + if not sp in B then Add( B, sp ); fi; od; - od; + + # We remove the old space from the list; + # and the Cartan subalgebra is removed once it occurs. - B:= newB; + B:= Filtered( B, x -> (x <> B[k]) ); + fi; od; + B:= List( B, x -> BasisVectors( Basis( x ) ) ); fi; - B:= Filtered( B, x -> not ( x[1] in H ) ); - # Now the pieces in 'B' are grouped together. ideals:=[]; @@ -2047,7 +2107,7 @@ InstallMethod( DirectSumDecomposition, # can be in this ideal because in that case this piece would # generate a smaller ideal inside this one.) - bb:= B[1]; + bb:= ShallowCopy( B[1] ); B:= Filtered( B, x -> x<> B[1] ); i:=1; while i<= Length( B ) do @@ -2072,7 +2132,6 @@ InstallMethod( DirectSumDecomposition, return List( ideals, I -> IdealNC( L, BasisVectors( BasisOfDomain( I ) ), "basis" )); -#T why to construct them again? else @@ -2083,6 +2142,15 @@ InstallMethod( DirectSumDecomposition, C:= LieCentre( L ); bvc:= BasisVectors( BasisOfDomain( C ) ); + + if Dimension( C ) = Dimension( L ) then + + #Now 'L' is abelian; hence 'L' is the direct sum of 'dim L' ideals. + + return List( bvc, v -> IdealNC( L, [ v ], "basis" ) ); + + fi; + BL:= BasisOfDomain( L ); bvl:= BasisVectors( BL ); @@ -2140,7 +2208,6 @@ InstallMethod( DirectSumDecomposition, adL:= List( bvl, x -> AdjointMatrix( BL, x ) ); centralizer:= FullMatrixAlgebraCentralizer( F, adL ); - Bc:= BasisOfDomain( centralizer ); Rad:= RadicalOfAlgebra( centralizer ); if Dimension( centralizer ) - Dimension( Rad ) = 1 then return [ L ]; @@ -2150,98 +2217,236 @@ InstallMethod( DirectSumDecomposition, # 'centralizer/Rad'. # We calculate a complete set of orthogonal idempotents in 'Q' # and then lift them to 'centralizer'. + # The orthogonal idempotents in 'Q' correspond to the decomposition + # of 'Q' as a direct sum of simple ideals. Now 'ideals' will contain + # a list of ideals of 'Q' such that the direct sum of these equals + # 'Q'. The variable 'ids' will contain the idempotents corresponding + # to the ideals in 'ids'. + # The algorithms has two parts: one for small fields (of size less than + # '2*Dimension( Q )', and one for big fields. + # If the field is big, then using a Las Vegas algorithm we find a + # splitting element (this is an element that generates 'Q'). By + # factoring the minimal polynomial of such element we can find a + # complete set of orthogonal idempotents in one step. + # However, if the field is small splitting elements might not exist. + # In this case we use decomposable elements (of which the minimum + # polynomial factors into two (or more) relatively prime factors. + # Then using the same procedure as for splitting elements we can + # find some idempotents. But in this case the corresponding ideals + # might split further. So we have to find decomposable elements in + # these and so on. + # Decomposable elements are found as follows: first we calculate + # the subalgebra of all elements x such that x^q=x + # (where 'q=Size( F )'). + # This subalgebra is a number of copies of the ground field. So any + # element independent from 1 of this subalgebra will have a minimum + # polynomial that splits completely. On the other hand, if 1 is the + # only basis vector of this subalgebra than the original algebra was + # simple. + # For a more elaborate description we refer to "W. Eberly and M. + # Giesbrecht, Efficient Decomposition of Associative Algebras, + # Proceedings of ISSAC 1996." hom:= NaturalHomomorphismByIdeal( centralizer, Rad ); Q:= ImagesSource( hom ); bQ:= BasisVectors( BasisOfDomain( Q ) ); + ids:= [ One( Q ) ]; + ideals:= [ Q ]; + + # The variable 'k' will point to the first element of 'ideals' that + # still has to be decomposed. + + k:=1; + + if Size(F) > 2*Dimension( Q )^2 then + set:= [ 0 .. 2*Dimension(Q)^2 ]*One( F ); + else + set:= [ ]; + fi; repeat - # We try to find an element of 'Q' that generates it. - # If we take the coefficients of such an element randomly - # from a set of '2*Dimension(Q)^2' elements, - # then this element generates 'Q' with probability 1/2 - # (see W. Eberly, Decomposition of algebras over finite fields - # and number fields, Comp. Complex. 1, 179--206 (1991)). - # If 'A' is defined over a finite field then we can just take - # the set of its elements. + if Length( set ) > 1 then + + # We are in the case of a big field. - if Characteristic( F ) = 0 then - cfs:= [ -Dimension(Q)^2 .. Dimension(Q)^2 ]; - else - cfs:= Filtered( AsList(F), x -> not IsZero( x ) ); - fi; + repeat - cf:= List( [ 1 .. Length(bQ) ], x -> Random( cfs ) ); - e:= LinearCombination( bQ, cf ); + # We try to find an element of 'Q' that generates it. + # If we take the coefficients of such an element randomly + # from a set of '2*Dimension(Q)^2' elements, + # then this element generates 'Q' with probability > 1/2 - # Now we calculate the minimum polynomial of 'e'. + bQ:= BasisVectors( BasisOfDomain( ideals[k] ) ); + cf:= List( [ 1 .. Length(bQ) ], x -> Random( set ) ); + e:= LinearCombination( bQ, cf ); - sp:= MutableBasisByGenerators( F, [ One( Q ) ] ); - vv:= [ One( Q ) ]; - x:= e; - while not IsContainedInSpan( sp, x ) do - Add( vv, x ); - CloseMutableBasis( sp, x ); - x:= x*e; - od; - sp:= UnderlyingLeftModule( ImmutableBasis( sp ) ); - cf:= - Coefficients( BasisByGeneratorsNC( sp, vv ), x ); - Add( cf, 1 ); - f:= ElementsFamily( FamilyObj( F ) ); - f:= UnivariateLaurentPolynomialByCoefficients( f, cf, 1 ); + # Now we calculate the minimum polynomial of 'e'. + + vv:= [ MultiplicativeNeutralElement( ideals[k] ) ]; + sp:= MutableBasisByGenerators( F, vv ); + x:= ShallowCopy( e ); - until DegreeOfUnivariateLaurentPolynomial( f ) = Dimension( Q ); + while not IsContainedInSpan( sp, x ) do + Add( vv, x ); + CloseMutableBasis( sp, x ); + x:= x*e; + od; + sp:= UnderlyingLeftModule( ImmutableBasis( sp ) ); + cf:= ShallowCopy( + - Coefficients( BasisByGeneratorsNC( sp, vv ), x ) + ); + Add( cf, One( F ) ); + f:= ElementsFamily( FamilyObj( F ) ); + f:= UnivariateLaurentPolynomialByCoefficients( f, cf, 0 ); - facs:= Factors( f ); + until DegreeOfUnivariateLaurentPolynomial( f ) = Dimension( Q ); + + else + + # Here the field is small. + + q:= Size( F ); + + # 'sol' will be a basis of the subalgebra of the k-th ideal + # consisting of all elements x such that x^q=x. + # If the length of this list is 1, + # then the ideal is simple and we proceed to the next one. If all + # ideals are simple then we quit the loop. + + sol:= [ ]; + while Length( sol ) < 2 and k <= Length( ideals ) do + bQ:= BasisVectors( Basis( ideals[k] ) ); + eq:= [ ]; + for i in [1..Dimension( ideals[k] )] do + Add( eq, Coefficients( Basis( ideals[k] ), bQ[i]^q-bQ[i] ) ); + od; + sol:= List( NullspaceMat( eq ), + x -> LinearCombination( bQ, x ) ); + if Length(sol) = 1 then k:=k+1; fi; + od; + + if k>Length(ideals) then break; fi; + + vv:= [ MultiplicativeNeutralElement( ideals[k] ) ]; + sp:= MutableBasisByGenerators( F, vv ); + + e:= sol[1]; + if IsContainedInSpan( sp, e ) then e:=sol[2]; fi; + + # We calculate the minimum polynomial of 'e'. + + x:= ShallowCopy( e ); + while not IsContainedInSpan( sp, x ) do + Add( vv, x ); + CloseMutableBasis( sp, x ); + x:= x*e; + od; + sp:= UnderlyingLeftModule( ImmutableBasis( sp ) ); + cf:= ShallowCopy( + - Coefficients( BasisByGeneratorsNC( sp, vv ), x ) + ); + Add( cf, One( F ) ); + + f:= ElementsFamily( FamilyObj( F ) ); + f:= UnivariateLaurentPolynomialByCoefficients( f, cf, 0 ); + + fi; + + facs:= Factors( f ); # Now we find elements h1,...,hs such that 'hi = 1 mod facs[i]' and # 'hi = 0 mod facs[j]' if 'i<>j'. # This is possible due to the Chinese remainder theorem. - hlist:= [ ]; - for i in [1..Length( facs )] do - cf:= List( [ 1..Length( facs ) ], x -> 0 ); - cf[i]:= 1; - j:= 1; - c:= cf[1]; - p:= facs[1]; - while j < Length(facs) do - j:= j + 1; - g:= GcdRepresentation( p, facs[j] ); - gcd:= g[1]*p+g[2]*facs[j]; - c:= p * (( g[1]*(cf[j]-c) / gcd ) mod facs[j]) + c; - p:= p*facs[j] / gcd; + hlist:= [ ]; + for i in [1..Length( facs )] do + cf:= List( [ 1..Length( facs ) ], x -> Zero( F ) ); + cf[i]:= One(F); + j:= 1; + c:= cf[1]; + p:= facs[1]; + while j < Length(facs) do + j:= j + 1; + g:= GcdRepresentation( p, facs[j] ); + gcd:= g[1]*p+g[2]*facs[j]; + c:= p*EuclideanRemainder( ( g[1]*(cf[j]-c) / gcd ) , facs[j] ) + + c; + p:= p*facs[j] / gcd; + od; + + Add( hlist, EuclideanRemainder( c*facs[i]^0 , p ) ); + od; - Add( hlist, c mod p ); + # Now a set of orthogonal idempotents is given by 'hi(e)'. + # We evaluate 'hi(e)' in a rather strange way; this in order to make + # sure that the one is the one of 'ideals[ k ]' ('e^0' will be the + # one of the big algebra 'Q'). - od; + id:= List( hlist, x -> Value( x, e, + MultiplicativeNeutralElement( ideals[k] ) ) ); + + if Length(set) = 0 then - # Now a complete set of orthogonal idempotents is given by 'hi(e)'. - # Finally we lift the idempotents to 'centralzer'. + # We are in the case of a small field; + # so we append the new idempotents and ideals + # (and erase the old ones). (If 'E' is an idempotent, + # then the corresponding ideal is given by 'E*Q*E'.) - id:= List( hlist, h -> Value( h, e ) ); - id:= List( id, e -> PreImagesRepresentative( hom, e ) ); + Append(ids,id); + + for l in [1..Length(id)] do + bb:=List(BasisVectors(Basis(ideals[k])),x->id[l]*x*id[l]); + Add(ideals,Subalgebra(Q,bb)); + od; + + ideals:=Filtered(ideals,x->x<>ideals[k]); + ids:=Filtered(ids,x->x<>ids[k]); + else + + # Here the field is big so we found the complete list of idempotents + # in one step. + + ids:= id; + k:=Length(ideals)+1; + fi; - # We have that 'id[i]^2-id[i]' is an element of 'Rad'. + while k<=Length(ideals) and Dimension( ideals[k] ) = 1 do k:=k+1; od; + + until k>Length(ideals); + + + id:= List( ids, e -> PreImagesRepresentative( hom, e ) ); + + # Now we lift the idempotents to the big algebra 'A'. The + # first idempotent is lifted as follows: + # We have that 'id[1]^2-id[1]' is an element of 'Rad'. # We construct the sequences e_{i+1} = e_i + n_i - 2e_in_i, - # and n_{i+1}=e_{i+1}^2-e_{i+1}, starting with e_0=id[i]. + # and n_{i+1}=e_{i+1}^2-e_{i+1}, starting with e_0=id[1]. # It can be proved by induction that e_q is an idempotent in 'A' # because n_0^{2^q}=0. - - q:= 0; - while 2^q <= Dimension( Rad ) do - q:= q+1; - od; - for i in [ 1 .. Length(id) ] do - ei:= id[i]; + # Now 'E' will be the sum of all idempotents lifted so far. + # Then the next lifted idempotent is obtained by setting + # 'ei:=id[i]-E*id[i]-id[i]*E+E*id[i]*E;' + # and lifting as above. It can be proved that in this manner we + # get an orthogonal system of primitive idempotents. + + E:= Zero( F )*id[1]; + + for i in [1..Length(id)] do + ei:= id[i]-E*id[i]-id[i]*E+E*id[i]*E; + q:= 0; + while 2^q <= Dimension( Rad ) do + q:= q+1; + od; ni:= ei*ei-ei; for j in [1..q] do ei:= ei+ni-2*ei*ni; ni:= ei*ei-ei; od; id[i]:= ei; + E:= E+ei; od; # For every idempotent of 'centralizer' we calculate @@ -3178,7 +3383,6 @@ DescriptionOfNormalizedUEAElement := function( T, listofpairs ) Unbind( mon[ len ] ); Unbind( mon[ len-1 ] ); len:= len - 2; - j:= j+2; else diff --git a/lib/algmat.gi b/lib/algmat.gi index 1d5fd004c6..49afdcdd34 100644 --- a/lib/algmat.gi +++ b/lib/algmat.gi @@ -1,10 +1,11 @@ ############################################################################# ## #W algmat.gi GAP library Thomas Breuer +#W Willem de Graaf ## #H @(#)$Id$ ## -#Y Copyright (C) 1996, Lehrstuhl D fuer Mathematik, RWTH Aachen, Germany +#Y Copyright (C) 1997, Lehrstuhl D fuer Mathematik, RWTH Aachen, Germany ## ## This file contains those functions that mainly deal with matrix algebras, ## that is, associative matrix algebras and matrix Lie algebras. @@ -744,7 +745,7 @@ InstallMethod( RadicalOfAlgebra, return TrivialSubalgebra( A ); fi; - I:= List( R, x -> x*I ); + I:= List( R, x -> LinearCombination( I, x ) ); t:= Length(I); pexp:= pexp*p; @@ -755,7 +756,7 @@ InstallMethod( RadicalOfAlgebra, # Transform back. bsp:= BasisByGeneratorsNC( VectorSpace( G, bb ), bb ); - R:= List( I, i -> Coefficients( bsp, i ) * bas ); + R:= List( I, i -> LinearCombination( bas, Coefficients( bsp, i )) ); else diff --git a/lib/algsc.gi b/lib/algsc.gi index 8e2fc188f5..d027683c36 100644 --- a/lib/algsc.gi +++ b/lib/algsc.gi @@ -541,25 +541,41 @@ end; ############################################################################# ## +#F QuaternionAlgebra( , , ) #F QuaternionAlgebra( ) ## -QuaternionAlgebra := function( F ) - local A; +QuaternionAlgebra := function( arg ) + local F, a, b, e, A; + + if Length( arg ) = 1 then + F:= arg[1]; + a:= AdditiveInverse( One( F ) ); + b:= a; + elif Length( arg ) = 3 then + F:= arg[1]; + a:= arg[2]; + b:= arg[3]; + else + Error( "usage: QuaternionAlgebra( [, , ] )" ); + fi; # Construct the algebra. + e:= One( F ); A:= AlgebraByStructureConstantsArg( [ F, - [ [[[1],[1]],[[2],[ 1]],[[3],[ 1]],[[4],[ 1]]], - [[[2],[1]],[[1],[-1]],[[4],[ 1]],[[3],[-1]]], - [[[3],[1]],[[4],[-1]],[[1],[-1]],[[2],[ 1]]], - [[[4],[1]],[[3],[ 1]],[[2],[-1]],[[1],[-1]]], + [ [ [[1],[e]], [[2],[ e]], [[3],[ e]], [[4],[ e]] ], + [ [[2],[e]], [[1],[ a]], [[4],[ e]], [[3],[ a]] ], + [ [[3],[e]], [[4],[-e]], [[1],[ b]], [[2],[ -b]] ], + [ [[4],[e]], [[3],[-a]], [[2],[ b]], [[1],[-a*b]] ], 0, Zero(F) ], "e", "i", "j", "k" ], IsSCAlgebraObj and IsQuaternion ); - # A quaternion algebra over the rationals is a division ring. - if F = Rationals then + # A quaternion algebra with parameters $-1$ over the rationals + # is a division ring. + if F = Rationals and a = -1 and b = -1 then SetFilterObj( A, IsMagmaWithInversesAndZero ); +#T better: use 'DivisionRingByGenerators' ! fi; # Return the quaternion algebra. diff --git a/lib/clas.gi b/lib/clas.gi index 468dd9a5f6..67bb8ecd5f 100644 --- a/lib/clas.gi +++ b/lib/clas.gi @@ -110,13 +110,6 @@ InstallMethod( Size, true, [ IsConjugacyClassGroupRep ], 0, InstallOtherMethod( Centralizer, true, [ IsConjugacyClassGroupRep ], 0, StabilizerOfExternalSet ); -############################################################################# -## -#M AsList( ) . . . . . . . . . . . . . . . . . . . by orbit algorithm -## -InstallMethod( AsList, true, [ IsExternalOrbitByStabilizerRep ], 0, - cl -> Orbit( ActingDomain( cl ), Representative( cl ) ) ); - ############################################################################# ## #M ConjugacyClasses( ) . . . . . . . . . . . . . . . . . . . of a group diff --git a/lib/claspcgs.gi b/lib/claspcgs.gi index a8554fd63e..02a10e10b6 100644 --- a/lib/claspcgs.gi +++ b/lib/claspcgs.gi @@ -567,7 +567,7 @@ GeneralStepClEANS := function( H, U, N, cl ) aff, # as affine space xset, # affine operation of on imgs, M, # generating matrices for affine operation - orbs, orb, # orbits of affine operation + orb, # orbit of affine operation Rep, # representative function to use for n, k, # cf. Mecky--Neub\"user paper cls,rep,pos,# set of classes with canonical representatives @@ -650,8 +650,7 @@ GeneralStepClEANS := function( H, U, N, cl ) od; else - orbs := ExternalOrbits( xset ); - for orb in orbs do + for orb in ExternalOrbitsStabilizers( xset ) do rep := PcElementByExponents( N, N{ N!.subspace.baseComplement }, CanonicalRepresentativeOfExternalSet( orb ){ ran } ); c := CorrectConjugacyClass( orb, H, U, h, rep, N, cNh ); diff --git a/lib/clasperm.gi b/lib/clasperm.gi index 6c0607a590..1280157c57 100644 --- a/lib/clasperm.gi +++ b/lib/clasperm.gi @@ -8,6 +8,9 @@ ## classes for permutation groups. ## #H $Log$ +#H Revision 4.9 1997/04/14 08:32:29 htheisse +#H made use of `ExternalOrbitsStabilizers' +#H #H Revision 4.8 1997/04/01 09:00:53 htheisse #H replaced `PreImage' by `PreImages' #H @@ -409,17 +412,16 @@ FusionRationalClassesPSubgroup := function( N, S, rationalClasses ) x -> Position( representatives, classimages[ x ] ) ); Add( genimages, PermList( prm ) ); od; - orbs := ExternalOrbits( N, [ 1 .. Length( rationalClasses ) ], + orbs := ExternalOrbitsStabilizers( N, + [ 1 .. Length( rationalClasses ) ], Concatenation( gensNmodS, gensS ), Concatenation( genimages, List( gensS, g -> () ) ) ); fusedClasses := [ ]; for orb in orbs do cl := rationalClasses[ Representative( orb ) ]; - if HasStabilizerOfExternalSet( orb ) then - SetStabilizerOfExternalSet( cl, Centralizer + SetStabilizerOfExternalSet( cl, Centralizer ( StabilizerOfExternalSet( orb ), Representative( cl ), StabilizerOfExternalSet( cl ) ) ); - fi; Add( fusedClasses, cl ); od; diff --git a/lib/coll.gd b/lib/coll.gd index ec5f15904a..b91234d0cf 100644 --- a/lib/coll.gd +++ b/lib/coll.gd @@ -5,7 +5,7 @@ ## #H @(#)$Id$ ## -#Y Copyright (C) 1996, Lehrstuhl D fuer Mathematik, RWTH Aachen, Germany +#Y Copyright (C) 1997, Lehrstuhl D fuer Mathematik, RWTH Aachen, Germany ## ## This file declares the operations for collections. ## @@ -13,6 +13,10 @@ Revision.coll_gd := "@(#)$Id$"; +#T change the installation of isomorphism and factor maintained methods +#T in the same way as that of subset maintained methods! + + ############################################################################# ## #C IsListOrCollection( ) @@ -132,12 +136,27 @@ UseSubsetRelation := NewOperation( "UseSubsetRelation", InstallMethod( UseSubsetRelation, "default method that returns 'true'", IsIdentical, - [ IsCollection, IsCollection ], 0, + [ IsCollection, IsCollection ], + # Make sure that this method is installed with ``real'' rank zero. + - 2 * SIZE_FLAGS(WITH_HIDDEN_IMPS_FLAGS(FLAGS_FILTER( IsCollection ))), function( super, sub ) return true; end ); +############################################################################# +## +#V SUBSET_MAINTAINED_INFO +## +## is a list of triples, +## the first entry being the list of filter numbers of an operation that is +## inherited to subsets, +## the second being the list of filter numbers of requirements, +## and the third being the real rank of the method. +## +SUBSET_MAINTAINED_INFO := []; + + ############################################################################# ## #F InstallSubsetMaintainedMethod( , , ) @@ -148,21 +167,131 @@ InstallMethod( UseSubsetRelation, ## and such that the value of is known for $D$. ## Then the value of for $S$ shall be the same as the value for $D$. ## +## We must be careful to choose the right ranks for the methods. +## Note that one method may require a property that is acquired using +## another method. +## For that, we give a method a rank that is lower than that of all methods +## that may yield some of the requirements and that is higher than that of +## all methods that require ; +## if this is not possible then a warning is printed. +#T (Maybe the mechanism has to be changed at some time because of this. +#T Another reason would be the direct installation of methods for +#T 'UseSubsetRelation', i.e., the ranks of these methods are not affected +#T by the code in 'InstallSubsetMaintainedMethod'.) +## InstallSubsetMaintainedMethod := function( operation, super_req, sub_req ) - local setter, tester, infostring; + + local setter, + tester, + infostring, + upper, + lower, + rank, + filtssub, # property and attribute flags of `sub_req' + filtsopr, # property and attribute flags of `operation' + triple, + req, + requsub, + testsub, + flag, + filt1, + filt2; setter:= Setter( operation ); tester:= Tester( operation ); infostring:= "method for operation "; APPEND_LIST_INTR( infostring, NAME_FUNCTION( operation ) ); + # Are there methods that may give us some of the requirements? + upper:= SUM_FLAGS; + # We must not call `SUBTR_SET' here because the lists kinds may be + # not yet defined. + # filtssub:= TRUES_FLAGS( FLAGS_FILTER( sub_req ) ); + # SUBTR_SET( filtssub, CATS_AND_REPS ); + filtssub:= []; + for flag in TRUES_FLAGS( FLAGS_FILTER( sub_req ) ) do + if not flag in CATS_AND_REPS then + ADD_LIST_DEFAULT( filtssub, flag ); + fi; + od; + for triple in SUBSET_MAINTAINED_INFO do + req:= SHALLOW_COPY_OBJ( filtssub ); + INTER_SET( req, triple[1] ); + if LEN_LIST( req ) <> 0 and triple[3] < upper then + upper:= triple[3]; + fi; + od; + + setter:= Setter( operation ); + # Are there methods that require 'operation'? + lower:= 0; + filt1:= FLAGS_FILTER( operation ); + if filt1 = false then + filt1:= FLAGS_FILTER( Tester( operation ) ); + fi; + # We must not call `SUBTR_SET' here because the lists kinds may be + # not yet defined. + # filtsopr:= SHALLOW_COPY_OBJ( TRUES_FLAGS( filt1 ) ); + # SUBTR_SET( filtsopr, CATS_AND_REPS ); + filtsopr:= []; + for flag in TRUES_FLAGS( filt1 ) do + if not flag in CATS_AND_REPS then + ADD_LIST_DEFAULT( filtsopr, flag ); + fi; + od; + for triple in SUBSET_MAINTAINED_INFO do + req:= SHALLOW_COPY_OBJ( filtsopr ); + INTER_SET( req, triple[2] ); + if LEN_LIST( req ) <> 0 and lower < triple[3] then + lower:= triple[3]; + fi; + od; + + # Compute the rank of the method. + # (Do we have a cycle?) + if upper <= lower then + Print( "#W warning: cycle in 'InstallSubsetMaintainedMethod'\n" ); + rank:= lower; + else + rank:= ( upper + lower ) / 2; + fi; + + # Update the info list. + ADD_LIST( SUBSET_MAINTAINED_INFO, [ filtsopr, filtssub, rank ] ); + + # Create the requirements for the method. + # 'super_req' may be taken as a whole, + # but 'sub_req' must be split into the category/representation part + # 'requsub' that is required by the method, + # and the property/attribute part 'testsub' that can be checked only + # after the method has been called. + # Note that some of the properties/attributes may be acquired by the + # object due to some other subset maintained methods, and the method + # selection of the operation 'UseSubsetRelation' would regard methods + # that require them as not applicable. + testsub:= IsObject; + requsub:= IsObject; + for flag in TRUES_FLAGS( FLAGS_FILTER( sub_req ) ) do + if flag in filtssub then + testsub:= testsub and FILTERS[ flag ]; + else + requsub:= requsub and FILTERS[ flag ]; + fi; + od; + filt1:= IsCollection and Tester( super_req ) and super_req and tester; + filt2:= IsCollection and Tester( requsub ) and requsub; + + # Adjust 'rank' such that 'INSTALL_METHOD' takes our rank. + rank:= rank - SIZE_FLAGS(WITH_HIDDEN_IMPS_FLAGS(FLAGS_FILTER( filt1 ))); + rank:= rank - SIZE_FLAGS(WITH_HIDDEN_IMPS_FLAGS(FLAGS_FILTER( filt2 ))); + + # Install the method. InstallMethod( UseSubsetRelation, infostring, IsIdentical, - [ IsCollection and Tester( super_req ) and super_req and tester, - IsCollection and Tester( sub_req ) and sub_req ], 0, + [ filt1, filt2 ], rank, function( super, sub ) - if not tester( sub ) then + if ( not tester( sub ) ) and testsub( sub ) then setter( sub, operation( super ) ); fi; #T argument for ``antifilters'' ? diff --git a/lib/ctbl.gd b/lib/ctbl.gd index 70ff95cec8..f88873fa06 100644 --- a/lib/ctbl.gd +++ b/lib/ctbl.gd @@ -27,8 +27,6 @@ Revision.ctbl_gd := #T 'PermutationCharacter' should return a proper character, not a list! -#T disallow 'Sort', change to 'SortedCharacterTable'! - ############################################################################# ## @@ -152,15 +150,41 @@ NearlyCharacterTablesFamily := NewFamily( "NearlyCharacterTablesFamily", ############################################################################# ## -#A CharacterDegrees( ) -#A CharacterDegrees( ) +#F CharacterDegrees( ,

) +#F CharacterDegrees( ) +#F CharacterDegrees( ) +## +## In the first two forms, 'CharacterDegrees' returns a collected list of +## the degrees of the absolutely irreducible characters of the group , +## in characteristic

resp. zero. +## +## In the third form, 'CharacterDegrees' returns a collected list of the +## degrees of the absolutely irreducible characters of the (ordinary or +## Brauer) character table . +## +#A CharacterDegreesAttr( ) +#A CharacterDegreesAttr( ) +## +## is the attribute for storing the character degrees computed by +## 'CharacterDegrees'. ## -## is a collected list of the degrees of the irreducible characters of -## the group . +#O CharacterDegreesOp( , ) ## -CharacterDegrees := NewAttribute( "CharacterDegrees", IsGroup ); -SetCharacterDegrees := Setter( CharacterDegrees ); -HasCharacterDegrees := Tester( CharacterDegrees ); +## is the operation called by 'CharacterDegrees' for that methods can be +## installed. +## (For the tables, one can call the attribute directly.) +## +CharacterDegrees := NewOperationArgs( "CharacterDegrees" ); + +CharacterDegreesAttr := NewAttribute( "CharacterDegreesAttr", IsGroup ); +SetCharacterDegreesAttr := Setter( CharacterDegreesAttr ); +HasCharacterDegreesAttr := Tester( CharacterDegreesAttr ); + +InstallIsomorphismMaintainedMethod( CharacterDegreesAttr, + IsGroup and HasCharacterDegreesAttr, IsGroup ); + +CharacterDegreesOp := NewOperation( "CharacterDegreesOp", + [ IsGroup, IsInt ] ); ############################################################################# @@ -321,6 +345,27 @@ SetClassParameters := Setter( ClassParameters ); HasClassParameters := Tester( ClassParameters ); +############################################################################# +## +#A ClassPermutation( ) +## +## is a permutation $\pi$ of classes of . +## Its meaning is that class fusions into that are stored on other +## tables must be followed by $\pi$ in order to describe the correct +## fusion. +## +## This attribute is bound only if was obtained from another table +## by permuting the classes (commands 'CharacterTableWithSortedClasses' or +## 'SortedCharacterTable'). +## It is necessary because the original table and the sorted table have the +## same identifier, and hence the same fusions are valid for the two tables. +## +ClassPermutation := NewAttribute( "ClassPermutation", + IsNearlyCharacterTable ); +SetClassPermutation := Setter( ClassPermutation ); +HasClassPermutation := Tester( ClassPermutation ); + + ############################################################################# ## #A ClassNames( ) @@ -384,6 +429,19 @@ SetInverseClasses := Setter( InverseClasses ); HasInverseClasses := Tester( InverseClasses ); +############################################################################# +## +#A Maxes( ) +## +## is a list of identifiers of the tables of all maximal subgroups of . +## This is known usually only for library tables. +#T meaningful also for tables with group? +## +Maxes := NewAttribute( "Maxes", IsNearlyCharacterTable ); +SetMaxes := Setter( Maxes ); +HasMaxes := Tester( Maxes ); + + ############################################################################# ## #A NamesOfFusionSources( ) @@ -753,6 +811,7 @@ PowerMapOp := NewOperation( "PowerMapOp", ComputedPowerMaps := NewAttribute( "ComputedPowerMaps", IsNearlyCharacterTable, "mutable" ); SetComputedPowerMaps := Setter( ComputedPowerMaps ); +HasComputedPowerMaps := Tester( ComputedPowerMaps ); ############################################################################# @@ -784,12 +843,14 @@ SupportedOrdinaryTableInfo := [ BlocksInfo, "blocksInfo", ComputedClassFusions, "computedClassFusions", ClassParameters, "classParameters", + ClassPermutation, "classPermutation", ComputedPowerMaps, "computedPowerMaps", Identifier, "identifier", InfoText, "infoText", Irr, "irr", IrredInfo, "irredInfo", IsSimpleGroup, "isSimpleGroup", + Maxes, "maxes", NamesOfFusionSources, "namesOfFusionSources", OrdersClassRepresentatives, "ordersClassRepresentatives", SizesCentralizers, "sizesCentralizers", @@ -806,16 +867,16 @@ SupportedBrauerTableInfo := Concatenation( SupportedOrdinaryTableInfo, [ ############################################################################# ## -#F ConvertToCharacterTable( ) . . . . create character table object -#F ConvertToCharacterTableNC( ) . . . create character table object +#F ConvertToOrdinaryTable( ) . . . . create character table object +#F ConvertToOrdinaryTableNC( ) . . . create character table object ## ## The components listed in 'SupportedOrdinaryTableInfo' are used to set ## properties and attributes. ## All other components will simply become components of the record object. ## -ConvertToCharacterTable := NewOperationArgs( "ConvertToCharacterTable" ); +ConvertToOrdinaryTable := NewOperationArgs( "ConvertToOrdinaryTable" ); -ConvertToCharacterTableNC := NewOperationArgs( "ConvertToCharacterTableNC" ); +ConvertToOrdinaryTableNC := NewOperationArgs( "ConvertToOrdinaryTableNC" ); ############################################################################# @@ -843,24 +904,155 @@ TableAutomorphisms := NewOperationArgs( "TableAutomorphisms" ); ############################################################################# ## -#F TransformingPermutationsCharTables( ) +#F TransformingPermutationsCharacterTables( ) ## -TransformingPermutationsCharTables := NewOperationArgs( - "TransformingPermutationsCharTables" ); +TransformingPermutationsCharacterTables := NewOperationArgs( + "TransformingPermutationsCharacterTables" ); ############################################################################# ## -#F Decomposition( ) +#F LowercaseString( ) . . . string consisting of lower case letters ## -Decomposition := NewOperationArgs( "Decomposition" ); +LowercaseString := NewOperationArgs( "LowercaseString" ); +#T move to another file !! ############################################################################# ## -#F LowercaseString( ) . . . string consisting of lower case letters +#O CharacterTableWithSortedCharacters( ) +#O CharacterTableWithSortedCharacters( , ) ## -LowercaseString := NewOperationArgs( "LowercaseString" ); +## is a character table that differs from only by the succession of +## its irreducible characters. +## This affects at most the value of the attributes `Irr' and `IrredInfo', +## namely these lists are permuted by the permutation . +## +## If no second argument is given then a permutation is used that yields +## irreducible characters of increasing degree for the result. +## For the succession of characters in the result, see "SortedCharacters". +## +## The result has all those attributes and properties of that are +## stored in 'SupportedOrdinaryTableInfo'. +## +## The result will *not* be a library table, even if is, +## and it will *not* have an underlying group. +## +CharacterTableWithSortedCharacters := NewOperation( + "CharacterTableWithSortedCharacters", [ IsNearlyCharacterTable ] ); + + +############################################################################# +## +#O SortedCharacters( , )\\ +#O SortedCharacters( , , \"norm\" )\\ +#O SortedCharacters( , , \"degree\" ) +## +## is a list containing the characters , in a succession specified +## by the other arguments. +## +## There are three possibilities to sort characters\:\ +## They can be sorted according to ascending norms (parameter '\"norm\"'), +## to ascending degree (parameter '\"degree\"'), +## or both (no third parameter), +## i.e., characters with same norm are sorted according to ascending degree, +## and characters with smaller norm precede those with bigger norm. +## +## Rational characters always will precede other ones with same norm resp.\ +## same degree afterwards. +## The trivial character, if contained in , will always be sorted to +## the first position. +## +SortedCharacters := NewOperation( + "SortedCharacters", [ IsNearlyCharacterTable, IsHomogeneousList ] ); + + +############################################################################# +## +#O CharacterTableWithSortedClasses( ) +#O CharacterTableWithSortedClasses( , \"centralizers\" ) +#O CharacterTableWithSortedClasses( , \"representatives\" ) +#O CharacterTableWithSortedClasses( , ) +## +## is a character table obtained on permutation of the classes of . +## If the second argument is the string `"centralizers"' then the classes +## of the result are sorted according to descending centralizer orders. +## If the second argument is the string `"representatives"' then the classes +## of the result are sorted according to ascending representative orders. +## If no second argument is given, then the classes +## of the result are sorted according to ascending representative orders, +## and classes with equal representative orders are sorted according to +## descending centralizer orders. +## +## If the second argument is a permutation then the classes of the +## result are sorted by application of this permutation. +## +## The result has all those attributes and properties of that are +## stored in 'SupportedOrdinaryTableInfo'. +## +## The result will *not* be a library table, even if is, +## and it will *not* have an underlying group. +## +CharacterTableWithSortedClasses := NewOperation( + "CharacterTableWithSortedClasses", [ IsNearlyCharacterTable ] ); + + +############################################################################# +## +#F SortedCharacterTable( , ) +#F SortedCharacterTable( , ) +#F SortedCharacterTable( , , ) +## +## is a character table obtained on permutation of the classes and the +## irreducibles characters of . +## +## The first form sorts the classes at positions contained in the list +## to the beginning, and sorts all characters in +## 'Irr( )' such that the first characters are those that contain +## in their kernel. +## +## The second form does the same successively for all kernels $k_i$ in +## the list $'normalseries' = [ k_1, k_2, \ldots, k_n ]$ where +## $k_i$ must be a sublist of $k_{i+1}$ for $1 \leq i \leq n-1$. +## +## The third form computes the table of the factor group of +## modulo the normal subgroup formed by the classes whose positions are +## contained in the list ; +## must be permutation equivalent to the table (in the +## sense of "TransformingPermutationsCharacterTables"), otherwise 'fail' is +## returned. The classes of are sorted such that the preimages +## of a class of are consecutive, and that the succession of +## preimages is that of . +## 'Irr( )' is sorted as by 'SortCharTable( , )'. +## +## (*Note* that the transformation is only unique up to table automorphisms +## of , and this need not be unique up to table automorphisms of .) +## +## All rearrangements of classes and characters are stable, i.e., the +## relative positions of classes and characters that are not distinguished +## by any relevant property is not changed. +## +## The result has all those attributes and properties of that are +## stored in 'SupportedOrdinaryTableInfo'. +## If is a library table then also the components of that are +## stored in 'SupportedLibraryTableComponents' are components of . +## +## The 'ClassPermutation' value of is changed if necessary, +## see "Conventions for Character Tables". +## +SortedCharacterTable := NewOperationArgs( "SortedCharacterTable" ); + + +############################################################################# +## +#F IrrConlon( ) +## +## compute the irreducible characters of a supersolvable group using +## Conlon's algorithm. +## The monomiality information (attribute 'TestMonomial') for each +## irreducible character is known. +## +IrrConlon := NewOperationArgs( "IrrConlon" ); ############################################################################# diff --git a/lib/ctbl.gi b/lib/ctbl.gi index a2cc9baa06..b3f2a39d76 100644 --- a/lib/ctbl.gi +++ b/lib/ctbl.gi @@ -31,7 +31,7 @@ Revision.ctbl_gi := ## For the following ``groupy'' operations, there are methods that allow ## an ordinary character table instead of a group. ## -## 'CharacterDegrees', +## 'CharacterDegreesAttr', ## 'CharacterTable', ## 'ClassMultiplicationCoefficient', ## 'OrdinaryCharacterTable', @@ -56,29 +56,81 @@ Revision.ctbl_gi := ############################################################################# ## -#M CharacterDegrees( ) . . . . . . . . . . . . . . . . . . . for a group -#M CharacterDegrees( ) . . . . . . . . . . . . . for a character table +#F CharacterDegrees( ) . . . . . . . . . . . . . . . . . . . for a group +#F CharacterDegrees( ,

) . . . . . . . . . . for a group and a prime +#F CharacterDegrees( ) . . . . . . . . . . . . . for a character table ## -## We delegate to 'Irr' for the group resp. table. +CharacterDegrees := function( arg ) + if Length( arg ) = 1 + and ( IsGroup( arg[1] ) or IsCharacterTable( arg[1] ) ) then + return CharacterDegreesAttr( arg[1] ); + elif Length( arg ) = 2 and IsGroup( arg[1] ) and IsInt( arg[2] ) then + return CharacterDegreesOp( arg[1], arg[2] ); + fi; + Error( "usage: CharacterDegrees([,

]) or CharacterDegrees()" ); +end; + + +############################################################################# +## +#M CharacterDegreesAttr( ) . . . . . . . . . . . . . . . . . for a group +#M CharacterDegreesOp( , ) . . . . . . . . . for a group and zero +## +## The attribute delegates to the operation. +## The operation delegates to 'Irr'. ## -InstallMethod( CharacterDegrees, +InstallMethod( CharacterDegreesAttr, "method for a group", true, [ IsGroup ], 0, - G -> Collected( List( Irr( G ), DegreeOfCharacter ) ) ); + G -> CharacterDegreesOp( G, 0 ) ); + +InstallOtherMethod( CharacterDegreesOp, + "method for a group, and zero", + true, + [ IsGroup, IsZeroCyc ], 0, + function( G, zero ) + return Collected( List( Irr( G ), DegreeOfCharacter ) ); + end ); + +InstallOtherMethod( CharacterDegreesOp, + "method for a group, and positive integer", + true, + [ IsGroup, IsInt and IsPosRat ], 0, + function( G, p ) + if Size( G ) mod p = 0 then + return CharacterDegreesAttr( CharacterTable( G, p ) ); + else + return CharacterDegreesAttr( G ); + fi; + end ); + -InstallOtherMethod( CharacterDegrees, - "method for a table", +############################################################################# +## +#M CharacterDegreesAttr( ) . . . . . . . . . . . for a character table +## +## We delegate to 'Irr' for the table. +## The ordinary table may ask its group. +## +InstallOtherMethod( CharacterDegreesAttr, + "method for a character table", true, [ IsCharacterTable ], 0, tbl -> Collected( List( Irr( tbl ), DegreeOfCharacter ) ) ); +InstallOtherMethod( CharacterDegreesAttr, + "method for an ordinary character table with group", + true, + [ IsOrdinaryTable and HasUnderlyingGroup ], 0, + tbl -> CharacterDegreesAttr( UnderlyingGroup( tbl ) ) ); + ############################################################################# ## -#M CharacterDegrees( ) . . . . . for group handled via nice monomorphism +#M CharacterDegreesAttr( ) . . . for group handled via nice monomorphism ## -AttributeMethodByNiceMonomorphism( CharacterDegrees, +AttributeMethodByNiceMonomorphism( CharacterDegreesAttr, [ IsGroup ] ); @@ -431,6 +483,7 @@ InstallOtherMethod( Size, [ IsCharacterTable and HasUnderlyingGroup ], 0, tbl -> Size( UnderlyingGroup( tbl ) ) ); + InstallOtherMethod( Size, "method for a character table with known centralizer sizes", true, @@ -438,6 +491,7 @@ InstallOtherMethod( Size, tbl -> SizesCentralizers( tbl )[1] ); #T immediate method ? + InstallOtherMethod( Size, "method for a group with known ordinary character table", true, @@ -1162,7 +1216,7 @@ InstallMethod( CharacterTableDirectProduct, ncc2_i, # fus; # projection/embedding map - direct:= ConvertToCharacterTableNC( rec() ); + direct:= ConvertToOrdinaryTableNC( rec() ); SetSize( direct, Size( tbl1 ) * Size( tbl2 ) ); SetIdentifier( direct, Concatenation( Identifier( tbl1 ), "x", Identifier( tbl2 ) ) ); @@ -2055,7 +2109,7 @@ InstallMethod( FusionConjugacyClassesOp, elif Size( tbl2 ) = Size( tbl1 ) then # find a transforming permutation - fusion:= TransformingPermutationsCharTables( tbl1, tbl2 ); + fusion:= TransformingPermutationsCharacterTables( tbl1, tbl2 ); if fusion = fail then return fail; elif 1 < Size( fusion.group ) then @@ -2593,10 +2647,10 @@ InstallOtherMethod( Display, ############################################################################# ## -#F ConvertToCharacterTable( ) . . . . create character table object -#F ConvertToCharacterTableNC( ) . . . create character table object +#F ConvertToOrdinaryTable( ) . . . . create character table object +#F ConvertToOrdinaryTableNC( ) . . . create character table object ## -ConvertToCharacterTableNC := function( record ) +ConvertToOrdinaryTableNC := function( record ) local names, # list of component names i; # loop over 'SupportedOrdinaryTableInfo' @@ -2632,7 +2686,7 @@ ConvertToCharacterTableNC := function( record ) return record; end; -ConvertToCharacterTable := function( record ) +ConvertToOrdinaryTable := function( record ) Error( "not yet implemented!" ); end; @@ -3447,6 +3501,437 @@ LowercaseString := function( str ) end; +############################################################################# +## +#F PermutationToSortCharacters( , , , ) +## +PermutationToSortCharacters := function( tbl, chars, degree, norm ) + + local rational, listtosort, i, len; + + if IsEmpty( chars ) then + return (); + fi; + + # Rational characters shall precede irrational ones of same degree, + # and the trivial character shall be the first one. + rational := function( chi ) + chi:= ValuesOfClassFunction( chi ); + if ForAll( chi, IsRat ) then + if ForAll( chi, x -> x = 1 ) then + return -1; + else + return 0; + fi; + else + return 1; + fi; + end; + + # Compute the permutation. + listtosort:= []; + if degree and norm then + for i in [ 1 .. Length( chars ) ] do + listtosort[i]:= [ ScalarProduct( chars[i], chars[i] ), + DegreeOfCharacter( chars[i] ), + rational( chars[i] ), i ]; + od; + elif degree then + for i in [ 1 .. Length( chars ) ] do + listtosort[i]:= [ DegreeOfCharacter( chars[i] ), + rational( chars[i] ), i ]; + od; + elif norm then + for i in [ 1 .. Length( chars ) ] do + listtosort[i]:= [ ScalarProduct( chars[i], chars[i] ), + rational( chars[i] ), i ]; + od; + else + Error( " or must be 'true'" ); + fi; + Sort( listtosort ); + len:= Length( listtosort[1] ); + for i in [ 1 .. Length( chars ) ] do + listtosort[i]:= listtosort[i][ len ]; + od; + return Inverse( PermList( listtosort ) ); +end; + + +############################################################################# +## +#M CharacterTableWithSortedCharacters( ) +## +InstallMethod( CharacterTableWithSortedCharacters, + "method for a character table", + true, + [ IsCharacterTable ], 0, + tbl -> CharacterTableWithSortedCharacters( tbl, + PermutationToSortCharacters( tbl, Irr( tbl ), true, false ) ) ); + + +############################################################################# +## +#M CharacterTableWithSortedCharacters( , ) +## +InstallOtherMethod( CharacterTableWithSortedCharacters, + "method for an ordinary character table, and a permutation", + true, + [ IsOrdinaryTable, IsPerm ], 0, + function( tbl, perm ) + + local new, i; + + # Create the new table. + new:= rec(); + ConvertToOrdinaryTable( new ); + + # Set the permuted attribute values. + SetIrr( new, Permuted( Irr( tbl ), perm ) ); + SetIrredInfo( new, Permuted( IrredInfo( tbl ), perm ) ); + + # Set the other supported values. + for i in [ 2, 4 .. Length( SupportedOrdinaryTableInfo ) ] do + if Tester( SupportedOrdinaryTableInfo[ i-1 ] ) + and not SupportedOrdinaryTableInfo[i] + in [ "irr", "irredInfo", "underlyingGroup" ] then + Setter( SupportedOrdinaryTableInfo[ i-1 ] )( new, + SupportedOrdinaryTableInfo[ i-1 ]( tbl ) ); + fi; + od; + + # Return the table. + return new; + end ); + + +############################################################################# +## +#M SortedCharacters( , ) +## +InstallMethod( SortedCharacters, + "method for a character table, and a homogeneous list", + true, + [ IsNearlyCharacterTable, IsHomogeneousList ], 0, + function( tbl, chars ) + return Permuted( chars, + PermutationToSortCharacters( tbl, chars, true, true ) ); + end ); + + +############################################################################# +## +#M SortedCharacters( , , \"norm\" ) +#M SortedCharacters( , , \"degree\" ) +## +InstallOtherMethod( SortedCharacters, + "method for a character table, a homogeneous list, and a string", + true, + [ IsNearlyCharacterTable, IsHomogeneousList, IsString ], 0, + function( tbl, chars, string ) + if string = "norm" then + return Permuted( chars, + PermutationToSortCharacters( tbl, chars, false, true ) ); + elif string = "degree" then + return Permuted( chars, + PermutationToSortCharacters( tbl, chars, true, false ) ); + else + Error( " must be \"norm\" or \"degree\"" ); + fi; + end ); + + +############################################################################# +## +#F PermutationToSortClasses( , , ) +## +PermutationToSortClasses := function( tbl, classes, orders ) + + local listtosort, i, len; + + # Compute the permutation. + listtosort:= []; + if classes and orders then + classes:= SizesConjugacyClasses( tbl ); + orders:= OrdersClassRepresentatives( tbl ); + for i in [ 1 .. NrConjugacyClasses( tbl ) ] do + listtosort[i]:= [ orders[i], classes[i], i ]; + od; + elif classes then + classes:= SizesConjugacyClasses( tbl ); + for i in [ 1 .. NrConjugacyClasses( tbl ) ] do + listtosort[i]:= [ classes[i], i ]; + od; + elif orders then + orders:= OrdersClassRepresentatives( tbl ); + for i in [ 1 .. NrConjugacyClasses( tbl ) ] do + listtosort[i]:= [ orders[i], i ]; + od; + else + Error( " or must be 'true'" ); + fi; + Sort( listtosort ); + len:= Length( listtosort[1] ); + for i in [ 1 .. Length( listtosort ) ] do + listtosort[i]:= listtosort[i][ len ]; + od; + return Inverse( PermList( listtosort ) ); +end; + + +############################################################################# +## +#M CharacterTableWithSortedClasses( ) +## +InstallMethod( CharacterTableWithSortedClasses, + "method for a character table", + true, + [ IsCharacterTable ], 0, + tbl -> CharacterTableWithSortedClasses( tbl, + PermutationToSortClasses( tbl, true, true ) ) ); + + +############################################################################# +## +#M CharacterTableWithSortedClasses( , \"centralizers\" ) +#M CharacterTableWithSortedClasses( , \"representatives\" ) +## +InstallOtherMethod( CharacterTableWithSortedClasses, + "method for a character table, and string", + true, + [ IsCharacterTable, IsString ], 0, + function( tbl, string ) + if string = "centralizers" then + return CharacterTableWithSortedClasses( tbl, + PermutationToSortClasses( tbl, true, false ) ); + elif string = "representatives" then + return CharacterTableWithSortedClasses( tbl, + PermutationToSortClasses( tbl, false, true ) ); + else + Error( " must be \"centralizers\" or \"representatives\"" ); + fi; + end ); + + +############################################################################# +## +#M CharacterTableWithSortedClasses( , ) +## +InstallOtherMethod( CharacterTableWithSortedClasses, + "method for an ordinary character table, and a permutation", + true, + [ IsOrdinaryTable, IsPerm ], 0, + function( tbl, perm ) + + local new, attr, fus, tblmaps, permmap, inverse, k; + + # Create the new table. + new:= rec(); + ConvertToOrdinaryTable( new ); + + # Set the permuted attribute values. + if 1^perm <> 1 then + Error( " must fix the first class" ); + elif Order( perm ) = 1 then + return tbl; + fi; + + # Set supported attributes that do not need adjustion. + for attr in [ Identifier, InfoText, IrredInfo, IsSimpleGroup, + Maxes, NamesOfFusionSources, UnderlyingCharacteristic ] do + if Tester( attr )( tbl ) then + Setter( attr )( new, attr( new ) ); + fi; + od; + + # Set known attributes that must be adjusted. + if HasClassParameters( tbl ) then + SetClassParameters( new, + Permuted( ClassParameters( tbl ), perm ) ); + fi; + if HasIrr( tbl ) then + SetIrr( new, + List( Irr( tbl ), chi -> CharacterByValues( new, + Permuted( ValuesOfClassFunction( chi, perm ) ) ) ) ); + fi; + if HasOrdersClassRepresentatives( tbl ) then + SetOrdersClassRepresentatives( new, + Permuted( OrdersClassRepresentatives( tbl ), perm ) ); + fi; + if HasSizesCentralizers( tbl ) then + SetSizesCentralizers( new, + Permuted( SizesCentralizers( tbl ), perm ) ); + fi; + for fus in ComputedClassFusions( tbl ) do + Add( ComputedClassFusions( new ), + rec( name:= fus.name, map:= Permuted( fus.map, perm ) ) ); + od; + + if HasComputedPowerMaps( tbl ) then + + tblmaps:= ComputedPowerMaps( tbl ); + permmap:= List( perm ); + inverse:= List( perm^(-1) ); + for k in [ Length( permmap ) + 1 .. NrConjugacyClasses( tbl ) ] do + permmap[k]:= k; + inverse[k]:= k; + od; + for k in [ 1 .. Length( tblmaps ) ] do + if IsBound( tblmaps[k] ) then + ComputedPowerMaps( new )[k]:= CompositionMaps( permmap, + CompositionMaps( tblmaps[k], inverse ) ); + fi; + od; + + fi; + + # The automorphisms of the sorted table are obtained on conjugation. + if HasAutomorphismsOfTable( tbl ) then + SetAutomorphismsOfTable( new, GroupByGenerators( + List( GeneratorsOfGroup( AutomorphismsOfTable( tbl ) ), + x -> x^perm ), () ) ); + fi; + + # Set the class permutation (important for fusions). + if HasClassPermutation( tbl ) then + SetClassPermutation( new, ClassPermutation( tbl ) * perm ); + else + SetClassPermutation( new, perm ); + fi; + + # Return the new table. + return new; + end ); + + +############################################################################# +## +#F SortedCharacterTable( , ) +#F SortedCharacterTable( , ) +#F SortedCharacterTable( , , ) +## +SortedCharacterTable := function( arg ) + + local i, j, tbl, kernels, list, columns, rows, chi, F, facttbl, kernel, + trans, ker, fus, new; + + # Check the arguments. + if not ( Length( arg ) in [ 2, 3 ] and IsOrdinaryTable( arg[1] ) and + IsList( arg[ Length( arg ) ] ) and + ( Length( arg ) = 2 or IsOrdinaryTable( arg[2] ) ) ) then + Error( "usage: SortedCharacterTable( , ) resp.\n", + " SortedCharacterTable( , ) resp.\n", + " SortedCharacterTable( , , )" ); + fi; + + tbl:= arg[1]; + + if Length( arg ) = 2 then + + # sort w.r. to kernel or series of kernels + kernels:= arg[2]; + if IsEmpty( kernels ) then + return tbl; + fi; + + # regard single kernel as special case of normal series + if IsInt( kernels[1] ) then + kernels:= [ kernels ]; + fi; + + # permutation of classes\: + # 'list[i] = k' if 'i' is contained in 'kernels[k]' but not + # in 'kernels[k-1]'; only the first position contains a zero + # to ensure that the identity is not moved. + # If class 'i' is not contained in any of the kernels we have + # 'list[i] = ""'. + list:= [ 0 ]; + for i in [ 2 .. NrConjugacyClasses( tbl ) ] do + list[i]:= ""; + od; + for i in [ 1 .. Length( kernels ) ] do + for j in kernels[i] do + if not IsInt( list[j] ) then + list[j]:= i; + fi; + od; + od; + columns:= Sortex( list ); + + # permutation of characters + # 'list[i] = -(k+1)' if '.irreducibles[i]' has 'kernels[k]' + # in its kernel but not 'kernels[k+1]'; if the 'i'--th irreducible + # contains none of 'kernels' in its kernel we have 'list[i] = -1', + # for an irreducible with kernel containing 'kernels[ Length( kernels ) ] + # the value is '-(Length( kernels ) + 1)'. + list:= []; + if HasIrr( tbl ) then + for chi in Irr( tbl ) do + i:= 1; + while i <= Length( kernels ) + and ForAll( kernels[i], x -> chi[x] = chi[1] ) do + i:= i+1; + od; + Add( list, -i ); + od; + rows:= Sortex( list ); + else + rows:= (); + fi; + + else + + # sort w.r. to table of factor group + facttbl:= arg[2]; + kernel:= arg[3]; + F:= CharacterTableFactorGroup( tbl, kernel ); + trans:= TransformingPermutationsCharacterTables( F, facttbl ); + if trans = fail then + Info( InfoCharacterTable, 2, + "SortedCharacterTable: tables of factors not compatible" ); + return fail; + fi; + + # permutation of classes\: + # 'list[i] = k' if 'i' maps to the 'j'--th class of , and + # 'trans.columns[j] = i' + list:= OnTuples( GetFusionMap( tbl, F ), trans.columns ); + columns:= Sortex( list ); + + # permutation of characters\: + # divide 'Irr( )' into two parts, those containing + # the kernel of the factor fusion in their kernel (value 0), + # and the others (value 1); do not forget to permute characters + # of the factor group with 'trans.rows'. + if HasIrr( tbl ) then + ker:= KernelChar( GetFusionMap( tbl, F ) ); + list:= []; + for chi in Irr( tbl ) do + if ForAll( ker, x -> chi[x] = chi[1] ) then + Add( list, 0 ); + else + Add( list, 1 ); + fi; + od; + rows:= Sortex( list ) * trans.rows; + else + rows:= (); + fi; + + # delete the fusion to 'F' on 'tbl' + fus:= ComputedClassFusions( tbl ); + Unbind( fus[ Length( fus ) ] ); +#T better ? + + fi; + + # Sort and return. + new:= CharacterTableWithSortedClasses( tbl, columns ); + new:= CharacterTableWithSortedCharacters( new, rows ); + return new; +end; + + ############################################################################# ## #E ctbl.gi . . . . . . . . . . . . . . . . . . . . . . . . . . . . ends here diff --git a/lib/ctblchar.gd b/lib/ctblchar.gd index cf62847925..d582113736 100644 --- a/lib/ctblchar.gd +++ b/lib/ctblchar.gd @@ -86,11 +86,15 @@ FrobeniusCharacterValue := NewOperationArgs( "FrobeniusCharacterValue" ); ############################################################################# ## -#F Tensored( , ) +#O Tensored( , ) ## -## returns the list of tensor products of with . +## Let and be lists of class functions of the same +## character table. +## `Tensored' returns the list of tensor products of all in with +## all in . ## -Tensored := NewOperationArgs( "Tensored" ); +Tensored := NewOperation( "Tensored", + [ IsClassFunctionCollection, IsClassFunctionCollection ] ); ############################################################################# diff --git a/lib/ctblchar.gi b/lib/ctblchar.gi index 53ba0b3913..ce697dd406 100644 --- a/lib/ctblchar.gi +++ b/lib/ctblchar.gi @@ -321,17 +321,48 @@ end; ############################################################################# ## -#F Tensored( , ) +#M Tensored( , ) . . . . for two lists of class functions ## -## returns the list of tensor products of with . -## -Tensored := function( chars1, chars2 ) - +InstallMethod( Tensored, + "method for two lists of class functions", + IsIdentical, + [ IsList and IsClassFunctionCollection, + IsList and IsClassFunctionCollection ], 0, + function( chars1, chars2 ) local i, j, k, nccl, tensored, single; - - if IsEmpty( chars1 ) then return []; fi; nccl:= Length( chars1[1] ); + tensored:= []; + for i in chars1 do + for j in chars2 do + Add( tensored, i*j ); + od; + od; + return tensored; + end ); +InstallOtherMethod( Tensored, + "method for list and empty list", + true, + [ IsList, IsList and IsEmpty ], 0, + function( chars, empty ) + return []; + end ); + +InstallOtherMethod( Tensored, + "method for empty list and list", + true, + [ IsList and IsEmpty, IsList ], 0, + function( empty, chars ) + return []; + end ); + +InstallOtherMethod( Tensored, + "method for two matrices", + IsIdentical, + [ IsMatrix, IsMatrix ], 0, + function( chars1, chars2 ) + local i, j, k, nccl, tensored, single; + nccl:= Length( chars1[1] ); tensored:= []; for i in chars1 do for j in chars2 do @@ -341,7 +372,7 @@ Tensored := function( chars1, chars2 ) od; od; return tensored; -end; + end ); ############################################################################# diff --git a/lib/ctblfuns.gd b/lib/ctblfuns.gd index 80ad7e2b2a..800b8ecb82 100644 --- a/lib/ctblfuns.gd +++ b/lib/ctblfuns.gd @@ -368,25 +368,16 @@ DeterminantChar := NewOperation( "DeterminantChar", ## for a group element in the -th conjugacy class of . ## ## 'EigenvaluesChar( , , )' is the list of length -## '$n$ = orders[ ]' where at position 'i' the multiplicity -## of 'E(n)^i = $e^{\frac{2\pi i}{n}$' as eigenvalue of $M$ is stored. +## '$n$ = orders[ ]' where at position 'k' the multiplicity +## of 'E(n)^k = $e^{\frac{2\pi i k}{n}$' as eigenvalue of $M$ is stored. ## -## We have '[ ] = List( [ 1 .. ], i -> E(n)^i ) +## We have '[ ] = List( [ 1 .. ], k -> E(n)^k ) ## * EigenvaluesChar( , , ). ## EigenvaluesChar := NewOperation( "EigenvaluesChar", [ IsNearlyCharacterTable, IsCharacter, IsInt and IsPosRat ] ); -############################################################################# -## -#O ScalarProduct( , ) -#O ScalarProduct( , , ) -## -ScalarProduct := NewOperation( "ScalarProduct", - [ IsClassFunction, IsClassFunction ] ); - - ############################################################################# ## #O RestrictedClassFunction( , ) diff --git a/lib/ctblfuns.gi b/lib/ctblfuns.gi index 7061e5d121..c89a31e6d5 100644 --- a/lib/ctblfuns.gi +++ b/lib/ctblfuns.gi @@ -2960,6 +2960,64 @@ InstallMethod( UglyVector, end ); +############################################################################# +## +#M ScalarProduct( , , ) . . . . for module of class functions +## +## Left modules of class functions carry the usual bilinear form. +## +InstallOtherMethod( ScalarProduct, + "method for left module of class functions, and two class functions", + IsCollsElmsElms, + [ IsFreeLeftModule and IsClassFunctionsSpaceRep, + IsClassFunction, IsClassFunction ], 0, + function( V, x1, x2 ) + + local tbl, # character table + i, # loop variable + scpr, # scalar product, result + weight; # lengths of conjugacy classes + + tbl:= V!.elementsunderlying; + weight:= SizesConjugacyClasses( tbl ); + x1:= ValuesOfClassFunction( x1 ); + x2:= ValuesOfClassFunction( x2 ); + scpr:= 0; + for i in [ 1 .. Length( x1 ) ] do + scpr:= scpr + x1[i] * GaloisCyc( x2[i], -1 ) * weight[i]; + od; + return scpr / Size( tbl ); + end ); + + +############################################################################# +## +#M ScalarProduct( , , ) . . for module of class funs. +## +## Left modules of class functions carry the usual bilinear form. +## +InstallOtherMethod( ScalarProduct, + "method for module of class functions, and two values lists", + Is2Identical3, + [ IsFreeLeftModule and IsClassFunctionsSpaceRep, + IsHomogeneousList, IsHomogeneousList ], 0, + function( V, x1, x2 ) + + local tbl, # character table + i, # loop variable + scpr, # scalar product, result + weight; # lengths of conjugacy classes + + tbl:= V!.elementsunderlying; + weight:= SizesConjugacyClasses( tbl ); + scpr:= 0; + for i in [ 1 .. Length( x1 ) ] do + scpr:= scpr + x1[i] * GaloisCyc( x2[i], -1 ) * weight[i]; + od; + return scpr / Size( tbl ); + end ); + + ############################################################################## ## #F NormalSubgroupClasses( , ) diff --git a/lib/ctblmono.gd b/lib/ctblmono.gd new file mode 100644 index 0000000000..bea015a20e --- /dev/null +++ b/lib/ctblmono.gd @@ -0,0 +1,393 @@ +############################################################################# +## +#W ctblmono.gd GAP library Thomas Breuer +#W & Erzsebet Horvath +## +#H @(#)$Id$ +## +#Y Copyright (C) 1997, Lehrstuhl D fuer Mathematik, RWTH Aachen, Germany +## +## This file contains the declarations of the functions dealing with +## monomiality questions for solvable groups. +## +Revision.ctblmono_gd := + "@(#)$Id$"; + + +############################################################################## +## +#V InfoMonomial +## +InfoMonomial := NewInfoClass( "InfoMonomial" ); + + +############################################################################## +## +#A Alpha( ) +## +## returns for a group a list whose -th entry is the maximal derived +## length of groups $ / \ker(\chi)$ for $\chi\in Irr()$ with +## $\chi(1)$ at most the -th irreducible degree of . +## +Alpha := NewAttribute( "Alpha", IsGroup ); +SetAlpha := Setter( Alpha ); +HasAlpha := Tester( Alpha ); + + +############################################################################## +## +#A Delta( ) +## +## returns the list '[ 1, alp[2] - alp[1], ..., alp[] - alp[-1] ]' +## where 'alp = Alpha( )'. +## +Delta := NewAttribute( "Delta", IsGroup ); +SetDelta := Setter( Delta ); +HasDelta := Tester( Delta ); + + +############################################################################## +## +#P IsBergerCondition( ) +#P IsBergerCondition( ) +## +## Called with a character , 'IsBergerCondition' returns 'true' if +## \[ ( \bigcap\{\ker(\psi);\psi(1) \< 'Degree( )'\} )^{\prime} +## \leq \ker(). \] +## +## Called with a group , 'IsBergerCondition' returns 'true' if all +## irreducible characters of satisfy +## \[ ( \bigcap_{\psi(1) \leq f_i} \ker(\psi) )^{\prime} \leq +## \bigcap_{\chi(1) = f_{i+1}} \ker(\chi) \ \forall 1 \leq i \leq n-1 \] +## where $1 = f_1 \leq f_2 \leq\ldots \leq f_n$ are the distinct irreducible +## degrees of . +## +## In the case that 'false' is returned 'InfoMonomial' tells about the +## degree for that the inequality is violated. +## +IsBergerCondition := NewProperty( "IsBergerCondition", IsGroup ); +SetIsBergerCondition := Setter( IsBergerCondition ); +HasIsBergerCondition := Tester( IsBergerCondition ); + +BergerCondition := IsBergerCondition; +#T compat3! + + +############################################################################## +## +#F TestHomogeneous( , ) +## +## returns a record with information whether the restriction of the group +## character of the group $G$ to the normal subgroup of $G$ is +## homogeneous, i.e., is a multiple of an irreducible character. +## +## may be given also as list of conjugacy class positions w.r. to $G$. +## +TestHomogeneous := NewOperationArgs( "TestHomogeneous" ); + + +############################################################################## +## +#A TestQuasiPrimitive( ) +## +## returns a record with information about quasiprimitivity of the group +## character (i.e., whether restricts homogeneously to every +## normal subgroup of ). +## +## The record contains at least the component +## 'isQuasiPrimitive': \\ 'true' or 'false'. +## +## If is not quasiprimitive then there is a component +## +## 'character': \\ an irreducible constituent of a nonhomogeneous +## restriction of . +## +## *Note*\:\ For solvable groups quasiprimitivity is the same as primitivity. +## +TestQuasiPrimitive := NewAttribute( "TestQuasiPrimitive", IsCharacter ); +SetTestQuasiPrimitive := Setter( TestQuasiPrimitive ); +HasTestQuasiPrimitive := Tester( TestQuasiPrimitive ); + + +############################################################################## +## +#P IsQuasiPrimitive( ) +## +## returns whether the character of the group is quasiprimitive, +## i.e., restricts homogeneously to every normal subgroup of . +## +IsQuasiPrimitive := NewProperty( "IsQuasiPrimitive", IsCharacter ); +SetIsQuasiPrimitive := Setter( IsQuasiPrimitive ); +HasIsQuasiPrimitive := Tester( IsQuasiPrimitive ); + + +############################################################################## +## +#P IsPrimitive( ) +## +## returns whether the character of the group is quasiprimitive, +## i.e., restricts homogeneously to every normal subgroup of . +## +#T defined elsewhere, maybe with a different definition ... +#T how to deal with such situations? + + +############################################################################## +## +#F TestInducedFromNormalSubgroup( , ) +#F TestInducedFromNormalSubgroup( ) +## +## returns a record with information about whether the irreducible group +## character of the group $G$ is induced from a proper normal subgroup +## of $G$. +## +## If is the only argument then it is checked whether there is a +## maximal normal subgroup of $G$ from that is induced. +## +## A second argument must be a normal subgroup of $G$ or the list of +## class positions of a normal subgroup of $G$. Then it is checked +## whether is induced from . +## +## The result contains always a component 'comment', a string. +## The component 'isInduced' is 'true' or 'false', depending on whether +## is induced. In the 'true' case the component 'character' +## contains a character of a maximal normal subgroup from that is +## induced. +## +#T problem! (attr.?) +## +TestInducedFromNormalSubgroup := NewOperationArgs( + "TestInducedFromNormalSubgroup" ); + + +############################################################################## +## +#P IsInducedFromNormalSubgroup( ) +## +## returns whether the character of the group $G$ is induced from a +## normal subgroup of $G$. +## +IsInducedFromNormalSubgroup := NewProperty( "IsInducedFromNormalSubgroup", + IsCharacter ); +SetIsInducedFromNormalSubgroup := Setter( IsInducedFromNormalSubgroup ); +HasIsInducedFromNormalSubgroup := Tester( IsInducedFromNormalSubgroup ); + + +############################################################################## +## +#A TestSubnormallyMonomial( ) +#A TestSubnormallyMonomial( ) +## +## returns a record with information whether the group or the +## irreducible group character is subnormally monomial. +## +## The result contains components 'comment' (a string) +## and 'isSubnormallyMonomial' ('true' or 'false'); +## in the case that 'isSubnormallyMonomial' is 'false' there is also +## a component 'character' that is not a SM character. +## +TestSubnormallyMonomial := NewAttribute( "TestSubnormallyMonomial", + IsGroup ); +SetTestSubnormallyMonomial := Setter( TestSubnormallyMonomial ); +HasTestSubnormallyMonomial := Tester( TestSubnormallyMonomial ); + + +############################################################################## +## +#P IsSubnormallyMonomial( ) +#P IsSubnormallyMonomial( ) +## +IsSubnormallyMonomial := NewProperty( "IsSubnormallyMonomial", + IsGroup ); +SetIsSubnormallyMonomial := Setter( IsSubnormallyMonomial ); +HasIsSubnormallyMonomial := Tester( IsSubnormallyMonomial ); + + +############################################################################# +## +#M IsMonomial( ) +## +## returns 'true' if every solvable group of order is monomial, +## and 'false' otherwise. +## +## Let $\nu_p(n)$ denote the multiplicity of the prime $p$ as +## factor of $n$, and $ord(p,q)$ the multiplicative order of $p \pmod{q}$. +## +## Then there exists a nomonomial group of order $n$ if and only if +## one of the following conditions is satisfied. +## +## \begin{enumerate} +## \item $\nu_2(n) \geq 2$ and there is a $p$ such that +## $\nu_p(n) \geq 3$ and $p \equiv -1 \pmod{4}$, +## \item $\nu_2(n) \geq 3$ and there is a $p$ such that +## $\nu_p(n) \geq 3$ and $p \equiv 1 \pmod{4}$, +## \item there are odd prime divisors $p$ and $q$ of $n$ such that +## $ord(p,q)$ is even and $ord(p,q) < \nu_p(n)$ +## (especially $\nu_p(n) \geq 3$), +## \item there is a prime divisor $q$ of $n$ such that +## $\nu_2(n) \geq 2 ord(2,q) + 2$ +## (especially $\nu_2(n) \geq 4$), +## \item $\nu_2(n) \geq 2$ and there is a $p$ such that +## $p \equiv 1 \pmod{4}$, $ord(p,q)$ is odd, +## and $2 ord(p,q) < \nu_p(n)$ +## (especially $\nu_p(n) \geq 3$). +## \end{enumerate} +## +## These five possibilities correspond to the five types of minimal +## nonmonomial groups that can occur as subgroup or factor group of +## the group with order $n$. +## +#T problem: where is the attribute defined? +#T IsMonomialNumber? +## + + +############################################################################## +## +#A TestMonomialQuick( ) +## +## returns a record with components +## +## 'isMonomial': \\ either 'true' or 'false' or '"?"' +## +## The function sets the 'isMonomial' flag if (non)monomiality was proved. +## +TestMonomialQuick := NewAttribute( "TestMonomialQuick", IsCharacter ); +SetTestMonomialQuick := Setter( TestMonomialQuick ); +HasTestMonomialQuick := Tester( TestMonomialQuick ); + + +############################################################################## +## +#A TestMonomial( ) +#A TestMonomial( ) +## +## returns a record containing information about monomiality of the group +## or the group character , respectively. +## +## If a character was proved to be monomial the result contains +## components 'isMonomial' (then 'true'), 'comment' (a string telling a +## reason for monomiality), and if it was necessary to compute a linear +## character from that is induced, also a component 'character'. +## +## If or was proved to be nonmonomial the component 'isMonomial' +## is 'false', and in the case of a nonmonomial character is contained +## in the component 'character' if it had been necessary to compute it. +## +## If the program cannot prove or disprove monomiality, then the result +## record contains the component 'isMonomial' with value '\"?\"'. +## +## It can happen that for all normal subgroups to that the restriction is +## not homogeneous the inertia groups in question do not contain a subgroup +## from that the character is induced? +## +## The algorithm proceeds as follows. +## Called with a character as argument, 'TestMonomialQuick( )' +## is inspected first. If this did not decide the question, we test all +## those normal subgroups of $G$ to that restricts nonhomogeneously +## whether the interesting character of the inertia subgroup is monomial. +## (If is quasiprimitive then it is nonmonomial.) +## +## Called with a group the program checks whether all representatives +## of character orbits are monomial. +#T used e.g. by 'Irr' for supersolvable groups, function 'IrrConlon'! +## +TestMonomial := NewAttribute( "TestMonomial", IsCharacter ); +SetTestMonomial := Setter( TestMonomial ); +HasTestMonomial := Tester( TestMonomial ); + + +############################################################################## +## +#F TestRelativelySM( ) +#F TestRelativelySM( ) +#F TestRelativelySM( , ) +#F TestRelativelySM( , ) +## +## If the only argument is a SM group $G$ or an irreducible character of a +## SM group $G$ then 'TestRelativelySM' returns a record with information +## about whether the argument is relatively SM with respect to every normal +## subgroup of $G$. +## +## If there is a second argument, a normal subgroup of $G$, then +## 'TestRelativelySM' returns a record with information whether the first +## argument is relatively SM with respect to , i.e, whether there is a +## subnormal subgroup $H$ of $G$ that contains such that the character +## resp. every irreducible character of $G$ is induced from a character +## $\psi$ of $H$ where the restriction of $\psi$ to is irreducible. +## +## The component 'isRelativelySM' is 'true' or 'false', the component +## 'comment' contains a string that describes the reason. +## If the argument is , and is not relatively SM with respect to +## a normal subgroup then the component 'character' contains a not +## relatively SM character of such a normal subgroup. +## +## *Note* that it is not checked whether $G$ is SM. +## +## The algorithm for a character and a normal subgroup +## proceeds as follows. +## If is abelian or has nilpotent factor then is relatively SM +## with respect to . +## Otherwise we check whether restricts irreducibly to ; in this +## case we also get a positive answer. +## Otherwise a subnormal subgroup from that is induced must be +## contained in a maximal normal subgroup of . So we get all maximal +## normal subgroups containing from that can be induced, take a +## character that induces to , and check recursively whether it is +## relatively subnormally monomial with respect to . +## +## For a group $G$ we consider only representatives of character orbits. +## +TestRelativelySM := NewOperationArgs( "TestRelativelySM" ); + + +############################################################################## +## +#P IsRelativelySM( ) +#P IsRelativelySM( ) +## +## returns whether the the group resp. the irreducible character +## of the group is relatively subnormally monomial with respect to +## every normal subgroup of . +## +## must be subnormally monomial. (This is *not* checked.) +## +IsRelativelySM := NewProperty( "IsRelativelySM", IsGroup ); +SetIsRelativelySM := Setter( IsRelativelySM ); +HasIsRelativelySM := Tester( IsRelativelySM ); + + +############################################################################## +## +#P IsMinimalNonmonomial( ) +## +## returns 'true' if the group is a minimal nonmonomial group, and +## 'false' otherwise. +## +IsMinimalNonmonomial := NewProperty( "IsMinimalNonmonomial", IsGroup ); +SetIsMinimalNonmonomial := Setter( IsMinimalNonmonomial ); +HasIsMinimalNonmonomial := Tester( IsMinimalNonmonomial ); + + +############################################################################## +## +#F MinimalNonmonomialGroup(

, ) +## +## returns the minimal nonmonomial group described by the parameters +## and

if such a group exists, and 'false' otherwise. +## +## Suppose that the required group $K$ exists. +## must be the size of the Fitting factor $K / F(K)$. +##

denotes the number $s$ such that the centre $Z(K)$ has order $2^s$ +## in the case that is twice an odd prime; in all other cases +##

is the (unique) prime that divides the order of $F(K)$. +## +MinimalNonmonomialGroup := NewOperationArgs( "MinimalNonmonomialGroup" ); + + +############################################################################# +## +#E ctblmono.gd . . . . . . . . . . . . . . . . . . . . . . . . . . ends here + + + diff --git a/lib/ctblpope.gd b/lib/ctblpope.gd new file mode 100644 index 0000000000..67bb6c8f56 --- /dev/null +++ b/lib/ctblpope.gd @@ -0,0 +1,401 @@ +############################################################################# +## +#W ctblpope.gd GAP library Thomas Breuer +#W & Goetz Pfeiffer +## +#H @(#)$Id$ +## +#Y Copyright (C) 1997, Lehrstuhl D fuer Mathematik, RWTH Aachen, Germany +## +## This file contains the declaration of those functions that are needed to +## compute and test possible permutation characters. +## +#N TODO: +#N - 'IsPermChar( , )' +#N (check whether can be a permutation character of ; +#N use also the kernel of , i.e., check whether the kernel factor +#N of can be a permutation character of the factor of by the +#N kernel; one example where this helps is the sum of characters of S3 +#N in O8+(2).3.2) +#N - 'Constituent' und 'Maxdeg' - Optionen in 'PermComb' +## +Revision.ctblpope_gd := + "@(#)$Id$"; + + +############################################################################# +## +#F SubClass( , ) . . . . . . . . . . . size of class in subgroup +## +## Given a permutation character of the group with character table +## 'SubClass' determines the sizes of the intersections of the +## classes with the corresponding subgroup. Of course this has to be a +## positive integer. +## +SubClass := NewOperationArgs( "SubClass" ); + + +############################################################################# +## +#F TestPerm1( , ) . . . . . . . . . . . . . . . . test permchar +## +## performs CAS test 1 and 2 for permutation characters +## +TestPerm1 := NewOperationArgs( "TestPerm1" ); + + +############################################################################# +## +#F TestPerm2( , ) . . . . . . . . . . . . test permchar +## +## performs CAS test 3, 4, and 5 for permutation characters +## +TestPerm2 := NewOperationArgs( "TestPerm2" ); + + +############################################################################# +## +#F TestPerm3( , ) . . . . . . . . . . . . . . . test permchar +## +## 'TestPerm3' performs CAS test 6 +## +TestPerm3 := NewOperationArgs( "TestPerm3" ); + + +############################################################################# +## +#F Inequalities( , [,

) . . . . . . . . . . for an abelian group +## +InstallMethod( CharacterDegreesOp, + "method for an abelian group, and an integer", + true, + [ IsGroup and IsAbelian, IsInt ], 0, + function( G, p ) + G:= Size( G ); + if p <> 0 then + while G mod p = 0 do + G:= G / p; + od; + fi; + return [ [ 1, G ] ]; + end ); + + +############################################################################# +## +#F AppendCollectedList( , ) +## +AppendCollectedList := function( list1, list2 ) + local pair1, pair2, toadd; + for pair2 in list2 do + toadd:= true; + for pair1 in list1 do + if pair1[1] = pair2[1] then + pair1[2]:= pair1[2] + pair2[2]; + toadd:= false; + break; + fi; + od; + if toadd then + AddSet( list1, pair2 ); + fi; + od; +end; + + +############################################################################# +## +#F KernelUnderDualAction( , , ) . . . . . . . local function +## +## is a PCGS of an elementary abelian group . +## is a vector in the dual space of , w.r.t. . +## The kernel of is returned. +## +KernelUnderDualAction := function( N, Npcgs, v ) + + local gens, # generators list + i, j; + + gens:= []; + for i in Reversed( [ 1 .. Length( v ) ] ) do + if IsZero( v[i] ) then + Add( gens, Npcgs[i] ); + else + # 'i' is the position of the last nonzero entry of 'v'. + for j in Reversed( [ 1 .. i-1 ] ) do + Add( gens, Npcgs[j]*Npcgs[i]^( Int(-v[j]/v[i]) ) ); + od; + return SubgroupNC( N, Reversed( gens ) ); + fi; + od; +end; + + +############################################################################# +## +#F ProjectiveCharDeg( , , ) +## +## is a collected list of the degrees of those faithful and absolutely +## irreducible characters of the group in characteristic that +## restrict homogeneously to the group generated by , which must be +## central in . +## Only those characters are counted that have value a multiple of +## 'E( Order() )' on . +## +ProjectiveCharDeg := function( G, z, q ) + + local oz, # the order of 'z' + N, # normal subgroup of 'G' + t, + r, # collected list of character degrees, result + h, # natural epimorphism + k, + c, + ci, + zn, + i, + p, # prime divisor of the size of 'N' + P, # Sylow 'p' subgroup of 'N' + O, + L, + Gpcgs, # PCGS of 'G' + Ppcgs, # PCGS of 'P' + Opcgs, # PCGS of 'O' + mats, + orbs, + orb, # loop over 'orbs' + stab; # stabilizer of canonical representative of 'orb' + + oz:= Order( z ); + + # For abelian groups, there are only linear characters. + if IsAbelian( G ) then + G:= Size( G ); + if q <> 0 then + while G mod q = 0 do + G:= G / q; + od; + fi; + return [ [ 1, G/oz ] ]; + fi; + + # Now 'G' is not abelian. + h:= NaturalHomomorphismByNormalSubgroup( G, SubgroupNC( G, [ z ] ) ); + N:= ElementaryAbelianSeries( Range( h ) ); + N:= N[ Length( N )-1 ]; + if not IsPrime( Size( N ) ) then + N:= ChiefSeriesUnderAction( Range( h ), N ); + N:= N[ Length( N )-1 ]; + fi; + + # 'N' is a normal subgroup such that 'N/' is a chief factor of 'G' + # of order 'i' which is a power of 'p'. + N:= PreImagesSet( h, N ); + i:= Size( N ) / oz; + p:= Factors( i )[1]; + + if not IsAbelian( N ) then + + h:= NaturalHomomorphismByNormalSubgroup( G, SubgroupNC( G, [ z ] ) ); + + # 'c' is a list of complement classes of 'N' modulo 'z' + c:= List( Complementclasses( Range( h ), ImagesSet( h, N ) ), + x -> PreImagesSet( h, x ) ); + r:= Centralizer( G, N ); + for L in c do + if IsSubset( L, r ) then + + # L is a complement to N in G modulo which centralizes N + r:= RootInt( Size(N) / oz ); + return List( ProjectiveCharDeg( L, z, q ), + x -> [ x[1]*r, x[2] ] ); + + fi; + od; + Error( "this should not happen" ); + + fi; + + # 'N' is abelian, 'P' is its Sylow 'p' subgroup. + P:= SylowSubgroup( N, p ); + + if p = q then + + # Factor out 'P' (lies in the kernel of the repr.) + h:= NaturalHomomorphismByNormalSubgroup( G, P ); + return ProjectiveCharDeg( Range( h ), ImageElm( h, z ), q ); + + elif i = Size( P ) then + + # 'z' is a p'-element, 'P' is elementary abelian. + # Find the characters of the factor group needed. + h:= NaturalHomomorphismByNormalSubgroup( G, P ); + r:= ProjectiveCharDeg( Range( h ), ImageElm( h, z ), q ); + + if p = i then + + # 'P' has order 'p'. + zn:= First( GeneratorsOfGroup( P ), g -> not IsOne( g ) ); + t:= Stabilizer( G, zn ); + i:= Size(G) / Size(t); + AppendCollectedList( r, + List( ProjectiveCharDeg( t, zn*z, q ), + x -> [ x[1]*i, x[2]*(p-1)/i ] ) ); + return r; + + else + + # 'P' has order strictly larger than 'p'. + # 'mats' describes the contragredient operation of 'G' on 'P'. + Gpcgs:= Pcgs( G ); + Ppcgs:= Pcgs( P ); + mats:= List( List( Gpcgs, Inverse ), + x -> TransposedMat( List( Ppcgs, + y -> ExponentsOfPcElement( Ppcgs, y^x ) )*Z(p)^0 ) ); + orbs:= ExternalOrbitsStabilizers( G, + Enumerator( FullRowModule( GF(p), Length( Ppcgs ) ) ), + Gpcgs, mats, OnRight ); + orbs:= Filtered( orbs, + o -> not IsZero( CanonicalRepresentativeOfExternalSet( o ) ) ); + + for orb in orbs do + + # 'k' is the kernel of the character. + stab:= StabilizerOfExternalSet( orb ); + h:= NaturalHomomorphismByNormalSubgroup( stab, + KernelUnderDualAction( P, Ppcgs, + CanonicalRepresentativeOfExternalSet( orb ) ) ); + + # 'zn' is an element of 'Range( h )'. + # Note that the image of 'P' under 'h' has order 'p'. + zn:= First( GeneratorsOfGroup( ImagesSet( h, P) ), + g -> not IsOne( g ) ) + * ImageElm( h, z ); + + # 'c' is stabilizer of the character, + # 'ci' is the number of orbits of characters with equal kernels + if p = 2 then + c := Range( h ); + ci := 1; + else + c := Stabilizer( Range( h ), zn ); + ci := Size( Range( h ) ) / Size( c ); + fi; + k:= Size( G ) / Size( stab ) * ci; + AppendCollectedList( r, + List( ProjectiveCharDeg( c, zn, q ), + x -> [ x[1]*k, x[2]*(p-1)/ci ] ) ); + + od; + return r; + + fi; + + elif IsCyclic( P ) then + + # Choose a generator 'zn' of 'P'. + zn := Pcgs( P )[1]; + t := Stabilizer( G, zn, OnPoints ); + if G = t then + # 'P' is a central subgroup of 'G'. + return List( ProjectiveCharDeg( G, zn*z, q ), + x -> [ x[1], x[2]*p ] ); + else + # 'P' is not central in 'G'. + return List( ProjectiveCharDeg( t, zn*z, q ), + x -> [ x[1]*p, x[2] ] ); + fi; + + fi; + + # 'P' is the direct product of the Sylow 'p' subgroup of 'z' + # and an elementary abelian 'p' subgroup. + O:= Omega( P ); + Opcgs:= Pcgs( O ); + Gpcgs:= Pcgs( G ); + + # 'zn' is a generator of the intersection of and 'O' + zn := z^(oz/p); + r := []; + mats:= List( List( Gpcgs, Inverse ), + x -> TransposedMat( List( Opcgs, + y -> ExponentsOfPcElement( Opcgs, y^x ) ) * Z(p)^0 ) ); + orbs:= ExternalOrbitsStabilizers( G, + Enumerator( GF(p)^Length( Opcgs ) ), + Gpcgs, mats, OnRight ); + orbs:= Filtered( orbs, + o -> not IsZero( CanonicalRepresentativeOfExternalSet( o ) ) ); + + # In this case the stabilzers of the kernels are already the + # stabilizers of the characters. + for orb in orbs do + k:= KernelUnderDualAction( O, Opcgs, + CanonicalRepresentativeOfExternalSet( orb ) ); + if not zn in k then + # The kernel avoids 'zn'. + t:= StabilizerOfExternalSet( orb ); + h:= NaturalHomomorphismByNormalSubgroup( t, k ); + t:= Size(G) / Size(t); + AppendCollectedList( r, List( ProjectiveCharDeg( Range( h ), + ImageElm( h, z ), q ), + x -> [ x[1]*t, x[2] ] ) ); + fi; + od; + return r; +end; + + +############################################################################# +## +#M CharacterDegreesOp( ,

) . . . . . . . . . . for a solvable group +## +## The used algorithm is described in +## +## S. B. Conlon, J. Symbolic Computation (1990) 9, 551-570. +## +## The main theoretic tool for the algorithm is Clifford theory. +## One recursive step of the algorithm will be described. +## +## Let $G$ be a solvable group, $z$ a central element in $G$, +## and let $q$ be the characteristic of the algebraic closed field $F$. +## Without loss of generality, we may assume that $G$ is nonabelian. +## Consider a faithful linear character $\lambda$ of $\langle z \rangle$. +## We calculate the character degrees $(G,z,q)$ of those absolutely +## irreducible characters of $G$ whose restrictions to $\langle z \rangle$ +## are a multiple of $\lambda$. +## +## We choose a normal subgroup $N$ of $G$ such that the factor +## $N / \langle z \rangle$ is a chief factor in $G$, and consider +## the following cases. +## +## If $N$ is nonabelian then we calculate a subgroup $L$ of $G$ such that +## $N \cap L = \langle z \rangle$, $L$ centralizes $N$, and $N L = G$. +## One can show that the order of $N / \langle z \rangle$ is a square $r^2$, +## and that the degrees $(G,z,q)$ are obtained from the degrees $(L,z,q)$ +## on multiplying each with $r$. +## +## If $N$ is abelian then the order of $N / \langle z \rangle$ is a prime +## power $p^i$. +## Let $P$ denote the Sylow $p$ subgroup of $N$. +## Following Clifford's theorem, we calculate orbit representatives and +## inertia subgroups with respect to the action of $G$ on those irreducible +## characters of $P$ that restrict to multiples of $\lambda_P$. +## For that, we distinguish three cases. +## +## (a) $z$ is a $p^{\prime}$ element. +## Then we compute first the character degrees $(G/P,zP,q)$, +## corresponding to the (orbit of the) trivial character. +## The action on the nontrivial irreducible characters of $P$ +## is dual to the action on the nonzero vectors of the vector space +## $P$. +## For each representative, we compute the kernel $K$, and the degrees +## $(S/K,zK,q)$, where $S$ denotes the inertia subgroup. +## +## (b) $z$ is not a $p^{\prime}$ element, and $P$ cyclic (not prime order). +## Let $y$ be a generator of $P$. +## If $y$ is central in $G$ then we have to return $p$ copies of the +## degrees $(G,zy,q)$. +## Otherwise we compute the degrees $(C_G(y),zy,q)$, and multiply +## each with $p$. +## +## (c) $z$ is not a $p^{\prime}$ element, and $P$ is not cyclic. +## We compute $O = \Omega(P)$. +## As above, we consider the dual operation to that in $O$, +## and for each orbit representative we check whether its restriction +## to $O$ is a multiple of $\lambda_O$, and if yes compute the degrees +## $(S/K,zK,q)$. +## +## Note that only those cases of the algorithm 'ProjectiveCharDeg' +## are needed that occur for trivial $z$. +## Especialy N is elementary abelian. +## +InstallMethod( CharacterDegreesOp, + "method for a solvable group and an integer (Conlon's algorithm)", + true, + [ IsGroup and IsSolvableGroup, IsInt ], 0, + function( G, q ) + + local r, # list of degrees, result + N, # elementary abelian normal subgroup of 'G' + p, # prime divisor of the order of 'N' + z, # one generator of 'N' + t, # stabilizer of 'z' in 'G' + i, # index of 't' in 'G' + Gpcgs, # PCGS of 'G' + Npcgs, # PCGS of 'N' + mats, # matrices describing the action of 'Gpcgs' w.r.t. 'Npcgs' + orbs, # orbits of the action + orb, # loop over 'orbs' + rep, # canonical representative of 'orb' + stab, # stabilkizer of 'rep' + h, # nat. hom. by the kernel of a character + c, + ci, + k; + + # If the group is abelian, we must give up because this method + # needs a proper elementary abelian normal subgroup for its + # reduction step. + # (Note that we must not call 'TryNextMethod' because the method + # for abelian groups has higher rank.) + if IsAbelian( G ) then + return CharacterDegrees( G, q ); + elif not ( q = 0 or IsPrimeInt( q ) ) then + Error( " mut be zero or a prime" ); + fi; + + # Choose a normal elementary abelian 'p'-subgroup 'N', + # not necessarily minimal. + N:= ElementaryAbelianSeries( G ); + N:= N[ Length( N ) - 1 ]; + r:= CharacterDegreesOp( G / N, q ); + p:= Factors( Size( N ) )[1]; + + if p = q then + + # If 'N' is a 'q'-group we are done. + return r; + + elif Size( N ) = p then + + # 'N' is of prime order. + z:= Pcgs( N )[1]; + t:= Stabilizer( G, z, OnPoints ); + i:= Size( G ) / Size( t ); + AppendCollectedList( r, List( ProjectiveCharDeg( t, z, q ), + x -> [ x[1]*i, x[2]*(p-1)/i ] ) ); + return r; + + else + + # 'N' is an elementary abelian 'p'-group of nonprime order. + Gpcgs:= Pcgs( G ); + Npcgs:= Pcgs( N ); + mats:= List( Gpcgs, x -> TransposedMat( List( Npcgs, + y -> ExponentsOfPcElement( Npcgs, y^x ) ) * Z(p)^0 )^-1 ); + orbs:= ExternalOrbitsStabilizers( G, + Enumerator( GF( p )^Length( Npcgs ) ), + Gpcgs, mats, OnRight ); + orbs:= Filtered( orbs, + o -> not IsZero( CanonicalRepresentativeOfExternalSet( o ) ) ); + + for orb in orbs do + + stab:= StabilizerOfExternalSet( orb ); + rep:= CanonicalRepresentativeOfExternalSet( orb ); + h:= NaturalHomomorphismByNormalSubgroup( stab, + KernelUnderDualAction( N, Npcgs, rep ) ); + # The kernel has index 'p' in 'stab'. + z:= First( GeneratorsOfGroup( ImagesSet( h, N ) ), + g -> not IsOne( g ) ); + if p = 2 then + c := Range( h ); + ci := 1; + else + c := Stabilizer( Range( h ), z ); + ci := Size( Range( h ) ) / Size( c ); + fi; + k:= Size( G ) / Size( stab ) * ci; + AppendCollectedList( r, List( ProjectiveCharDeg( c, z, q ), + x -> [ x[1]*k, x[2]*(p-1)/ci ] ) ); + + od; + + fi; + + return r; + end ); + + +############################################################################# +## +#F CoveringTriplesCharacters( , ) . . . . . . . . . . . . . . . local +## +## must be a supersolvable group, and a central element in . +## 'CoveringTriplesCharacters' returns a list of tripels $[ T, K, e ]$ +## such that every irreducible character $\chi$ of with the property +## that $\chi()$ is a multiple of 'E( Order() )' is induced from a +## linear character of some $T$, with kernel $K$. +## The element $e \in T$ is chosen such that $\langle e K \rangle = T/K$. +## +## The algorithm is in principle the same as 'ProjectiveCharDeg', +## but the recursion stops if $ = $. +## The structure and the names of the variables are the same. +## +CoveringTriplesCharacters := function( G, z ) + + local oz, + N, + t, + r, + h, + k, + c, + zn, + i, + p, + P, + O, + Gpcgs, + Ppcgs, + Opcgs, + mats, + orbs, + orb; + + # The trivial character will be dealt with separately. + if IsTrivial( G ) then + return []; + fi; + + oz:= Order( z ); + if Size( G ) = oz then + return [ [ G, TrivialSubgroup( G ), z ] ]; + fi; + + h:= NaturalHomomorphismByNormalSubgroup( G, SubgroupNC( G, [ z ] ) ); + N:= ElementaryAbelianSeries( Range( h ) ); + N:= N[ Length( N ) - 1 ]; + if not IsPrime( Size( N ) ) then + N:= ChiefSeriesUnderAction( Range( h ), N ); + N:= N[ Length( N ) - 1 ]; + fi; + N:= PreImagesSet( h, N ); + + if not IsAbelian( N ) then + Print( "#I misuse of 'CoveringTriplesCharacters'!\n" ); + return []; + fi; + + i:= Size( N ) / oz; + p:= Factors( i )[1]; + P:= SylowSubgroup( N, p ); + + if i = Size( P ) then + + # 'z' is a p'-element, 'P' is elementary abelian. + # Find the characters of the factor group needed. + h:= NaturalHomomorphismByNormalSubgroup( G, P ); + r:= List( CoveringTriplesCharacters( Range( h ), ImageElm( h, z ) ), + x -> [ PreImagesSet( h, x[1] ), + PreImagesSet( h, x[2] ), + PreImagesRepresentative( h, x[3] ) ] ); + + if p = i then + + # 'P' has order 'p'. + zn:= First( GeneratorsOfGroup( P ), g -> not IsOne( g ) ); + return Concatenation( r, + CoveringTriplesCharacters( Stabilizer( G, zn ), zn*z ) ); + + else + + Gpcgs:= Pcgs( G ); + Ppcgs:= Pcgs( P ); + mats:= List( List( Gpcgs, Inverse ), + x -> TransposedMat( List( Ppcgs, + y -> ExponentsOfPcElement( Ppcgs, y^x ) )*Z(p)^0 ) ); + orbs:= ExternalOrbitsStabilizers( G, + Enumerator( FullRowModule( GF(p), Length( Ppcgs ) ) ), + Gpcgs, mats, OnRight ); + orbs:= Filtered( orbs, + o -> not IsZero( CanonicalRepresentativeOfExternalSet( o ) ) ); + + for orb in orbs do + h:= NaturalHomomorphismByNormalSubgroup( + StabilizerOfExternalSet( orb ), + KernelUnderDualAction( P, Ppcgs, + CanonicalRepresentativeOfExternalSet( orb ) ) ); + zn:= First( GeneratorsOfGroup( ImagesSet( h, P ) ), + g -> not IsOne( g ) ) + * ImageElm( h, z ); + + if p = 2 then + c:= Range( h ); + else + c:= Stabilizer( Range( h ), zn ); + fi; + Append( r, List( CoveringTriplesCharacters( c, zn ), + x -> [ PreImagesSet( h, x[1] ), + PreImagesSet( h, x[2] ), + PreImagesRepresentative( h, x[3] ) ] ) ); + od; + return r; + + fi; + + elif IsCyclic( P ) then + + zn:= Pcgs( P )[1]; + return CoveringTriplesCharacters( Stabilizer( G, zn ), zn*z ); + + fi; + + O:= Omega( P ); + Opcgs:= Pcgs( O ); + Gpcgs:= Pcgs( G ); + + zn := z^(oz/p); + r := []; + mats:= List( List( Gpcgs, Inverse ), + x -> TransposedMat( List( Opcgs, + y -> ExponentsOfPcElement( Opcgs, y^x ) )*Z(p)^0 ) ); + orbs:= ExternalOrbitsStabilizers( G, + Enumerator( FullRowModule( GF(p), Length( Opcgs ) ) ), + Gpcgs, mats, OnRight ); + orbs:= Filtered( orbs, + o -> not IsZero( CanonicalRepresentativeOfExternalSet( o ) ) ); + + for orb in orbs do + k:= KernelUnderDualAction( O, Opcgs, + CanonicalRepresentativeOfExternalSet( orb ) ); + if not zn in k then + t:= SubgroupNC( G, StabilizerOfExternalSet( orb ) ); + h:= NaturalHomomorphismByNormalSubgroup( t, k ); + Append( r, + List( CoveringTriplesCharacters( Range( h ), ImageElm( h, z ) ), + x -> [ PreImagesSet( h, x[1] ), + PreImagesSet( h, x[2] ), + PreImagesRepresentative( h, x[3] ) ] ) ); + fi; + od; + return r; +end; + + +############################################################################# +## +#F IrrConlon( ) +## +## This algorithm is a generalization of the algorithm to compute the +## absolutely irreducible degrees of a solvable group to the computation +## of the absolutely irreducible characters of a supersolvable group, +## using an idea like in +## +## S. B. Conlon, J. Symbolic Computation (1990) 9, 535-550. +## +## The function 'CoveringTriplesCharacters' is used to compute a list of +## triples describing linear representations of subgroups of . +## These linear representations are induced to and then evaluated on +## representatives of the conjugacy classes. +## +## For every irreducible character the monomiality information is stored as +## value of the attribute 'TestMonomial'. +## +IrrConlon := function( G ) + + local ccl, # conjugacy classes of 'G' + Gpcgs, # PCGS of 'G' + irr, # matrix of character values + irredinfo, # monomiality info + evl, # encode class representatives as words in 'Gpcgs' + i, + t, + chi, + j, + mat, + k, + triple, + hom, + zi, + oz, + ee, + zp, + co, # cosets + coreps, # representatives of 'co' + dim, + rep, # matrix representation + bco, + p, + r, + mulmoma, # local function: multiply monomial matrices + i1, # loop variable in 'mulmoma' + re, # result of 'mulmoma' + ct; # character table of 'G' + + # Compute the product of the monomial matrices 'a' and 'b'; + # The diagonal elements are powers of a fixed 'oz'-th root of unity. + mulmoma:= function( a, b ) + re:= rec( perm:= [], diag:= [] ); + for i1 in [ 1 .. Length( a.perm ) ] do + re.perm[i1]:= b.perm[ a.perm[i1] ]; + re.diag[ b.perm[i1] ]:= ( b.diag[ b.perm[i1] ] + a.diag[i1] ) mod oz; + od; + return re; + end; + + ccl:= ConjugacyClasses( G ); + Gpcgs:= Pcgs( G ); + irr:= []; + irredinfo:= [ rec( inducedFrom:= rec( subgroup:= G, kernel:= G ) ) ]; + + # 'evl' is a list describing representatives of the nontrivial + # conjugacy classes. + # the entry for the element $g.1^2*g.2^0*g.3^1$ is $[ 1, 1, 3 ]$. + evl:= []; + for i in [ 2 .. Length( ccl ) ] do + k:= ExponentsOfPcElement( Gpcgs, Representative( ccl[i] ) ); + t:= []; + for j in [ 1 .. Length( k ) ] do + if 0 < k[j] then + Append( t, [ 1 .. k[j] ]*0 + j ); + fi; + od; + Add( evl, t ); + od; + + for triple in CoveringTriplesCharacters( G, One( G ) ) do + + hom:= NaturalHomomorphismByNormalSubgroup( triple[1], triple[2] ); + zi:= ImagesRepresentative( hom, triple[3] ); + oz:= Order( zi ); + ee:= E( oz ); + zp:= List( [ 1 .. oz ], x -> zi^x ); + co:= RightCosets( G, triple[1] ); + coreps:= List( co, Representative ); + dim:= Length( co ); + + # 'rep' describes a matrix representation on a module with basis + # a transversal of the stabilizer in 'G'. + # (The monomial matrices are the same as in 'RepresentationsPGroup'.) + rep:= []; + for i in Gpcgs do + mat:= rec( perm:= [], diag:= [] ); + for j in [ 1 .. dim ] do + bco:= co[j]*i; + p:= Position( co, bco, 0 ); + Add( mat.perm, p ); + mat.diag[p]:= Position( zp, + ImageElm( hom, coreps[j]*i*Inverse( coreps[p] ) ), 0 ); + od; + Add( rep, mat ); + od; + + # Compute the representing matrices for class representatives, + # and their traces. + chi:= [ dim ]; + for j in evl do + mat:= Iterated( rep{ j }, mulmoma ); + t:= 0; + for k in [ 1 .. dim ] do + if mat.perm[k] = k then + t:= t + ee^mat.diag[k]; + fi; + od; + Add( chi, t ); + od; + + # Test if 'chi' is known and add 'chi' and its Galois-conjugates + # to the list. + # Also compute the monomiality information. + if not chi in irr then + chi:= GaloisMat( [ chi ] ).mat; + Append( irr, chi ); + for j in chi do + Add( irredinfo, rec( subgroup:= triple[1], kernel:= triple[2] ) ); + od; + fi; + + od; + + # Construct the characters from their values lists, + # and set the monomiality info. + ct:= CharacterTable( G ); + irr:= Concatenation( [ TrivialCharacter( G ) ], + List( irr, chi -> CharacterByValues( ct, chi ) ) ); + for i in [ 1 .. Length( irr ) ] do + SetTestMonomial( irr[i], irredinfo[i] ); + od; + + # Return the characters. + return irr; +end; + + +############################################################################# +## +#M Irr( ) . . . . . . . for a supersolvable group (Conlon's algorithm) +## +InstallMethod( Irr, + "method for a supersolvable group (Conlon's algorithm)", + true, + [ IsGroup and IsSupersolvableGroup ], 0, + IrrConlon ); + + +############################################################################# +## +#E ctblsolv.gi . . . . . . . . . . . . . . . . . . . . . . . . . . ends here + + + diff --git a/lib/ctblsymm.gd b/lib/ctblsymm.gd new file mode 100644 index 0000000000..e8fa481c49 --- /dev/null +++ b/lib/ctblsymm.gd @@ -0,0 +1,170 @@ +############################################################################# +## +#W ctblsymm.gd GAP library Goetz Pfeiffer +## +#H @(#)$Id$ +## +#Y Copyright (C) 1997, Lehrstuhl D fuer Mathematik, RWTH Aachen, Germany +## +## This file contains the declaration of functions needed for a direct +## computation of the character values of wreath products of a group $G$ +## with $S_n$, the symmetric group on n points. Special cases are the +## symmetric group $S_n$ itself and the Weyl group of type $B_n$ which is +## a wreath product of a cyclic group $C_2$ of order 2 with the symmetric +## group $S_n$. +## +## Moreover the character values of alternating groups $A_n$ are obtained +## by restriction from $S_n$ and the character values of Weyl groups of +## type $D_n$ are obtained from those of type $B_n$. +## +## The values are computed by a generalized Murnaghan-Nakayama formula. +## +## For a good reference of used formulae see: +## G. James, A.Kerber: The Representation Theory of the Symmetric Group, +## Addison-Wesley, 1981. +## A. Kerber, Representations of Permutation Groups I, Springer 1971. +## A. Kerber, Representations of Permutation Groups II, Springer 1975. +## +## Now the classes (as well as the characters) of $S_n$ are indexed by +## partitions (i.e. the cycle structure of the elements in that class). +## In general the classes (and again the characters) of the wreath +## product $G wr S_n$ are indexed by $r$-tuples of partitions, where $r$ +## is the number of classes of the group $G$ and these partitions +## together form a partition of $n$. That is after distributing $n$ over +## $r$ places each place is partitioned. +## +## There are different ways to represent a partition and we make use of +## two of them. +## +## First there is the partition as a finite nonincreasing sequence of +## numbers which sum up to $n$. This representation serves to compute a +## complete list of partitions of $n$ and is stored in the resulting +## table in the record field . +## +## The most beautiful way to treat Young tableaux and hooks of partitions +## is their representation as beta-numbers. A beta-number is a set, +## which arises from a partition by reversing the order and adding a +## sequence [0,1,2,...] of the same length. Since this reversed +## partition is allowed to have leading zeros, its beta-set is not +## uniquely determined. Each beta-set however determines a unique +## partition. For example a beta-set for the partition [4,2,1] is +## [1,3,6], another one [0,1,3,5,8]. To remove a $k$-hook from the +## corresponding Young tableau the beta-numbers are placed as beads on +## $k$ strings. +## +## xxxx _________ _________ _________ xxxx +## xx 0 1 2 | o | o o | +## x 3 4 5 o | | -> | | | +## 6 | | o | | o | | +## +## To find a removable $k$-hook now simply means to find a free place +## for a bead one step up on its string, the hook is then removed by +## lifting this bead. (You see how this process can produce leading +## zeros.) Beta-numbers are used to parametrize the characters. +## +## The case $2 wr S-n$ uses pairs of these objects while the general +## wreath product uses lists of them. A list of beta-numbers is called a +## symbol. +## +Revision.ctblsymm_gd := + "@(#)$Id$"; + + +############################################################################# +## +#F BetaSet( ) . . . . . . . . . . . . . . . . . . . . . . beta set. +## +BetaSet := NewOperationArgs( "BetaSet" ); + + +############################################################################# +## +#F CentralizerWreath( , ) . . . . centralizer in G wr Sn. +## +CentralizerWreath := NewOperationArgs( "CentralizerWreath" ); + + +############################################################################# +## +#F PowerWreath( , ,

) . . . . . . power map in G wr Sn. +## +PowerWreath := NewOperationArgs( "PowerWreath" ); + + +############################################################################# +## +#F InductionScheme( ) . . . . . . . . . . . . . . . . removal of hooks. +## +InductionScheme := NewOperationArgs( "InductionScheme" ); + + +############################################################################# +## +#F MatCharsWreathSymmetric( , ) . . . character matrix of G wr Sn. +## +MatCharsWreathSymmetric := NewOperationArgs( "MatCharsWreathSymmetric" ); + + +############################################################################# +## +#F CharValueSymmetric( , , ) . . . . . character value in S_n. +## +CharValueSymmetric := NewOperationArgs( "CharValueSymmetric" ); + + +############################################################################# +## +#V CharTableSymmetric . . . . generic character table of symmetric groups. +## +CharTableSymmetric := "2bdefined"; + + +############################################################################# +## +#V CharTableAlternating . . generic character table of alternating groups. +## +CharTableAlternating := "2bdefined"; + + +############################################################################# +## +#F CharValueWeylB( , , ) . . . . . character value in 2 wr Sn. +## +CharValueWeylB := NewOperationArgs( "CharValueWeylB" ); + + +############################################################################# +## +#V CharTableWeylB . . . . generic character table of Weyl groups of type B. +## +CharTableWeylB := "2bdefined"; + + +############################################################################# +## +#V CharTableWeylD . . . . generic character table of Weyl groups of type D. +## +CharTableWeylD := "2bdefined"; + + +############################################################################# +## +#F CharValueWreathSymmetric( , , , ) . . +#F . . . . character value in G wr Sn. +## +CharValueWreathSymmetric := NewOperationArgs( "CharValueWreathSymmetric" ); + + +############################################################################# +## +#F CharTableWreathSymmetric( , ) . . . character table of G wr Sn. +## +CharTableWreathSymmetric := NewOperationArgs( "CharTableWreathSymmetric" ); + + +############################################################################# +## +#E ctblsymm.gd . . . . . . . . . . . . . . . . . . . . . . . . . . ends here + + + diff --git a/lib/files.gd b/lib/files.gd new file mode 100644 index 0000000000..6dc69e0edd --- /dev/null +++ b/lib/files.gd @@ -0,0 +1,125 @@ +############################################################################# +## +#W files.gd GAP Library Frank Celler +## +#H @(#)$Id$ +## +#Y Copyright (C) 1996, Lehrstuhl D fuer Mathematik, RWTH Aachen, Germany +## +## This file contains the operations for files and directories. +## +Revision.files_gd := + "@(#)$Id$"; + + +############################################################################# +## + +#C IsDirectory +## +IsDirectory := NewCategory( + "IsDirectory", + IsObject ); + + +############################################################################# +## + +#V DirectoriesFamily +## +DirectoriesFamily := NewFamily( "DirectoriesFamily" ); + + +############################################################################# +## + +#O Directory( ) +## +Directory := NewOperation( + "Directory", + [ IsString ] ); + + +############################################################################# +## +#O Filename( , ) +## +Filename := NewOperation( + "Filename", + [ IsList, IsString ] ); + + +############################################################################# +## +#O Read( ) +## +Read := NewOperation( + "Read", + [ IsString ] ); + + +############################################################################# +## +#O ReadTest( ) +## +ReadTest := NewOperation( + "ReadTest", + [ IsString ] ); + + +############################################################################# +## + +#F DirectoriesLibrary( ) +## +DIRECTORIES_LIBRARY := rec(); + +DirectoriesLibrary := function( arg ) + local name, dirs, dir, path; + + if 0 = Length(arg) then + name := "lib"; + elif 1 = Length(arg) then + name := arg[1]; + else + Error( "DirectoriesLibrary( [] )" ); + fi; + + if '\\' in name or ':' in name then + Error( " must not contain '\\' or ':'" ); + fi; + if not IsBound(DIRECTORIES_LIBRARY.(name)) then + dirs := []; + for dir in GAP_ROOT_PATHS do + path := Concatenation( dir, name ); + Add( dirs, Directory(path) ); + od; + DIRECTORIES_LIBRARY.(name) := Immutable(dirs); + fi; + + return DIRECTORIES_LIBRARY.(name); +end; + + +############################################################################# +## +#F DirectoriesPackagePrograms( ) +## +DirectoriesPackagePrograms := function( name ) + local arch, dirs, dir, path; + + arch := GAP_ARCHITECTURE; + dirs := []; + for dir in GAP_ROOT_PATHS do + path := Concatenation( dir, "pkg/", name, "/bin/", arch, "/" ); + Add( dirs, Directory(path) ); + od; + return dirs; +end; + + +############################################################################# +## + +#E files.gd . . . . . . . . . . . . . . . . . . . . . . . . . . . ends here +## diff --git a/lib/files.gi b/lib/files.gi index 9fa4b1c5d9..f46c55edc1 100644 --- a/lib/files.gi +++ b/lib/files.gi @@ -1,76 +1,167 @@ -Filename := function( dirs, name ) - - for dir in dirs do - new := Filename( dir, name ); - if IsExistingFile(new) then - return new; - fi; - od; - return fail; +############################################################################# +## +#W files.gi GAP Library Frank Celler +## +#H @(#)$Id$ +## +#Y Copyright (C) 1996, Lehrstuhl D fuer Mathematik, RWTH Aachen, Germany +## +## This file contains the methods for files and directories. +## +Revision.files_gi := + "@(#)$Id$"; + + +############################################################################# +## + +#R IsDirectoryRep +## +IsDirectoryRep := NewRepresentation( + "IsDirectoryRep", + IsPositionalObjectRep, + [] ); + + +############################################################################# +## +#V DirectoryKind +## +DirectoryKind := NewKind( + DirectoriesFamily, + IsDirectory and IsDirectoryRep ); + + +############################################################################# +## + +#M Directory( ) +## +InstallMethod( Directory, + "string", + true, + [ IsString ], + 0, + +function( str ) + if '\\' in str or ':' in str then + Error( " must not contain '\\' or ':'" ); + fi; + if str[Length(str)] = '/' then + str := Immutable(str); + else + str := Immutable( Concatenation( str, "/" ) ); + fi; + return Objectify( DirectoryKind, [str] ); +end ); -end; -Filename := function( dir, name ) - return Concatenation( dir!.dirname, name ); -end; -DIRS_SYSTEM_PROGRAMS := Immutable( List( - DIRECTORIES_SYSTEM_PROGRAMS. - x -> Directory(x) ) ); +############################################################################# +## +#M PrintObj( ) +## +InstallMethod( PrintObj, + "default directory rep", + true, + [ IsDirectoryRep ], + 0, + +function( obj ) + Print( "dir(", obj![1] ,")" ); +end ); -DirectoriesSystemPrograms := function() - return DIRS_SYSTEM_PROGRAMS; -end; +############################################################################# +## +#M Filename( , ) +## +InstallOtherMethod( Filename, + "string", + true, + [ IsDirectory, + IsString ], + 0, -DIR_CURRENT := Directory("./"); +function( dir, name ) + if '/' in name or '\\' in name or ':' in name then + Error( " must not contain '/', '\\' or ':'" ); + fi; + return Immutable( Concatenation( dir![1], name ) ); +end ); -DirectoryCurrent := function() - return DIR_CURRENT; -end; +############################################################################# +## +#M Filename( , ) +## +InstallMethod( Filename, + "string", + true, + [ IsList, + IsString ], + 0, +function( dirs, name ) + local dir, new; -DirectoriesPackagePrograms := function( name ) - arch := GAP_ARCHITECTURE; - dirs := []; - for dir in GAP_ROOT_PATHS do - path := Concatenation( dir, "pkg/", name, "bin/", arch, "/" ); - Add( dirs, Directory(path) ); + for dir in dirs do + new := Filename( dir, name ); + if IsExistingFile(new) then + return new; + fi; od; - return dirs; -end; + return fail; +end ); -DirectoriesLibrary := function( arg ) - local name, dirs, dir, path; - if 0 = Length(arg) then - name := "lib"; - elif 1 = Length(arg) then - name := arg[1]; - else - Error( "DirectoriesLibrary( [] )" ); - fi; +############################################################################# +## +#M Read( ) +## +READ_INDENT := ""; - dirs := []; - for dir in GAP_ROOT_PATHS do - path := Concatenation( dir, name ); - Add( dirs, Directory(path) ); - od; +InstallMethod( Read, + "string", + true, + [ IsString ], + 0, - return dirs; -end; +function ( name ) + local readIndent, found; + readIndent := SHALLOW_COPY_OBJ( READ_INDENT ); + APPEND_LIST_INTR( READ_INDENT, " " ); + InfoRead1( "#I", READ_INDENT, "Read( \"", name, "\" )\n" ); + found := READ(name); + READ_INDENT := readIndent; + if found and READ_INDENT = "" then + InfoRead1( "#I Read( \"", name, "\" ) done\n" ); + fi; + if not found then + Error( "file \"", name, "\" must exist and be readable" ); + fi; +end ); -Directory := function( str ) - return Objectify( IsDirectory and IsDirectoryRep, - rec( dirname := Immutable(str) ) ); -end; +############################################################################# +## +#M ReadTest( ) +## +InstallMethod( ReadTest, + "string", + true, + [ IsString ], + 0, + READ_TEST ); +############################################################################# +## +#E files.gi . . . . . . . . . . . . . . . . . . . . . . . . . . . ends here +## diff --git a/lib/ghom.gd b/lib/ghom.gd index 3aa6d00cdd..745f19c77b 100644 --- a/lib/ghom.gd +++ b/lib/ghom.gd @@ -68,7 +68,12 @@ InstallAttributeMethodByGroupGeneralMappingByImages := "also for `AsGroupGeneralMappingByImages'", true, [ HasAsGroupGeneralMappingByImages, value_filter ], SUM_FLAGS, function( hom, value ) - Setter( attr )( AsGroupGeneralMappingByImages( hom ), value ); + local asggmbi; + + asggmbi := AsGroupGeneralMappingByImages( hom ); + if not HasAsGroupGeneralMappingByImages( asggmbi ) then + Setter( attr )( asggmbi, value ); + fi; TryNextMethod(); end ); end; diff --git a/lib/ghom.gi b/lib/ghom.gi index 4680f91e41..812670a36e 100644 --- a/lib/ghom.gi +++ b/lib/ghom.gi @@ -542,12 +542,18 @@ end; ############################################################################# ## -#F IsomorphismPermGroup( ) +#M IsomorphismPermGroup( ) . . . . . . . . . by right regular operation ## -InstallMethod(IsomorphismPermGroup,"right regular",true,[IsGroup],0, -function(G) - return OperationHomomorphism(G,G,OnRight); -end); +InstallMethod( IsomorphismPermGroup, "right regular operation", true, + [ IsGroup and IsFinite ], 0, + function( G ) + local nice; + + nice := OperationHomomorphism( G, G, OnRight ); + SetRange( nice, Image( nice ) ); + SetIsBijective( nice, true ); + return nice; +end ); ############################################################################# ## diff --git a/lib/ghompcgs.gi b/lib/ghompcgs.gi index e67a76f0a6..dcefe25e7d 100644 --- a/lib/ghompcgs.gi +++ b/lib/ghompcgs.gi @@ -32,8 +32,8 @@ function( G, H, gens, imgs ) GeneralMappingsFamily( ElementsFamily( FamilyObj( G ) ), ElementsFamily( FamilyObj( H ) ) ), filter ), - rec( generators := AsList(pcgs[1]), - genimages := pcgs[2], + rec( generators := gens, + genimages := imgs, sourcePcgs := pcgs[1], sourcePcgsImages := pcgs[2] ) ); @@ -67,8 +67,8 @@ function( G, H, gens, imgs ) GeneralMappingsFamily( ElementsFamily( FamilyObj( G ) ), ElementsFamily( FamilyObj( H ) ) ), filter ), - rec( generators := AsList(pcgs[1]), - genimages := pcgs[2], + rec( generators := gens, + genimages := imgs, sourcePcgs := pcgs[1], sourcePcgsImages := pcgs[2] ) ); @@ -329,15 +329,22 @@ end); InstallMethod( NaturalHomomorphismByNormalSubgroup, IsIdentical, [ IsPcGroup, IsPcGroup ], 0, function( G, N ) - local pcgsK, pcgsF, F, hom; - - if IsInducedPcgs( G ) then - pcgsK := NormalIntersectionPcgs( ParentPcgs( Pcgs( G ) ), - Pcgs( N ), Pcgs( G ) ); - else - pcgsK := Pcgs( N ); + local pcgsG, pcgsN, pcgsK, pcgsF, F, hom; + + pcgsG := Pcgs( G ); pcgsN := Pcgs( N ); + if IsInducedPcgs( pcgsN ) then + if ParentPcgs( pcgsN ) = pcgsG then + pcgsK := pcgsN; + elif IsInducedPcgs( pcgsG ) + and ParentPcgs( pcgsN ) = ParentPcgs( pcgsG ) then + pcgsK := NormalIntersectionPcgs( ParentPcgs( pcgsG ), + pcgsN, pcgsG ); + fi; + fi; + if not IsBound( pcgsK ) then + pcgsK := InducedPcgsByGenerators( pcgsG, GeneratorsOfGroup( N ) ); fi; - pcgsF := Pcgs( G ) mod pcgsK; + pcgsF := pcgsG mod pcgsK; F := GroupByPcgs( pcgsF ); hom := Objectify( NewKind( GeneralMappingsFamily ( ElementsFamily( FamilyObj( G ) ), diff --git a/lib/gprd.gi b/lib/gprd.gi index eb8b971041..1580d4a297 100644 --- a/lib/gprd.gi +++ b/lib/gprd.gi @@ -5,6 +5,9 @@ #H @(#)$Id$ ## #H $Log$ +#H Revision 4.7 1997/04/16 14:04:31 beick +#H Added generic direct products of groups +#H #H Revision 4.6 1997/03/25 10:14:51 ahulpke #H 'DirectProduct' may take a list of groups as agrument #H @@ -42,6 +45,52 @@ local D,grps,i; return D; end; +############################################################################# +## +#M DirectProduct2( , ) +## +InstallMethod( DirectProduct2, true, [IsGroup, IsGroup], 0, +function( G, H ) + local fam, gensG, idG, gensH, idH, gens, D; + gensG := GeneratorsOfGroup( G ); + idG := One( G ); + gensH := GeneratorsOfGroup( H ); + idH := One( H ); + gens := Concatenation( + List( gensG, x -> Tuple( [x,idH] ) ), + List( gensH, x -> Tuple( [idG,x] ) ) ); + D := Group( gens ); + if HasSize( G ) and HasSize( H ) then + SetSize( D, Size(G)*Size(H) ); + fi; + if HasIsSolvableGroup( G ) and HasIsSolvableGroup( H ) then + SetIsSolvableGroup( D, IsSolvableGroup( G ) and IsSolvableGroup( H ) ); + fi; + SetDirectProductInfo( D, rec( groups := [G, H] ) ); + return D; +end ); + +############################################################################# +## +#M \in( , ) +## +InstallMethod( \in, true, [IsTuple, IsGroup and HasDirectProductInfo], 0, +function( g, G ) + local n, info; + n := Length( g ); + info := DirectProductInfo( G ); + return ForAll( [1..n], x -> g[x] in info.groups[x] ); +end ); + +############################################################################# +## +#M Size( ) +## +InstallMethod( Size, true, [IsGroup and HasDirectProductInfo], 0, +function( D ) + return Product( List( DirectProductInfo( D ).groups, x -> Size(x) ) ); +end ); + ############################################################################# ## diff --git a/lib/gprdperm.gi b/lib/gprdperm.gi index e1ed832ef7..c58154f49d 100644 --- a/lib/gprdperm.gi +++ b/lib/gprdperm.gi @@ -71,7 +71,8 @@ InstallMethod( DirectProduct2, local info; info := DirectProductInfo( D ); return DirectProductPermGroupConstructor( info.groups, [ H ], - info.olds, info.news, info.perms, GeneratorsOfGroup( D ) ); + info.olds, info.news, info.perms, + ShallowCopy( GeneratorsOfGroup( D ) ) ); end ); ############################################################################# diff --git a/lib/grp.gd b/lib/grp.gd index 263dedb80a..b27eeb7f8c 100644 --- a/lib/grp.gd +++ b/lib/grp.gd @@ -1,10 +1,13 @@ ############################################################################# ## -#W grp.gd GAP library ............. +#W grp.gd GAP library Thomas Breuer +#W Frank Celler +#W Bettina Eick +#W Heiko Theissen ## #H @(#)$Id$ ## -#Y Copyright (C) 1996, Lehrstuhl D fuer Mathematik, RWTH Aachen, Germany +#Y Copyright (C) 1997, Lehrstuhl D fuer Mathematik, RWTH Aachen, Germany ## ## This file contains the declarations of operations for groups. ## @@ -213,6 +216,17 @@ SetChiefSeries := Setter( ChiefSeries ); HasChiefSeries := Tester( ChiefSeries ); +############################################################################# +## +#O ChiefSeriesUnderAction( , ) +## +## is a chief series of the group w.r.t. to the action of the supergroup +## . +## +ChiefSeriesUnderAction := NewOperation( "ChiefSeriesUnderAction", + [ IsGroup, IsGroup ] ); + + ############################################################################# ## #A CommutatorFactorGroup( ) @@ -457,6 +471,8 @@ HasNrConjugacyClasses := Tester( NrConjugacyClasses ); ## #A Omega( ) ## +## is the largest elementary abelian normal subgroup in the $p$-group . +## Omega := NewAttribute( "Omega", IsGroup ); SetOmega := Setter( Omega ); HasOmega := Tester( Omega ); @@ -616,6 +632,10 @@ HasUpperCentralSeriesOfGroup := Tester( UpperCentralSeriesOfGroup ); ## #O Agemo( ,

) ## +## is the subgroup of the $p$-group that is generated by the $p$-th +## powers of the generators of . +#T why not an attribute?? +## Agemo := NewOperation( "Agemo", [ IsGroup, IsPosRat and IsInt ] ); diff --git a/lib/grp.gi b/lib/grp.gi index dac164e350..59435248d4 100644 --- a/lib/grp.gi +++ b/lib/grp.gi @@ -1,10 +1,13 @@ ############################################################################# ## -#W grp.gi GAP library ............. +#W grp.gi GAP library Thomas Breuer +#W Frank Celler +#W Bettina Eick +#W Heiko Theissen ## #H @(#)$Id$ ## -#Y Copyright (C) 1996, Lehrstuhl D fuer Mathematik, RWTH Aachen, Germany +#Y Copyright (C) 1997, Lehrstuhl D fuer Mathematik, RWTH Aachen, Germany ## ## This file contains generic methods for groups. ## @@ -337,8 +340,13 @@ InstallMethod( AsGroup, ############################################################################# ## -#M ChiefSeries( ) +#M ChiefSeries( ) . . . . . . . . delegate to 'ChiefSeriesUnderAction' ## +InstallMethod( ChiefSeries, + "method for a group (delegate to 'ChiefSeriesUnderAction'", + true, + [ IsGroup ], 0, + G -> ChiefSeriesUnderAction( G, G ) ); ############################################################################# @@ -686,8 +694,103 @@ InstallMethod( NrConjugacyClasses, ############################################################################# ## -#M Omega( ) +#M Omega( ) . . . . . . . . . . . . . . . . . for an abelian $p$-group +## +#T the code should be cleaned, +#T especially one should avoid the many unnecessary calls of 'Difference' ## +InstallMethod( Omega, + "method for a p-group (abelian)", + true, + [ IsGroup ], 0, + function( G ) + + local facts, # prime factors of the size of 'G' + p, # unique prime divisor of the size of 'G' + pcgs, # PCGS of 'G' + i, j, rel, rl, rc, ng, ml, mc, m, k, q, + one; # identity of 'G' + + if not IsAbelian( G ) then + TryNextMethod(); + fi; +#T should be changed as soon as a generic method for p-groups is available. + + # Check that 'G' is a 'p'-group. + facts:= Set( Factors( Size( G ) ) ); + if 1 < Length( facts ) then + Error( " must be a p-group" ); + fi; + + p:= facts[1]; + pcgs:= Pcgs( G ); + ng:= ShallowCopy( pcgs ); + + # 'rel' is the relation matrix of 'G'. + rel:= List( ng, x -> ShallowCopy( AdditiveInverse( + ExponentsOfPcElement( pcgs, x^p ) ) ) ); + for i in [ 1 .. Length( rel ) ] do + rel[i][i]:= rel[i][i] + p; + od; + # rel:= List( ng, x -> List( ng, function(y) if x=y then return p; + # else return 0; fi; end)-ExponentsOfPcElement( ng, x^p ) ); + + # rl, rc are the remaining lines and columns of rel to be used + rl:= [ 1 .. Length( ng ) ]; + rc:= [ 1 .. Length( ng ) ]; + while 1 < Length( rl ) do + + # find empty column, find min entry + m:= AbsInt( Maximum( rel[ rl[1] ] ) ) + 1; + for i in rl do + for j in rc do + if rel[i][j] <> 0 and AbsInt( rel[i][j] ) < m then + # 'rel[ml][mc]' is minimal entry of 'rel' + ml:= i; + mc:= j; + m:= AbsInt( rel[i][j] ); + fi; + od; + od; + while Maximum(List(Difference(rl,[ml]),x->AbsInt(rel[x][mc])))>0 do + for i in Difference(rl,[ml]) do + AddRowVector( rel[i], rel[ml], -QuoInt(rel[i][mc],rel[ml][mc]) ); + # rel[i]:=rel[i]-QuoInt(rel[i][mc],rel[ml][mc])*rel[ml]; + od; + # find min entry + m:=AbsInt(Maximum(rel[rl[1]]))+1; + for i in rl do + for j in rc do + if rel[i][j] <> 0 and AbsInt(rel[i][j]) < m then + # rel[ml][mc] is minimal entry of rel + ml:=i; mc:=j; m:=AbsInt(rel[i][j]); + fi; + od; + od; + od; + for i in Difference(rc,[mc]) do + q:= QuoInt(rel[ml][i],rel[ml][mc]); + rel[ml][i]:= rel[ml][i] - q*rel[ml][mc]; + ng[mc]:=ng[mc]*ng[i]^q; + od; + if Maximum(List(Difference(rc,[mc]),x->AbsInt(rel[ml][x])))=0 then + RemoveSet( rl, ml ); + RemoveSet( rc, mc ); + fi; + od; + + # Construct the generators. + m:= []; + one:= One( G ); + for i in ng do + if i <> one then + Add( m, i^(Order(i)/p) ); + fi; + od; + + return SubgroupNC( G, m ); + end ); + ############################################################################# ## @@ -988,6 +1091,7 @@ InstallMethod( Agemo, fi; end ); + ############################################################################# ## #M AgemoAbove( , ,

) . . . . . . . . . . . . . . . . . . . . local @@ -1290,10 +1394,25 @@ InstallMethod( Core, return C; end ); + ############################################################################# ## #M FactorGroup( , ) +#M \/( , ) ## +InstallMethod( FactorGroup, + "generic method for two groups", + IsIdentical, + [ IsGroup, IsGroup ], 0, + function( G, N ) + return ImagesSource( NaturalHomomorphismByNormalSubgroup( G, N ) ); + end ); + +InstallOtherMethod( \/, + "generic method for two groups", + IsIdentical, + [ IsGroup, IsGroup ], 0, + FactorGroup ); ############################################################################# @@ -1717,9 +1836,10 @@ HallSubgroup := function( G, pi ) return known[Product(pi)]; end; + ############################################################################# ## -#M SylowSubgroupOp( ,

) . . . . . . . . .operation for Sylow subgroup +#M SylowSubgroupOp( ,

) . . . . . . . . . . . for a group and a prime ## InstallMethod( SylowSubgroupOp, "generic method for group and prime", @@ -1751,6 +1871,33 @@ InstallMethod( SylowSubgroupOp, return S; end ); + +############################################################################# +## +#M SylowSubgroupOp( ,

) +## +HELP_PRINT_SECTION := function( book, chapter, section ) + local info, chap, filename, stream, done, line, lines; + + # get the chapter info + info := HELP_BOOK_INFO(book); + chap := HELP_CHAPTER_INFO( book, chapter ); + if chap = fail then + return; + fi; + + # store lines + lines := []; + + # open the stream and read in the help + filename := Filename( info.directories, info.filenames[chapter] ); + stream := InputTextFile(filename); + done := false; + if section = 0 then + SeekPositionStream( stream, chap[1] ); + Add( lines, FILLED_LINE( info.chapters[chapter], + info.bookname, '_' ) ); + else + SeekPositionStream( stream, chap[2][section] ); + Add( lines, FILLED_LINE( info.sections[chapter][section], + info.chapters[chapter], '_' ) ); + fi; + ReadLine(stream); + repeat + line := ReadLine(stream); + if line <> fail then + if MATCH_BEGIN( line, HELP_SECTION_BEGIN ) then + done := true; + else + line := line{[1..Length(line)-1]}; + + # blanks lines are ok + if 0 = Length(line) then + Add( lines, line ); + + # ignore lines starting with '%' + elif line[1] = '%' then + ; + + # ignore the index command + elif MATCH_BEGIN(line,"\\index") then + ; + + # example environment + elif MATCH_BEGIN(line,"\\beginexample") then + Add( lines, "" ); + elif MATCH_BEGIN(line,"\\endexample") then + Add( lines, "" ); + + # use everything else + else + Add( lines, line ); + fi; + fi; + else + done := true; + fi; + until done; + CloseStream(stream); + Add( lines, "" ); + HELP_PRINT_LINES(lines); + +end; + + +############################################################################# +## + +#F HELP_BOOKS( ) +## +HELP_BOOKS := function( book ) + local books, i; + + books := []; + for i in [ 1, 4 .. Length(HELP_MAIN_BOOKS)-2 ] do + Add( books, FILLED_LINE( + HELP_MAIN_BOOKS[i+2], + HELP_MAIN_BOOKS[i], + '.' ) ); + od; + Sort(books); + HELP_PRINT_LINES( Concatenation( + [ FILLED_LINE( "Table of Books", "GAP 4", '_' ) ], + books, + [ "" ] + ) ); + return true; + +end; + + +############################################################################# +## +#F HELP_CHAPTERS( ) +## +HELP_CHAPTERS := function( book ) + local info, chap, i; + + # one book + if 0 < Length(book) then + + # read in the information file "manual.six" of this book + info := HELP_BOOK_INFO(book); + if info = fail then + Print( "unknown book \"", book, "\"\n" ); + return false; + fi; + + # print the chapters + chap := ShallowCopy(info.chapters); + Sort(chap); + HELP_PRINT_LINES( Concatenation( + [ FILLED_LINE( "Table of Chapters", info.bookname, '_' ) ], + chap, + [ "" ] + ) ); + + # all books + else + for i in [ 1, 4 .. Length(HELP_MAIN_BOOKS)-2 ] do + HELP_CHAPTERS( HELP_MAIN_BOOKS[i] ); + od; + fi; + + return true; + +end; + + +############################################################################# +## +#F HELP_SECTIONS( ) +## +HELP_SECTIONS := function( book ) + local info, lines, chap, sec, i; + + # one book + if 0 < Length(book) then + + # read in the information file "manual.six" of this book + info := HELP_BOOK_INFO(book); + if info = fail then + Print( "unknown book \"", book, "\"\n" ); + return false; + fi; + + # print the sections + lines := [ FILLED_LINE( "Table of Sections", info.bookname, '_' ) ]; + for chap in [ 1 .. Length(info.chapters) ] do + Add( lines, info.chapters[chap] ); + for sec in [ 1 .. Length(info.sections[chap]) ] do + Add(lines,Concatenation(" ",info.sections[chap][sec])); + od; + od; + Add( lines, "" ); + HELP_PRINT_LINES(lines); + + # all books + else + for i in [ 1, 4 .. Length(HELP_MAIN_BOOKS)-2 ] do + HELP_SECTIONS( HELP_MAIN_BOOKS[i] ); + od; + fi; + + return true; + +end; + + +############################################################################# +## +#F HELP_WELCOME_TO_GAP( ) +## +HELP_WELCOME_TO_GAP := function( book ) + local lines; + + lines := [ + "Welcome to GAP\n" + ]; + HELP_PRINT_LINES(lines); +end; + + +############################################################################# +## +#F HELP( ) +## +HELP_RING_IDX := 0; +HELP_BOOK_RING := List( [1..16], x -> "tutorial" ); +HELP_TOPIC_RING := List( [1..16], x -> "Welcome to GAP" ); + +HELP := function( str ) + local p, book, move; + + # extract the book + p := Position( str, ':' ); + if p <> fail then + book := str{[1..p-1]}; + str := str{[p+1..Length(str)]}; + else + book := ""; + fi; + move := false; + + # if the topic is empty take the last one again + if str = "" then + book := HELP_BOOK_RING[HELP_RING_IDX+1]; + str := HELP_TOPIC_RING[HELP_RING_IDX+1]; + move := true; + + # if the topic is '-' we are interested in the previous section again + elif str = "-" then + HELP_RING_IDX := (HELP_RING_IDX-1) mod 16; + book := HELP_BOOK_RING[HELP_RING_IDX+1]; + str := HELP_TOPIC_RING[HELP_RING_IDX+1]; + move := true; + + # if the topic is '+' we are interested in the last section again + elif str = "+" then + HELP_RING_IDX := (HELP_RING_IDX+1) mod 16; + book := HELP_BOOK_RING[HELP_RING_IDX+1]; + str := HELP_TOPIC_RING[HELP_RING_IDX+1]; + move := true; + fi; + + # if the topic is '<' we are interested in the one before 'LastTopic' + if str = '<' then + ; + + # if the topic is '>' we are interested in the one after 'LastTopic' + elif str = '>' then + ; + + # if the topic is '<<' we are interested in the first section + elif str = "<<" then + ; + + # if the topic is '>>' we are interested in the next chapter + elif str = ">>" then + ; + + # if the subject is 'Welcome to GAP' display a welcome message + elif str = "Welcome to GAP" then + if HELP_WELCOME_TO_GAP(book) and not move then + HELP_RING_IDX := (HELP_RING_IDX+1) mod 16; + HELP_BOOK_RING[HELP_RING_IDX+1] := book; + HELP_TOPIC_RING[HELP_RING_IDX+1] := "Welcome to GAP"; + fi; + + # if the topic is 'books' display the table of books + elif MATCH_BEGIN_LOWER( "books", str ) then + if HELP_BOOKS(book) and not move then + HELP_RING_IDX := (HELP_RING_IDX+1) mod 16; + HELP_BOOK_RING[HELP_RING_IDX+1] := book; + HELP_TOPIC_RING[HELP_RING_IDX+1] := "books"; + fi; + + # if the topic is 'chapter' display the table of chapters + elif MATCH_BEGIN_LOWER( "chapters", str ) then + if HELP_CHAPTERS(book) and not move then + HELP_RING_IDX := (HELP_RING_IDX+1) mod 16; + HELP_BOOK_RING[HELP_RING_IDX+1] := book; + HELP_TOPIC_RING[HELP_RING_IDX+1] := "chapters"; + fi; + + # if the topic is 'sections' display the table of sections + elif MATCH_BEGIN_LOWER( "sections", str ) then + if HELP_SECTIONS(book) and not move then + HELP_RING_IDX := (HELP_RING_IDX+1) mod 16; + HELP_BOOK_RING[HELP_RING_IDX+1] := book; + HELP_TOPIC_RING[HELP_RING_IDX+1] := "sections"; + fi; + + # if the topic is 'Copyright' print the copyright + elif MATCH_BEGIN_LOWER( "copyright", str ) then + HELP_COPYRIGHT(); + + # if the topic is '?' search the index + elif str[1] = '?' then + HELP_INDEX( str{[2..Length(str)]} ); + + # search for this topic + else + HELP_TOPIC(str); + fi; +end; + + +############################################################################# +## + +#E help.g . . . . . . . . . . . . . . . . . . . . . . . . . . . . ends here +## diff --git a/lib/init.g b/lib/init.g index 31f0293d96..9947b3bbca 100644 --- a/lib/init.g +++ b/lib/init.g @@ -69,32 +69,12 @@ end; ############################################################################# ## - -#F Read( ) . . . . . . . . . . . . . . . . read in file named +#F InfoRead? . . . . . . . . . . . . . . . . . . . . print what file is read ## -READ_INDENT := ""; - if DEBUG_LOADING then InfoRead1 := Print; fi; if not IsBound(InfoRead1) then InfoRead1 := Ignore; fi; if not IsBound(InfoRead2) then InfoRead2 := Ignore; fi; -Read := function ( name ) - local readIndent, found; - - readIndent := SHALLOW_COPY_OBJ( READ_INDENT ); - APPEND_LIST_INTR( READ_INDENT, " " ); - InfoRead1( "#I", READ_INDENT, "Read( \"", name, "\" )\n" ); - found := READ(name); - READ_INDENT := readIndent; - if found and READ_INDENT = "" then - InfoRead1( "#I Read( \"", name, "\" ) done\n" ); - fi; - if not found then - Error( "file \"", name, "\" must exist and be readable" ); - fi; - #return found; -end; - ############################################################################# ## diff --git a/lib/lattice.gd b/lib/lattice.gd new file mode 100644 index 0000000000..f87d8ee0b1 --- /dev/null +++ b/lib/lattice.gd @@ -0,0 +1,268 @@ +############################################################################# +## +#W lattice.gd GAP library Thomas Breuer +## +#A @(#)$Id$ +## +#Y Copyright (C) 1997, Lehrstuhl D fuer Mathematik, RWTH Aachen, Germany +## +## This file contains the declaration of functions and operations dealing +## with lattices. +## +Revision.lattice_gd := + "@(#)$Id$"; + + +############################################################################# +## +#V InfoLattice +## +InfoLattice := NewInfoClass( "InfoLattice" ); + + +############################################################################# +## +#O ScalarProduct( , ) +#O ScalarProduct( , , ) +## +ScalarProduct := NewOperation( "ScalarProduct", + [ IsVector, IsVector ] ); + + +############################################################################# +## +#O InverseMatMod( , ) +## +## For a square integral matrix and a prime (both is *not* +## checked!), 'InverseMatMod' returns an integral matrix with +## ' \* ' congruent to the identity matrix modulo , +## if such a matrix exists, and 'fail' otherwise. +## +InverseMatMod := NewOperation( "InverseMatMod", [ IsMatrix, IsInt ] ); + + +############################################################################# +## +#F PadicCoefficients( , , , , ) +## +PadicCoefficients := NewOperationArgs( "PadicCoefficients" ); + + +############################################################################# +## +#F LinearIndependentColumns( ) +## +## is a maximal list of positions of linear independent columns in the +## matrix . +## +LinearIndependentColumns := NewOperationArgs( "LinearIndependentColumns" ); + + +############################################################################# +## +#F DecompositionInt( , , ) . . . . . . . . integral solutions +## +## returns the decomposition matrix with ' \* = ', for and +## integral matrices. +## +## For an odd prime $p$, each integer $x$ has a unique representation +## $x = \sum_{i=0}^{n} x_i p^i$ where $|x_i| \leq \frac{p-1}{2}$ . +## Let $x$ be a solution of the equation $xA = b$ where $A$ is a square +## integral matrix and $b$ an integral vector, $\overline{A} = A \bmod p$ +## and $\overline{b} = b \bmod p$; +## then $\overline{x} \overline{A} \equiv \overline{b} \bmod p$ for +## $\overline{x} = x \bmod p$. +## Assume $\overline{A}$ is regular over the field with $p$ elements; then +## $\overline{x}$ is uniquely determined mod $p$. +## Define $x^{\prime} = \frac{x - \overline{x}}{p}$ and +## $b^{\prime} = \frac{b - \overline{x} A }{p}$. +## If $y$ is a solution of the equation $x^{\prime} A = b^{\prime}$ we +## have $( \overline{x} + p y ) A = b$ and thus $x = \overline{x} + p y$ +## is the solution of our problem. +## Note that the process must terminate if an integral solution $x$ exists, +## since the $p$--adic series for $y$ has one term less than that for $x$. +## +## If $A$ is not square, it must have full rank, +## and $'Length( )' \leq 'Length( [1] )'$. +## +DecompositionInt := NewOperationArgs( "DecompositionInt" ); + + +############################################################################# +## +#F IntegralizedMat( ) +#F IntegralizedMat( , ) +## +IntegralizedMat := NewOperationArgs( "IntegralizedMat" ); + + +############################################################################# +## +#F Decomposition( , , ) . . . . . . . . . . integral solutions +#F Decomposition( , , \"nonnegative\" ) . . . . . . integral solutions +## +## For a matrix of cyclotomics and a list of cyclotomic vectors, +## 'Decomposition' tries to find integral solutions of the linear equation +## systems ' \* = [i]'. +## +## must have full rank, i.e., there must be a linear independent set of +## columns of same length as . +## +## 'Decomposition( , , )', where is a nonnegative +## integer, computes for every '[i]' the initial part +## $\Sum_{k=0}^{} x_k p^k$ (all $x_k$ integer vectors with entries +## bounded by $\pm\frac{p-1}{2}$) of the $p$-adic series of a hypothetical +## solution. The prime $p$ is 83 first; if the reduction of +## modulo $p$ is singular, the next prime is chosen automatically. +## +## A list is returned. If the computed initial part for +## ' \* = [i]' *is* a solution, we have '[i] = ', otherwise +## '[i] = false'. +## +## 'Decomposition( , , \"nonnegative\" )' assumes that the solutions +## have only nonnegative entries. +## This is e.g.\ satisfied for the decomposition of ordinary characters into +## Brauer characters. +## If the first column of consists of positive integers, +## the necessary number of iterations can be computed. In that case +## the 'i'-th entry of the returned list is 'false' if there *exists* no +## nonnegative integral solution of the system ' \* = [i]', and it +## is the solution otherwise. +## +## *Note* that the result is a list of 'false' if has not full rank, +## even if there might be a unique integral solution for some equation +## system. +## +Decomposition := NewOperationArgs( "Decomposition" ); + + +############################################################################# +## \Section{LLLReducedBasis}% +## \index{LLL algorithm!for vectors}% +## \index{short vectors spanning a lattice}% +## \index{lattice base reduction} +## +#F LLLReducedBasis( ) +#F LLLReducedBasis( , ) +#F LLLReducedBasis( , \"linearcomb\" ) +#F LLLReducedBasis( , , \"linearcomb\" ) +#F LLLReducedBasis( , ) +#F LLLReducedBasis( , , ) +#F LLLReducedBasis( , , \"linearcomb\" ) +#F LLLReducedBasis( , , , \"linearcomb\" ) +## +## 'LLLReducedBasis' provides an implementation of the LLL algorithm by +## Lenstra, Lenstra and Lov{\accent19 a}sz (see~\cite{LLL82}, \cite{Poh87}). +## The implementation follows the description on pages 94f. in~\cite{Coh93}. +## +## 'LLLReducedBasis' returns a record whose component 'basis' is a list of +## LLL reduced linearly independent vectors spanning the same lattice as +## the list . +## must be a lattice, with scalar product of the vectors and +## given by 'ScalarProduct( , , )'. +## If no lattice is specified then the scalar product of vectors given by +## 'ScalarProduct( , )' is used. +## +## In the case of the option '\"linearcomb\"', the result record contains +## also the components 'relations' and 'transformation', with the following +## meaning. +## 'relations' is a basis of the relation space of , i.e., of +## vectors such that ' \* ' is zero. +## 'transformation' gives the expression of the new lattice basis in +## terms of the old, i.e., +## 'transformation \* ' equals the 'basis' component of the result. +## +## Another optional argument is , the ``sensitivity\'\' of the algorithm, +## a rational number between $\frac{1}{4}$ and 1 (the default value is +## $\frac{3}{4}$). +## +## (The function "LLLReducedGramMat" computes an LLL reduced Gram matrix.) +## +LLLReducedBasis := NewOperationArgs( "LLLReducedBasis" ); + + +############################################################################# +## \Section{LLLReducedGramMat}% +## \index{LLL algorithm!for Gram matrices}% +## \index{lattice base reduction} +## +#F LLLReducedGramMat( ) . . . . . . . . . . . . LLL reduced Gram matrix +#F LLLReducedGramMat( , ) +## +## 'LLLReducedGramMat' provides an implementation of the LLL algorithm by +## Lenstra, Lenstra and Lov{\accent19 a}sz (see~\cite{LLL82}, \cite{Poh87}). +## The implementation follows the description on pages 94f. in~\cite{Coh93}. +## +## Let the Gram matrix of the vectors $(b_1, b_2, \ldots, b_n)$; +## this means is either a square symmetric matrix or lower triangular +## matrix (only the entries in the lower triangular half are used by the +## program). +## +## 'LLLReducedGramMat' returns a record whose component 'remainder' is the +## Gram matrix of the LLL reduced basis corresponding to $(b_1, b_2, \ldots, +## b_n)$. +## If was a lower triangular matrix then also the 'remainder' component +## is a lower triangular matrix. +## +## The result record contains also the components 'relations' and +## 'transformation', which have the following meaning. +## +## 'relations' is a basis of the space of vectors $(x_1,x_2,\ldots,x_n)$ +## such that $\sum_{i=1}^n x_i b_i$ is zero, +## and 'transformation' gives the expression of the new lattice basis in +## terms of the old, i.e., 'transformation' is the matrix $T$ such that +## $T \cdot \cdot T^{tr}$ is the 'remainder' component of the result. +## +## The optional argument denotes the ``sensitivity'' of the algorithm, +## it must be a rational number between $\frac{1}{4}$ and 1; the default +## value is $ = \frac{3}{4}$. +## +## (The function "LLLReducedBasis" computes an LLL reduced basis.) +## +## | gap> g:= [ [ 4, 6, 5, 2, 2 ], [ 6, 13, 7, 4, 4 ], +## > [ 5, 7, 11, 2, 0 ], [ 2, 4, 2, 8, 4 ], [ 2, 4, 0, 4, 8 ] ];; +## gap> LLLReducedGramMat( g ); +## rec( +## remainder := +## [ [ 4, 2, 1, 2, 2 ], [ 2, 5, 0, 2, 2 ], [ 1, 0, 5, 0, -2 ], +## [ 2, 2, 0, 8, 4 ], [ 2, 2, -2, 4, 8 ] ], +## transformation := +## [ [ 1, 0, 0, 0, 0 ], [ -1, 1, 0, 0, 0 ], [ -1, 0, 1, 0, 0 ], +## [ 0, 0, 0, 1, 0 ], [ 0, 0, 0, 0, 1 ] ], +## scalarproducts := +## [ [ 1, 0, 0, 0, 0 ], [ 1/2, 1, 0, 0, 0 ], [ 1/4, -1/8, 1, 0, 0 ], +## [ 1/2, 1/4, -2/25, 1, 0 ], [ 1/2, 1/4, -38/75, 8/21, 1 ] ], +## bsnorms := [ 4, 4, 75/16, 168/25, 32/7 ] )| +## +LLLReducedGramMat := NewOperationArgs( "LLLReducedGramMat" ); + + +############################################################################# +## +#F ShortestVectors( , [, \"positive\" ] ) +## +## ... +## +ShortestVectors := NewOperationArgs( "ShortestVectors" ); + + +############################################################################# +## +#F OrthogonalEmbeddings( [, \"positive\" ] [, ] ) +## +OrthogonalEmbeddings := NewOperationArgs( "OrthogonalEmbeddings" ); + + +############################################################################# +## +#F LLLint() . . . . . . . . . . . . . . . . . . . .. . integer only LLL +## +LLLint := NewOperationArgs( "LLLint" ); + + +############################################################################# +## +#E lattice.gd . . . . . . . . . . . . . . . . . . . . . . . . . . ends here + + + diff --git a/lib/lattice.gi b/lib/lattice.gi new file mode 100644 index 0000000000..bb899b6ddc --- /dev/null +++ b/lib/lattice.gi @@ -0,0 +1,2039 @@ +############################################################################# +## +#W lattice.gi GAP library Thomas Breuer +## +#H @(#)$Id$ +## +#Y Copyright (C) 1997, Lehrstuhl D fuer Mathematik, RWTH Aachen, Germany +## +## This file contains methods for lattices. +## +## +Revision.lattice_gi := + "@(#)$Id$"; + + +############################################################################# +## +#M ScalarProduct( , ) . . . . . . . . . . . . . . for two row vectors +## +InstallMethod( ScalarProduct, + "method for two row vectors", + IsIdentical, + [ IsRowVector, IsRowVector ], 0, + function( v, w ) + return v * w; + end ); + + +############################################################################# +## +#F StandardScalarProduct( , , ) +## +StandardScalarProduct:= function( L, x, y ) return x * y; end; + + +############################################################################# +## +#M InverseMatMod( , ) +## +## For a square integral matrix and a prime (both is *not* +## checked!), 'InverseMatMod' returns an integral matrix with +## ' \* ' congruent to the identity matrix modulo , +## if such a matrix exists, and 'false' otherwise. +## +InstallMethod( InverseMatMod, + "method for a matrix, and an integer", + true, + [ IsMatrix, IsPosRat and IsInt ], 0, + function( intmat, p ) + + local i, j, k, # loop variables + n, # dimension + intmatq, intmatqinv, # matrix & inverse modulo p + x, # solution of one iteration + zline, # help-line for exchange + nullv, # zero-vector + mult, # multiplication table of the field + inverse, # list of inverses of field elements + val; + + n:= Length( intmat ); + + # inverses modulo 'p'; we have 'inverse[x] * x = 1' + inverse:= [ 1 ]; + for i in [ 2 .. p-1 ] do + inverse[i]:= Inverse( i ) mod p; +#T better? + od; + + # multiplication table; we have 'mult[i][j]' congruent 'i\*j' mod 'p' + mult:= []; + for i in [ 1 .. p-1 ] do + mult[i]:= []; + for j in [ 1 .. p-1 ] do + mult[i][j]:= ( i*j ) mod p; + od; + od; + + # 'intmatq'\: 'intmat' reduced mod 'p' + intmatq := []; + for i in [ 1 .. n ] do + intmatq[i] := []; + for j in [ 1 .. n ] do + intmatq[i][j]:= intmat[i][j] mod p; + od; + od; + intmatqinv := IdentityMat( n ); + + for i in [ 1 .. n ] do + j := i; + while j <= n and intmatq[j][i] = 0 do + j := j + 1; + od; + if j > n then + + # matrix is singular modulo that 'p' + return fail; + else + + # exchange lines 'i' and 'j' + if j <> i then + zline := intmatq[j]; + intmatq[j] := intmatq[i]; + intmatq[i] := zline; + zline := intmatqinv[j]; + intmatqinv[j] := intmatqinv[i]; + intmatqinv[i] := zline; + fi; + + # normalize line 'i' + zline:= intmatq[i]; + if zline[i] <> 1 then + x:= mult[ inverse[ zline[i] ] ]; + zline[i]:= 1; + for k in [ i+1 .. n ] do + if zline[k] <> 0 then + zline[k]:= x[ zline[k] ]; + fi; + od; + zline:= intmatqinv[i]; + for k in [1 .. n] do + if zline[k] <> 0 then + zline[k]:= x[ zline[k] ]; + fi; + od; + fi; + + # elimination in column 'i' + for j in [ 1 .. n ] do + if j <> i and intmatq[j][i] <> 0 then + x:= mult[ intmatq[j][i] ]; + for k in [ 1 .. n ] do + if intmatqinv[i][k] <> 0 then + intmatqinv[j][k]:= + (intmatqinv[j][k] - x[ intmatqinv[i][k] ] ) mod p; + fi; + if intmatq[i][k] <> 0 then + intmatq[j][k]:= + (intmatq[j][k] - x[ intmatq[i][k] ] ) mod p; + fi; + od; + fi; + od; + + fi; + + od; + + return intmatqinv; + end ); + + +############################################################################# +## +#F PadicCoefficients( , , , , ) +## +PadicCoefficients := function( A, Amodpinv, b, prime, depth ) + + local i, n, coeff, step, p2, val; + + n:= Length( b ); + coeff:= []; + step:= 0; + p2:= ( prime - 1 ) / 2; + while PositionNot( b, 0 ) <= n and step < depth do + step:= step + 1; + coeff[ step ]:= ShallowCopy( b * Amodpinv ); + for i in [ 1 .. n ] do + val:= coeff[ step ][i] mod prime; + if val > p2 then + coeff[ step ][i]:= val - prime; + else + coeff[ step ][i]:= val; + fi; + od; + b:= ( b - coeff[ step ] * A ) / prime; + od; + Add( coeff, b ); + return coeff; +end; + + +############################################################################# +## +#F LinearIndependentColumns( ) +## +LinearIndependentColumns := function( mat ) + + local m, n, # dimensions of 'mat' + maxrank, # maximal possible rank of 'mat' + i, j, k, q, + row, + zero, + val, + choice; # list of linear independent columns, result + + # Make a copy to avoid changing the original argument. + m := Length( mat ); + n := Length( mat[1] ); + maxrank:= m; + if n < m then + maxrank:= n; + fi; + zero := Zero( mat[1][1] ); + mat := List( mat, ShallowCopy ); + choice:= []; + + # run through all columns of the matrix + i:= 0; + for k in [1..n] do + + # find a nonzero entry in this column + j := i + 1; + while j <= m and mat[j][k] = zero do j := j+1; od; + + # if there is a nonzero entry + if j <= m then + + i:= i+1; + + # Choose this column. + Add( choice, k ); + if Length( choice ) = maxrank then + return choice; + fi; + + # Swap rows 'j' and 'i'. + row:= mat[j]; + mat[j]:= mat[i]; + mat[i]:= row; + + # Normalize column 'k'. + MultRowVector( mat[q], [ j .. m ], mat[q], [ j .. m ], + Inverse( row[k] ) ); + # val:= row[k]; + # for q in [ j .. m ] do + # mat[q][k] := mat[q][k] / val; + # od; + row[k]:= 1; + + # Clear all entries in row 'i'. + for j in [ k+1 .. n ] do + if mat[i][j] <> zero then + val:= mat[i][j]; + for q in [ i .. m ] do + mat[q][j] := mat[q][j] - val * mat[q][k]; + od; + fi; + od; + + fi; + + od; + + # Return the list of positions of linear independent columns. + return choice; +end; + + +############################################################################# +## +#F DecompositionInt( , , ) . . . . . . . . integral solutions +## +## returns the decomposition matrix with ' \* = ' for and +## integral matrices. +## +## For an odd prime $p$, each integer $x$ has a unique representation +## $x = \sum_{i=0}^{n} x_i p^i$ where $|x_i| \leq \frac{p-1}{2}$ . +## Let $x$ be a solution of the equation $xA = b$ where $A$ is a square +## integral matrix and $b$ an integral vector, $\overline{A} = A \bmod p$ +## and $\overline{b} = b \bmod p$; +## then $\overline{x} \overline{A} \equiv \overline{b} \bmod p$ for +## $\overline{x} = x \bmod p$. +## Assume $\overline{A}$ is regular over the field with $p$ elements; then +## $\overline{x}$ is uniquely determined mod $p$. +## Define $x^{\prime} = \frac{x - \overline{x}}{p}$ and +## $b^{\prime} = \frac{b - \overline{x} A }{p}$. +## If $y$ is a solution of the equation $x^{\prime} A = b^{\prime}$ we +## have $( \overline{x} + p y ) A = b$ and thus $x = \overline{x} + p y$ +## is the solution of our problem. +## Note that the process must terminate if an integral solution $x$ exists, +## since the $p$--adic series for $y$ has one term less than that for $x$. +## +## If $A$ is not square, it must have full rank, +## and $'Length( )' \leq 'Length( [1] )'$. +## +DecompositionInt := function( A, B, depth ) + + local i, j, # loop variables + Aqinv, # inverse of matrix modulo p + b, # vector + sol, # solution of one step + result, # whole solution + p, # prime + ph, # half of ( prime minus one ) + nullv, # zero-vector + origA, # store full argument 'A' in case of column choice + n, # dimension + choice, + coeff, + val; + + # check input parameters + if Length( A ) > Length( A[1] ) then + Error( " must have at least 'Length()' columns" ); + elif not IsMatrix( A ) and ForAll( A, x -> ForAll( x, IsInt ) ) then + Error( " must be integer matrix" ); + elif not ForAll( B, x -> x = fail or ( ForAll( x, IsInt ) + and Length( x ) = Length( A[1] ) ) ) then + Error( " must be list of integer vectors", + " of same dimension as in " ); + elif not IsInt( depth ) and depth >= 0 then + Error( " (of iterations) must be a nonnegative integer" ); + fi; + + # initialisations + n := Length( A ); + depth := depth + 1; + result := []; + p := 83; + ph := ( p -1 ) / 2; + nullv := List( [ 1 .. n ], x -> 0 ); + + # if 'A' is not square choose 'n' linear independent columns + origA:= A; + if Length( A[1] ) > n then + + choice:= LinearIndependentColumns( A ); + if Length( choice ) < Length( A ) then + Error( " has not full rank" ); + fi; + A:= List( A, x -> x{ choice } ); + + else + choice:= [ 1 .. n ]; + fi; + + # compute the inverse 'Aqinv' of 'A' modulo 'p'; + Aqinv:= InverseMatMod( A, p ); + while Aqinv = fail do + + # matrix is singular modulo that 'p', choose another one + p := NextPrimeInt( p ); + Print( "#I DecompositionInt: choosing new prime : ", p, "\n" ); +#T better Info + Aqinv:= InverseMatMod( A, p ); + od; + + # compute the p-adic coefficients of the solutions, + # and form the solutions + for b in B do + + if b = fail then + Add( result, fail ); + else + b:= b{ choice }; + coeff:= PadicCoefficients( A, Aqinv, b, p, depth ); + if coeff[ Length( coeff ) ] = nullv then + sol := nullv; + for i in Reversed( [ 1 .. Length( coeff ) - 1 ] ) do + sol := sol * p + coeff[i]; + od; + Add( result, ShallowCopy( sol ) ); + else + Add( result, fail ); + fi; + fi; + + od; + + # if the argument 'A' is not square test if the solutions are correct + if Length( origA[1] ) > n then + for i in [ 1 .. Length( result ) ] do + if result[i] <> fail and result[i] * origA <> B[i] then + result[i]:= fail; + fi; + od; + fi; + + return result; +end; + + +############################################################################# +## +#F IntegralizedMat( ) +#F IntegralizedMat( , ) +## +IntegralizedMat := function( arg ) + + local i, A, inforec, tr, f, + stab, # Galois stabilizer of 'f' + galaut, repr, aut, conj, pos, row, intA, + col, introw, nofcyc, + coeffs; # coefficients of one column basis + + if Length( arg ) = 0 or Length( arg ) > 2 or not IsMatrix( arg[1] ) + or ( Length( arg ) = 2 and not IsRecord( arg[2] ) ) then + Error( "usage: IntegralizedMat( ) resp. \n", + " IntegralizedMat( , )" ); + fi; + + A:= arg[1]; + if Length( arg ) = 2 then + + # just use 'inforec' to transform 'A' + inforec:= arg[2]; + + else + + # compute transformed matrix 'intA' and info record 'inforec' + inforec:= rec( intcols := [], + irratcols:= [], + fields := [] ); + tr:= TransposedMat( A ); + + for i in [ 1 .. Length( tr ) ] do + + if IsBound( tr[i] ) then + + if ForAll( tr[i], IsInt ) then + Add( inforec.intcols, i ); + else + + # compute the field and the coefficients of values; + # if 'tr' contains conjugates of the row, delete them + f:= FieldByGenerators( tr[i] ); + stab:= GaloisStabilizer( f ); + nofcyc:= NofCyc( GeneratorsOfField( f ) ); + galaut:= PrimeResidues( nofcyc ); + SubtractSet( galaut, stab ); + repr:= []; + while galaut <> [] do + Add( repr, galaut[1] ); + SubtractSet( galaut, + List( stab * galaut[1], x -> x mod nofcyc) ); + od; + for aut in repr do + conj:= List( tr[i], x-> GaloisCyc( x, aut ) ); + pos:= Position( tr, conj, 0 ); + if pos <> fail then + Unbind( tr[ pos ] ); + fi; + od; + inforec.fields[i]:= f; + Add( inforec.irratcols, i ); + + fi; + fi; + od; + fi; + + intA:= []; + for row in A do + introw:= []; + coeffs:= row{ inforec.intcols }; + for col in inforec.irratcols do + if coeffs <> fail then + Append( introw, coeffs ); + coeffs:= Coefficients( CanonicalBasis( inforec.fields[ col ] ), + row[ col ] ); + fi; + od; + if coeffs = fail then + introw:= fail; + else + Append( introw, coeffs ); + fi; + Add( intA, introw ); + od; + + return rec( mat:= intA, inforec:= inforec ); +end; + + +############################################################################# +## +#F Decomposition( , , ) . . . . . . . . . . integral solutions +#F Decomposition( , , \"nonnegative\" ) . . . . . . integral solutions +## +## For a matrix of cyclotomics and a list of cyclotomic vectors, +## 'Decomposition' tries to find integral solutions of the linear equation +## systems ' \* = [i]'. +## +## must have full rank, i.e., there must be a linear independent set of +## columns of same length as . +## +## 'Decomposition( , , )', where is a nonnegative +## integer, computes for every '[i]' the initial part +## $\Sum_{k=0}^{} x_k p^k$ (all $x_k$ integer vectors with entries +## bounded by $\pm\frac{p-1}{2}$) of the $p$-adic series of a hypothetical +## solution. The prime $p$ is 83 first; if the reduction of +## modulo $p$ is singular, the next prime is chosen automatically. +## +## A list is returned. If the computed initial part for +## ' \* = [i]' *is* a solution, we have '[i] = ', otherwise +## '[i] = false'. +## +## 'Decomposition( , , \"nonnegative\" )' assumes that the solutions +## have only nonnegative entries. +## This is e.g.\ satisfied for the decomposition of ordinary characters into +## Brauer characters. +## If the first column of consists of positive integers, +## the necessary number of iterations can be computed. In that case +## the 'i'-th entry of the returned list is 'false' if there *exists* no +## nonnegative integral solution of the system ' \* = [i]', and it +## is the solution otherwise. +## +## *Note* that the result is a list of 'false' if has not full rank, +## even if there might be a unique integral solution for some equation +## system. +## +Decomposition := function( A, B, depth_or_nonnegative ) + + local i, j, intA, row, intB, newintA, newintB, result, choice, inforec; + + # Check the input parameters. + if not ( IsInt( depth_or_nonnegative ) and depth_or_nonnegative >= 0 ) + and depth_or_nonnegative <> "nonnegative" then + Error( "usage: Decomposition( ,, ) for integer \n", + " resp. Decomposition( ,,\"nonnegative\" )\n", + " ( solution of * = )" ); + elif not ( IsMatrix(A) and IsMatrix(B) + and Length(B[1]) = Length(A[1]) ) then + Error( ", must be matrices with same number of columns" ); + fi; + + # Transform 'A' to an integer matrix 'intA'. + intA:= IntegralizedMat( A ); + inforec:= intA.inforec; + intA:= intA.mat; + + # Transform 'B' to 'intB', choose coefficients compatible. + intB:= IntegralizedMat( B, inforec ).mat; + + # If 'intA' is not square then choose linear independent columns. + if Length( intA ) < Length( intA[1] ) then + choice:= LinearIndependentColumns( intA ); + newintA:= List( intA, x -> x{ choice } ); + newintB:= []; + for i in [ 1 .. Length( intB ) ] do + if intB[i] = fail then + newintB[i]:= fail; + else + newintB[i]:= intB[i]{ choice }; + fi; + od; + elif Length( intA ) = Length( intA[1] ) then + newintA:= intA; + newintB:= intB; + else + Error( "There must be a subset of columns forming a regular matrix" ); + fi; + + # depth of iteration + if depth_or_nonnegative = "nonnegative" then + if not ForAll( newintA, x -> IsInt( x[1] ) and x[1] >= 0 ) then + Error( "option \"nonnegative\" is allowed only if the first column\n", + " of consists of positive integers" ); + fi; + + # The smallest value that has length 'c' in the p-adic series is + # p^c + \Sum_{k=0}^{c-1} -\frac{p-1}{2} p^k = \frac{1}{2}(p^c + 1). + # So if $'[i][1] / Minimum( newintA[1] )' \< \frac{1}{2}(p^c + 1)$ + # we have 'depth' at most 'c-1'. + + result:= DecompositionInt( newintA, newintB, + LogInt( 2*Int( Maximum( List( B, x->x[1] ) ) + / Minimum( List( A, x -> x[1]) ) ), 83 ) + 2 ); + for i in [ 1 .. Length( result ) ] do + if IsList( result[i] ) and Minimum( result[i] ) < 0 then + result[i]:= fail; + fi; + od; + else + result:= DecompositionInt( newintA , newintB, depth_or_nonnegative ); + fi; + + # if 'intA' is not square test if the result is correct + if Length( intA ) < Length( intA[1] ) then + for i in [ 1 .. Length( result ) ] do + if result[i] <> fail and result[i] * A <> B[i] then + result[i]:= fail; + fi; + od; + fi; + + return result; +end; + + +############################################################################# +## +#F LLLReducedBasis( ) +#F LLLReducedBasis( , ) +#F LLLReducedBasis( , \"linearcomb\" ) +#F LLLReducedBasis( , , \"linearcomb\" ) +#F LLLReducedBasis( , ) +#F LLLReducedBasis( , , ) +#F LLLReducedBasis( , , \"linearcomb\" ) +#F LLLReducedBasis( , , , \"linearcomb\" ) +## +LLLReducedBasis := function( arg ) + + local mmue, # buffer $\mue$ + L, # the lattice + y, # sensitivity $y$ (default $y = \frac{3}{4}$) + kmax, # $k_{max}$ + b, # list $b$ of vectors + H, # basechange matrix $H$ + mue, # matrix $\mue$ of scalar products + B, # list $B$ of norms of $b^{\ast}$ + BB, # buffer $B$ + q, # buffer $q$ for function 'RED' + i, # loop variable $i$ + j, # loop variable $j$ + k, # loop variable $k$ + l, # loop variable $l$ + n, # number of vectors in $b$ + lc, # boolean: option 'linearcomb'? + scpr, # scalar product of lattice 'L' + RED, # reduction subprocedure; 'RED( l )' + # means 'RED( k, l )' in Cohen's book + r; # number of zero vectors found up to now + + RED := function( l ) + + # Terminate for $\|\mue_{k,l}\| \leq \frac{1}{2}$. + if 1 < mue[k][l] * 2 or mue[k][l] * 2 < -1 then + + # Let $q = 'Round( mue[k][l] )'$ (is never zero), \ldots +#T Round ? + q:= Int( mue[k][l] ); + if AbsInt( mue[k][l] - q ) * 2 > 1 then + q:= q + SignInt( mue[k][l] ); + fi; + + # \ldots and subtract $q b_l$ from $b_k$; + AddRowVector( b[k], b[l], - q ); + + # adjust 'mue', \ldots + mue[k][l]:= mue[k][l] - q; + for i in [ r+1 .. l-1 ] do + if mue[l][i] <> 0 then + mue[k][i]:= mue[k][i] - q * mue[l][i]; + fi; + od; + + # \ldots and the basechange. + if lc then + AddRowVector( H[k], H[l], - q ); + fi; + + fi; + end; + + + # Check the input parameters. + if IsLeftModule( arg[1] ) then + L:= arg[1]; + scpr:= ScalarProduct; + arg:= arg{ [ 2 .. Length( arg ) ] }; + elif IsList( arg[1] ) then + # There is no lattice given, take standard scalar product. + L:= "L"; + scpr:= StandardScalarProduct; + else + Error( "usage: LLLReducedBasis( [], [,]", + "[,\"linearcomb\"] )" ); + fi; + + b:= List( arg[1], ShallowCopy ); + + # Preset the ``sensitivity'' (value between $\frac{1}{4}$ and 1). + if IsBound( arg[2] ) and IsRat( arg[2] ) then + y:= arg[2]; + if y <= 1/4 or y >= 1 then + Error( "sensitivity 'y' must satisfy 1/4 < y < 1" ); + fi; + else + y:= 3/4; + fi; + + # Get the other optional paramater. + lc:= false; + for i in [ 2 .. Length( arg ) ] do + if arg[i] = "linearcomb" then lc:= true; fi; + od; + + + # step 1 (Initialize \ldots + n := Length( b ); + k := 2; + kmax := 1; + mue := []; + r := 0; + if lc then + H:= IdentityMat( n ); + fi; + + Info( InfoLattice, 1, + "LLLReducedBasis called with ", n, " vectors, y = ", y ); + + # \ldots and handle the case of leading zero vectors in the input.) + i:= 1; + while i <= n and ForAll( b[i], IsZero ) do +#T better? + i:= i+1; + od; + if n < i then + + r:= n; + k:= n+1; + + elif 1 < i then + + q := b[i]; + b[i] := b[1]; + b[1] := q; + if lc then + q := H[i]; + H[i] := H[1]; + H[1] := q; + fi; + + fi; + + B := [ scpr( L, b[1], b[1] ) ]; + + while k <= n do + + # step 2 (Incremental Gram-Schmidt) + + # If $k \leq k_{max}$ go to step 3. + # Otherwise \ldots + if k > kmax then + + Info( InfoLattice, 2, + "LLLReducedBasis: Take ", Ordinal( k ), " vector" ); + + # \ldots set $k_{max} \leftarrow k$ + # and for $j = 1, \ldots, k-1$ set + # $\mue_{k,j} \leftarrow b_k \cdot b_j^{\ast} / B_j$ if + # $B_j \not= 0$ and $\mue_{k,j} \leftarrow 0$ if $B_j = 0$, \ldots + kmax:= k; + mue[k]:= []; + for j in [ r+1 .. k-1 ] do + mmue:= scpr( L, b[k], b[j] ); + for i in [ r+1 .. j-1 ] do + mmue:= mmue - mue[j][i] * mue[k][i]; + od; + mue[k][j]:= mmue; + od; + + # (Now 'mue[k][j]' contains $\mue_{k,j} B_j$ for all $j$.) + for j in [ r+1 .. k-1 ] do + mue[k][j]:= mue[k][j] / B[j]; + od; + + # \ldots then set $b_k^{\ast} \leftarrow + # b_k - \sum_{j=1}^{k-1} \mue_{k,j} b_j^{\ast}$ and + # $B_k \leftarrow b_k^{\ast} \cdot b_k^{\ast}$. + B[k]:= scpr( L, b[k], b[k] ); + for j in [ r+1 .. k-1 ] do + B[k]:= B[k] - mue[k][j]^2 * B[j]; + od; + + fi; + + # step 3 (Test LLL condition) + RED( k-1 ); + while B[k] < ( y - mue[k][k-1] * mue[k][k-1] ) * B[k-1] do + + # Execute Sub-algorithm SWAPG$( k )$\: + # Exchange the vectors $b_k$ and $b_{k-1}$, + q := b[k]; + b[k] := b[k-1]; + b[k-1] := q; + + # $H_k$ and $H_{k-1}$, + if lc then + q := H[k]; + H[k] := H[k-1]; + H[k-1] := q; + fi; + + # and if $k > 2$, for all $j$ such that $1 \leq j \leq k-2$ + # exchange $\mue_{k,j}$ with $\mue_{k-1,j}$. + for j in [ r+1 .. k-2 ] do + q := mue[k][j]; + mue[k][j] := mue[k-1][j]; + mue[k-1][j] := q; + od; + + # Then set $\mue \leftarrow \mue_{k,k-1}$ + mmue:= mue[k][k-1]; + + # and $B \leftarrow B_k + \mue^2 B_{k-1}$. + BB:= B[k] + mmue^2 * B[k-1]; + + # Now, in the case $B = 0$ (i.e. $B_k = \mue = 0$), + if BB = 0 then + + # exchange $B_k$ and $B_{k-1}$ + B[k] := B[k-1]; + B[k-1] := 0; + + # and for $i = k+1, k+2, \ldots, k_{max}$ + # exchange $\mue_{i,k}$ and $\mue_{i,k-1}$. + for i in [ k+1 .. kmax ] do + q := mue[i][k]; + mue[i][k] := mue[i][k-1]; + mue[i][k-1] := q; + od; + + # In the case $B_k = 0$ and $\mue \not= 0$, + elif B[k] = 0 and mmue <> 0 then + + # set $B_{k-1} \leftarrow B$, + B[k-1]:= BB; + + # $\mue_{k,k-1} \leftarrow \frac{1}{\mue} + mue[k][k-1]:= 1 / mmue; + + # and for $i = k+1, k+2, \ldots, k_{max}$ + # set $\mue_{i,k-1} \leftarrow \mue_{i,k-1} / \mue$. + for i in [ k+1 .. kmax ] do + mue[i][k-1]:= mue[i][k-1] / mmue; + od; + + else + + # Finally, in the case $B_k \not= 0$, + # set (in this order) $t \leftarrow B_{k-1} / B$, + q:= B[k-1] / BB; + + # $\mue_{k,k-1} \leftarrow \mue t$, + mue[k][k-1]:= mmue * q; + + # $B_k \leftarrow B_k t$, + B[k]:= B[k] * q; + + # $B_{k-1} \leftarrow B$, + B[k-1]:= BB; + + # then for $i = k+1, k+2, \ldots, k_{max}$ set + # (in this order) $t \leftarrow \mue_{i,k}$, + # $\mue_{i,k} \leftarrow \mue_{i,k-1} - \mue t$, + # $\mue_{i,k-1} \leftarrow t + \mue_{k,k-1} \mue_{i,k}$. + for i in [ k+1 .. kmax ] do + q := mue[i][k]; + mue[i][k] := mue[i][k-1] - mmue * q; + mue[i][k-1] := q + mue[k][k-1] * mue[i][k]; + od; + + fi; + + # Terminate the subalgorithm. + + if k > 2 then k:= k-1; fi; + + # Here we have always 'k > r' since the loop is entered + # for 'k > r+1' only (because of 'B[k-1] \<> 0'), + # so the only problem might be the case 'k = r+1', + # namely 'mue[ r+1 ][r]' is used then; but this is bound + # provided that the initial list of vectors did not start + # with zero vectors, and its (perhaps not updated) value + # does not matter because this would mean just to subtract + # a multiple of a zero vector. + + RED( k-1 ); + + od; + + if B[ r+1 ] = 0 then + r:= r+1; + Unbind( b[r] ); + fi; + + for l in [ k-2, k-3 .. r+1 ] do + RED( l ); + od; + k:= k+1; + + # step 4 (Finished?) + # If $k \leq n$ go to step 2. + + od; + + # Otherwise, let $r$ be the number of initial vectors $b_i$ + # which are equal to zero, output $p \leftarrow n - r$, + # the vectors $b_i$ for $r+1 \leq i \leq n$ (which form an LLL-reduced + # basis of $L$), the transformation matrix $H \in GL_n(\Z)$ + # and terminate the algorithm. + + # Check whether the last calls of 'RED' have produced new zero vectors + # in 'b'; unfortunately this cannot be read off from 'B'. + while r < n and ForAll( b[ r+1 ], x -> x = 0 ) do + r:= r+1; + od; + + Info( InfoLattice, 1, + "LLLReducedBasis returns basis of length ", n-r ); + + if lc then + return rec( basis := b{ [ r+1 .. n ] }, + relations := H{ [ 1 .. r ] }, + transformation := H{ [ r+1 .. n ] } ); + else + return rec( basis := b{ [ r+1 .. n ] } ); + fi; + +end; + + +############################################################################# +## +#F LLLReducedGramMat( ) . . . . . . . . . . . . LLL reduced Gram matrix +#F LLLReducedGramMat( , ) +## +LLLReducedGramMat := function( arg ) + + local gram, # the Gram matrix + mmue, # buffer $\mue$ + y, # sensitivity $y$ (default $y = \frac{3}{4}$) + kmax, # $k_{max}$ + H, # basechange matrix $H$ + mue, # matrix $\mue$ of scalar products + B, # list $B$ of norms of $b^{\ast}$ + BB, # buffer $B$ + q, # buffer $q$ for function 'RED' + i, # loop variable $i$ + j, # loop variable $j$ + k, # loop variable $k$ + l, # loop variable $l$ + n, # length of 'gram' + RED, # reduction subprocedure; 'RED( l )' + # means 'RED( k, l )' in Cohen's book + ak, # buffer vector in Gram-Schmidt procedure + r; # number of zero vectors found up to now + + RED := function( l ) + + # Terminate for $\|\mue_{k,l}\| \leq \frac{1}{2}$. + if 1 < mue[k][l] * 2 or mue[k][l] * 2 < -1 then + + # Let $q = 'Round( mue[k][l] )'$ (is never zero), \ldots + q:= Int( mue[k][l] ); + if AbsInt( mue[k][l] - q ) * 2 > 1 then + q:= q + SignInt( mue[k][l] ); + fi; + + # \ldots adjust the Gram matrix (rows and columns, but only + # in the lower triangular half), \ldots + gram[k][k]:= gram[k][k] - q * gram[k][l]; + for i in [ r+1 .. l ] do + gram[k][i]:= gram[k][i] - q * gram[l][i]; + od; + for i in [ l+1 .. k ] do + gram[k][i]:= gram[k][i] - q * gram[i][l]; + od; + for i in [ k+1 .. n ] do + gram[i][k]:= gram[i][k] - q * gram[i][l]; +#T AddRowVector + od; + + # \ldots adjust 'mue', \ldots + mue[k][l]:= mue[k][l] - q; + for i in [ r+1 .. l-1 ] do + if mue[l][i] <> 0 then + mue[k][i]:= mue[k][i] - q * mue[l][i]; + fi; + od; + + # \ldots and the basechange. + H[k]:= H[k] - q * H[l]; + + fi; + end; + + + # Check the input parameters. + if arg[1] = [] or ( IsList( arg[1] ) and IsList( arg[1][1] ) ) then + + gram:= List( arg[1], ShallowCopy ); + + # Preset the ``sensitivity'' (value between $\frac{1}{4}$ and 1). + if IsBound( arg[2] ) and IsRat( arg[2] ) then + y:= arg[2]; + if y <= 1/4 or y >= 1 then + Error( "sensitivity 'y' must satisfy 1/4 < y < 1" ); + fi; + else + y:= 3/4; + fi; + + else + Error( "usage: LLLReducedGramMat( [,] )" ); + fi; + + # step 1 (Initialize \ldots + n := Length( gram ); + k := 2; + kmax := 1; + mue := []; + r := 0; + ak := []; + H := IdentityMat( n ); + + Info( InfoLattice, 1, + "LLLReducedGramMat called with matrix of length ", n, + ", y = ", y ); + + # \ldots and handle the case of leading zero vectors in the input.) + i:= 1; + while i <= n and gram[i][i] = 0 do + i:= i+1; + od; + if i > n then + + r:= n; + k:= n+1; + + elif i > 1 then + + for j in [ i+1 .. n ] do + gram[j][1]:= gram[j][i]; + gram[j][i]:= 0; + od; + gram[1][1]:= gram[i][i]; + gram[i][i]:= 0; + + q := H[i]; + H[i] := H[1]; + H[1] := q; + + fi; + + B:= [ gram[1][1] ]; + + while k <= n do + + # step 2 (Incremental Gram-Schmidt) + + # If $k \leq k_{max}$ go to step 3. + if k > kmax then + + Info( InfoLattice, 2, + "LLLReducedGramMat: Take ", Ordinal( k ), " vector" ); + + # Otherwise \ldots + kmax:= k; + B[k]:= gram[k][k]; + mue[k]:= []; + for j in [ r+1 .. k-1 ] do + ak[j]:= gram[k][j]; + for i in [ r+1 .. j-1 ] do + ak[j]:= ak[j] - mue[j][i] * ak[i]; + od; + mue[k][j]:= ak[j] / B[j]; + B[k]:= B[k] - mue[k][j] * ak[j]; + od; + + fi; + + # step 3 (Test LLL condition) + RED( k-1 ); + while B[k] < ( y - mue[k][k-1] * mue[k][k-1] ) * B[k-1] do + + # Execute Sub-algorithm SWAPG$( k )$\: + # Exchange $H_k$ and $H_{k-1}$, + q := H[k]; + H[k] := H[k-1]; + H[k-1] := q; + + # adjust the Gram matrix (rows and columns, + # but only in the lower triangular half), + for j in [ r+1 .. k-2 ] do + q := gram[k][j]; + gram[k][j] := gram[k-1][j]; + gram[k-1][j] := q; + od; + for j in [ k+1 .. n ] do + q := gram[j][k]; + gram[j][k] := gram[j][k-1]; + gram[j][k-1] := q; + od; + q := gram[k-1][k-1]; + gram[k-1][k-1] := gram[k][k]; + gram[k][k] := q; + + # and if $k > 2$, for all $j$ such that $1 \leq j \leq k-2$ + # exchange $\mue_{k,j}$ with $\mue_{k-1,j}$. + for j in [ r+1 .. k-2 ] do + q := mue[k][j]; + mue[k][j] := mue[k-1][j]; + mue[k-1][j] := q; + od; + + # Then set $\mue \leftarrow \mue_{k,k-1}$ + mmue:= mue[k][k-1]; + + # and $B \leftarrow B_k + \mue^2 B_{k-1}$. + BB:= B[k] + mmue^2 * B[k-1]; + + # Now, in the case $B = 0$ (i.e. $B_k = \mue = 0$), + if BB = 0 then + + # exchange $B_k$ and $B_{k-1}$ + B[k] := B[k-1]; + B[k-1] := 0; + + # and for $i = k+1, k+2, \ldots, k_{max}$ + # exchange $\mue_{i,k}$ and $\mue_{i,k-1}$. + for i in [ k+1 .. kmax ] do + q := mue[i][k]; + mue[i][k] := mue[i][k-1]; + mue[i][k-1] := q; + od; + + # In the case $B_k = 0$ and $\mue \not= 0$, + elif B[k] = 0 and mmue <> 0 then + + # set $B_{k-1} \leftarrow B$, + B[k-1]:= BB; + + # $\mue_{k,k-1} \leftarrow \frac{1}{\mue} + mue[k][k-1]:= 1 / mmue; + + # and for $i = k+1, k+2, \ldots, k_{max}$ + # set $\mue_{i,k-1} \leftarrow \mue_{i,k-1} / \mue$. + for i in [ k+1 .. kmax ] do + mue[i][k-1]:= mue[i][k-1] / mmue; + od; + + else + + # Finally, in the case $B_k \not= 0$, + # set (in this order) $t \leftarrow B_{k-1} / B$, + q:= B[k-1] / BB; + + # $\mue_{k,k-1} \leftarrow \mue t$, + mue[k][k-1]:= mmue * q; + + # $B_k \leftarrow B_k t$, + B[k]:= B[k] * q; + + # $B_{k-1} \leftarrow B$, + B[k-1]:= BB; + + # then for $i = k+1, k+2, \ldots, k_{max}$ set + # (in this order) $t \leftarrow \mue_{i,k}$, + # $\mue_{i,k} \leftarrow \mue_{i,k-1} - \mue t$, + # $\mue_{i,k-1} \leftarrow t + \mue_{k,k-1} \mue_{i,k}$. + for i in [ k+1 .. kmax ] do + q:= mue[i][k]; + mue[i][k]:= mue[i][k-1] - mmue * q; + mue[i][k-1]:= q + mue[k][k-1] * mue[i][k]; + od; + + fi; + + # Terminate the subalgorithm. + + if k > 2 then k:= k-1; fi; + + # Here we have always 'k > r' since the loop is entered + # for 'k > r+1' only (because of 'B[k-1] \<> 0'), + # so the only problem might be the case 'k = r+1', + # namely 'mue[ r+1 ][r]' is used then; but this is bound + # provided that the initial Gram matrix did not start + # with zero columns, and its (perhaps not updated) value + # does not matter because this would mean just to subtract + # a multiple of a zero vector. + + RED( k-1 ); + + od; + + if B[ r+1 ] = 0 then + r:= r+1; + fi; + + for l in [ k-2, k-3 .. r+1 ] do + RED( l ); + od; + k:= k+1; + + # step 4 (Finished?) + # If $k \leq n$ go to step 2. + + od; + + # Otherwise, let $r$ be the number of initial vectors $b_i$ + # which are equal to zero, + # take the nonzero rows and columns of the Gram matrix + # the transformation matrix $H \in GL_n(\Z)$ + # and terminate the algorithm. + + if IsBound( arg[1][1][n] ) then + + # adjust also upper half of the Gram matrix + gram:= gram{ [ r+1 .. n ] }{ [ r+1 .. n ] }; + for i in [ 2 .. n-r ] do + for j in [ 1 .. i-1 ] do + gram[j][i]:= gram[i][j]; + od; + od; + + else + + # get the triangular matrix + gram:= gram{ [ r+1 .. n ] }; + for i in [ 1 .. n-r ] do + gram[i]:= gram[i]{ [ r+1 .. r+i ] }; + od; + + fi; + + Info( InfoLattice, 1, + "LLLReducedGramMat returns matrix of length ", n-r ); + + return rec( remainder := gram, + relation := H{ [ 1 .. r ] }, + transformation := H{ [ r+1 .. n ] }, + scalarproducts := mue, + bsnorms := B{ [ r+1 .. n ] } ); + + # The components 'scalarproducts' and 'bsnorms' are used by + # 'ShortestVectors'. + +end; + + +############################################################################# +## +#F ShortestVectors( , [, \"positive\" ] ) +## +ShortestVectors := function( arg ) + + local + # variables + n, i, checkpositiv, a, llg, nullv, m, c, q, anz, con, b, v, + # procedures + kur, srt, vschr; + + # sub-procedures + kur := function( ) + local l; + for l in [1..n] do + v[l] := 0; + od; + anz := 0; + con := true; + srt( n, 0 ); + end; + + # search for shortest vectors + srt := function( d, dam ) + local i, j, x, k, k1, q; + if d = 0 then + if v = nullv then + con := false; + else + anz := anz + 1; + vschr( dam ); + fi; + else + x := 0; + for j in [d+1..n] do + x := x + v[j] * llg.scalarproducts[j][d]; + od; + i := - Int( x ); + if AbsInt( -x-i ) * 2 - 1 > 0 then + i := i - SignInt( x ); + fi; + k := i + x; + q := ( m + 1/1000 - dam ) / llg.bsnorms[d]; + if k * k - q < 0 then + repeat + i := i + 1; + k := k + 1; + until k * k - q > 0 and k > 0; + i := i - 1; + k := k - 1; + while k * k - q < 0 and con do + v[d] := i; + k1 := llg.bsnorms[d] * k * k + dam; + srt( d-1, k1 ); + i := i - 1; + k := k - 1; + od; + fi; + fi; + end; + + # output of vector + vschr := function( dam ) + local i, j, w, neg; + c.vectors[anz] := []; + neg := false; + for i in [1..n] do + w := 0; + for j in [1..n] do + w := w + v[j] * llg.transformation[j][i]; + od; + if w < 0 then + neg := true; + fi; + c.vectors[anz][i] := w; + od; + if checkpositiv and neg then + c.vectors[anz] := []; + anz := anz - 1; + else + c.norms[anz] := dam; + fi; + end; + + # main program + # check input + if not IsBound( arg[1] ) + or not IsList( arg[1] ) or not IsList( arg[1][1] ) then + Error ( "first argument must be Gram matrix\n", + "usage: ShortestVectors( , [,<\"positive\">] )" ); + elif not IsBound( arg[2] ) or not IsInt( arg[2] ) then + Error ( "second argument must be integer\n", + "usage: ShortestVectors( , [,<\"positive\">] )"); + elif IsBound( arg[3] ) then + if IsString( arg[3] ) then + if arg[3] = "positive" then + checkpositiv := true; + else + checkpositiv := false; + fi; + else + Error ( "third argument must be string\n", + "usage: ShortestVectors( , [,<\"positive\">] )"); + fi; + else + checkpositiv := false; + fi; + a := arg[1]; + m := arg[2]; + n := Length( a ); + b := List( a, ShallowCopy ); + c := rec( vectors:=[],norms:=[]); + v := []; + nullv := []; + for i in [1..n] do + nullv[i] := 0; + od; + llg:=LLLReducedGramMat(b); + kur(); + Info( InfoLattice, 2, + "ShortestVectors: ", Length( c.vectors ), " vectors found" ); + return c; +end; + + +############################################################################# +## +#F OrthogonalEmbeddings( [, \"positive\" ] [, ] ) +## +OrthogonalEmbeddings := function( arg ) + local + # sonstige prozeduren + Symmatinv, + # variablen fuer Embed + maxdim, M, D, s, phi, mult, m, x, t, x2, sumg, sumh, + f, invg, sol, solcount, out, + l, g, nullv, i, j, k, n, kgv, a, IdMat, chpo, + # booleans + positiv, checkpositiv, checkdim, + # prozeduren fuer Embed + comp1, comp2, scp2, multiples, solvevDMtr, + Dextend, Mextend, inca, rnew, + deca, algorithm; + + Symmatinv := function( b ) + # inverts symmetric matrices + + local n, i, j, l, k, c, d, ba, B, kgv, kgv1; + n := Length( b ); + c := List( IdMat, ShallowCopy ); + d := []; + B := []; + kgv1 := 1; + ba := List( IdMat, ShallowCopy ); + for i in [1..n] do + k := b[i][i]; + for j in [1..i-1] do + k := k - c[i][j] * c[i][j] * B[j]; + od; + B[i] := k; + for j in [i+1..n] do + k := b[j][i]; + for l in [1..i-1] do + k := k - c[i][l] * c[j][l] * B[l]; + od; + if B[i] <> 0 then + c[j][i] := k / B[i]; + else + Error ( "matrix not invertible, ", Ordinal( i ), + " column is linearly dependent" ); + fi; + od; + od; + if B[n] = 0 then + Error ( "matrix not invertible, ", Ordinal( i ), + " column is linearly dependent" ); + fi; + for i in [1..n-1] do + for j in [i+1..n] do + if c[j][i] <> 0 then + for l in [1..i] do + ba[j][l] := ba[j][l] - c[j][i] * ba[i][l]; + od; + fi; + od; + od; + for i in [1..n] do + for j in [1..i-1] do + ba[j][i] := ba[i][j]; + ba[i][j] := ba[i][j] / B[i]; + od; + ba[i][i] := 1/B[i]; + od; + for i in [1..n] do + d[i] := []; + for j in [1..n] do + if i >= j then + k := ba[i][j]; + l := i + 1; + else + l := j; + k := 0; + fi; + while l <= n do + k := k + ba[i][l] * ba[l][j]; + l := l + 1; + od; + d[i][j] := k; + kgv1 := Lcm( kgv1, DenominatorRat( k ) ); + od; + od; + for i in [1..n] do + for j in [1..n] do + d[i][j] := kgv1 * d[i][j]; + od; + od; + return rec( inverse := d, enuminator := kgv1 ); + end; + + # program embed + + comp1 := function( a, b ) + local i; + if ( a[n+1] < b[n+1] ) then + return false; + elif ( a[n+1] > b[n+1] ) then + return true; + else + for i in [ 1 .. n ] do + if AbsInt( a[i] ) > AbsInt( b[i] ) then + return true; + elif AbsInt( a[i] ) < AbsInt( b[i] ) then + return false; + fi; + od; + fi; + return false; + end; + + comp2 := function( a, b ) + local i, t; + t := Length(a)-1; + if a[t+1] < b[t+1] then + return true; + elif a[t+1] > b[t+1] then + return false; + else + for i in [ 1 .. t ] do + if a[i] < b[i] then + return false; + elif a[i] > b[i] then + return true; + fi; + od; + fi; + return false; + end; + + scp2 := function( k, l ) + # uses x, invg, + # changes + local i, j, sum, sum1; + + sum := 0; + for i in [1..n] do + sum1 := 0; + for j in [1..n] do + sum1 := sum1 + x[k][j] * invg[j][i]; + od; + sum := sum + sum1 * x[l][i]; + od; + return sum; + end; + + multiples := function( l ) + # uses m, phi, + # changes mult, s, k, a, sumh, sumg, + local v, r, i, j, brk; + + for j in [1..n] do + sumh[j] := 0; + od; + i := l; + while i <= t and ( not checkdim or s <= maxdim ) do + if mult[i] * phi[i][i] < m then + brk := false; + repeat + v := solvevDMtr( i ); + if not IsBound( v[1] ) or not IsList( v[1] ) then + r := rnew( v, i ); + if r >= 0 then + if r > 0 then + Dextend( r ); + fi; + Mextend( v, i ); + a[i] := a[i] + 1; + else + brk := true; + fi; + else + brk := true; + fi; + until a[i] * phi[i][i] >= m or ( checkdim and s > maxdim ) + or brk; + mult[i] := a[i]; + while a[i] > 0 do + s := s - 1; + if M[s][Length( M[s] )] = 1 then + k := k -1; + fi; + a[i] := a[i] - 1; + od; + fi; + if mult[i] <> 0 then + for j in [1..n] do + sumh[j] := sumh[j] + mult[i] * x2[i][j]; + od; + fi; + i := i + 1; + od; + end; + + solvevDMtr := function( l ) + # uses M, D, phi, f, + # changes + local M1, M2, i, j, k1, v, sum; + + k1 := 1; + v := []; + i := 1; + while i < s do + sum := 0; + M1 := Length( M[i] ); + M2 := M[i][M1]; + for j in [1..M1-1] do + sum := sum + v[j] * M[i][j]; + od; + if M2 = 1 then + v[k1] := -( phi[l][f[i]] + sum ) / D[k1]; + k1 := k1 + 1; + else + if DenominatorRat( sum ) <> 1 + or NumeratorRat( sum ) <> -phi[l][f[i]] then + v[1] := []; + i := s; + fi; + fi; + i := i + 1; + od; + return( v ); + end; + + inca := function( l ) + # uses x2, + # changes l, a, sumg, sumh, + local v, r, brk, i; + + while l <= t and ( not checkdim or s <= maxdim ) do + brk := false; + repeat + v := solvevDMtr( l ); + if not IsBound( v[1] ) or not IsList( v[1] ) then + r := rnew( v, l ); + if r >= 0 then + if r > 0 then + Dextend( r ); + fi; + Mextend( v, l ); + a[l] := a[l] + 1; + for i in [1..n] do + sumg[i] := sumg[i] + x2[l][i]; + od; + else + brk := true; + fi; + else + brk := true; + fi; + until a[l] >= mult[l] or ( checkdim and s > maxdim ) or brk; + mult[l] := 0; + l := l + 1; + od; + return l; + end; + + rnew := function( v, l ) + # uses phi, m, k, D, + # changes v, + local sum, i; + sum := m - phi[l][l]; + for i in [1..k-1] do + sum := sum - v[i] * D[i] * v[i]; + od; + if sum >= 0 then + if sum > 0 then + v[k] := 1; + else + v[k] := 0; + fi; + fi; + return sum; + end; + + Mextend := function( line, l ) + # uses D, + # changes M, s, f, + local i; + for i in [1..Length( line )-1] do + line[i] := line[i] * D[i]; + od; + M[s] := line; + f[s] := l; + s := s + 1; + end; + + Dextend := function( r ) + # uses a, + # changes k, D, + D[k] := r; + k := k + 1; + end; + + deca := function( l ) + # uses x2, t, M, + # changes l, k, s, a, sumg, + local i; + if l <> 1 then + l := l - 1; + if l = t - 1 then + while a[l] > 0 do + s := s -1; + if M[s][Length( M[s] )] = 1 then + k := k - 1; + fi; + a[l] := a[l] - 1; + for i in [1..n] do + sumg[i] := sumg[i] - x2[l][i]; + od; + od; + l := deca( l ); + else + if a[l] <> 0 then + s := s - 1; + if M[s][Length( M[s] )] = 1 then + k := k - 1; + fi; + a[l] := a[l] - 1; + for i in [1..n] do + sumg[i] := sumg[i] - x2[l][i]; + od; + l := l + 1; + else + l := deca( l ); + fi; + fi; + fi; + return l; + end; + + # check input + if not IsList( arg[1] ) or not IsList( arg[1][1] ) then + Error( "first argument must be symmetric Gram matrix\n", + "usage : Orthog... ( < gram-matrix > \n", + " [, <\"positive\"> ] [, < integer > ] )" ); + elif Length( arg[1] ) <> Length( arg[1][1] ) then + Error( "Gram matrix must be quadratic\n", + "usage : Orthog... ( < gram-matrix >\n", + " [, <\"positive\"> ] [, < integer > ] )" ); + fi; + g := List( arg[1], ShallowCopy ); + checkpositiv := false; + checkdim := false; + chpo := "xxx"; + if IsBound( arg[2] ) then + if IsString( arg[2] ) then + chpo := arg[2]; + if arg[2] = "positive" then + checkpositiv := true; + fi; + else + if IsInt( arg[2] ) then + maxdim := arg[2]; + checkdim := true; + else + Error( "second argument must be string or integer\n", + "usage : Orthog... ( < gram-matrix >\n", + " [, <\"positive\"> ] [, < integer > ] )" ); + fi; + fi; + fi; + if IsBound( arg[3] ) then + if IsString( arg[3] ) then + chpo := arg[3]; + if arg[3] = "positive" then + checkpositiv := true; + fi; + else + if IsInt( arg[3] ) then + maxdim := arg[3]; + checkdim := true; + else + Error( "third argument must be string or integer\n", + "usage : Orthog... ( < gram-matrix >\n", + " [, <\"positive\"> ] [, < integer > ] )" ); + fi; + fi; + fi; + n := Length( g ); + for i in [1..n] do + for j in [1..i-1] do + if g[i][j] <> g[j][i] then + Error( "matrix not symmetric \n", + "usage : Orthog... ( < gram-matrix >\n", + " [, <\"positive\"> ] [, < integer > ] )" ); + fi; + od; + od; + + # main program + IdMat := IdentityMat( n ); + invg := Symmatinv( g ); + m := invg.enuminator; + invg := invg.inverse; + x := ShortestVectors( invg, m, chpo ); + t := Length(x.vectors); + for i in [1..t] do + x.vectors[i][n+1] := x.norms[i]; + od; + x := x.vectors; + M := []; + M[1] := []; + D := []; + mult := []; + sol := []; + f := []; + solcount := 0; + s := 1; + k := 1; + l := 1; + a := []; + for i in [1..t] do + a[i] := 0; + x[i][n+2] := 0; + mult[i] := 0; + od; + sumg := []; + sumh := []; + for i in [1..n] do + sumg[i] := 0; + sumh[i] := 0; + od; + Sort(x,comp1); + x2 := []; + for i in [1..t] do + x2[i] := []; + for j in [1..n] do + x2[i][j] := x[i][j] * x[i][j]; + x[i][n+2] := x[i][n+2] + x2[i][j]; + od; + od; + phi := []; + for i in [1..t] do + phi[i] := []; + for j in [1..i-1] do + phi[i][j] := scp2( i, j ); + od; + phi[i][i] := x[i][n+1]; + od; + repeat + multiples( l ); + + # (former call of 'tracecond') + if ForAll( [ 1 .. n ], i -> g[i][i] - sumg[i] <= sumh[i] ) then + l := inca( l ); + if s-k = n then + solcount := solcount + 1; + Info( InfoLattice, 2, + "OrthogonalEmbeddings: ", solcount, " solutions found" ); + sol[solcount] := []; + for i in [1..t] do + sol[solcount][i] := a[i]; + od; + sol[solcount][t+1] := s - 1; + fi; + fi; + l := deca( l ); + until l <= 1; + out := rec( vectors := [], norms := [], solutions := [] ); + for i in [1..t] do + out.vectors[i] := []; + out.norms[i] := x[i][n+1]/m; + for j in [1..n] do + out.vectors[i][j] := x[i][j]; + od; + od; + Sort( sol, comp2 ); + for i in [1..solcount] do + out.solutions[i] := []; + for j in [1..t] do + for k in [1..sol[i][j]] do + Add( out.solutions[i], j ); + od; + od; + od; + return out; +end; + + +############################################################################# +## +#F LLLint() . . . . . . . . . . . . . . . . . . . .. . integer only LLL +## +LLLint := function( lat ) + local b,mu,i,j,k,ka,dim,l,d,dkp,n,r,za,ne,nne,dkm,dkma,mue,muea,muk,mum, + ca1,ca2,cb1,cb2,tw,sel,s,dkpv; + + b:= List( lat, ShallowCopy ); + mu:=[]; + d:=[1,b[1]*b[1]]; + n:=Length(lat); + Info( InfoLattice, 1, "integer LLL in dimension ", n ); + dim:=1; + k:=2; + + while dim0 then + b[k]:=b[k]-r*b[k-1]; + for j in [1..k-2] do + mu[k][j]:=mu[k][j]-r*mu[k-1][j]; + od; + mu[k][k-1]:=mu[k][k-1]-r*d[k]; + fi; + + mue:=mu[k][k-1]; + dkp:=d[k+1]*d[k-1]; + dkpv:=dkp*4; + + if d[k]*d[k]*3-mue*mue*4>dkpv then + + #(2) + Info( InfoLattice, 2, "swap ", k-1, " <-> ", k ); + + muea:=mue; + dkm:=d[k]; + dkma:=dkm; + + ca1:=1; + ca2:=0; + cb1:=0; + cb2:=1; + + # iterierter vektor-ggT + repeat + dkm:=(dkp+mue*mue)/dkm; + tw:=ca1; + ca1:=cb1; + cb1:=tw; + tw:=ca2; + ca2:=cb2; + cb2:=tw; + + ne:=dkm; + za:=mue; + if za<0 then + za:=-za; + s:=-1; + else + s:=1; + fi; + nne:=ne/2; + if IsInt(nne) then + za:=za+nne; + else + za:=2*za+ne; + ne:=ne*2; + fi; + r:=s*QuoInt(za,ne); + + if r<>0 then + cb1:=cb1-r*ca1; + cb2:=cb2-r*ca2; + mue:=mue-r*dkm; + fi; + until dkm*dkm*3-mue*mue*4<=dkpv; + + d[k]:=dkm; + mu[k][k-1]:=mue; + + tw:=ca1*b[k-1]+ca2*b[k]; + b[k]:=cb1*b[k-1]+cb2*b[k]; + b[k-1]:=tw; + + if k>2 then + sel:=[1..k-2]; + muk:=mu[k]{sel}; + mum:=mu[k-1]{sel}; + tw:=ca1*mum+ca2*muk; + mu[k]{sel}:=cb1*mum+cb2*muk; + mu[k-1]{sel}:=tw; + fi; + + for j in [k+1..dim] do + za:=ca1*dkma+ca2*muea; + tw:=(za*mu[j][k-1]+ca2*mu[j][k]*d[k-1])/dkma; + mu[j][k]:=(((cb1*dkma+cb2*muea)*dkm-mue*za)*mu[j][k-1]+ + (cb2*dkm-ca2*mue)*d[k-1]*mu[j][k])/dkma/d[k-1]; + mu[j][k-1]:=tw; + od; + + if k>2 then + k:=k-1; + fi; + else + for l in [2..k-1] do + #reduce(k-l); + + ne:=d[k-l+1]; + za:=mu[k][k-l]; + if za<0 then + za:=-za; + s:=-1; + else + s:=1; + fi; + nne:=ne/2; + if IsInt(nne) then + za:=za+nne; + else + za:=2*za+ne; + ne:=ne*2; + fi; + r:=s*QuoInt(za,ne); + if r<>0 then + b[k]:=b[k]-r*b[k-l]; + for j in [1..k-l-1] do + mu[k][j]:=mu[k][j]-r*mu[k-l][j]; + od; + mu[k][k-l]:=mu[k][k-l]-r*d[k-l+1]; + fi; + od; + k:=k+1; + fi; + od; + + od; + return b; +end; + + +############################################################################# +## +#E lattice.gi . . . . . . . . . . . . . . . . . . . . . . . . . . ends here + + + diff --git a/lib/list.gd b/lib/list.gd index b64cd4a026..bafd2c5d5e 100644 --- a/lib/list.gd +++ b/lib/list.gd @@ -5,7 +5,7 @@ ## #H @(#)$Id$ ## -#Y Copyright (C) 1996, Lehrstuhl D fuer Mathematik, RWTH Aachen, Germany +#Y Copyright (C) 1997, Lehrstuhl D fuer Mathematik, RWTH Aachen, Germany ## ## This file contains the definition of operations and functions for lists. ## @@ -190,6 +190,16 @@ InstallTrueMethod( IsHomogeneousList, IsList and IsEmpty ); InstallTrueMethod( IsFinite, IsHomogeneousList and IsInternalRep ); +############################################################################# +## +#P IsNSortedList() +## +IsNSortedList := + NewPropertyKernel( "IsNSortedList", + IsDenseList, + IS_NSORT_LIST ); + + ############################################################################# ## #P IsSSortedList() diff --git a/lib/mapphomo.gi b/lib/mapphomo.gi index 01d3f38297..9b942a0548 100644 --- a/lib/mapphomo.gi +++ b/lib/mapphomo.gi @@ -75,7 +75,7 @@ InstallMethod( RespectsOne, R:= Range( map ); return IsMagmaWithOne( S ) and IsMagmaWithOne( R ) - and One( R ) in ImagesElm( One( R ) ); + and One( R ) in ImagesElm( map, One( S ) ); end ); @@ -434,7 +434,7 @@ InstallMethod( RespectsZero, R:= Range( map ); return IsAdditiveMagmaWithZero( S ) and IsAdditiveMagmaWithZero( R ) - and Zero( R ) in ImagesElm( Zero( S ) ); + and Zero( R ) in ImagesElm( map, Zero( S ) ); end ); diff --git a/lib/mapping.gd b/lib/mapping.gd index c14da5e425..2ebbfb7905 100644 --- a/lib/mapping.gd +++ b/lib/mapping.gd @@ -192,6 +192,22 @@ SetFamilySource := Setter( FamilySource ); HasFamilySource := Tester( FamilySource ); +############################################################################# +## +#A FamiliesOfGeneralMappingsAndRanges( ) +## +## is a list that stores at the odd positions the families of general +## mappings with source in the family , at the even positions the +## families of ranges of the general mappings. +## +FamiliesOfGeneralMappingsAndRanges := NewAttribute( + "FamiliesOfGeneralMappingsAndRanges", IsFamily, "mutable" ); +SetFamiliesOfGeneralMappingsAndRanges := Setter( + FamiliesOfGeneralMappingsAndRanges ); +HasFamiliesOfGeneralMappingsAndRanges := Tester( + FamiliesOfGeneralMappingsAndRanges ); + + ############################################################################# ## #P IsConstantTimeAccessGeneralMapping( ) diff --git a/lib/mapping.gi b/lib/mapping.gi index f6839614a9..e01881048a 100644 --- a/lib/mapping.gi +++ b/lib/mapping.gi @@ -25,13 +25,13 @@ Revision.mapping_gi := ############################################################################# ## -#V FAMILIES_GENERAL_MAPPINGS +#M FamiliesOfGeneralMappingsAndRanges( ) ## -## is a list of triples, with first and second components the family of -## source resp. range elements, and third component the general mappings -## family. -## -FAMILIES_GENERAL_MAPPINGS := []; +InstallMethod( FamiliesOfGeneralMappingsAndRanges, + "method for a family (return empty list)", + true, + [ IsFamily ], 0, + Fam -> [] ); ############################################################################# @@ -39,12 +39,13 @@ FAMILIES_GENERAL_MAPPINGS := []; #F GeneralMappingsFamily( , ) ## GeneralMappingsFamily := function( FS, FR ) - local entry, Fam; + local info, i, Fam; # Check whether this family was already constructed. - for entry in FAMILIES_GENERAL_MAPPINGS do - if IsIdentical( entry[1], FS ) and IsIdentical( entry[2], FR ) then - return entry[3]; + info:= FamiliesOfGeneralMappingsAndRanges( FS ); + for i in [ 2, 4 .. Length( info ) ] do + if IsIdentical( info[ i-1 ], FR ) then + return info[i]; fi; od; @@ -54,7 +55,7 @@ GeneralMappingsFamily := function( FS, FR ) SetFamilySource( Fam, FS ); # Store the family. - Add( FAMILIES_GENERAL_MAPPINGS, [ FS, FR, Fam ] ); + Append( info, [ FR, Fam ] ); # Return the family. return Fam; diff --git a/lib/meataxe.gi b/lib/meataxe.gi index da91fa4c86..b10bdb3200 100644 --- a/lib/meataxe.gi +++ b/lib/meataxe.gi @@ -430,21 +430,15 @@ end; ## (i.e. each has leading coefficient 1 in a unique place). ## SMTX.InducedActionSubmodule ( module, sub ) computes the submodule of ## module for which sub is the basis. -## If sub is empty or generates the whole space, then the empty sequence -## is returned. ## If sub does not generate a submodule then fail is returned. SMTX.InducedActionSubmodule := function ( module, sub ) local ans, dim, subdim, smodule,F; - ans := []; subdim := Length (sub); if subdim = 0 then - return ans; + return List(module.generators,i->[[]]); fi; dim := SMTX.Dimension(module); - if subdim = dim then - return ans; - fi; F:=SMTX.Field(module); ans:=SMTX.SubQuotActions(SMTX.Generators(module), @@ -473,21 +467,16 @@ end; ## module is a module record, and sub is a list of generators of a submodule. ## IT IS ASSUMED THAT THE GENERATORS OF SUB ARE NORMED. ## (i.e. each has leading coefficient 1 in a unique place). -## If sub is empty or generates the whole space, then the empty sequence -## is returned. Otherwise, qmodule is returned, where qmodule +## Qmodule is returned, where qmodule ## is the quotient module. ## SMTX.InducedActionFactorModule := function ( module, sub ) local ans, dim, subdim, F,qmodule; - ans := []; subdim := Length (sub); - if subdim=0 then - return ans; - fi; dim := SMTX.Dimension(module); if subdim = dim then - return ans; + return List(module.generators,i->[[]]); fi; F:=SMTX.Field(module); @@ -516,8 +505,7 @@ end; ## SMTX.InducedAction computes the submodule and quotient ## and the original module with its matrices written wrt to the basis used ## to compute smodule and qmodule. -## If sub is empty or generates the whole space, then the empty sequence -## is returned. Otherwise, [smodule, qmodule, nmodule] is returned, +## [smodule, qmodule, nmodule] is returned, ## where smodule is the submodule and qmodule the quotient module. ## The matrices of nmodule have the form A 0 where A and B are the ## C B @@ -533,15 +521,8 @@ local module,sub,typ,ans,dim,subdim,F,one,erg; else typ:=7; fi; - ans := []; subdim := Length (sub); - if subdim=0 then - return ans; - fi; dim := SMTX.Dimension(module); - if subdim=dim then - return ans; - fi; F := SMTX.Field(module); one := One (F); erg:=SMTX.SubQuotActions(SMTX.Generators(module), diff --git a/lib/oprt.gd b/lib/oprt.gd index 9fb181210d..48c3aa5d67 100644 --- a/lib/oprt.gd +++ b/lib/oprt.gd @@ -5,6 +5,10 @@ #H @(#)$Id$ ## #H $Log$ +#H Revision 4.22 1997/04/14 08:31:09 htheisse +#H added `ExternalOrbitsStabilizers' +#H new method for `ImagesSource' with known base +#H #H Revision 4.21 1997/04/09 09:17:08 htheisse #H gave sparse homomorphisms an external set #H allowed \`Permutation' to return fail instead of error @@ -195,6 +199,12 @@ ExternalOrbits := NewOperationArgs( "ExternalOrbits" ); ExternalOrbitsOp := NewOperation( "ExternalOrbits", OrbitsishReq ); ExternalOrbitsAttr := NewAttribute( "ExternalOrbits", IsExternalSet ); +ExternalOrbitsStabilizers := NewOperationArgs( "ExternalOrbitsStabilizers" ); +ExternalOrbitsStabilizersOp := NewOperation( "ExternalOrbitsStabilizers", + OrbitsishReq ); +ExternalOrbitsStabilizersAttr := NewAttribute( "ExternalOrbitsStabilizers", + IsExternalSet ); + Permutation := NewOperationArgs( "Permutation" ); PermutationOp := NewOperation( "Permutation", [ IsObject, IsList, IsFunction ] ); diff --git a/lib/oprt.gi b/lib/oprt.gi index 4f4bf15464..3836b7a23e 100644 --- a/lib/oprt.gi +++ b/lib/oprt.gi @@ -367,14 +367,25 @@ end ); ## InstallMethod( Enumerator, true, [ IsExternalSubset ], 0, function( xset ) - local henum, sublist, pnt; + local G, henum, gens, oprs, opr, sublist, pnt, pos; + G := ActingDomain( xset ); henum := HomeEnumerator( xset ); - sublist := BlistList( [ 1 .. Length( henum ) ], - MovedPoints( ImagesSource - ( OperationHomomorphismAttr( xset ) ) ) ); + if IsExternalSetByOperatorsRep( xset ) then + gens := xset!.generators; + oprs := xset!.operators; + opr := xset!.funcOperation; + else + gens := GeneratorsOfGroup( G ); + oprs := gens; + opr := FunctionOperation( xset ); + fi; + sublist := BlistList( [ 1 .. Length( henum ) ], [ ] ); for pnt in xset!.start do - sublist[ PositionCanonical( henum, pnt ) ] := true; + pos := PositionCanonical( henum, pnt ); + if not sublist[ pos ] then + OrbitByPosOp( G, henum, sublist, pos, pnt, gens, oprs, opr ); + fi; od; return Objectify( NewKind( FamilyObj( henum ), IsSubsetEnumerator ), rec( homeEnumerator := henum, @@ -441,6 +452,13 @@ InstallMethod( PrintObj, true, [ IsExternalOrbit ], 0, Print( Representative( xorb ), "^G < ", HomeEnumerator( xorb ) ); end ); +############################################################################# +## +#M AsList( ) . . . . . . . . . . . . . . . . . . by orbit algorithm +## +InstallMethod( AsList, true, [ IsExternalOrbit ], 0, + xorb -> Orbit( xorb, Representative( xorb ) ) ); + ############################################################################# ## #M = . . . . . . . . . . . . . . . . . . by ``conjugacy'' test @@ -1032,15 +1050,73 @@ InstallMethod( ExternalOrbitsOp, "G, D, gens, oprs, opr", true, OrbitsishReq, 0, function( G, D, gens, oprs, opr ) - local blist, orbs, next, pnt, orb, p; - + local blist, orbs, next, pnt, orb; + + blist := BlistList( [ 1 .. Length( D ) ], [ ] ); + orbs := [ ]; + next := 1; + while next <> fail do + pnt := D[ next ]; + orb := ExternalOrbitOp( G, D, pnt, gens, oprs, opr ); + SetCanonicalRepresentativeOfExternalSet( orb, pnt ); + SetEnumerator( orb, OrbitByPosOp( G, D, blist, next, pnt, + gens, oprs, opr ) ); + Add( orbs, orb ); + next := Position( blist, false, next ); + od; + return Immutable( orbs ); +end ); + +InstallOtherMethod( ExternalOrbitsOp, + "G, xset, gens, oprs, opr", true, + [ IsGroup, IsExternalSet, + IsList, + IsList, + IsFunction ], 0, + function( G, xset, gens, oprs, opr ) + local D, blist, orbs, next, pnt, orb; + + D := Enumerator( xset ); + blist := BlistList( [ 1 .. Length( D ) ], [ ] ); + orbs := [ ]; + next := 1; + while next <> fail do + pnt := D[ next ]; + orb := ExternalOrbitOp( G, xset, pnt, gens, oprs, opr ); + SetCanonicalRepresentativeOfExternalSet( orb, pnt ); + SetEnumerator( orb, OrbitByPosOp( G, D, blist, next, pnt, + gens, oprs, opr ) ); + Add( orbs, orb ); + next := Position( blist, false, next ); + od; + return Immutable( orbs ); +end ); + +############################################################################# +## +#F ExternalOrbitsStabilizers( ) . . . . . . list of transitive xsets +## +ExternalOrbitsStabilizers := function( arg ) + return AttributeOperation( ExternalOrbitsStabilizersOp, + ExternalOrbitsStabilizersAttr, true, arg ); +end; + +InstallMethod( ExternalOrbitsStabilizersOp, + "G, D, gens, oprs, opr", true, + OrbitsishReq, 0, + function( G, D, gens, oprs, opr ) + local blist, orbs, next, pnt, orb, orbstab, p; + blist := BlistList( [ 1 .. Length( D ) ], [ ] ); orbs := [ ]; next := 1; while next <> fail do pnt := D[ next ]; orb := ExternalOrbitOp( G, D, pnt, gens, oprs, opr ); + orbstab := OrbitStabilizer( G, D, pnt, gens, oprs, opr ); SetCanonicalRepresentativeOfExternalSet( orb, pnt ); + SetEnumerator( orb, orbstab.orbit ); + SetStabilizerOfExternalSet( orb, orbstab.stabilizer ); Add( orbs, orb ); for p in orb do blist[ PositionCanonical( D, p ) ] := true; @@ -1050,14 +1126,14 @@ InstallMethod( ExternalOrbitsOp, return Immutable( orbs ); end ); -InstallOtherMethod( ExternalOrbitsOp, +InstallOtherMethod( ExternalOrbitsStabilizersOp, "G, xset, gens, oprs, opr", true, [ IsGroup, IsExternalSet, IsList, IsList, IsFunction ], 0, function( G, xset, gens, oprs, opr ) - local D, blist, orbs, next, pnt, orb, p; + local D, blist, orbs, next, pnt, orb, orbstab, p; D := Enumerator( xset ); blist := BlistList( [ 1 .. Length( D ) ], [ ] ); @@ -1066,7 +1142,10 @@ InstallOtherMethod( ExternalOrbitsOp, while next <> fail do pnt := D[ next ]; orb := ExternalOrbitOp( G, xset, pnt, gens, oprs, opr ); + orbstab := OrbitStabilizer( G, D, pnt, gens, oprs, opr ); SetCanonicalRepresentativeOfExternalSet( orb, pnt ); + SetEnumerator( orb, orbstab.orbit ); + SetStabilizerOfExternalSet( orb, orbstab.stabilizer ); Add( orbs, orb ); for p in orb do blist[ PositionCanonical( D, p ) ] := true; @@ -1408,6 +1487,16 @@ InstallMethod( BlocksOp, return List( B, b -> D{ b } ); end ); +InstallMethod( BlocksOp, + "G, [ ], seed, gens, oprs, opr", true, + [ IsGroup, IsList and IsEmpty, IsList, + IsList, + IsList, + IsFunction ], SUM_FLAGS, + function( G, D, seed, gens, oprs, opr ) + return Immutable( [ ] ); +end ); + ############################################################################# ## #F MaximalBlocks( ) . . . . . . . . . . . . . . . . . maximal blocks @@ -1636,6 +1725,16 @@ InstallMethod( TransitivityOp, true, OrbitsishReq, 0, return Transitivity( ImagesSource( hom ), [ 1 .. Length( D ) ] ); end ); +InstallMethod( TransitivityOp, + "G, [ ], gens, perms, opr", true, + [ IsGroup, IsList and IsEmpty, + IsList, + IsList, + IsFunction ], SUM_FLAGS, + function( G, D, gens, oprs, opr ) + return 0; +end ); + ############################################################################# ## #F IsPrimitive( , , , , ) . . . . primitivity test @@ -1714,6 +1813,26 @@ InstallMethod( IsSemiRegularOp, true, OrbitsishReq, 0, return IsSemiRegular( ImagesSource( hom ), [ 1 .. Length( D ) ] ); end ); +InstallMethod( IsSemiRegularOp, + "G, [ ], gens, perms, opr", true, + [ IsGroup, IsList and IsEmpty, + IsList, + IsList, + IsFunction ], SUM_FLAGS, + function( G, D, gens, oprs, opr ) + return true; +end ); + +InstallMethod( IsSemiRegularOp, + "G, D, gens, [ ], opr", true, + [ IsGroup, IsList, + IsList, + IsList and IsEmpty, + IsFunction ], SUM_FLAGS, + function( G, D, gens, oprs, opr ) + return IsTrivial( G ); +end ); + ############################################################################# ## #F IsRegular( ) . . . . . . . . . . . . . . . . . . . regularity test @@ -2059,14 +2178,37 @@ InstallMethod( ImagesRepresentative, FamSourceEqFamElm, xset := hom!.externalSet; D := HomeEnumerator( xset ); opr := FunctionOperation( xset ); - if not IsBound( xset!.base ) then - xset!.base := List( Base( xset ), b -> PositionCanonical( D, b ) ); + if not IsBound( xset!.basePermImage ) then + xset!.basePermImage := List( Base( xset ), + b -> PositionCanonical( D, b ) ); fi; imgs := List( Base( xset ), b -> PositionCanonical( D, opr( b, elm ) ) ); return RepresentativeOperationOp( ImagesSource( hom ), - xset!.base, imgs, OnTuples ); + xset!.basePermImage, imgs, OnTuples ); end ); +############################################################################# +## +#M ImagesSource( ) . . . . . . . . . . . . . . . . . set base in image +## +InstallMethod( ImagesSource, true, + [ IsOperationHomomorphismByBase ], 0, + function( hom ) + local xset, img, D; + + xset := hom!.externalSet; + img := ImagesSet( hom, Source( hom ) ); + if not HasBase( img ) then + if not IsBound( xset!.basePermImage ) then + D := HomeEnumerator( xset ); + xset!.basePermImage := List( Base( xset ), + b -> PositionCanonical( D, b ) ); + fi; + SetBase( img, xset!.basePermImage ); + fi; + return img; +end ); + ############################################################################# ## #M ImagesRepresentative( , ) . . . . . restricted `Permutation' diff --git a/lib/oprtperm.gi b/lib/oprtperm.gi index 24a3e1cbe0..7aa0c59cb9 100644 --- a/lib/oprtperm.gi +++ b/lib/oprtperm.gi @@ -5,6 +5,12 @@ #H @(#)$Id$ ## #H $Log$ +#H Revision 4.26 1997/04/15 10:28:06 htheisse +#H more detailed checks in `RepresentativeOperation' +#H +#H Revision 4.25 1997/04/14 08:31:35 htheisse +#H corrected some requirements +#H #H Revision 4.24 1997/03/18 09:10:26 htheisse #H corrected `RepresentativeOperation' for perm groups #H @@ -48,12 +54,12 @@ Revision.oprtperm_gi := ## InstallOtherMethod( OrbitOp, "G, int, gens, perms, opr", true, - [ IsGroup, IsInt, + [ IsPermGroup, IsInt, + IsList, IsList, - IsList and IsPermCollection, IsFunction ], 0, function( G, pnt, gens, oprs, opr ) - if opr <> OnPoints then + if gens <> oprs or opr <> OnPoints then TryNextMethod(); fi; if HasStabChain( G ) and IsInBasicOrbit( StabChainAttr( G ), pnt ) then @@ -63,6 +69,33 @@ InstallOtherMethod( OrbitOp, fi; end ); +############################################################################# +## +#M OrbitStabilizer( , , , , ) . . on integers +## +InstallOtherMethod( OrbitStabilizerOp, + "G, int, gens, perms, opr", true, + [ IsPermGroup, IsInt, + IsList, + IsList, + IsFunction ], 0, + function( G, pnt, gens, oprs, opr ) + local S; + + if gens <> oprs or opr <> OnPoints then + TryNextMethod(); + fi; + S := StabChain( G, [ pnt ] ); + if BasePoint( S ) = pnt then + return Immutable( rec( orbit := S.orbit, + stabilizer := GroupStabChain + ( G, S.stabilizer, true ) ) ); + else + return Immutable( rec( orbit := [ pnt ], + stabilizer := G ) ); + fi; +end ); + ############################################################################# ## #M Orbits( , , , , ) . . . . . . . on integers @@ -515,16 +548,16 @@ end ); ## InstallMethod( EarnsOp, "G, ints, gens, perms, opr", true, - [ IsGroup, IsList and IsCyclotomicsCollection, + [ IsPermGroup, IsList, + IsList, IsList, - IsList and IsPermCollection, IsFunction ], 0, function( G, Omega, gens, oprs, opr ) local pcgs, n, fac, p, d, alpha, beta, G1, G2, orb, Gamma, M, C, f, P, Q, Q0, R, R0, pre, gen, g, ord, pa, a, x, y, z; - if opr <> OnPoints then + if gens <> oprs or opr <> OnPoints then TryNextMethod(); fi; @@ -639,13 +672,12 @@ end ); ## InstallMethod( TransitivityOp, "G, ints, gens, perms, opr", true, - [ IsGroup, IsList and IsCyclotomicsCollection, + [ IsPermGroup, IsList and IsCyclotomicsCollection, IsList, IsList, IsFunction ], 0, function( G, D, gens, oprs, opr ) - if opr <> OnPoints - or not IsIdentical( gens, oprs ) then + if gens <> oprs or opr <> OnPoints then TryNextMethod(); elif not IsTransitiveOp( G, D, gens, oprs, opr ) then @@ -658,23 +690,13 @@ InstallMethod( TransitivityOp, fi; end ); -InstallMethod( TransitivityOp, - "G, [ ], gens, perms, opr", true, - [ IsGroup, IsList and IsEmpty, - IsList, - IsList, - IsFunction ], SUM_FLAGS, - function( G, D, gens, oprs, opr ) - return 0; -end ); - ############################################################################# ## #M IsSemiRegular( , , , , ) . . . . for perm groups ## InstallMethod( IsSemiRegularOp, "G, ints, gens, perms, opr", true, - [ IsPermGroup, IsList and IsCyclotomicsCollection, + [ IsGroup, IsList and IsCyclotomicsCollection, IsList, IsList and IsPermCollection, IsFunction ], 0, @@ -813,11 +835,11 @@ InstallOtherMethod( RepresentativeOperationOp, true, [ IsPermGroup, i, f; # loop variables # standard operation on points, make a basechange and trace the rep - if opr = OnPoints and IsInt( d ) then + if opr = OnPoints and IsInt( d ) and IsInt( e ) then d := [ d ]; e := [ e ]; S := true; elif ( opr = OnPairs or opr = OnTuples ) - and IsList( d ) and ForAll( d, IsInt ) then + and IsPositionsList( d ) and IsPositionsList( e ) then S := true; fi; if IsBound( S ) then @@ -845,16 +867,17 @@ InstallOtherMethod( RepresentativeOperationOp, true, [ IsPermGroup, fi; # operation on (lists of) permutations, use backtrack - elif opr = OnPoints and IsPerm( d ) then + elif opr = OnPoints and IsPerm( d ) and IsPerm( e ) then rep := RepOpElmTuplesPermGroup( true, G, [ d ], [ e ], TrivialSubgroup( G ), TrivialSubgroup( G ) ); elif ( opr = OnPairs or opr = OnTuples ) - and IsList( d ) and IsPermCollection( d ) then + and IsList( d ) and IsPermCollection( d ) + and IsList( e ) and IsPermCollection( e ) then rep := RepOpElmTuplesPermGroup( true, G, d, e, TrivialSubgroup( G ), TrivialSubgroup( G ) ); # operation on permgroups, use backtrack - elif opr = OnPoints and IsPermGroup(d) then + elif opr = OnPoints and IsPermGroup( d ) and IsPermGroup( e ) then rep := IsomorphismPermGroups( G, d, e ); # operation on pairs on tuples of other objects, iterate @@ -863,19 +886,23 @@ InstallOtherMethod( RepresentativeOperationOp, true, [ IsPermGroup, S := G; i := 1; while i <= Length(d) and rep <> fail do - rep2 := RepresentativeOperationOp( - S, d[i], e[i]^(rep^-1), OnPoints ); - if rep2 <> fail then - rep := rep2 * rep; - S := StabilizerOp( S, d[i], OnPoints ); - else + if e[i] = fail then rep := fail; + else + rep2 := RepresentativeOperationOp( S, d[i], e[i]^(rep^-1), + OnPoints ); + if rep2 <> fail then + rep := rep2 * rep; + S := StabilizerOp( S, d[i], OnPoints ); + else + rep := fail; + fi; fi; i := i + 1; od; # operation on sets of points, use backtrack - elif opr = OnSets and ForAll( d, IsInt ) then + elif opr = OnSets and IsPositionsList( d ) and IsPositionsList( e ) then rep := RepOpSetsPermGroup( G, d, e ); # other operation, fall back on default representative @@ -902,7 +929,7 @@ InstallOtherMethod( StabilizerOp, if opr = OnPoints and IsInt( d ) then base := [ d ]; elif ( opr = OnPairs or opr = OnTuples ) - and IsList( d ) and ForAll( d, IsInt ) then + and IsPositionsList( d ) then base := d; fi; if IsBound( base ) then diff --git a/lib/pcgsind.gi b/lib/pcgsind.gi index 2dbabb2f59..f08328efd3 100644 --- a/lib/pcgsind.gi +++ b/lib/pcgsind.gi @@ -389,7 +389,7 @@ InstallMethod( InducedPcgsByGeneratorsWithImages, function( pcgs, gens, imgs ) local ro, max, id, igs, chain, new, seen, old, u, uw, up, e, x, c, - cw, d, i, j; + cw, d, i, j, f; # do family check here to avoid problems with the empty list if not IsIdentical( FamilyObj(pcgs), FamilyObj(gens) ) then @@ -399,6 +399,9 @@ function( pcgs, gens, imgs ) Error( " and must have equal length"); fi; + # get the trivial case first + if gens = AsList( pcgs ) then return [pcgs, imgs]; fi; + # get relative orders and composition length ro := RelativeOrders(pcgs); max := Length(pcgs); @@ -413,7 +416,10 @@ function( pcgs, gens, imgs ) chain := max+1; # contains a list of generators and images - new := List( Reversed([1..Length(gens)]), i -> [gens[i], imgs[i]]); + new := List( [1..Length(gens)], i -> [gens[i], imgs[i]]); + f := function( x, y ) return DepthOfPcElement( pcgs, x[1] ) + < DepthOfPcElement( pcgs, y[1] ); end; + Sort( new, f ); # holds a list of words already seen seen := Union( Set( gens ), [id[1]] ); diff --git a/lib/read1.g b/lib/read1.g index e0942d3b01..4ae3131859 100644 --- a/lib/read1.g +++ b/lib/read1.g @@ -24,8 +24,13 @@ ReadLib( "rest.gi" ); ReadLib( "listcoef.gi" ); ReadLib( "info.gd" ); -ReadLib( "assert.gd" ); ReadLib( "info.gi" ); +ReadLib( "assert.gd" ); ReadLib( "assert.gi" ); +ReadLib( "files.gd" ); +ReadLib( "streams.gd" ); +ReadLib( "files.gi" ); +ReadLib( "streams.gi" ); +ReadLib( "help.g" ); diff --git a/lib/read3.g b/lib/read3.g index 8744cbffdf..e471ad46ee 100644 --- a/lib/read3.g +++ b/lib/read3.g @@ -28,6 +28,7 @@ ReadLib( "basis.gd" ); ReadLib( "basismut.gd" ); ReadLib( "vspc.gd" ); ReadLib( "vspchom.gd" ); +ReadLib( "lattice.gd" ); ReadLib( "algebra.gd" ); ReadLib( "algfp.gd" ); ReadLib( "alglie.gd" ); diff --git a/lib/read5.g b/lib/read5.g index f42f016121..5309f490f4 100644 --- a/lib/read5.g +++ b/lib/read5.g @@ -33,6 +33,7 @@ ReadLib( "vspc.gi" ); ReadLib( "vspcrow.gi" ); ReadLib( "vspcmat.gi" ); ReadLib( "vspchom.gi" ); +ReadLib( "lattice.gi" ); ReadLib( "algebra.gi" ); ReadLib( "algfp.gi" ); diff --git a/lib/read7.g b/lib/read7.g index 429e0aa88e..4a4795334f 100644 --- a/lib/read7.g +++ b/lib/read7.g @@ -8,12 +8,21 @@ ReadLib( "ctbl.gd" ); ReadLib( "ctblfuns.gd" ); ReadLib( "ctblchar.gd" ); ReadLib( "ctblmaps.gd" ); +# ReadLib( "ctbllatt.gd" ); +ReadLib( "ctblsymm.gd" ); +ReadLib( "ctblpope.gd" ); +ReadLib( "ctblmono.gd" ); ReadLib( "ctbl.gi" ); ReadLib( "ctblfuns.gi" ); ReadLib( "ctblchar.gi" ); ReadLib( "ctblmaps.gi" ); +# ReadLib( "ctbllatt.gi" ); +# ReadLib( "ctblsymm.gi" ); +ReadLib( "ctblsolv.gi" ); +# ReadLib( "ctblpope.gi" ); +# ReadLib( "ctblmono.gi" ); ############################################################################# diff --git a/lib/streams.gd b/lib/streams.gd index 05ea4f6870..a80e3fe75a 100644 --- a/lib/streams.gd +++ b/lib/streams.gd @@ -124,11 +124,12 @@ SeekPositionStream := NewOperation( ############################################################################# ## -#O CloseInput( ) + +#O CloseStream( ) ## -CloseInput := NewOperation( - "CloseInput", - [ IsInputStream ] ); +CloseStream := NewOperation( + "CloseStream", + [ IsStream ] ); ############################################################################# diff --git a/lib/streams.gi b/lib/streams.gi index dbfef2d65b..77cf7e71f9 100644 --- a/lib/streams.gi +++ b/lib/streams.gi @@ -25,9 +25,9 @@ ClosedStreamKind := NewKind( ############################################################################# ## -#M CloseInput( ) +#M CloseStream( ) ## -InstallMethod( CloseInput, +InstallMethod( CloseStream, "input stream", true, [ IsInputStream ], @@ -78,6 +78,34 @@ function( stream ) end ); +############################################################################# +## +#M Read( ) +## +InstallOtherMethod( Read, + "input text stream", + true, + [ IsInputTextStream ], + 0, + +function( stream ) + READ_STREAM(stream); + CloseStream(stream); +end ); + + +############################################################################# +## +#M ReadTest( ) +## +InstallOtherMethod( ReadTest, + "input text stream", + true, + [ IsInputTextStream ], + 0, + READ_TEST_STREAM ); + + ############################################################################# ## #M RewindStream( ) @@ -328,9 +356,9 @@ end ); ############################################################################# ## -#M CloseInput( ) +#M CloseStream( ) ## -InstallMethod( CloseInput, +InstallMethod( CloseStream, "input text file", true, [ IsInputStream and IsInputTextFileRep ], diff --git a/lib/tuples.gd b/lib/tuples.gd index 3abb2e8a34..63b5f3ad0f 100644 --- a/lib/tuples.gd +++ b/lib/tuples.gd @@ -20,7 +20,8 @@ Revision.tuples_gd := ## IsTuple := NewCategory( "IsTuple", IsDenseList ); - +InstallTrueMethod( IsMultiplicativeElementWithInverse, IsTuple ); +InstallTrueMethod( IsMultiplicativeElementWithOne, IsTuple ); ############################################################################# ## diff --git a/lib/tuples.gi b/lib/tuples.gi index cb0b9f7676..275a7c754c 100644 --- a/lib/tuples.gi +++ b/lib/tuples.gi @@ -225,10 +225,41 @@ InstallMethod( Length, true, [IsDefaultTupleRep], 0, return Length(ComponentsOfTuplesFamily( FamilyObj (tuple))); end); +############################################################################## +## +#M Inverse( ) +## +InstallMethod( Inverse, true, [IsTuple], 0, +function( elm ) + return Tuple( List( elm, x -> Inverse( x ) ) ); +end ); +############################################################################## +## +#M One( ) +## +InstallMethod( One, true, [IsTuple], 0, +function( elm ) + return Tuple( List( elm, x -> One( x ) ) ); +end); +############################################################################## +## +#M \*( , ) +## +InstallMethod( \*, true, [IsTuple, IsTuple ], 0, +function( elm1, elm2 ) + local n; + n := Length( elm1 ); + return Tuple( List( [1..n], x -> elm1[x]*elm2[x] ) ); +end ); - - - +############################################################################## +## +#M \^( , ) +## +InstallMethod( \^, true, [IsTuple, IsInt], 0, +function( elm, x ) + return Tuple( List( elm, y -> y^x ) ); +end); diff --git a/src/Makefile b/src/Makefile index 3de8425f3b..69af1b3778 100644 --- a/src/Makefile +++ b/src/Makefile @@ -472,7 +472,8 @@ gac: $(SRC)/gac ## used directly, they should only be addressed by the recursive calls of ## 'make' from above. ## -OBJECTS = system.o scanner.o gasman.o \ +OBJECTS = system.o sysfiles.o \ + scanner.o gasman.o \ objects.o gvars.o \ calls.o opers.o \ ariths.o records.o lists.o \ @@ -490,7 +491,7 @@ OBJECTS = system.o scanner.o gasman.o \ code.o vars.o \ exprs.o stats.o funcs.o \ intrprtr.o compiler.o compiled.o \ - read.o gap.o + read.o gap.o streams.o gap: $(OBJECTS) compstat.o $(CC) $(LFLAGS) -o gap $(OBJECTS) compstat.o @@ -505,7 +506,11 @@ gap: $(OBJECTS) compstat.o ## implicit rules work only if the source is in the same directory). ## system.o: $(SRC)/system.c $(SRC)/system.h - $(CC) $(CFLAGS_SYS) $(CFLAGS_SIG) -o system.o -c $(SRC)/system.c + $(CC) $(CFLAGS_SYS) $(CFLAGS_SIG) -o system.o -c $(SRC)/system.c + +sysfiles.o: $(SRC)/sysfiles.c $(SRC)/sysfiles.h \ + $(SRC)/system.h + $(CC) $(CFLAGS_SYS) $(CFLAGS_SIG) -o sysfiles.o -c $(SRC)/sysfiles.c scanner.o: $(SRC)/scanner.c $(SRC)/scanner.h \ $(SRC)/system.h @@ -932,7 +937,11 @@ gap.o: $(SRC)/gap.c $(SRC)/gap.h \ $(SRC)/intrprtr.h $(SRC)/read.h $(CC) $(CFLAGS) -o gap.o -c $(SRC)/gap.c -compstat.o: $(SRC)/compstat.c \ +streams.o: $(SRC)/streams.c $(SRC)/streams.h \ + $(SRC)/system.h $(SRC)/sysfiles.h + $(CC) $(CFLAGS) -o streams.o -c $(SRC)/streams.c + +compstat.o: $(SRC)/compstat.c $(SRC)/compstat.h \ $(SRC)/system.h $(CC) $(CFLAGS) -o compstat.o -c $(SRC)/compstat.c diff --git a/src/ariths.c b/src/ariths.c index 34089c87ee..19e5c5dbce 100644 --- a/src/ariths.c +++ b/src/ariths.c @@ -12,10 +12,11 @@ char * Revision_ariths_c = "@(#)$Id$"; #include "system.h" /* Ints, UInts */ -#include "scanner.h" /* Pr */ -#include "gasman.h" /* InfoBags */ +#include "gasman.h" /* InfoBags */ #include "objects.h" /* TYPE_OBJ, FIRST_VIRTUAL_TYPE,...*/ +#include "scanner.h" /* Pr */ + #include "gvars.h" /* AssGVar, GVarName */ #include "calls.h" /* ObjFunc */ diff --git a/src/blister.c b/src/blister.c index ee44b3aed3..697d248f64 100644 --- a/src/blister.c +++ b/src/blister.c @@ -71,10 +71,11 @@ char * Revision_blister_c = "@(#)$Id$"; #include "system.h" /* system dependent functions */ -#include "scanner.h" /* Pr */ -#include "gasman.h" /* NewBag, ResizeBag, CHANGED_BAG */ +#include "gasman.h" /* NewBag, ResizeBag, CHANGED_BAG */ #include "objects.h" /* Obj, TYPE_OBJ, SIZE_OBJ, ... */ +#include "scanner.h" /* Pr */ + #include "gvars.h" /* AssGVar, GVarName */ #include "calls.h" /* generic call mechanism */ diff --git a/src/bool.c b/src/bool.c index 4ebd3ba0c7..e11cc7f45f 100644 --- a/src/bool.c +++ b/src/bool.c @@ -12,10 +12,11 @@ char * Revision_bool_c = "@(#)$Id$"; #include "system.h" /* Ints, UInts */ -#include "scanner.h" /* Pr */ -#include "gasman.h" /* NewBag, CHANGED_BAG */ +#include "gasman.h" /* NewBag, CHANGED_BAG */ #include "objects.h" /* Obj, TYPE_OBJ, types */ +#include "scanner.h" /* Pr */ + #include "gvars.h" /* AssGVar, GVarName */ #include "calls.h" /* NewFunctionC */ @@ -287,11 +288,11 @@ void InitBool ( void ) InitMarkFuncBags( T_BOOL , MarkNoSubBags ); /* make the two bags */ - InitGlobalBag( &True ); + InitGlobalBag( &True, "TRUE" ); True = NewBag( T_BOOL, 0L ); - InitGlobalBag( &False ); + InitGlobalBag( &False, "FALSE" ); False = NewBag( T_BOOL, 0L ); - InitGlobalBag( &Fail ); + InitGlobalBag( &Fail, "FAIL" ); Fail = NewBag( T_BOOL, 0L ); AssGVar( GVarName( "FAIL" ), Fail ); diff --git a/src/calls.c b/src/calls.c index fbccfc7e5b..8c0185ce6b 100644 --- a/src/calls.c +++ b/src/calls.c @@ -37,10 +37,11 @@ char * Revision_calls_c = #include "system.h" /* Ints, UInts */ -#include "scanner.h" /* Pr */ -#include "gasman.h" /* Bag, NewBag */ +#include "gasman.h" /* Bag, NewBag */ #include "objects.h" /* Obj, TYPE_OBJ, types */ +#include "scanner.h" /* Pr */ + #include "gvars.h" /* AssGVar, GVarName */ #define INCLUDE_DECLARATION_PART @@ -1042,6 +1043,79 @@ Obj DoProfXargs ( } +/**************************************************************************** +** +*F InitHandlerFunc( , ) . . . . . . . . register a handler +** +** Every handler should be registered (once) before it is installed in any +** function bag. This is needed so that it can be identified when loading a +** saved workspace. should be a unique C string, identifying the +** handler +*/ + +#ifndef MAX_HANDLERS +#define MAX_HANDLERS 4096 +#endif + +typedef struct { + ObjFunc hdlr; + Char *cookie; +} TypeHandlerInfo; + +static TypeHandlerInfo HandlerFuncs[MAX_HANDLERS]; +static UInt NHandlerFuncs = 0; + + +void InitHandlerFunc ( + ObjFunc hdlr, + Char *cookie) +{ + if (NHandlerFuncs >= MAX_HANDLERS) + { + Pr("No room left for function handler\n",0L,0L); + SyExit(1); + } + HandlerFuncs[NHandlerFuncs].hdlr = hdlr; + HandlerFuncs[NHandlerFuncs].cookie = cookie; + NHandlerFuncs++; +} + + + +static void CheckHandlersBag( + Bag bag ) +{ +#ifdef DEBUG_HANDLER_REGISTRATION + UInt i,j; + ObjFunc hdlr; + if (TYPE_BAG(bag) == T_FUNCTION) + { + for (j = 0; j < 8; j++) + { + hdlr = HDLR_FUNC(bag,j); + for (i = 0; i < NHandlerFuncs; i++) + { + if (hdlr == HandlerFuncs[i].hdlr) + break; + } + if (i == NHandlerFuncs) + { + Pr("Unregistered Handler %d args ", j, 0L); + PrintObj(NAME_FUNC(bag)); + Pr("\n",0L,0L); + } + } + } +#endif + return; +} + +void CheckAllHandlers( + void ) +{ + CallbackForAllBags( CheckHandlersBag); +} + /**************************************************************************** ** @@ -1099,6 +1173,9 @@ Obj NewFunctionT ( Obj func; /* function, result */ Obj prof; /* profiling bag */ + + + /* make the function object */ func = NewBag( type, size ); @@ -1170,6 +1247,7 @@ Obj NewFunctionCT ( Int len; /* length */ Int i, k, l; /* loop variables */ + /* convert the arguments list to an object */ len = 0; for ( k = 0; nams_c[k] != '\0'; k++ ) { @@ -1760,55 +1838,102 @@ void InitCalls () PrintObjFuncs[ T_FUNCTION ] = PrintFunction; /* make and install the 'IS_FUNCTION' filter */ + InitHandlerFunc( IsFunctionHandler, "IS_FUNCTION" ); IsFunctionFilt = NewFilterC( "IS_FUNCTION", 1L, "obj", IsFunctionHandler ); AssGVar( GVarName( "IS_FUNCTION" ), IsFunctionFilt ); /* make and install the 'CALL_FUNCTION' operation */ + InitHandlerFunc( CallFunctionHandler, "CALL_FUNCTION" ); CallFunctionOper = NewOperationC( "CALL_FUNCTION", -1L, "args", CallFunctionHandler ); AssGVar( GVarName( "CALL_FUNCTION" ), CallFunctionOper ); /* make and install the 'CALL_FUNC_LIST' operation */ + InitHandlerFunc( CallFuncListHandler, "CALL_FUNC_LIST" ); CallFuncListOper = NewOperationC( "CALL_FUNC_LIST", 2L, "func, list", CallFuncListHandler ); AssGVar( GVarName( "CALL_FUNC_LIST" ), CallFuncListOper ); /* make and install the 'NAME_FUNC' etc. operations */ + InitHandlerFunc( NAME_FUNC_Handler, "NAME_FUNCTION" ); NAME_FUNC_Oper = NewOperationC( "NAME_FUNCTION", 1L, "func", NAME_FUNC_Handler ); AssGVar( GVarName( "NAME_FUNCTION" ), NAME_FUNC_Oper ); + InitHandlerFunc( NARG_FUNC_Handler, "NARG_FUNCTION" ); NARG_FUNC_Oper = NewOperationC( "NARG_FUNCTION", 1L, "func", NARG_FUNC_Handler ); AssGVar( GVarName( "NARG_FUNCTION" ), NARG_FUNC_Oper ); + InitHandlerFunc( NAMS_FUNC_Handler, "NAMS_FUNCTION" ); NAMS_FUNC_Oper = NewOperationC( "NAMS_FUNCTION", 1L, "func", NAMS_FUNC_Handler ); AssGVar( GVarName( "NAMS_FUNCTION" ), NAMS_FUNC_Oper ); + InitHandlerFunc( PROF_FUNC_Handler, "PROF_FUNCTION" ); PROF_FUNC_Oper = NewOperationC( "PROF_FUNCTION", 1L, "func", PROF_FUNC_Handler ); AssGVar( GVarName( "PROF_FUNCTION" ), PROF_FUNC_Oper ); /* make and install the profile functions */ + InitHandlerFunc( FuncCLEAR_PROFILE_FUNCTION, "Clear Profile"); AssGVar( GVarName( "CLEAR_PROFILE_FUNCTION" ), NewFunctionC( "CLEAR_PROFILE_FUNCTION", 1L, "function", FuncCLEAR_PROFILE_FUNCTION ) ); + InitHandlerFunc( FuncIS_PROFILED_FUNCTION, "Is Profiled"); AssGVar( GVarName( "IS_PROFILED_FUNCTION" ), NewFunctionC( "IS_PROFILED_FUNCTION", 1L, "function", FuncIS_PROFILED_FUNCTION ) ); + InitHandlerFunc( FuncPROFILE_FUNCTION, "Profile function"); AssGVar( GVarName( "PROFILE_FUNCTION" ), NewFunctionC( "PROFILE_FUNCTION", 1L, "function", FuncPROFILE_FUNCTION ) ); + InitHandlerFunc( FuncUNPROFILE_FUNCTION, "Unprofile function"); AssGVar( GVarName( "UNPROFILE_FUNCTION" ), NewFunctionC( "UNPROFILE_FUNCTION", 1L, "function", FuncUNPROFILE_FUNCTION ) ); + + + InitHandlerFunc( DoFail0args, "0 arg fail"); + InitHandlerFunc( DoFail1args, "1 arg fail"); + InitHandlerFunc( DoFail2args, "2 arg fail"); + InitHandlerFunc( DoFail3args, "3 arg fail"); + InitHandlerFunc( DoFail4args, "4 arg fail"); + InitHandlerFunc( DoFail5args, "5 arg fail"); + InitHandlerFunc( DoFail6args, "6 arg fail"); + InitHandlerFunc( DoFailXargs, "X arg fail"); + + InitHandlerFunc( DoWrap0args, "0 arg wrap"); + InitHandlerFunc( DoWrap1args, "1 arg wrap"); + InitHandlerFunc( DoWrap2args, "2 arg wrap"); + InitHandlerFunc( DoWrap3args, "3 arg wrap"); + InitHandlerFunc( DoWrap4args, "4 arg wrap"); + InitHandlerFunc( DoWrap5args, "5 arg wrap"); + InitHandlerFunc( DoWrap6args, "6 arg wrap"); + + InitHandlerFunc( DoProf0args, "0 arg profile"); + InitHandlerFunc( DoProf1args, "1 arg profile"); + InitHandlerFunc( DoProf2args, "2 arg profile"); + InitHandlerFunc( DoProf3args, "3 arg profile"); + InitHandlerFunc( DoProf4args, "4 arg profile"); + InitHandlerFunc( DoProf5args, "5 arg profile"); + InitHandlerFunc( DoProf6args, "6 arg profile"); + InitHandlerFunc( DoProfXargs, "X arg profile"); + + InitHandlerFunc( DoComplete0args, "0 arg complete"); + InitHandlerFunc( DoComplete1args, "1 arg complete"); + InitHandlerFunc( DoComplete2args, "2 arg complete"); + InitHandlerFunc( DoComplete3args, "3 arg complete"); + InitHandlerFunc( DoComplete4args, "4 arg complete"); + InitHandlerFunc( DoComplete5args, "5 arg complete"); + InitHandlerFunc( DoComplete6args, "6 arg complete"); + InitHandlerFunc( DoCompleteXargs, "X arg complete"); } diff --git a/src/code.c b/src/code.c index 0af1f60cc3..7b293d420a 100644 --- a/src/code.c +++ b/src/code.c @@ -17,10 +17,10 @@ char * Revision_code_c = #include /* assert */ #include "system.h" /* Ints, UInts */ -#include "scanner.h" /* Pr ?*/ -#include "gasman.h" /* NewBag, CHANGED_BAG */ +#include "gasman.h" /* NewBag, CHANGED_BAG */ #include "objects.h" /* Obj, TYPE_OBJ, types */ +#include "scanner.h" /* Pr ?*/ #include "calls.h" /* NARG_FUNC, NLOC_FUNC, NAMS_FU...*/ /*N 1996/06/16 mschoene func expressions should be different from funcs */ @@ -3076,12 +3076,12 @@ void CodeAssertEnd3Args ( void ) void InitCode ( void ) { /* make the result variable known to Gasman */ - InitGlobalBag( &CodeResult ); + InitGlobalBag( &CodeResult, "CodeResult" ); /* allocate the statements and expressions stacks */ - InitGlobalBag( &StackStat ); + InitGlobalBag( &StackStat, "StackStat" ); StackStat = NewBag( T_BODY, 64*sizeof(Stat) ); - InitGlobalBag( &StackExpr ); + InitGlobalBag( &StackExpr, "StackExpr" ); StackExpr = NewBag( T_BODY, 64*sizeof(Expr) ); /* install the marking functions for function body bags */ diff --git a/src/compiler.c b/src/compiler.c index 95052986fb..b1596beb6d 100644 --- a/src/compiler.c +++ b/src/compiler.c @@ -17,10 +17,11 @@ char * Revision_compiler_c = #include /* variable argument list macros */ #include "system.h" /* Ints, UInts */ -#include "scanner.h" /* Pr */ -#include "gasman.h" /* NewBag, CHANGED_BAG */ +#include "gasman.h" /* NewBag, CHANGED_BAG */ #include "objects.h" /* Obj, TYPE_OBJ, types */ +#include "scanner.h" /* Pr */ + #include "gvars.h" /* InitGVars */ #include "calls.h" /* NARG_FUNC, NLOC_FUNC, NAMS_FU...*/ @@ -5791,12 +5792,13 @@ void InitCompiler ( void ) /* announce the global variables */ - InitGlobalBag( &CompInfoGVar ); - InitGlobalBag( &CompInfoRNam ); - InitGlobalBag( &CompFunctions ); + InitGlobalBag( &CompInfoGVar, "CompInfoGVar" ); + InitGlobalBag( &CompInfoRNam, "CompInfoRNam" ); + InitGlobalBag( &CompFunctions, "CompFunctions" ); /* make the compile function */ + InitHandlerFunc(CompileFuncHandler,"Compile function"); CompileFuncFunc = NewFunctionC( "CompileFunc", 5L, "output, func, name, magic1, magic2", CompileFuncHandler ); diff --git a/src/costab.c b/src/costab.c index 79a765e129..025337117a 100644 --- a/src/costab.c +++ b/src/costab.c @@ -15,10 +15,11 @@ char * Revision_costab_c = #include "system.h" /* Ints, UInts, SyIsIntr */ -#include "scanner.h" /* Pr */ -#include "gasman.h" /* Retype */ +#include "gasman.h" /* Retype */ #include "objects.h" /* Obj, TYPE_OBJ, types */ +#include "scanner.h" /* Pr */ + #include "gvars.h" /* AssGVar, GVarName */ #include "gap.h" /* Error */ @@ -2839,60 +2840,70 @@ void InitCosetTable ( void ) { /* functions for coset tables */ + InitHandlerFunc( FuncApplyRel, "costab: apply relator"); AssGVar( GVarName( "ApplyRel" ), NewFunctionC( "ApplyRel", 2L, "app, relator", FuncApplyRel ) ); + InitHandlerFunc( FuncMakeConsequences, "costab: make consequences"); AssGVar( GVarName( "MakeConsequences" ), NewFunctionC( "MakeConsequences", 1L, "list", FuncMakeConsequences ) ); + InitHandlerFunc( FuncStandardizeTable, "costab: standardize table"); AssGVar( GVarName( "StandardizeTable" ), NewFunctionC( "StandardizeTable", 1L, "table", FuncStandardizeTable ) ); + InitHandlerFunc( FuncApplyRel2, "costab: apply rel 2"); AssGVar( GVarName( "ApplyRel2" ), NewFunctionC( "ApplyRel2", 3L, "app, relator, nums", FuncApplyRel2 ) ); + InitHandlerFunc( FuncCopyRel, "costab: copy relator"); AssGVar( GVarName( "CopyRel" ), NewFunctionC( "CopyRel", 1L, "relator", FuncCopyRel ) ); + InitHandlerFunc( FuncMakeCanonical, "costab: make canonical"); AssGVar( GVarName( "MakeCanonical" ), NewFunctionC( "MakeCanonical", 1L, "relator", FuncMakeCanonical ) ); + InitHandlerFunc( FuncTreeEntry, "costab: tree entry"); AssGVar( GVarName( "TreeEntry" ), NewFunctionC( "TreeEntry", 1L, "relator", FuncTreeEntry ) ); + InitHandlerFunc( FuncMakeConsequences2, "costab: make consequences 2"); AssGVar( GVarName( "MakeConsequences2" ), NewFunctionC( "MakeConsequences2", 1L, "list", FuncMakeConsequences2 ) ); + InitHandlerFunc( FuncStandardizeTable2, "costab: standardize table 2"); AssGVar( GVarName( "StandardizeTable2" ), NewFunctionC( "StandardizeTable2", 2L, "table, table", FuncStandardizeTable2 ) ); + InitHandlerFunc( FuncAddAbelianRelator, "costab: add abelian relator"); AssGVar( GVarName( "AddAbelianRelator" ), NewFunctionC( "AddAbelianRelator", 2L, "rels, number", FuncAddAbelianRelator ) ); /* static variables */ - InitGlobalBag( &objRel ); - InitGlobalBag( &objNums ); - InitGlobalBag( &objFactor ); - InitGlobalBag( &objTable ); - InitGlobalBag( &objTable2 ); - InitGlobalBag( &objNext ); - InitGlobalBag( &objPrev ); - InitGlobalBag( &objTree ); - InitGlobalBag( &objTree1 ); - InitGlobalBag( &objTree2 ); - InitGlobalBag( &objWordValue ); - InitGlobalBag( &objExponent ); + InitGlobalBag( &objRel , "costab: relator" ); + InitGlobalBag( &objNums , "costab: parallel numbers list" ); + InitGlobalBag( &objFactor , "costab: factor" ); + InitGlobalBag( &objTable , "costab: table" ); + InitGlobalBag( &objTable2 , "costab: factor table" ); + InitGlobalBag( &objNext , "costab: next" ); + InitGlobalBag( &objPrev , "costab: prev" ); + InitGlobalBag( &objTree , "costab: subgroup gens tree" ); + InitGlobalBag( &objTree1 , "costab: first tree compt" ); + InitGlobalBag( &objTree2 , "costab: second tree compt" ); + InitGlobalBag( &objWordValue, "costab: word value" ); + InitGlobalBag( &objExponent , "costab: subgroup order" ); } diff --git a/src/cyclotom.c b/src/cyclotom.c index 6488e63174..814e466e74 100644 --- a/src/cyclotom.c +++ b/src/cyclotom.c @@ -89,10 +89,11 @@ char * Revision_cyclotom_c = "@(#)$Id$"; #include "system.h" /* Ints, UInts */ -#include "scanner.h" /* Pr */ -#include "gasman.h" /* NewBag, CHANGED_BAG */ +#include "gasman.h" /* NewBag, CHANGED_BAG */ #include "objects.h" /* Obj, TYPE_OBJ, types */ +#include "scanner.h" /* Pr */ + #include "gvars.h" /* AssGVar, GVarName */ #include "calls.h" /* NewFunctionC */ @@ -1892,12 +1893,12 @@ void InitCyc ( void ) /* create the result buffer */ ResultCyc = NEW_PLIST( T_PLIST, 1024 ); - InitGlobalBag( &ResultCyc ); + InitGlobalBag( &ResultCyc , "cyclotomic result buffer"); res = ADDR_OBJ( ResultCyc ); for ( i = 0; i < 1024; i++ ) { res[i] = INTOBJ_INT(0); } /* tell Gasman about the place were we remember the primitive root */ - InitGlobalBag( &LastECyc ); + InitGlobalBag( &LastECyc, "cyclotomic: primitive root"); /* install the kind function */ ImportGVarFromLibrary( "KIND_CYC", &KIND_CYC ); @@ -1954,26 +1955,32 @@ void InitCyc ( void ) ProdFuncs[ T_CYC ][ T_RAT ] = ProdCycInt; /* and finally install the internal functions */ + InitHandlerFunc( EHandler, "E" ); EOper = NewOperationC( "E", 1L, "n", EHandler ); AssGVar( GVarName( "E" ), EOper ); + InitHandlerFunc( IsCycHandler, "IS_CYC" ); IsCycFilt = NewFilterC( "IS_CYC", 1L, "obj", IsCycHandler ); AssGVar( GVarName( "IS_CYC" ), IsCycFilt ); + InitHandlerFunc( IsCycIntHandler, "IS_CYC_INT" ); IsCycIntOper = NewOperationC( "IS_CYC_INT", 1L, "obj", IsCycIntHandler ); AssGVar( GVarName( "IS_CYC_INT" ), IsCycIntOper ); + InitHandlerFunc( NofCycHandler, "N_OF_CYC" ); NofCycOper = NewOperationC( "N_OF_CYC", 1L, "cyc", NofCycHandler ); AssGVar( GVarName( "N_OF_CYC" ), NofCycOper ); + InitHandlerFunc( CoeffsCycHandler, "COEFFS_CYC" ); CoeffsCycOper = NewOperationC( "COEFFS_CYC", 1L, "cyc", CoeffsCycHandler ); AssGVar( GVarName( "COEFFS_CYC" ), CoeffsCycOper ); + InitHandlerFunc( GaloisCycHandler, "GALOIS_CYC" ); GaloisCycOper = NewOperationC( "GALOIS_CYC", 2L, "cyc, n", GaloisCycHandler ); AssGVar( GVarName( "GALOIS_CYC" ), GaloisCycOper ); diff --git a/src/dt.c b/src/dt.c index fb5690acd3..80a860eba6 100644 --- a/src/dt.c +++ b/src/dt.c @@ -33,9 +33,9 @@ #include "system.h" -#include "scanner.h" #include "gasman.h" #include "objects.h" +#include "scanner.h" #include "bool.h" #include "calls.h" #include "gap.h" @@ -1738,15 +1738,24 @@ void InitDeepThought( void ) exp = RNamName("exp"); bas = RNamName("bas"); /* install the internal functions */ + InitHandlerFunc( FuncMakeFormulaVector, "dt: make formula vector"); AssGVar( GVarName( "MakeFormulaVector" ), NewFunctionC("MakeFormulaVector", 2L, "tree, presentation", FuncMakeFormulaVector ) ); + + InitHandlerFunc( FuncFindNewReps, "dt: find new reps"); AssGVar( GVarName( "FindNewReps" ), NewFunctionC("FindNewReps", 4L, "tree, representatives, presentation, maximum", FuncFindNewReps ) ); + + InitHandlerFunc( FuncUnmarkTree, "dt: unmark tree"); AssGVar( GVarName( "UnmarkTree" ), NewFunctionC("UnmarkTree", 1L, "tree", FuncUnmarkTree ) ); + + InitHandlerFunc( FuncGetPols, "dt: get polynomials"); AssGVar( GVarName( "GetPols" ), NewFunctionC(" GetPols", 3L, "list, presentation, polynomials", FuncGetPols) ); + + InitHandlerFunc( Funcposition, "dt: evaluation"); AssGVar( GVarName( "DT_evaluation" ), NewFunctionC( "DT_evaluation", 1L, "vector", Funcposition) ); InitFopyGVar( GVarName( "dt_add" ), &Dt_add ); diff --git a/src/dteval.c b/src/dteval.c index eeb19808be..2fff5c843f 100644 --- a/src/dteval.c +++ b/src/dteval.c @@ -1,7 +1,7 @@ #include "system.h" -#include "scanner.h" #include "gasman.h" #include "objects.h" +#include "scanner.h" #include "bool.h" #include "calls.h" #include "gap.h" @@ -815,24 +815,44 @@ void InitDTEvaluation(void) evlist = RNamName("evlist"); evlistvec = RNamName("evlistvec"); + + InitHandlerFunc( Funccompress, "dteval: compress"); AssGVar( GVarName("Compress"), NewFunctionC("Compress", 1L, "list", Funccompress) ); + + InitHandlerFunc( FuncMultiply, "dteval: multiply"); AssGVar( GVarName("Multiply"), NewFunctionC("Multiply", 3L, "lword, rword, representatives", FuncMultiply) ); - AssGVar( GVarName("Pover"), NewFunctionC("Pover", 3L, + + InitHandlerFunc( FuncPower, "dteval: power"); + AssGVar( GVarName("Power"), NewFunctionC("Power", 3L, "word, exponent, representatives", FuncPower) ); + + InitHandlerFunc( FuncDTmultiplyL, "dteval: DTMultiply"); AssGVar( GVarName("DTMultiply"), NewFunctionC("DTMultiply", 3L, "lword, rword, rewritingsystem", FuncDTmultiplyL) ); + + InitHandlerFunc( FuncDTPowerL, "dteval: DTPowerL"); AssGVar( GVarName("DTPower"), NewFunctionC("DTPower", 3L, "word, exponent, rewritingsytem", FuncDTPowerL) ); + + InitHandlerFunc( FuncDTSolutionL, "dteval: DTSolutionL"); AssGVar( GVarName("DTSolution"), NewFunctionC("DTSolution", 3L, "lword, rword, rewritingsystem", FuncDTSolutionL) ); + + InitHandlerFunc( FuncDTCommutatorL, "dteval: DTCommutatorL"); AssGVar( GVarName("DTCommutator"), NewFunctionC("DTCommutator", 3L, "lword, rword, rewritingsystem", FuncDTCommutatorL) ); + + InitHandlerFunc( FuncDTQuotientL, "dteval: DTQuotientL"); AssGVar( GVarName("DTQuotient"), NewFunctionC("DTQuotient", 3L, "lword, rword, rewritingsystem", FuncDTQuotientL) ); + + InitHandlerFunc( FuncDTConjugateL, "dteval: DTConjugateL"); AssGVar( GVarName("DTConjugate"), NewFunctionC("DTConjugate", 3L, "lword, rword, rewritingsystem", FuncDTConjugateL) ); + + InitHandlerFunc( FuncWernerProduct, "dteval: Werner Product"); AssGVar( GVarName("WernerProduct"), NewFunctionC("WernerProduct", 3L, "lword, rword, rewritingsystem", FuncWernerProduct) ); } diff --git a/src/exprs.c b/src/exprs.c index 8664825adc..8fbfa43350 100644 --- a/src/exprs.c +++ b/src/exprs.c @@ -15,10 +15,11 @@ char * Revision_exprs_c = "@(#)$Id$"; #include "system.h" /* Ints, UInts */ -#include "scanner.h" /* Pr */ -#include "gasman.h" /* NewBag, CHANGED_BAG */ +#include "gasman.h" /* NewBag, CHANGED_BAG */ #include "objects.h" /* Obj, TYPE_OBJ, types */ +#include "scanner.h" /* Pr */ + #include "gvars.h" /* Tilde, VAL_GVAR, AssGVar, GVa...*/ #include "ariths.h" /* generic operations */ diff --git a/src/finfield.c b/src/finfield.c index e192e80dff..c26f7c49de 100644 --- a/src/finfield.c +++ b/src/finfield.c @@ -52,10 +52,11 @@ char * Revision_finfield_c = "@(#)$Id$"; #include "system.h" /* Ints, UInts */ -#include "scanner.h" /* Pr */ -#include "gasman.h" /* NewBag, CHANGED_BAG */ +#include "gasman.h" /* NewBag, CHANGED_BAG */ #include "objects.h" /* Obj, TYPE_OBJ, types */ +#include "scanner.h" /* Pr */ + #include "gvars.h" /* AssGVar, GVarName */ #include "calls.h" /* NewFunctionC */ @@ -1935,19 +1936,19 @@ void InitFinfield ( void ) /* create the fields and integer conversion bags */ CharFF = NEW_PLIST( T_PLIST, 0 ); SET_LEN_PLIST( CharFF, 0 ); - InitGlobalBag( &CharFF ); + InitGlobalBag( &CharFF, "finfield: characteristics" ); DegrFF = NEW_PLIST( T_PLIST, 0 ); SET_LEN_PLIST( DegrFF, 0 ); - InitGlobalBag( &DegrFF ); + InitGlobalBag( &DegrFF, "finfield: degree" ); SuccFF = NEW_PLIST( T_PLIST, 0 ); SET_LEN_PLIST( SuccFF, 0 ); - InitGlobalBag( &SuccFF ); + InitGlobalBag( &SuccFF, "finfield: successor" ); KindFF = NEW_PLIST( T_PLIST, 0 ); SET_LEN_PLIST( KindFF, 0 ); - InitGlobalBag( &KindFF ); + InitGlobalBag( &KindFF, "finfield: element kinds" ); IntFF = NEW_PLIST( T_PLIST, 0 ); SET_LEN_PLIST( IntFF, 0 ); - InitGlobalBag( &IntFF ); + InitGlobalBag( &IntFF, "finifield: integer conversion" ); /* install the functions that handle overflow */ ImportFuncFromLibrary( "SUM_FFE_LARGE", &SUM_FFE_LARGE ); @@ -1957,26 +1958,32 @@ void InitFinfield ( void ) ImportFuncFromLibrary( "LOG_FFE_LARGE", &LOG_FFE_LARGE ); /* install the internal functions */ + InitHandlerFunc( IsFFEHandler, "IS_FFE" ); IsFFEFilt = NewFilterC( "IS_FFE", 1L, "obj", IsFFEHandler ); AssGVar( GVarName( "IS_FFE" ), IsFFEFilt ); + InitHandlerFunc( CharFFEDefaultHandler, "ffe: characteristic of FFE default"); CharFFEDefaultFunc = NewFunctionC( "CHAR_FFE_DEFAULT", 1L, "z", CharFFEDefaultHandler ); AssGVar( GVarName( "CHAR_FFE_DEFAULT" ), CharFFEDefaultFunc ); + InitHandlerFunc( DegreeFFEDefaultHandler, "ffe: degree of FFE default"); DegreeFFEDefaultFunc = NewFunctionC( "DEGREE_FFE_DEFAULT", 1L, "z", DegreeFFEDefaultHandler ); AssGVar( GVarName( "DEGREE_FFE_DEFAULT" ), DegreeFFEDefaultFunc ); + InitHandlerFunc( LogFFEDefaultHandler, "ffe: log in FFE default"); LogFFEDefaultFunc = NewFunctionC( "LOG_FFE_DEFAULT", 2L, "z, r", LogFFEDefaultHandler ); AssGVar( GVarName( "LOG_FFE_DEFAULT" ), LogFFEDefaultFunc ); + InitHandlerFunc( IntFFEDefaultHandler, "ffe: int -> FFE default"); IntFFEDefaultFunc = NewFunctionC( "INT_FFE_DEFAULT", 1L, "z", IntFFEDefaultHandler ); AssGVar( GVarName( "INT_FFE_DEFAULT" ), IntFFEDefaultFunc ); + InitHandlerFunc( ZHandler, "ffe: Z function"); ZFunc = NewFunctionC( "Z", 1L, "q", ZHandler ); AssGVar( GVarName( "Z" ), ZFunc ); diff --git a/src/funcs.c b/src/funcs.c index 27f3a34b1f..7af0252b37 100644 --- a/src/funcs.c +++ b/src/funcs.c @@ -20,10 +20,10 @@ char * Revision_funcs_c = #include /* assert */ #include "system.h" /* Ints, UInts */ -#include "scanner.h" /* Pr */ -#include "gasman.h" /* NewBag, CHANGED_BAG */ +#include "gasman.h" /* NewBag, CHANGED_BAG */ #include "objects.h" /* Obj, TYPE_OBJ, types */ +#include "scanner.h" /* Pr */ #include "calls.h" /* CALL_ARGS, Function, ObjFunc */ @@ -1068,7 +1068,7 @@ void ExecEnd ( void InitFuncs ( void ) { /* make the global variable known to Gasman */ - InitGlobalBag( &ExecState ); + InitGlobalBag( &ExecState, "funcs: ExecState" ); /* install the evaluators and executors */ ExecStatFuncs [ T_PROCCALL_0ARGS ] = ExecProccall0args; @@ -1107,6 +1107,16 @@ void InitFuncs ( void ) PrintExprFuncs[ T_FUNCCALL_6ARGS ] = PrintFunccall; PrintExprFuncs[ T_FUNCCALL_XARGS ] = PrintFunccall; PrintExprFuncs[ T_FUNC_EXPR ] = PrintFuncExpr; + + + InitHandlerFunc( DoExecFunc0args, "0 arg interpreted function"); + InitHandlerFunc( DoExecFunc1args, "1 arg interpreted function"); + InitHandlerFunc( DoExecFunc2args, "2 arg interpreted function"); + InitHandlerFunc( DoExecFunc3args, "3 arg interpreted function"); + InitHandlerFunc( DoExecFunc4args, "4 arg interpreted function"); + InitHandlerFunc( DoExecFunc5args, "5 arg interpreted function"); + InitHandlerFunc( DoExecFunc6args, "6 arg interpreted function"); + InitHandlerFunc( DoExecFuncXargs, "X arg interpreted function"); } diff --git a/src/gac b/src/gac index dcf64a056c..efcdddf6c7 100755 --- a/src/gac +++ b/src/gac @@ -144,31 +144,31 @@ while [ $# -gt 0 ]; do -o|--output) shift; output="$1";; -ffast-int-arith) if [ "X${gap_options}" = "X" ]; then - gap_options="-X FAST_INT_ARITH" + gap_options="-D FAST_INT_ARITH" else gap_options="${gap_options},FAST_INT_ARITH" fi;; -ffast-plain-lists) if [ "X${gap_options}" = "X" ]; then - gap_options="-X FAST_PLAIN_LISTS" + gap_options="-D FAST_PLAIN_LISTS" else gap_options="${gap_options},FAST_PLAIN_LISTS" fi;; -ffast-list-funcs) if [ "X${gap_options}" = "X" ]; then - gap_options="-X FAST_LIST_FUNCS" + gap_options="-D FAST_LIST_FUNCS" else gap_options="${gap_options},FAST_LIST_FUNCS" fi;; -fno-check-types) if [ "X${gap_options}" = "X" ]; then - gap_options="-X NO_CHECK_TYPES" + gap_options="-D NO_CHECK_TYPES" else gap_options="${gap_options},NO_CHECK_TYPES" fi;; -fno-check-list-elms) if [ "X${gap_options}" = "X" ]; then - gap_options="- NO_CHECK_LIST_ELMS" + gap_options="-D NO_CHECK_LIST_ELMS" else gap_options="${gap_options},NO_CHECK_LIST_ELMS" fi;; @@ -433,7 +433,7 @@ elif [ ${comp_mode} = "comp_to_c" ]; then name=`basename ${input} .g` if [ "X${output}" = "X" ]; then output=${name}.c; fi temps_c="${temps_c} /tmp/$$_${name}.c" - gap_compile /tmp/$$_${name}.c ${input} "Init_Dynamic" + gap_compile /tmp/$$_${name}.c ${input} "Init_${name}" mv /tmp/$$_${name}.c ${output} output="";; @@ -441,7 +441,7 @@ elif [ ${comp_mode} = "comp_to_c" ]; then name=`basename ${input} .gap` if [ "X${output}" = "X" ]; then output=${name}.c; fi temps_c="${temps_c} /tmp/$$_${name}.c" - gap_compile /tmp/$$_${name}.c ${input} "Init_Dynamic" + gap_compile /tmp/$$_${name}.c ${input} "Init_${name}" mv /tmp/$$_${name}.c ${output} output="";; @@ -449,7 +449,7 @@ elif [ ${comp_mode} = "comp_to_c" ]; then name=`basename ${input} .gd` if [ "X${output}" = "X" ]; then output=${name}.c; fi temps_c="${temps_c} /tmp/$$_${name}.c" - gap_compile /tmp/$$_${name}.c ${input} "Init_Dynamic" + gap_compile /tmp/$$_${name}.c ${input} "Init_${name}" mv /tmp/$$_${name}.c ${output} output="";; @@ -457,7 +457,7 @@ elif [ ${comp_mode} = "comp_to_c" ]; then name=`basename ${input} .gi` if [ "X${output}" = "X" ]; then output=${name}.c; fi temps_c="${temps_c} /tmp/$$_${name}.c" - gap_compile /tmp/$$_${name}.c ${input} "Init_Dynamic" + gap_compile /tmp/$$_${name}.c ${input} "Init_${name}" mv /tmp/$$_${name}.c ${output} output="";; diff --git a/src/gap.c b/src/gap.c index a4ab84e43e..3ee2f1b165 100644 --- a/src/gap.c +++ b/src/gap.c @@ -16,11 +16,12 @@ char * Revision_gap_c = #include #include "system.h" /* Ints, UInts */ -#include "scanner.h" /* Pr */ + extern char * In; #include "gasman.h" /* NewBag, CHANGED_BAG */ - #include "objects.h" /* Obj, TYPE_OBJ, types */ +#include "scanner.h" /* Pr */ + #include "gvars.h" /* InitGVars */ #include "calls.h" /* InitCalls */ @@ -327,7 +328,7 @@ Obj SizeScreenHandler ( /**************************************************************************** ** -*F * * * * * * * * * * * * * * print and error * * * * * * * * * * * * * * * +*F * * * * * * * * * * * * * * error functions * * * * * * * * * * * * * * * */ @@ -335,46 +336,15 @@ Obj SizeScreenHandler ( /**************************************************************************** ** -*F FuncPrint( , ) . . . . . . . . . . . . . . . . print -*/ -Obj FuncPrint ( - Obj self, - Obj args ) -{ - Obj arg; - UInt i; - - /* print all the arguments, take care of strings and functions */ - for ( i = 1; i <= LEN_PLIST(args); i++ ) { - arg = ELM_LIST(args,i); - if ( IsStringConv(arg) && MUTABLE_TYPE(TYPE_OBJ(arg))==T_STRING ) { - PrintString1(arg); - } - else if ( TYPE_OBJ( arg ) == T_FUNCTION ) { - PrintObjFull = 1; - PrintFunction( arg ); - PrintObjFull = 0; - } - else { - PrintObj( arg ); - } - } - - return 0; -} - - -/**************************************************************************** -** *F FuncDownEnv( <, level> ) . . . . . . . . . change the environment */ -UInt ErrorLevel; +UInt ErrorLevel; -Obj ErrorLVars0; -Obj ErrorLVars; -Int ErrorLLevel; +Obj ErrorLVars0; +Obj ErrorLVars; +Int ErrorLLevel; -extern Obj BottomLVars; +extern Obj BottomLVars; Obj FuncDownEnv ( @@ -654,7 +624,7 @@ Obj ErrorMode ( ** *F ErrorQuit( , , ) . . . . . . . . . . . print and quit */ -void ErrorQuit ( +void ErrorQuit ( Char * msg, Int arg1, Int arg2 ) @@ -717,11 +687,11 @@ Obj FuncError ( *F Complete( ) . . . . . . . . . . . . . . . . . . . complete a file */ -Obj CompNowFuncs; +Obj CompNowFuncs; -UInt CompNowCount; +UInt CompNowCount; -void Complete ( +void Complete ( Obj list ) { Obj filename; @@ -779,7 +749,7 @@ void Complete ( ** *F DoCompleteargs( ... ) . . . . . . . . . . handler to complete a file */ -Obj DoComplete0args ( +Obj DoComplete0args ( Obj self ) { Complete( BODY_FUNC( self ) ); @@ -792,7 +762,7 @@ Obj DoComplete0args ( return CALL_0ARGS( self ); } -Obj DoComplete1args ( +Obj DoComplete1args ( Obj self, Obj arg1 ) { @@ -806,7 +776,7 @@ Obj DoComplete1args ( return CALL_1ARGS( self, arg1 ); } -Obj DoComplete2args ( +Obj DoComplete2args ( Obj self, Obj arg1, Obj arg2 ) @@ -821,7 +791,7 @@ Obj DoComplete2args ( return CALL_2ARGS( self, arg1, arg2 ); } -Obj DoComplete3args ( +Obj DoComplete3args ( Obj self, Obj arg1, Obj arg2, @@ -837,7 +807,7 @@ Obj DoComplete3args ( return CALL_3ARGS( self, arg1, arg2, arg3 ); } -Obj DoComplete4args ( +Obj DoComplete4args ( Obj self, Obj arg1, Obj arg2, @@ -854,7 +824,7 @@ Obj DoComplete4args ( return CALL_4ARGS( self, arg1, arg2, arg3, arg4 ); } -Obj DoComplete5args ( +Obj DoComplete5args ( Obj self, Obj arg1, Obj arg2, @@ -872,7 +842,7 @@ Obj DoComplete5args ( return CALL_5ARGS( self, arg1, arg2, arg3, arg4, arg5 ); } -Obj DoComplete6args ( +Obj DoComplete6args ( Obj self, Obj arg1, Obj arg2, @@ -891,7 +861,7 @@ Obj DoComplete6args ( return CALL_6ARGS( self, arg1, arg2, arg3, arg4, arg5, arg6 ); } -Obj DoCompleteXargs ( +Obj DoCompleteXargs ( Obj self, Obj args ) { @@ -1518,457 +1488,6 @@ Obj FuncSHOW_STAT ( } -/**************************************************************************** -** - -*F * * * * * * * * * streams and files related functions * * * * * * * * * * -*/ - - -/**************************************************************************** -** - -*F FuncREAD( ) . . . . . . . . . . . . . . . . . . . read a file -*/ -Obj FuncREAD ( - Obj self, - Obj filename ) -{ - UInt type; - - /* check the argument */ - while ( ! IsStringConv( filename ) ) { - filename = ErrorReturnObj( - "READ: must be a string (not a %s)", - (Int)(InfoBags[TYPE_OBJ(filename)].name), 0L, - "you can return a string for " ); - } - - /* try to open the file */ - if ( ! OpenInput( CSTR_STRING(filename) ) ) { - return False; - } - NrError = 0; - - /* now do the reading */ - while ( 1 ) { - type = ReadEvalCommand(); - - /* handle return-value or return-void command */ - if ( type == 1 || type == 2 ) { - Pr( - "'return' must not be used in file read-eval loop", - 0L, 0L ); - } - - /* handle quit command or */ - else if ( type == 8 || type == 16 ) { - break; - } - - } - - /* close the input file again, and return 'true' */ - if ( ! CloseInput() ) { - ErrorQuit( - "Panic: READ cannot close input, this should not happen", - 0L, 0L ); - } - NrError = 0; - return True; -} - - -/**************************************************************************** -** -*F FuncREAD_AS_FUNC( ) . . . . . . . . . . . . . . . read a file -*/ -Obj READ_AS_FUNC ( - Char * filename ) -{ - Obj func; - UInt type; - - /* try to open the file */ - if ( ! OpenInput( filename ) ) { - return Fail; - } - NrError = 0; - - /* now do the reading */ - type = ReadEvalFile(); - - /* get the function */ - if ( type == 0 ) { - func = ReadEvalResult; - } - else { - func = Fail; - } - - /* close the input file again, and return 'true' */ - if ( ! CloseInput() ) { - ErrorQuit( - "Panic: READ_AS_FUNC cannot close input, this should not happen", - 0L, 0L ); - } - NrError = 0; - - /* return the function */ - return func; -} - -Obj FuncREAD_AS_FUNC ( - Obj self, - Obj filename ) -{ - /* check the argument */ - while ( ! IsStringConv( filename ) ) { - filename = ErrorReturnObj( - "READ_AS_FUNC: must be a string (not a %s)", - (Int)(InfoBags[TYPE_OBJ(filename)].name), 0L, - "you can return a string for " ); - } - - /* read the function */ - return READ_AS_FUNC( CSTR_STRING(filename) ); -} - - -/**************************************************************************** -** -*F READ_GAP_ROOT( ) . . . read from gap root, dyn-load or static -** -** 'READ_GAP_ROOT' tries to find a file under the root directory, it will -** search all directories given in 'SyGapRootPaths', check dynamically -** loadable modules and statically linked modules. -*/ -Int READ_GAP_ROOT ( Char * filename ) -{ - Char result[256]; - Int res; - UInt type; - StructCompInitInfo* info; - Obj func; - UInt4 crc; - Char * file; - - /* try to find the file */ - file = SyFindGapRootFile(filename); - if ( file ) { - crc = SyGAPCRC(file); - } - else { - crc = 0; - } - res = SyFindOrLinkGapRootFile( filename, crc, result, 256 ); - - /* not found */ - if ( res == 0 ) { - return 0; - } - - /* dynamically linked */ - else if ( res == 1 ) { - if ( SyDebugLoading ) { - Pr( "#I READ_GAP_ROOT: loading '%s' dynamically\n", - (Int)filename, 0L ); - } - info = *(StructCompInitInfo**)result; - (info->link)(); - func = (Obj)(info->function1)(); - CALL_0ARGS(func); - return 1; - } - - /* statically linked */ - else if ( res == 2 ) { - if ( SyDebugLoading ) { - Pr( "#I READ_GAP_ROOT: loading '%s' statically\n", - (Int)filename, 0L ); - } - info = *(StructCompInitInfo**)result; - (info->link)(); - func = (Obj)(info->function1)(); - CALL_0ARGS(func); - return 1; - } - - /* ordinary gap file */ - else if ( res == 3 ) { - if ( SyDebugLoading ) { - Pr( "#I READ_GAP_ROOT: loading '%s' as GAP file\n", - (Int)filename, 0L ); - } - if ( OpenInput(result) ) { - NrError = 0; - while ( 1 ) { - type = ReadEvalCommand(); - if ( type == 1 || type == 2 ) { - Pr( "'return' must not be used in file", 0L, 0L ); - } - else if ( type == 8 || type == 16 ) { - break; - } - } - CloseInput(); - NrError = 0; - return 1; - } - else { - return 0; - } - } - - /* don't know */ - else { - ErrorQuit( "unknown result code %d from 'SyFindGapRoot'", res, 0L ); - return 0; - } -} - - -/**************************************************************************** -** -*F FuncREAD_GAP_ROOT( ) . . . . . . . . . . . . . . . read a file -*/ -Obj FuncREAD_GAP_ROOT ( - Obj self, - Obj filename ) -{ - /* check the argument */ - while ( ! IsStringConv( filename ) ) { - filename = ErrorReturnObj( - "READ: must be a string (not a %s)", - (Int)(InfoBags[TYPE_OBJ(filename)].name), 0L, - "you can return a string for " ); - } - - /* try to open the file */ - if ( READ_GAP_ROOT( CSTR_STRING(filename) ) ) { - return True; - } - else { - return False; - } -} - - -/**************************************************************************** -** -*F FuncReadTest( ) . . . . . . . . . . . . . . read a test file -*/ -Obj FuncReadTest ( - Obj self, - Obj filename ) -{ - UInt type; - UInt time; - - /* check the argument */ - while ( ! IsStringConv( filename ) ) { - filename = ErrorReturnObj( - "ReadTest: must be a string (not a %s)", - (Int)(InfoBags[TYPE_OBJ(filename)].name), 0L, - "you can return a string for " ); - } - - /* try to open the file */ - if ( ! OpenTest( CSTR_STRING(filename) ) ) { - return False; - } - NrError = 0; - - /* get the starting time */ - time = SyTime(); - - /* now do the reading */ - while ( 1 ) { - - /* read and evaluate the command */ - type = ReadEvalCommand(); - - /* stop the stopwatch */ - AssGVar( Time, INTOBJ_INT( SyTime() - time ) ); - - /* handle ordinary command */ - if ( type == 0 && ReadEvalResult != 0 ) { - - /* print the result */ - if ( *In != ';' ) { - IsStringConv( ReadEvalResult ); - PrintObj( ReadEvalResult ); - Pr( "\n", 0L, 0L ); - } - else { - Match( S_SEMICOLON, ";", 0UL ); - } - - } - - /* handle return-value or return-void command */ - else if ( type == 1 || type == 2 ) { - Pr( - "'return' must not be used in file read-eval loop", - 0L, 0L ); - } - - /* handle quit command or */ - else if ( type == 8 || type == 16 ) { - break; - } - - } - - /* close the input file again, and return 'true' */ - if ( ! CloseTest() ) { - ErrorQuit( - "Panic: ReadTest cannot close input, this should not happen", - 0L, 0L ); - } - NrError = 0; - return True; -} - - -/**************************************************************************** -** -*F FuncLogTo( ) . . . . . . . . . . . . internal function 'LogTo' -** -** 'FunLogTo' implements the internal function 'LogTo'. -** -** 'LogTo( )' \\ -** 'LogTo()' -** -** 'LogTo' instructs GAP to echo all input from the standard input files, -** '*stdin*' and '*errin*' and all output to the standard output files, -** '*stdout*' and '*errout*', to the file with the name . -** The file is created if it does not exist, otherwise it is truncated. -** -** 'LogTo' called with no argument closes the current logfile again, so that -** input from '*stdin*' and '*errin*' and output to '*stdout*' and -** '*errout*' will no longer be echoed to a file. -*/ -Obj FuncLogTo ( - Obj self, - Obj args ) -{ - Obj filename; - - /* 'LogTo()' */ - if ( LEN_LIST(args) == 0 ) { - if ( ! CloseLog() ) { - ErrorQuit("LogTo: can not close the logfile",0L,0L); - return 0; - } - } - - /* 'LogTo( )' */ - else if ( LEN_LIST(args) == 1 ) { - filename = ELM_LIST(args,1); - while ( ! IsStringConv(filename) ) { - filename = ErrorReturnObj( - "LogTo: must be a string (not a %s)", - (Int)(InfoBags[TYPE_OBJ(filename)].name), 0L, - "you can return a string for " ); - } - if ( ! OpenLog( CSTR_STRING(filename) ) ) { - ErrorReturnVoid( - "LogTo: cannot log to %s", - (Int)CSTR_STRING(filename), 0L, - "you can return" ); - return 0; - } - } - - return 0; -} - - -/**************************************************************************** -** -*F FuncIsExistingFile( , ) . . . . . . does file exists -*/ -Obj FuncIsExistingFile ( - Obj self, - Obj filename ) -{ - /* check the argument */ - while ( ! IsStringConv( filename ) ) { - filename = ErrorReturnObj( - " must be a string (not a %s)", - (Int)(InfoBags[TYPE_OBJ(filename)].name), 0L, - "you can return a string for " ); - } - - /* call the system dependent function */ - return SyIsExistingFile( CSTR_STRING(filename) ) ? True : False; -} - - -/**************************************************************************** -** -*F FuncIsReadableFile( , ) . . . . . . is file readable -*/ -Obj FuncIsReadableFile ( - Obj self, - Obj filename ) -{ - /* check the argument */ - while ( ! IsStringConv( filename ) ) { - filename = ErrorReturnObj( - " must be a string (not a %s)", - (Int)(InfoBags[TYPE_OBJ(filename)].name), 0L, - "you can return a string for " ); - } - - /* call the system dependent function */ - return SyIsReadableFile( CSTR_STRING(filename) ) ? True : False; -} - - -/**************************************************************************** -** -*F FuncIsWritableFile( , ) . . . . . . is file writable -*/ -Obj FuncIsWritableFile ( - Obj self, - Obj filename ) -{ - /* check the argument */ - while ( ! IsStringConv( filename ) ) { - filename = ErrorReturnObj( - " must be a string (not a %s)", - (Int)(InfoBags[TYPE_OBJ(filename)].name), 0L, - "you can return a string for " ); - } - - /* call the system dependent function */ - return SyIsWritableFile( CSTR_STRING(filename) ) ? True : False; -} - - -/**************************************************************************** -** -*F FuncIsExecutableFile( , ) . . . . is file executable -*/ -Obj FuncIsExecutableFile ( - Obj self, - Obj filename ) -{ - /* check the argument */ - while ( ! IsStringConv( filename ) ) { - filename = ErrorReturnObj( - " must be a string (not a %s)", - (Int)(InfoBags[TYPE_OBJ(filename)].name), 0L, - "you can return a string for " ); - } - - /* call the system dependent function */ - return SyIsExecutableFile( CSTR_STRING(filename) ) ? True : False; -} - - /**************************************************************************** ** @@ -1985,12 +1504,13 @@ Obj FuncIsExecutableFile ( ** ** 'GASMAN( "display" | "clear" | "collect" | "message" | "partial" )' */ -Obj FuncGASMAN ( +Obj FuncGASMAN ( Obj self, Obj args ) { Obj cmd; /* argument */ UInt i, k; /* loop variables */ + Char buf[100]; /* check the argument */ while ( ! IS_LIST(args) || LEN_LIST(args) == 0 ) { @@ -2015,16 +1535,18 @@ Obj FuncGASMAN ( /* if request display the statistics */ if ( SyStrcmp( CSTR_STRING(cmd), "display" ) == 0 ) { - Pr( "\t\t%30s ", (Int)"type", 0L ); - Pr( "%8d %8d ", (Int)"alive", (Int)"size" ); - Pr( "%8d %8d\n", (Int)"total", (Int)"size" ); + Pr( "%40s ", (Int)"type", 0L ); + Pr( "%8s %8s ", (Int)"alive", (Int)"kbyte" ); + Pr( "%8s %8s\n", (Int)"total", (Int)"kbyte" ); for ( k = 0; k < 256; k++ ) { if ( InfoBags[k].name != 0 ) { - Pr("%30s ", (Int)InfoBags[k].name, 0L ); - Pr("%8d %8d ",(Int)InfoBags[k].nrLive, - (Int)InfoBags[k].sizeLive); + buf[0] = '\0'; + SyStrncat( buf, InfoBags[k].name, 40 ); + Pr("%40s ", (Int)buf, 0L ); + Pr("%8d %8d ", (Int)InfoBags[k].nrLive, + (Int)(InfoBags[k].sizeLive/1024)); Pr("%8d %8d\n",(Int)InfoBags[k].nrAll, - (Int)InfoBags[k].sizeAll); + (Int)(InfoBags[k].sizeAll/1024)); } } } @@ -2032,8 +1554,13 @@ Obj FuncGASMAN ( /* if request display the statistics */ else if ( SyStrcmp( CSTR_STRING(cmd), "clear" ) == 0 ) { for ( k = 0; k < 256; k++ ) { - InfoBags[k].nrAll = InfoBags[k].nrLive; - InfoBags[k].sizeAll = InfoBags[k].sizeLive; +#ifdef GASMAN_CLEAR_TO_LIVE + InfoBags[k].nrAll = InfoBags[k].nrLive; + InfoBags[k].sizeAll = InfoBags[k].sizeLive; +#else + InfoBags[k].nrAll = 0; + InfoBags[k].sizeAll = 0; +#endif } } @@ -2047,6 +1574,16 @@ Obj FuncGASMAN ( CollectBags(0,0); } + /* or display information about global bags */ + else if ( SyStrcmp( CSTR_STRING(cmd), "global" ) == 0 ) { + for ( i = 0; i < GlobalBags.nr; i++ ) { + if ( *(GlobalBags.addr[i]) != 0 ) { + Pr( "%50s: %12d bytes\n", (Int)GlobalBags.cookie[i], + (Int)SIZE_BAG(*(GlobalBags.addr[i])) ); + } + } + } + /* or finally toggle Gasman messages */ else if ( SyStrcmp( CSTR_STRING(cmd), "message" ) == 0 ) { SyMsgsFlagBags = (SyMsgsFlagBags + 1) % 3; @@ -2056,8 +1593,8 @@ Obj FuncGASMAN ( else { cmd = ErrorReturnObj( "GASMAN: must be %s or %s", - (Int)"\"display\" or \"clear\"", - (Int)"\"collect\" or \"message\" or \"partial\"", + (Int)"\"display\" or \"clear\" or \"global\" or ", + (Int)"\"collect\" or \"partial\" or \"message\"", "you can return a new string for " ); goto again; } @@ -2151,7 +1688,7 @@ Obj FuncXTYPE_OBJ ( ** *F FuncOBJ_HANDLE( , ) . . . . . . expert function 'OBJ_HANDLE' */ -Obj FuncOBJ_HANLDE ( +Obj FuncOBJ_HANDLE ( Obj self, Obj obj ) { @@ -2184,7 +1721,7 @@ Obj FuncOBJ_HANLDE ( ** *F FuncHANDLE_OBJ( , ) . . . . . . expert function 'HANDLE_OBJ' */ -Obj FuncHANLDE_OBJ ( +Obj FuncHANDLE_OBJ ( Obj self, Obj obj ) { @@ -2231,6 +1768,48 @@ Obj FuncSWAP_MPTR ( } +/**************************************************************************** +** +*F FuncIDENTS_GVAR( ) . . . . . . . . . . idents of global variables +*/ +Obj FuncIDENTS_GVAR ( + Obj self ) +{ + extern Obj NameGVars; + Obj copy; + UInt i; + + copy = NEW_PLIST( T_PLIST+IMMUTABLE, LEN_PLIST(NameGVars) ); + for ( i = 1; i <= LEN_PLIST(NameGVars); i++ ) { + SET_ELM_PLIST( copy, i, ELM_PLIST( NameGVars, i ) ); + } + SET_LEN_PLIST( copy, LEN_PLIST(NameGVars) ); + return copy; +} + + +/**************************************************************************** +** +*F FuncASS_GVAR( , , ) . . . . assign to a global variable +*/ +Obj FuncASS_GVAR ( + Obj self, + Obj gvar, + Obj val ) +{ + /* check the argument */ + while ( ! IsStringConv( gvar ) ) { + gvar = ErrorReturnObj( + "READ: must be a string (not a %s)", + (Int)(InfoBags[TYPE_OBJ(gvar)].name), 0L, + "you can return a string for " ); + } + + AssGVar( GVarName( CSTR_STRING(gvar) ), val ); + return 0L; +} + + /**************************************************************************** ** @@ -2391,6 +1970,10 @@ void InitGap ( SET_REVISION( "gvars_c", Revision_gvars_c ); SET_REVISION( "gvars_h", Revision_gvars_h ); + InitStreams(); + SET_REVISION( "gap_c", Revision_streams_c ); + SET_REVISION( "gap_h", Revision_streams_h ); + InitObjects(); SET_REVISION( "objects_c", Revision_objects_c ); SET_REVISION( "objects_h", Revision_objects_h ); @@ -2537,6 +2120,10 @@ void InitGap ( SET_REVISION( "read_c", Revision_read_c ); SET_REVISION( "read_h", Revision_read_h ); + InitSysFiles(); + SET_REVISION( "sysfiles_c", Revision_sysfiles_c ); + SET_REVISION( "sysfiles_h", Revision_sysfiles_h ); + /* and now for a special hack */ for ( i = LAST_CONSTANT_TYPE+1; i <= LAST_REAL_TYPE; i++ ) { @@ -2545,9 +2132,9 @@ void InitGap ( /* init the completion function */ - InitGlobalBag( &CompNowFuncs ); - InitGlobalBag( &CompThenFuncs ); - InitGlobalBag( &CompLists ); + InitGlobalBag( &CompNowFuncs, "gap: compnowfuncs" ); + InitGlobalBag( &CompThenFuncs,"gap: compthenfuncs" ); + InitGlobalBag( &CompLists, "gap: complists" ); CompLists = NEW_PLIST( T_PLIST, 0 ); SET_LEN_PLIST( CompLists, 0 ); @@ -2596,141 +2183,143 @@ void InitGap ( /* install the internal functions */ + InitHandlerFunc( FuncRuntime, "Runtime"); AssGVar( GVarName( "Runtime" ), NewFunctionC( "Runtime", 0L, "", FuncRuntime ) ); + InitHandlerFunc( SizeScreenHandler, "Size Screen"); AssGVar( GVarName( "SizeScreen" ), NewFunctionC( "SizeScreen", -1L, "args", SizeScreenHandler ) ); + InitHandlerFunc( FuncID_FUNC, "ID_FUNC"); AssGVar( GVarName( "ID_FUNC" ), NewFunctionC( "ID_FUNC", 1L, "object", FuncID_FUNC ) ); + AssGVar( GVarName( "ExportToKernelFinished" ), + NewFunctionC( "ExportToKernelFinished", 0L, "", + FuncExportToKernelFinished ) ); + /* install the print and error functions */ + InitHandlerFunc( FuncPrint, "Print"); AssGVar( GVarName( "Print" ), NewFunctionC( "Print", -1L, "args", FuncPrint ) ); + InitHandlerFunc( FuncDownEnv, "DownEnv"); AssGVar( GVarName( "DownEnv" ), NewFunctionC( "DownEnv", -1L, "", FuncDownEnv ) ); + InitHandlerFunc( FuncWhere, "Where"); AssGVar( GVarName( "Where" ), NewFunctionC( "Where", -1L, "", FuncWhere ) ); + InitHandlerFunc( FuncError, "Error"); AssGVar( GVarName( "Error" ), NewFunctionC( "Error", -1L, "args", FuncError ) ); /* install the functions for creating the init file */ + InitHandlerFunc( FuncCOM_FILE, "COM_FILE"); AssGVar( GVarName( "COM_FILE" ), NewFunctionC( "COM_FILE", 2L, "filename, crc", FuncCOM_FILE ) ); + InitHandlerFunc( FuncCOM_FUN, "COM_FUN"); AssGVar( GVarName( "COM_FUN" ), NewFunctionC( "COM_FUN", 1L, "number", FuncCOM_FUN ) ); + InitHandlerFunc( FuncMAKE_INIT, "MAKE_INIT"); AssGVar( GVarName( "MAKE_INIT" ), NewFunctionC( "MAKE_INIT", -1L, "output, input1, ...", FuncMAKE_INIT ) ); /* install functions for dynamically/statically loadable modules */ + InitHandlerFunc( FuncGAP_CRC, "GAP_CRC"); AssGVar( GVarName( "GAP_CRC" ), NewFunctionC( "GAP_CRC", 1L, "filename", FuncGAP_CRC ) ); + InitHandlerFunc( FuncLOAD_DYN, "LOAD_DYN"); AssGVar( GVarName( "LOAD_DYN" ), NewFunctionC( "LOAD_DYN", 2L, "filename, crc", FuncLOAD_DYN ) ); + InitHandlerFunc( FuncLOAD_STAT, "LOAD_STAT"); AssGVar( GVarName( "LOAD_STAT" ), NewFunctionC( "LOAD_STAT", 2L, "filename, crc", FuncLOAD_STAT ) ); + InitHandlerFunc( FuncSHOW_STAT, "SHOW_STAT"); AssGVar( GVarName( "SHOW_STAT" ), NewFunctionC( "SHOW_STAT", 0L, "", FuncSHOW_STAT ) ); - /* streams and files related functions */ - AssGVar( GVarName( "READ" ), - NewFunctionC( "READ", 1L, "filename", - FuncREAD ) ); - - AssGVar( GVarName( "READ_AS_FUNC" ), - NewFunctionC( "READ_AS_FUNC", 1L, "filename", - FuncREAD_AS_FUNC ) ); - - AssGVar( GVarName( "READ_GAP_ROOT" ), - NewFunctionC( "READ_GAP_ROOT", 1L, "filename", - FuncREAD_GAP_ROOT ) ); - - AssGVar( GVarName( "ReadTest" ), - NewFunctionC( "ReadTest", 1L, "filename", - FuncReadTest ) ); - - AssGVar( GVarName( "LogTo" ), - NewFunctionC( "LogTo", -1L, "args", - FuncLogTo ) ); - - AssGVar( GVarName( "IsExistingFile" ), - NewFunctionC( "IsExistingFile", 1L, "filename", - FuncIsExistingFile ) ); - - AssGVar( GVarName( "IsReadableFile" ), - NewFunctionC( "IsReadableFile", 1L, "filename", - FuncIsReadableFile ) ); - - AssGVar( GVarName( "IsWritableFile" ), - NewFunctionC( "IsWritableFile", 1L, "filename", - FuncIsWritableFile ) ); - - AssGVar( GVarName( "IsExecutableFile" ), - NewFunctionC( "IsExecutableFile", 1L, "filename", - FuncIsExecutableFile ) ); - + InitHandlerFunc( FuncExportToKernelFinished, "ExportToKernelFinished"); AssGVar( GVarName( "ExportToKernelFinished" ), NewFunctionC( "ExportToKernelFinished", 0L, "", FuncExportToKernelFinished ) ); /* debugging functions */ - AssGVar( GVarName( "GASMAN" ), - NewFunctionC( "GASMAN", -1L, "args", - FuncGASMAN ) ); - - AssGVar( GVarName( "SHALLOW_SIZE" ), - NewFunctionC( "SHALLOW_SIZE", 1L, "object", - FuncSHALLOW_SIZE ) ); - - AssGVar( GVarName( "TYPE_OBJ" ), - NewFunctionC( "TYPE_OBJ", 1L, "object", - FuncTYPE_OBJ ) ); - - AssGVar( GVarName( "XTYPE_OBJ" ), - NewFunctionC( "XTYPE_OBJ", 1L, "object", - FuncXTYPE_OBJ ) ); - - AssGVar( GVarName( "OBJ_HANDLE" ), - NewFunctionC( "OBJ_HANDLE", 1L, "object", - FuncOBJ_HANLDE ) ); - - AssGVar( GVarName( "HANDLE_OBJ" ), - NewFunctionC( "HANDLE_OBJ", 1L, "object", - FuncHANLDE_OBJ ) ); - - AssGVar( GVarName( "SWAP_MPTR" ), - NewFunctionC( "SWAP_MPTR", 2L, "obj1, obj2", - FuncSWAP_MPTR ) ); - - + InitHandlerFunc( FuncGASMAN, "GASMAN"); + AssGVar( GVarName( "GASMAN" ), + NewFunctionC( "GASMAN", -1L, "args", + FuncGASMAN ) ); + + InitHandlerFunc( FuncSHALLOW_SIZE, "SHALLOW_SIZE"); + AssGVar( GVarName( "SHALLOW_SIZE" ), + NewFunctionC( "SHALLOW_SIZE", 1L, "object", + FuncSHALLOW_SIZE ) ); + + InitHandlerFunc( FuncTYPE_OBJ, "TYPE_OBJ"); + AssGVar( GVarName( "TYPE_OBJ" ), + NewFunctionC( "TYPE_OBJ", 1L, "object", + FuncTYPE_OBJ ) ); + + InitHandlerFunc( FuncXTYPE_OBJ, "XTYPE_OBJ"); + AssGVar( GVarName( "XTYPE_OBJ" ), + NewFunctionC( "XTYPE_OBJ", 1L, "object", + FuncXTYPE_OBJ ) ); + + InitHandlerFunc( FuncOBJ_HANDLE, "OBJ_HANDLE"); + AssGVar( GVarName( "OBJ_HANDLE" ), + NewFunctionC( "OBJ_HANDLE", 1L, "object", + FuncOBJ_HANDLE ) ); + + InitHandlerFunc( FuncHANDLE_OBJ, "HANDLE_OBJ"); + AssGVar( GVarName( "HANDLE_OBJ" ), + NewFunctionC( "HANDLE_OBJ", 1L, "object", + FuncHANDLE_OBJ ) ); + + InitHandlerFunc( FuncSWAP_MPTR, "SWAP_MPTR"); + AssGVar( GVarName( "SWAP_MPTR" ), + NewFunctionC( "SWAP_MPTR", 2L, "obj1, obj2", + FuncSWAP_MPTR ) ); + + InitHandlerFunc( FuncIDENTS_GVAR, "IDENTS_GVAR"); + AssGVar( GVarName( "IDENTS_GVAR" ), + NewFunctionC( "IDENTS_GVAR", 0L, "", + FuncIDENTS_GVAR ) ); + + InitHandlerFunc( FuncASS_GVAR, "ASS_GVAR"); + AssGVar( GVarName( "ASS_GVAR" ), + NewFunctionC( "ASS_GVAR", 2L, "gvar, value", + FuncASS_GVAR ) ); + +#ifdef DEBUG_HANDLER_REGISTRATION + CheckAllHandlers(); +#endif + /* read the init files */ if ( SySystemInitFile[0] ) { if ( READ_GAP_ROOT(SySystemInitFile) == 0 ) { @@ -2773,3 +2362,9 @@ void InitGap ( *E gap.c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . ends here */ + + + + + + diff --git a/src/gap.h b/src/gap.h index dd7490d96d..22f51733af 100644 --- a/src/gap.h +++ b/src/gap.h @@ -14,6 +14,17 @@ char * Revision_gap_h = #endif +/**************************************************************************** +** + +*V Time . . . . . . . . . . . . . . . . . . . . . . global variable 'time' +** +** 'Time' is the global variable 'time', which is automatically assigned the +** time the last command took. +*/ +extern UInt Time; + + /**************************************************************************** ** diff --git a/src/gasman.c b/src/gasman.c index 652571e994..dd893603f2 100644 --- a/src/gasman.c +++ b/src/gasman.c @@ -123,6 +123,11 @@ char * Revision_gasman_c = #include "objects.h" /* Obj */ #include "scanner.h" /* Pr */ #include "code.h" /* T_LVARS */ +#else +#ifdef DEBUG_GLOBAL_BAGS +#include "objects.h" /* Obj */ +#include "scanner.h" /* Pr */ +#endif #endif @@ -509,37 +514,66 @@ void MarkAllSubBagsDefault ( } - /**************************************************************************** ** -*F InitGlobalBag() . . . . . inform Gasman about global bag identifier +*F CallbackForAllBags( ) call a C function on all non-zero mptrs +** +** This calls a C function on every bag, including garbage ones, by simply +** walking the masterpointer area. Not terribly safe ** -** 'InitGlobalBag' simply leaves the address in a global array, where -** it is used by 'CollectBags'. */ -#ifndef NR_GLOBAL_BAGS -#define NR_GLOBAL_BAGS 20000L -#endif +void CallbackForAllBags( + void (*func)() ) +{ + Bag ptr; + for (ptr = (Bag)MptrBags; ptr < (Bag)OldBags; ptr ++) + if (*ptr != 0) + { + (*func)(ptr); + } +} -typedef struct { - Bag * addr [NR_GLOBAL_BAGS]; - UInt nr; -} TypeGlobalBags; +/**************************************************************************** +** +*V GlobalBags . . . . . . . . . . . . . . . . . . . . . list of global bags +*/ TypeGlobalBags GlobalBags; +/**************************************************************************** +** +*F InitGlobalBag(, ) inform Gasman about global bag identifier +** +** 'InitGlobalBag' simply leaves the address in a global array, where +** it is used by 'CollectBags'. is also recorded to allow things to +** be matched up after loading a saved workspace. +*/ void InitGlobalBag ( - Bag * addr ) + Bag * addr, + Char * cookie ) { - extern TypeAbortFuncBags AbortFuncBags; + extern TypeAbortFuncBags AbortFuncBags; if ( GlobalBags.nr == NR_GLOBAL_BAGS ) { (*AbortFuncBags)( "Panic: Gasman cannot handle so many global variables" ); } - GlobalBags.addr[GlobalBags.nr++] = addr; +#ifdef DEBUG_GLOBAL_BAGS + { + UInt i; + for (i = 0; i < GlobalBags.nr; i++) + if ( 0 == SyStrcmp(GlobalBags.cookie[i], cookie) ) + if (GlobalBags.addr[i] == addr) + Pr("Duplicate global bag entry %s\n", (Int)cookie, 0L); + else + Pr("Duplicate global bag cookie %s\n", (Int)cookie, 0L); + } +#endif + GlobalBags.addr[GlobalBags.nr] = addr; + GlobalBags.cookie[GlobalBags.nr] = cookie; + GlobalBags.nr++; } @@ -1672,6 +1706,7 @@ void SwapMasterPoint ( } + /**************************************************************************** ** @@ -1688,8 +1723,7 @@ void SwapMasterPoint ( ** 'SET_ELM_BAG' are functions to support debugging. They are not intended ** to be used in an application using {\Gasman}. Note that the functions ** 'TYPE_BAG', 'SIZE_BAG', and 'PTR_BAG' shadow the macros of the same name, -** which are usually not available in a debugger. -*/ +** which are usually not available in a debugger. */ #ifdef DEBUG_FUNCTIONS_BAGS #undef TYPE_BAG diff --git a/src/gasman.h b/src/gasman.h index f8e1cd936c..252a3c5e2e 100644 --- a/src/gasman.h +++ b/src/gasman.h @@ -667,11 +667,29 @@ extern Bag MarkedBags; PTR_BAG(bag)[-1] = MarkedBags; MarkedBags = (bag); } +/**************************************************************************** +** +*V GlobalBags . . . . . . . . . . . . . . . . . . . . . list of global bags +*/ +#ifndef NR_GLOBAL_BAGS +#define NR_GLOBAL_BAGS 20000L +#endif + + +typedef struct { + Bag * addr [NR_GLOBAL_BAGS]; + Char * cookie [NR_GLOBAL_BAGS]; + UInt nr; +} TypeGlobalBags; + +extern TypeGlobalBags GlobalBags; + + /**************************************************************************** ** *F InitGlobalBag() . . . . . inform Gasman about global bag identifier ** -** 'InitGlobalBag( )' +** 'InitGlobalBag( , )' ** ** 'InitGlobalBag' informs {\Gasman} that there is a bag identifier at the ** address , which must be of type '(Bag\*)'. {\Gasman} will look at @@ -686,9 +704,15 @@ extern Bag MarkedBags; ** by default. If the application has more global variables that may hold ** bag identifier, you have to compile {\Gasman} with a higher value of ** 'NR_GLOBAL_BAGS', i.e., with 'make COPTS=-DNR_GLOBAL_BAGS='. +** +** is a C string, which should uniquely identify this global +** bag from all others. It is used in reconstructing the Workspace +** after a save and load */ + extern void InitGlobalBag ( - Bag * addr ); + Bag * addr, + Char * cookie ); /**************************************************************************** @@ -856,6 +880,17 @@ extern void InitBags ( UInt dirty, TypeAbortFuncBags abort_func ); +/**************************************************************************** +** +*F CallbackForAllBags( ) call a C function on all non-zero mptrs +** +** This calls a C function on every bag, including garbage ones, by simply +** walking the masterpointer area. Not terribly safe +** +*/ + +extern void CallbackForAllBags( + void (*func)() ); /**************************************************************************** diff --git a/src/gvars.c b/src/gvars.c index 2a8f8549d4..0a1e1e641e 100644 --- a/src/gvars.c +++ b/src/gvars.c @@ -29,11 +29,12 @@ char * Revision_gvars_c = "@(#)$Id$"; #include "system.h" /* Ints, UInts */ -#include "scanner.h" /* Pr */ -#include "gasman.h" /* NewBag, CHANGED_BAG */ +#include "gasman.h" /* NewBag, CHANGED_BAG */ #include "objects.h" /* Obj, TYPE_OBJ, SIZE_OBJ, ... */ +#include "scanner.h" /* Pr */ + #define INCLUDE_DECLARATION_PART #include "gvars.h" /* declaration part of the package */ #undef INCLUDE_DECLARATION_PART @@ -360,6 +361,28 @@ UInt GVarName ( return INT_INTOBJ(gvar); } +/**************************************************************************** +** +*V CopyAndFopyGVars . . kernel table of kernel copies and "fopies" of global +** variables +** +** This needs to be kept inside the kernel so that the copies can be updated +** after loading a workspace. +*/ + +typedef struct { + Obj * copy; + UInt isFopy; + Char * name; +} TypeCopyGVar; + +#ifndef MAX_COPY_AND_FOPY_GVARS +#define MAX_COPY_AND_FOPY_GVARS 4096 +#endif + +static TypeCopyGVar CopyAndFopyGVars[MAX_COPY_AND_FOPY_GVARS]; + +static NCopyAndFopyGVars = 0; /**************************************************************************** ** @@ -394,6 +417,17 @@ void InitCopyGVar ( /* now copy the value of to */ *copy = VAL_GVAR(gvar); + + /* make a record in the kernel also, for saving and loading */ + if (NCopyAndFopyGVars >= MAX_COPY_AND_FOPY_GVARS) + { + Pr("No room to record CopyGVar\n",0L,0L); + SyExit(1); + } + CopyAndFopyGVars[NCopyAndFopyGVars].copy = copy; + CopyAndFopyGVars[NCopyAndFopyGVars].isFopy = 0; + CopyAndFopyGVars[NCopyAndFopyGVars].name = NameGVar(gvar); + NCopyAndFopyGVars++; } @@ -444,6 +478,17 @@ void InitFopyGVar ( else { *copy = ErrorMustHaveAssObjFunc; } + + /* make a record in the kernel also, for saving and loading */ + if (NCopyAndFopyGVars >= MAX_COPY_AND_FOPY_GVARS) + { + Pr("No room to record FopyGVar\n",0L,0L); + SyExit(1); + } + CopyAndFopyGVars[NCopyAndFopyGVars].copy = copy; + CopyAndFopyGVars[NCopyAndFopyGVars].isFopy = 1; + CopyAndFopyGVars[NCopyAndFopyGVars].name = NameGVar(gvar); + NCopyAndFopyGVars++; } @@ -457,7 +502,21 @@ void InitFopyGVar ( ** Actually when such expressions appear in functions, one should probably ** use a local variable. But for now this is good enough. */ -UInt Tilde; +UInt Tilde; + + +/**************************************************************************** +** +*F MakeReadOnlyGVar( ) . . . . . . make a global variable read only +*/ +Obj MakeReadOnlyGVarFunc; + +Obj MakeReadOnlyGVar ( + UInt gvar ) +{ + SET_ELM_PLIST( WriteGVars, gvar, INTOBJ_INT(0) ); + CHANGED_BAG(WriteGVars) +} /**************************************************************************** @@ -471,14 +530,10 @@ UInt Tilde; ** 'MakeReadOnlyGVar' make the global variable with the name (which ** must be a GAP string) read only. */ -Obj MakeReadOnlyGVarFunc; - -Obj MakeReadOnlyGVarHandler ( +Obj MakeReadOnlyGVarHandler ( Obj self, Obj name ) { - UInt gvar; /* the global variable */ - /* check the argument */ while ( ! IsStringConv( name ) ) { name = ErrorReturnObj( @@ -488,15 +543,27 @@ Obj MakeReadOnlyGVarHandler ( } /* get the variable and make it read only */ - gvar = GVarName( CSTR_STRING(name) ); - SET_ELM_PLIST( WriteGVars, gvar, INTOBJ_INT(0) ); - CHANGED_BAG(WriteGVars) + MakeReadOnlyGVar(GVarName(CSTR_STRING(name))); /* return void */ return 0; } +/**************************************************************************** +** +*F MakeReadWriteGVar( ) . . . . . . make a global variable read write +*/ +Obj MakeReadWriteGVarFunc; + +Obj MakeReadWriteGVar ( + UInt gvar ) +{ + SET_ELM_PLIST( WriteGVars, gvar, INTOBJ_INT(1) ); + CHANGED_BAG(WriteGVars) +} + + /**************************************************************************** ** *F MakeReadWriteGVarHandler(,) make a global variable read write @@ -508,14 +575,10 @@ Obj MakeReadOnlyGVarHandler ( ** 'MakeReadWriteGVar' make the global variable with the name (which ** must be a GAP string) read and writable. */ -Obj MakeReadWriteGVarFunc; - -Obj MakeReadWriteGVarHandler ( +Obj MakeReadWriteGVarHandler ( Obj self, Obj name ) { - UInt gvar; /* the global variable */ - /* check the argument */ while ( ! IsStringConv( name ) ) { name = ErrorReturnObj( @@ -525,8 +588,7 @@ Obj MakeReadWriteGVarHandler ( } /* get the variable and make it read write */ - gvar = GVarName( CSTR_STRING(name) ); - SET_ELM_PLIST( WriteGVars, gvar, INTOBJ_INT(1) ); + MakeReadWriteGVar(GVarName(CSTR_STRING(name))); /* return void */ return 0; @@ -666,38 +728,43 @@ UInt completion_gvar ( void InitGVars ( void ) { /* make the error functions for 'AssGVar' */ - InitGlobalBag( &ErrorMustEvalToFuncFunc ); + InitGlobalBag( &ErrorMustEvalToFuncFunc, "gvars: error function 1" ); + InitHandlerFunc( ErrorMustEvalToFuncHandler, + "error must evaluate to a function"); ErrorMustEvalToFuncFunc = NewFunctionC( "ErrorMustEvalToFunc", -1L,"args", ErrorMustEvalToFuncHandler ); - InitGlobalBag( &ErrorMustHaveAssObjFunc ); + + InitGlobalBag( &ErrorMustHaveAssObjFunc, "gvars: error function 2" ); + InitHandlerFunc( ErrorMustHaveAssObjHandler, + "error must have associated object"); ErrorMustHaveAssObjFunc = NewFunctionC( "ErrorMustHaveAssObj", -1L,"args", ErrorMustHaveAssObjHandler ); /* make the lists for global variables */ CountGVars = 0; - InitGlobalBag( &ValGVars ); + InitGlobalBag( &ValGVars, "gvars: values" ); ValGVars = NEW_PLIST( T_PLIST, 0 ); SET_LEN_PLIST( ValGVars, 0 ); PtrGVars = ADDR_OBJ( ValGVars ); - InitGlobalBag( &NameGVars ); + InitGlobalBag( &NameGVars, "gvars: names" ); NameGVars = NEW_PLIST( T_PLIST, 0 ); SET_LEN_PLIST( NameGVars, 0 ); - InitGlobalBag( &WriteGVars ); + InitGlobalBag( &WriteGVars, "gvars: writable flags" ); WriteGVars = NEW_PLIST( T_PLIST, 0 ); SET_LEN_PLIST( WriteGVars, 0 ); - InitGlobalBag( &ExprGVars ); + InitGlobalBag( &ExprGVars, "gvars: expressions for AUTO" ); ExprGVars = NEW_PLIST( T_PLIST, 0 ); SET_LEN_PLIST( ExprGVars, 0 ); - InitGlobalBag( &CopiesGVars ); + InitGlobalBag( &CopiesGVars, "gvars: kernel copies" ); CopiesGVars = NEW_PLIST( T_PLIST, 0 ); SET_LEN_PLIST( CopiesGVars, 0 ); - InitGlobalBag( &FopiesGVars ); + InitGlobalBag( &FopiesGVars, "gvars: kernel fopies" ); FopiesGVars = NEW_PLIST( T_PLIST, 0 ); SET_LEN_PLIST( FopiesGVars, 0 ); /* make the list of global variables */ SizeGVars = 997; - InitGlobalBag( &TableGVars ); + InitGlobalBag( &TableGVars, "gvars: hash tables" ); TableGVars = NEW_PLIST( T_PLIST, SizeGVars ); SET_LEN_PLIST( TableGVars, SizeGVars ); @@ -705,14 +772,18 @@ void InitGVars ( void ) Tilde = GVarName( "~" ); /* install the functions 'MakeReadOnlyGVar' and 'MakeReadWriteGVar' */ + InitHandlerFunc( MakeReadOnlyGVarHandler, "make gvar read only"); MakeReadOnlyGVarFunc = NewFunctionC( "MakeReadOnlyGVar", 1L, "name", MakeReadOnlyGVarHandler ); AssGVar( GVarName( "MakeReadOnlyGVar" ), MakeReadOnlyGVarFunc ); + + InitHandlerFunc( MakeReadWriteGVarHandler, "make gvar read write"); MakeReadWriteGVarFunc = NewFunctionC( "MakeReadWriteGVar", 1L, "name", MakeReadWriteGVarHandler ); AssGVar( GVarName( "MakeReadWriteGVar" ), MakeReadWriteGVarFunc ); /* install the function 'AUTO' */ + InitHandlerFunc( AUTOHandler, "AUTO"); AUTOFunc = NewFunctionC( "AUTO", -1L, "args", AUTOHandler ); AssGVar( GVarName( "AUTO" ), AUTOFunc ); } diff --git a/src/gvars.h b/src/gvars.h index e2886ed068..0686a444f8 100644 --- a/src/gvars.h +++ b/src/gvars.h @@ -171,6 +171,24 @@ extern void InitFopyGVar ( extern UInt Tilde; +/**************************************************************************** +** +*F iscomplete_gvar( , ) . . . . . . . . . . . . . check +*/ +extern UInt iscomplete_gvar ( + Char * name, + UInt len ); + + +/**************************************************************************** +** +*F completion_gvar( , ) . . . . . . . . . . . . find completion +*/ +extern UInt completion_gvar ( + Char * name, + UInt len ); + + /**************************************************************************** ** *F InitGVars() . . . . . . . . . . . initialize the global variables package diff --git a/src/integer.c b/src/integer.c index af369c4b4a..d9d7df8adc 100644 --- a/src/integer.c +++ b/src/integer.c @@ -85,10 +85,11 @@ char * Revision_integer_c = "@(#)$Id$"; #include "system.h" /* Ints, UInts */ -#include "scanner.h" /* Pr */ -#include "gasman.h" /* NewBag, CHANGED_BAG */ +#include "gasman.h" /* NewBag, CHANGED_BAG */ #include "objects.h" /* Obj, TYPE_OBJ, types */ +#include "scanner.h" /* Pr */ + #include "gvars.h" /* AssGVar, GVarName */ #include "calls.h" /* NewFunctionC */ @@ -2567,20 +2568,29 @@ void InitInt ( void ) /* install the internal function */ + InitHandlerFunc( IsIntHandler, "IS_INT" ); IsIntFilt = NewFilterC( "IS_INT", 1L, "obj", IsIntHandler ); AssGVar( GVarName( "IS_INT" ), IsIntFilt ); + + InitHandlerFunc( FuncQuoInt, "QUO_INT"); AssGVar( GVarName( "QUO_INT" ), NewFunctionC( "QUO_INT", 2L, "int1, int2", FuncQuoInt ) ); + + InitHandlerFunc( FuncRemInt, "REM_INT"); AssGVar( GVarName( "REM_INT" ), NewFunctionC( "REM_INT", 2L, "int1, int2", FuncRemInt ) ); + + InitHandlerFunc( FuncGcdInt, "GCD_INT"); AssGVar( GVarName( "GCD_INT" ), NewFunctionC( "GCD_INT", 2L, "int1, int2", FuncGcdInt ) ); + InitHandlerFunc( ProdIntObjHandler, "PROD_INT_OBJ"); ProdIntObjFunc = NewFunctionC( "PROD_INT_OBJ", 2L, "n, op", ProdIntObjHandler ); AssGVar( GVarName( "PROD_INT_OBJ" ), ProdIntObjFunc ); + InitHandlerFunc( PowObjIntHandler, "POW_OBJ_INT"); PowObjIntFunc = NewFunctionC( "POW_OBJ_INT", 2L, "op, n", PowObjIntHandler ); AssGVar( GVarName( "POW_OBJ_INT" ), PowObjIntFunc ); diff --git a/src/intrprtr.c b/src/intrprtr.c index 5c7f6d3322..be925b5356 100644 --- a/src/intrprtr.c +++ b/src/intrprtr.c @@ -20,10 +20,11 @@ char * Revision_intrprtr_c = #include /* assert */ #include "system.h" /* Ints, UInts */ -#include "scanner.h" /* Pr */ -#include "gasman.h" /* NewBag, CHANGED_BAG */ +#include "gasman.h" /* NewBag, CHANGED_BAG */ #include "objects.h" /* Obj, TYPE_OBJ, types */ +#include "scanner.h" /* Pr */ + #include "gvars.h" /* Tilde, VAL_GVAR, AssGVar */ #include "calls.h" /* generic call mechanism */ @@ -3942,9 +3943,9 @@ void InitIntrprtr ( void ) { UInt lev; - InitGlobalBag( &IntrResult ); - InitGlobalBag( &IntrState ); - InitGlobalBag( &StackObj ); + InitGlobalBag( &IntrResult, "interpreter: result" ); + InitGlobalBag( &IntrState, "interpreter: state" ); + InitGlobalBag( &StackObj, "interpreter: object stack" ); /* The work of handling Info messages is delegated to the GAP level */ ImportFuncFromLibrary( "InfoDecision", &InfoDecision ); diff --git a/src/listfunc.c b/src/listfunc.c index c42b27b000..814e1a01af 100644 --- a/src/listfunc.c +++ b/src/listfunc.c @@ -12,10 +12,11 @@ char * Revision_listfunc_c = "@(#)$Id$"; #include "system.h" /* Ints, UInts */ -#include "scanner.h" /* Pr */ -#include "gasman.h" /* NewBag, CHANGED_BAG */ +#include "gasman.h" /* NewBag, CHANGED_BAG */ #include "objects.h" /* Obj, TYPE_OBJ, types */ +#include "scanner.h" /* Pr */ + #include "gvars.h" /* AssGVar, GVarName */ #include "calls.h" /* Function */ @@ -961,23 +962,27 @@ void InitListFunc ( void ) DepthVectorFuncs[ T_PLIST_CYC_SSORT ] = DepthListx; /* install the internal functions */ + InitHandlerFunc( AddListHandler, "ADD_LIST" ); AddListOper = NewOperationC( "ADD_LIST", 2L, "list, val", AddListHandler ); AssGVar( GVarName( "ADD_LIST" ), AddListOper ); + InitHandlerFunc( AppendListIntrHandler, "APPEND_LIST_INTR"); AppendListIntrFunc = NewFunctionC( "APPEND_LIST_INTR", 2L, "list1, list2", AppendListIntrHandler ); AssGVar( GVarName( "APPEND_LIST_INTR" ), AppendListIntrFunc ); /* make and install the 'POSITION_SORTED_LIST' function */ + InitHandlerFunc( PositionSortedListHandler, "POSITION_SORTED_LIST"); PositionSortedListFunc = NewFunctionC( "POSITION_SORTED_LIST", 2L, "list, obj", PositionSortedListHandler ); AssGVar( GVarName( "POSITION_SORTED_LIST" ), PositionSortedListFunc ); /* make and install the 'POSITION_SORTED_LIST_COMP' function */ + InitHandlerFunc( PositionSortedListCompHandler, "POSITION_SORTED_LIST_COMP"); PositionSortedListCompFunc = NewFunctionC( "POSITION_SORTED_LIST_COMP", 3L, "list, obj, func", PositionSortedListCompHandler ); @@ -985,38 +990,48 @@ void InitListFunc ( void ) PositionSortedListCompFunc ); /* make and install the 'SORT_LIST' function */ + InitHandlerFunc( SortListHandler, "SORT_LIST"); SortListFunc = NewFunctionC( "SORT_LIST", 1L, "list", SortListHandler ); AssGVar( GVarName( "SORT_LIST" ), SortListFunc ); /* make and install the 'SORT_LIST_COMP' function */ + InitHandlerFunc( SortListCompHandler, "SORT_LIST_COMP"); SortListCompFunc = NewFunctionC( "SORT_LIST_COMP", 2L, "list, func", SortListCompHandler ); AssGVar( GVarName( "SORT_LIST_COMP" ), SortListCompFunc ); + InitHandlerFunc( FuncOnPoints, "OnPoints"); AssGVar( GVarName( "OnPoints" ), NewFunctionC( "OnPoints", 2L, "pnt, elm", FuncOnPoints ) ); + InitHandlerFunc( FuncOnPairs, "OnPairs"); AssGVar( GVarName( "OnPairs" ), NewFunctionC( "OnPairs", 2L, "pair, elm", FuncOnPairs ) ); + InitHandlerFunc( FuncOnTuples, "OnTuples"); AssGVar( GVarName( "OnTuples" ), NewFunctionC( "OnTuples", 2L, "tuple, elm", FuncOnTuples ) ); + InitHandlerFunc( FuncOnSets, "OnSets"); AssGVar( GVarName( "OnSets" ), NewFunctionC( "OnSets", 2L, "set, elm", FuncOnSets ) ); + InitHandlerFunc( FuncOnRight, "OnRight"); AssGVar( GVarName( "OnRight" ), NewFunctionC( "OnRight", 2L, "pnt, elm", FuncOnRight ) ); + InitHandlerFunc( FuncOnLeft, "OnLeftAntiOperation"); AssGVar( GVarName( "OnLeftAntiOperation" ), - NewFunctionC( "OnLeft", 2L, "pnt, elm", + NewFunctionC( "OnLeftAntiOperation", 2L, "pnt, elm", FuncOnLeft ) ); + InitHandlerFunc( FuncOnLeftInverse, "OnLeftInverse"); AssGVar( GVarName( "OnLeftInverse" ), - NewFunctionC( "OnLeft", 2L, "pnt, elm", + NewFunctionC( "OnLeftInverse", 2L, "pnt, elm", FuncOnLeftInverse ) ); + InitHandlerFunc( DepthVectorHandler, "Depthvector"); AssGVar( GVarName( "DepthVector" ), NewFunctionC( "DepthVector", 1L, "list", DepthVectorHandler ) ); diff --git a/src/listoper.c b/src/listoper.c index 17116112d6..d4d19c0504 100644 --- a/src/listoper.c +++ b/src/listoper.c @@ -13,10 +13,11 @@ char * Revision_listoper_c = "@(#)$Id$"; #include "system.h" /* Ints, UInts */ -#include "scanner.h" /* Pr */ -#include "gasman.h" /* NewBag, CHANGED_BAG */ +#include "gasman.h" /* NewBag, CHANGED_BAG */ #include "objects.h" /* Obj, TYPE_OBJ, types */ +#include "scanner.h" /* Pr */ + #include "gvars.h" /* AssGVar, GVarName */ #include "calls.h" /* NewFunctionC */ @@ -1254,70 +1255,87 @@ void InitListOper ( void ) } } + InitHandlerFunc( EqListListHandler, "EQ_LIST_LIST_DEFAULT"); EqListListFunc = NewFunctionC( "EQ_LIST_LIST_DEFAULT", 2L, "listL, listR", EqListListHandler ); AssGVar( GVarName( "EQ_LIST_LIST_DEFAULT" ), EqListListFunc ); + InitHandlerFunc( LtListListHandler, "LT_LIST_LIST_DEFAULT"); LtListListFunc = NewFunctionC( "LT_LIST_LIST_DEFAULT", 2L, "listL, listR", LtListListHandler ); AssGVar( GVarName( "LT_LIST_LIST_DEFAULT" ), LtListListFunc ); + InitHandlerFunc( InListDefaultHandler, "IN_LIST_DEFAULT"); InListDefaultFunc = NewFunctionC( "IN_LIST_DEFAULT", 2L, "obj, list", InListDefaultHandler ); AssGVar( GVarName( "IN_LIST_DEFAULT" ), InListDefaultFunc ); + InitHandlerFunc( SumSclListHandler, "SUM_SCL_LIST_DEFAULT"); SumSclListFunc = NewFunctionC( "SUM_SCL_LIST_DEFAULT", 2L, "listL, listR", SumSclListHandler ); AssGVar( GVarName( "SUM_SCL_LIST_DEFAULT" ), SumSclListFunc ); + InitHandlerFunc( SumListSclHandler, "SUM_LIST_SCL_DEFAULT"); SumListSclFunc = NewFunctionC( "SUM_LIST_SCL_DEFAULT", 2L, "listL, listR", SumListSclHandler ); AssGVar( GVarName( "SUM_LIST_SCL_DEFAULT" ), SumListSclFunc ); + InitHandlerFunc( SumListListHandler, "SUM_LIST_LIST_DEFAULT"); SumListListFunc = NewFunctionC( "SUM_LIST_LIST_DEFAULT", 2L, "listL, listR", SumListListHandler ); AssGVar( GVarName( "SUM_LIST_LIST_DEFAULT" ), SumListListFunc ); + InitHandlerFunc( ZeroListDefaultHandler, "ZERO_LIST_DEFAULT"); ZeroListDefaultFunc = NewFunctionC( "ZERO_LIST_DEFAULT", 1L, "list", ZeroListDefaultHandler ); AssGVar( GVarName( "ZERO_LIST_DEFAULT" ), ZeroListDefaultFunc ); + InitHandlerFunc( AInvListDefaultHandler, "AINV_LIST_DEFAULT"); AInvListDefaultFunc = NewFunctionC( "AINV_LIST_DEFAULT", 1L, "list", AInvListDefaultHandler ); AssGVar( GVarName( "AINV_LIST_DEFAULT" ), AInvListDefaultFunc ); + InitHandlerFunc( DiffSclListHandler, "DIFF_SCL_LIST_DEFAULT"); DiffSclListFunc = NewFunctionC( "DIFF_SCL_LIST_DEFAULT", 2L, "listL, listR", DiffSclListHandler ); AssGVar( GVarName( "DIFF_SCL_LIST_DEFAULT" ), DiffSclListFunc ); + InitHandlerFunc( DiffListSclHandler, "DIFF_LIST_SCL_DEFAULT"); DiffListSclFunc = NewFunctionC( "DIFF_LIST_SCL_DEFAULT", 2L, "listL, listR", DiffListSclHandler ); AssGVar( GVarName( "DIFF_LIST_SCL_DEFAULT" ), DiffListSclFunc ); + InitHandlerFunc( DiffListListHandler, "DIFF_LIST_LIST_DEFAULT"); DiffListListFunc = NewFunctionC( "DIFF_LIST_LIST_DEFAULT", 2L, "listL, listR", DiffListListHandler ); AssGVar( GVarName( "DIFF_LIST_LIST_DEFAULT" ), DiffListListFunc ); + InitHandlerFunc( ProdSclListHandler, "PROD_SCL_LIST_DEFAULT"); ProdSclListFunc = NewFunctionC( "PROD_SCL_LIST_DEFAULT", 2L, "listL, listR", ProdSclListHandler ); AssGVar( GVarName( "PROD_SCL_LIST_DEFAULT" ), ProdSclListFunc ); + InitHandlerFunc( ProdListSclHandler, "PROD_LIST_SCL_DEFAULT"); ProdListSclFunc = NewFunctionC( "PROD_LIST_SCL_DEFAULT", 2L, "listL, listR", ProdListSclHandler ); AssGVar( GVarName( "PROD_LIST_SCL_DEFAULT" ), ProdListSclFunc ); + InitHandlerFunc( ProdListListHandler, "PROD_LIST_LIST_DEFAULT"); ProdListListFunc = NewFunctionC( "PROD_LIST_LIST_DEFAULT", 2L, "listL, listR", ProdListListHandler ); AssGVar( GVarName( "PROD_LIST_LIST_DEFAULT" ), ProdListListFunc ); + InitHandlerFunc( OneMatrixHandler, "ONE_MATRIX"); OneMatrixFunc = NewFunctionC( "ONE_MATRIX", 1L, "list", OneMatrixHandler ); AssGVar( GVarName( "ONE_MATRIX" ), OneMatrixFunc ); + InitHandlerFunc( InvMatrixHandler, "INV_MATRIX"); InvMatrixFunc = NewFunctionC( "INV_MATRIX", 1L, "list", InvMatrixHandler ); AssGVar( GVarName( "INV_MATRIX" ), InvMatrixFunc ); + InitHandlerFunc( PowMatrixIntHandler, "POW_MATRIX_INT"); InvMatrixFunc = NewFunctionC( "POW_MATRIX_INT", 2L, "list, int", PowMatrixIntHandler ); AssGVar( GVarName( "POW_MATRIX_INT" ), PowMatrixIntFunc ); diff --git a/src/lists.c b/src/lists.c index b4dec61734..44bec0f867 100644 --- a/src/lists.c +++ b/src/lists.c @@ -22,10 +22,11 @@ char * Revision_lists_c = "@(#)$Id$"; #include "system.h" /* Ints, UInts */ -#include "scanner.h" /* Pr */ -#include "gasman.h" /* NewBag, CHANGED_BAG */ +#include "gasman.h" /* NewBag, CHANGED_BAG */ #include "objects.h" /* Obj, TYPE_OBJ, SIZE_OBJ, ... */ +#include "scanner.h" /* Pr */ + #include "gvars.h" /* AssGVar, GVarName */ #include "calls.h" /* ObjFunc */ @@ -1736,6 +1737,7 @@ void InitLists () UInt type; /* loop variable */ /* make and install the 'IS_LIST' filter */ + InitHandlerFunc( IsListHandler, "IS_LIST" ); IsListFilt = NewFilterC( "IS_LIST", 1L, "obj", IsListHandler ); AssGVar( GVarName( "IS_LIST" ), IsListFilt ); @@ -1750,6 +1752,7 @@ void InitLists () } /* make and install the 'LEN_LIST' operation */ + InitHandlerFunc( LenListHandler, "LEN_LIST" ); LenListAttr = NewAttributeC( "LEN_LIST", 1L, "list", LenListHandler ); AssGVar( GVarName( "LEN_LIST" ), LenListAttr ); @@ -1761,6 +1764,7 @@ void InitLists () } /* make and install the 'ISB_LIST' operation */ + InitHandlerFunc( IsbListHandler, "ISB_LIST" ); IsbListOper = NewOperationC( "ISB_LIST", 2L, "list, pos", IsbListHandler ); AssGVar( GVarName( "ISB_LIST" ), IsbListOper ); @@ -1774,6 +1778,7 @@ void InitLists () } /* make and install the 'ELM0_LIST' operation */ + InitHandlerFunc( Elm0ListHandler, "ELM0_LIST" ); Elm0ListOper = NewOperationC( "ELM0_LIST", 2L, "list, pos", Elm0ListHandler ); AssGVar( GVarName( "ELM0_LIST" ), Elm0ListOper ); @@ -1787,6 +1792,7 @@ void InitLists () } /* make and install the 'ELM_LIST' operation */ + InitHandlerFunc( ElmListHandler, "ELM_LIST" ); ElmListOper = NewOperationC( "ELM_LIST", 2L, "list, pos", ElmListHandler ); AssGVar( GVarName( "ELM_LIST" ), ElmListOper ); @@ -1802,6 +1808,7 @@ void InitLists () } /* make and install the 'ELMS_LIST' operation */ + InitHandlerFunc( ElmsListHandler, "ELMS_LIST" ); ElmsListOper = NewOperationC( "ELMS_LIST", 2L, "list, poss", ElmsListHandler ); AssGVar( GVarName( "ELMS_LIST" ), ElmsListOper ); @@ -1814,11 +1821,15 @@ void InitLists () for ( type = FIRST_EXTERNAL_TYPE; type <= LAST_EXTERNAL_TYPE; type++ ) { ElmsListFuncs[ type ] = ElmsListObject; } + + + InitHandlerFunc( ElmsListDefaultHandler, "ELMS_LIST_DEFAULT"); ElmsListDefaultFunc = NewFunctionC( - "ELMS_LIST_DEFAULT", 2L, "list, poss", ElmsListDefaultHandler ); + "ELMS_LIST_DEFAULT", 2L, "list, poss", ElmsListDefaultHandler ); AssGVar( GVarName( "ELMS_LIST_DEFAULT" ), ElmsListDefaultFunc ); /* make and install the 'UNB_LIST' operation */ + InitHandlerFunc( UnbListHandler, "UNB_LIST" ); UnbListOper = NewOperationC( "UNB_LIST", 2L, "list, pos", UnbListHandler ); AssGVar( GVarName( "UNB_LIST" ), UnbListOper ); @@ -1833,6 +1844,7 @@ void InitLists () } /* make and install the 'ASS_LIST' operation */ + InitHandlerFunc( AssListHandler, "ASS_LIST" ); AssListOper = NewOperationC( "ASS_LIST", 3L, "list, pos, obj", AssListHandler ); AssGVar( GVarName( "ASS_LIST" ), AssListOper ); @@ -1847,6 +1859,7 @@ void InitLists () } /* make and install the 'ASSS_LIST' operation */ + InitHandlerFunc( AsssListHandler, "ASSS_LIST" ); AsssListOper = NewOperationC( "ASSS_LIST", 3L, "list, poss, objs", AsssListHandler ); AssGVar( GVarName( "ASSS_LIST" ), AsssListOper ); @@ -1859,11 +1872,14 @@ void InitLists () for ( type = FIRST_EXTERNAL_TYPE; type <= LAST_EXTERNAL_TYPE; type++ ) { AsssListFuncs[ type ] = AsssListObject; } + + InitHandlerFunc( AsssListDefaultHandler, "ASSS_LIST_DEFAULT"); AsssListDefaultFunc = NewFunctionC( "ASSS_LIST_DEFAULT", 3L, "list, poss, objs", AsssListDefaultHandler ); AssGVar( GVarName( "ASSS_LIST_DEFAULT" ), AsssListDefaultFunc ); /* make and install the 'IS_DENSE_LIST' filter */ + InitHandlerFunc( IsDenseListHandler, "IS_DENSE_LIST" ); IsDenseListFilt = NewFilterC( "IS_DENSE_LIST", 1L, "obj", IsDenseListHandler ); AssGVar( GVarName( "IS_DENSE_LIST" ), IsDenseListFilt ); @@ -1878,6 +1894,7 @@ void InitLists () } /* make and install the 'IS_HOMOG_LIST' filter */ + InitHandlerFunc( IsHomogListHandler, "IS_HOMOG_LIST" ); IsHomogListFilt = NewFilterC( "IS_HOMOG_LIST", 1L, "obj", IsHomogListHandler ); AssGVar( GVarName( "IS_HOMOG_LIST" ), IsHomogListFilt ); @@ -1892,6 +1909,7 @@ void InitLists () } /* make and install the 'IS_TABLE_LIST' filter */ + InitHandlerFunc( IsTableListHandler, "IS_TABLE_LIST" ); IsTableListFilt = NewFilterC( "IS_TABLE_LIST", 1L, "obj", IsTableListHandler ); AssGVar( GVarName( "IS_TABLE_LIST" ), IsTableListFilt ); @@ -1906,6 +1924,7 @@ void InitLists () } /* make and install the 'IS_SSORT_LIST' property */ + InitHandlerFunc( IsSSortListHandler, "IS_SSORT_LIST" ); IsSSortListProp = NewPropertyC( "IS_SSORT_LIST", 1L, "obj", IsSSortListHandler ); AssGVar( GVarName( "IS_SSORT_LIST" ), IsSSortListProp ); @@ -1918,15 +1937,20 @@ void InitLists () for ( type = FIRST_EXTERNAL_TYPE; type <= LAST_EXTERNAL_TYPE; type++ ) { IsSSortListFuncs[ type ] = IsSSortListObject; } + + InitHandlerFunc( IsSSortListDefaultHandler, "IS_SSORT_LIST_DEFAULT"); IsSSortListDefaultFunc = NewFunctionC( "IS_SSORT_LIST_DEFAULT",1L,"obj", IsSSortListDefaultHandler ); AssGVar( GVarName( "IS_SSORT_LIST_DEFAULT" ), IsSSortListDefaultFunc ); /* make and install the 'IS_NSORT_LIST' property */ + InitHandlerFunc( IsNSortListHandler, "IS_NSORT_LIST" ); IsNSortListProp = NewPropertyC( "IS_NSORT_LIST", 1L, "obj", IsNSortListHandler ); + AssGVar( GVarName( "IS_NSORT_LIST" ), IsNSortListProp ); /* make and install the 'IS_POSS_LIST' property */ + InitHandlerFunc( IsPossListHandler, "IS_POSS_LIST" ); IsPossListProp = NewPropertyC( "IS_POSS_LIST", 1L, "obj", IsPossListHandler ); AssGVar( GVarName( "IS_POSS_LIST" ), IsPossListProp ); @@ -1939,11 +1963,15 @@ void InitLists () for ( type = FIRST_EXTERNAL_TYPE; type <= LAST_EXTERNAL_TYPE; type++ ) { IsPossListFuncs[ type ] = IsPossListObject; } + + InitHandlerFunc( IsPossListDefaultHandler, "IS_POSS_LIST_DEFAULT"); IsPossListDefaultFunc = NewFunctionC( "IS_POSS_LIST_DEFAULT",1L,"obj", IsPossListDefaultHandler ); AssGVar( GVarName( "IS_POSS_LIST_DEFAULT" ), IsPossListDefaultFunc ); - /* make and install the 'POS_LIST' operation */ + /* make and install the 'POS_LIST' operation */ + InitHandlerFunc( PosListHandler2, "POS_LIST 2 args" ); + InitHandlerFunc( PosListHandler3, "POS_LIST 3 args" ); PosListOper = NewOperationC( "POS_LIST", -1, "list, obj", DoOperation0Args ); HDLR_FUNC( PosListOper, 2 ) = PosListHandler2; @@ -1958,6 +1986,8 @@ void InitLists () for ( type = FIRST_EXTERNAL_TYPE; type <= LAST_EXTERNAL_TYPE; type++ ) { PosListFuncs[ type ] = PosListObject; } + + InitHandlerFunc( PosListDefaultHandler, "POS_LIST_DEFAULT"); PosListDefaultFunc = NewFunctionC( "POS_LIST_DEFAULT", 3L, "list, obj, start", PosListDefaultHandler ); AssGVar( GVarName( "POS_LIST_DEFAULT" ), PosListDefaultFunc ); diff --git a/src/objcftl.c b/src/objcftl.c index a498324866..79f81b9ae6 100644 --- a/src/objcftl.c +++ b/src/objcftl.c @@ -3,14 +3,14 @@ *A pcc.c GAP source Werner Nickel ** ** -** This file contains a collector from thye left for polycyclic +** This file contains a collector from the left for polycyclic ** presentations. */ #include "system.h" -#include "scanner.h" #include "gasman.h" #include "objects.h" +#include "scanner.h" #include "plist.h" #include "gvars.h" #include "calls.h" @@ -411,9 +411,13 @@ void InitPcc ( void ) { AssGVar( GVarName( "PC_DEFAULT_KIND" ), INTOBJ_INT( PC_DEFAULT_KIND ) ); /* Install internal functions. */ + + InitHandlerFunc( FuncCollectPolycyc, "CollectPolycyclic"); AssGVar( GVarName( "CollectPolycyclic" ), NewFunctionC( "CollectPolycyclic", 3L, "pcp, list, word", FuncCollectPolycyc ) ); + + InitHandlerFunc( FunBinaryPower, "BinaryPower"); AssGVar( GVarName( "BinaryPower" ), NewFunctionC( "BinaryPower", 3L, "pcp, word, exponent", FunBinaryPower ) ); diff --git a/src/objects.c b/src/objects.c index 6fd43b4bdf..727bb1df3d 100644 --- a/src/objects.c +++ b/src/objects.c @@ -12,13 +12,14 @@ char * Revision_objects_c = "@(#)$Id$"; #include "system.h" /* Ints, UInts, SyIsIntr */ -#include "scanner.h" /* Pr */ #include "gasman.h" /* Retype */ #define INCLUDE_DECLARATION_PART #include "objects.h" /* declaration part of the package */ #undef INCLUDE_DECLARATION_PART +#include "scanner.h" /* Pr */ + #include "gvars.h" /* AssGVar, GVarName */ #include "calls.h" /* NewFunctionC */ @@ -1371,12 +1372,14 @@ void InitObjects ( void ) Int t; /* loop variable */ /* make and install the 'FAMILY_KIND' function */ + InitHandlerFunc( FamilyKindHandler, "FAMILY_KIND" ); FamilyKindFunc = NewFunctionC( "FAMILY_KIND", 1L, "kind", FamilyKindHandler ); AssGVar( GVarName( "FAMILY_KIND" ), FamilyKindFunc ); /* make and install the 'KIND_OBJ' function */ + InitHandlerFunc( KindObjHandler, "KIND_OBJ" ); KindObjFunc = NewFunctionC( "KIND_OBJ", 1L, "obj", KindObjHandler ); AssGVar( GVarName( "KIND_OBJ" ), KindObjFunc ); @@ -1386,12 +1389,14 @@ void InitObjects ( void ) /* make and install the 'FAMILY_OBJ' function */ + InitHandlerFunc( FamilyObjHandler, "FAMILY_OBJ" ); FamilyObjFunc = NewFunctionC( "FAMILY_OBJ", 1L, "obj", FamilyObjHandler ); AssGVar( GVarName( "FAMILY_OBJ" ), FamilyObjFunc ); /* make and install the 'IS_MUTABLE_OBJ' filter */ + InitHandlerFunc( IsMutableObjHandler, "IS_MUTABLE_OBJ" ); IsMutableObjFilt = NewFilterC( "IS_MUTABLE_OBJ", 1L, "obj", IsMutableObjHandler ); AssGVar( GVarName( "IS_MUTABLE_OBJ" ), @@ -1406,6 +1411,7 @@ void InitObjects ( void ) /* make and install the 'IS_COPYABLE_OBJ' filter */ + InitHandlerFunc( IsCopyableObjHandler, "IS_COPYABLE_OBJ" ); IsCopyableObjFilt = NewFilterC( "IS_COPYABLE_OBJ", 1L, "obj", IsCopyableObjHandler ); AssGVar( GVarName( "IS_COPYABLE_OBJ" ), @@ -1420,6 +1426,7 @@ void InitObjects ( void ) /* make and install the 'SHALLOW_COPY_OBJ' operation */ + InitHandlerFunc( ShallowCopyObjHandler, "SHALLOW_COPY_OBJ" ); ShallowCopyObjOper = NewOperationC( "SHALLOW_COPY_OBJ", 1L, "obj", ShallowCopyObjHandler ); AssGVar( GVarName( "SHALLOW_COPY_OBJ" ), @@ -1438,10 +1445,12 @@ void InitObjects ( void ) /* make and install the 'COPY_OBJ' function */ + InitHandlerFunc( ImmutableCopyObjHandler, "IMMUTABLE_COPY_OBJ" ); ImmutableCopyObjFunc = NewFunctionC( "IMMUTABLE_COPY_OBJ", 1L, "obj", ImmutableCopyObjHandler ); AssGVar( GVarName( "IMMUTABLE_COPY_OBJ" ), ImmutableCopyObjFunc ); + InitHandlerFunc( MutableCopyObjHandler, "DEEP_COPY_OBJ" ); MutableCopyObjFunc = NewFunctionC( "DEEP_COPY_OBJ", 1L, "obj", MutableCopyObjHandler ); @@ -1471,6 +1480,7 @@ void InitObjects ( void ) /* make and install the 'PRINT_OBJ' operation */ + InitHandlerFunc( PrintObjHandler, "PRINT_OBJ" ); PrintObjOper = NewOperationC( "PRINT_OBJ", 1L, "obj", PrintObjHandler ); AssGVar( GVarName( "PRINT_OBJ" ), PrintObjOper ); @@ -1485,6 +1495,7 @@ void InitObjects ( void ) /* make and install the 'IS_IDENTICAL_OBJ' function */ + InitHandlerFunc( IsIdenticalHandler, "IS_IDENTICAL_OBJ" ); IsIdenticalFunc = NewFunctionC( "IS_IDENTICAL_OBJ", 2, "obj1, obj2", IsIdenticalHandler ); AssGVar( GVarName( "IS_IDENTICAL_OBJ" ), IsIdenticalFunc ); @@ -1512,39 +1523,49 @@ void InitObjects ( void ) /* make and install the functions for low level accessing of objects */ + InitHandlerFunc( IS_COMOBJ_Handler, "IS_COMOBJ" ); IS_COMOBJ_Func = NewFunctionC( "IS_COMOBJ", 1L, "obj", IS_COMOBJ_Handler ); AssGVar( GVarName( "IS_COMOBJ" ), IS_COMOBJ_Func ); - + + InitHandlerFunc( SET_KIND_COMOBJ_Handler, "SET_KIND_COMOBJ" ); SET_KIND_COMOBJ_Func = NewFunctionC( "SET_KIND_COMOBJ", 2L, "obj, kind", SET_KIND_COMOBJ_Handler ); AssGVar( GVarName( "SET_KIND_COMOBJ" ), SET_KIND_COMOBJ_Func ); - + + InitHandlerFunc( IS_POSOBJ_Handler, "IS_POSOBJ" ); IS_POSOBJ_Func = NewFunctionC( "IS_POSOBJ", 1L, "obj", IS_POSOBJ_Handler ); AssGVar( GVarName( "IS_POSOBJ" ), IS_POSOBJ_Func ); - + + InitHandlerFunc( SET_KIND_POSOBJ_Handler, "SET_KIND_POSOBJ" ); SET_KIND_POSOBJ_Func = NewFunctionC( "SET_KIND_POSOBJ", 2L, "obj, kind", SET_KIND_POSOBJ_Handler ); AssGVar( GVarName( "SET_KIND_POSOBJ" ), SET_KIND_POSOBJ_Func ); - + + InitHandlerFunc( LEN_POSOBJ_Handler, "LEN_POSOBJ" ); LEN_POSOBJ_Func = NewFunctionC( "LEN_POSOBJ", 1L, "obj", LEN_POSOBJ_Handler ); AssGVar( GVarName( "LEN_POSOBJ" ), LEN_POSOBJ_Func ); - + + InitHandlerFunc( IS_DATOBJ_Handler, "IS_DATOBJ" ); IS_DATOBJ_Func = NewFunctionC( "IS_DATOBJ", 1L, "obj", IS_DATOBJ_Handler ); AssGVar( GVarName( "IS_DATOBJ" ), IS_DATOBJ_Func ); - + + InitHandlerFunc( SET_KIND_DATOBJ_Handler, "SET_KIND_DATOBJ" ); SET_KIND_DATOBJ_Func = NewFunctionC( "SET_KIND_DATOBJ", 2L, "obj, kind", SET_KIND_DATOBJ_Handler ); AssGVar( GVarName( "SET_KIND_DATOBJ" ), SET_KIND_DATOBJ_Func ); /* install the debug functions */ + InitHandlerFunc( SIZE_OBJ_Handler, "SIZE_OBJ" ); SIZE_OBJ_Func = NewFunctionC( "SIZE_OBJ", 1L, "obj", SIZE_OBJ_Handler ); AssGVar( GVarName( "SIZE_OBJ" ), SIZE_OBJ_Func ); + + InitHandlerFunc( TYPE_OBJ_Handler, "TYPE_OBJ" ); TYPE_OBJ_Func = NewFunctionC( "TYPE_OBJ", 1L, "obj", TYPE_OBJ_Handler ); AssGVar( GVarName( "TYPE_OBJ" ), TYPE_OBJ_Func ); diff --git a/src/objfgelm.c b/src/objfgelm.c index f18a84b795..5346722847 100644 --- a/src/objfgelm.c +++ b/src/objfgelm.c @@ -76,10 +76,11 @@ char * Revision_objfgelm_c = #include /* assert */ #include "system.h" /* Ints, UInts */ -#include "scanner.h" /* Pr */ -#include "gasman.h" /* NewBag, CHANGED_BAG */ +#include "gasman.h" /* NewBag, CHANGED_BAG */ #include "objects.h" /* Obj, TYPE_OBJ, types */ +#include "scanner.h" /* Pr */ + #include "gvars.h" /* AssGVar, GVarName */ #include "gap.h" /* Error */ @@ -2825,173 +2826,215 @@ void InitFreeGroupElements ( void ) INTOBJ_INT(AWP_FIRST_FREE) ); /* '8Bits' methods */ + InitHandlerFunc( Func8Bits_Equal, "8Bits_Equal" ); AssGVar( GVarName( "8Bits_Equal" ), NewFunctionC( "8Bits_Equal", 2L, "8_bits_word, 8_bits_word", Func8Bits_Equal ) ); + InitHandlerFunc( Func8Bits_ExponentSums1, "8Bits_ExponentSums1" ); AssGVar( GVarName( "8Bits_ExponentSums1" ), NewFunctionC( "8Bits_ExponentSums1", 1L, "8_bits_word", Func8Bits_ExponentSums1 ) ); + InitHandlerFunc( Func8Bits_ExponentSums3, "8Bits_ExponentSums3" ); AssGVar( GVarName( "8Bits_ExponentSums3" ), NewFunctionC( "8Bits_ExponentSums3", 3L, "8_bits_word, start, end", Func8Bits_ExponentSums3 ) ); + InitHandlerFunc( Func8Bits_ExponentSyllable, "8Bits_ExponentSyllable" ); AssGVar( GVarName( "8Bits_ExponentSyllable" ), NewFunctionC( "8Bits_ExponentSyllable", 2L, "8_bits_word, position", Func8Bits_ExponentSyllable ) ); + InitHandlerFunc( Func8Bits_ExtRepOfObj, "8Bits_ExtRepOfObj" ); AssGVar( GVarName( "8Bits_ExtRepOfObj" ), NewFunctionC( "8Bits_ExtRepOfObj", 1L, "8_bits_word", Func8Bits_ExtRepOfObj ) ); + InitHandlerFunc( Func8Bits_GeneratorSyllable, "8Bits_GeneratorSyllable" ); AssGVar( GVarName( "8Bits_GeneratorSyllable" ), NewFunctionC( "8Bits_GeneratorSyllable", 2L, "8_bits_word, position", Func8Bits_GeneratorSyllable ) ); + InitHandlerFunc( Func8Bits_Less, "8Bits_Less" ); AssGVar( GVarName( "8Bits_Less" ), NewFunctionC( "8Bits_Less", 2L, "8_bits_word, 8_bits_word", Func8Bits_Less ) ); + InitHandlerFunc( Func8Bits_AssocWord, "8Bits_AssocWord" ); AssGVar( GVarName( "8Bits_AssocWord" ), NewFunctionC( "8Bits_AssocWord", 2L, "kind, data", Func8Bits_AssocWord ) ); + InitHandlerFunc( FuncNBits_NumberSyllables, "NBits_NumberSyllables" ); AssGVar( GVarName( "8Bits_NumberSyllables" ), NewFunctionC( "NBits_NumberSyllables", 1L, "8_bits_word", FuncNBits_NumberSyllables ) ); + InitHandlerFunc( Func8Bits_ObjByVector, "8Bits_ObjByVector" ); AssGVar( GVarName( "8Bits_ObjByVector" ), NewFunctionC( "8Bits_ObjByVector", 2L, "kind, data", Func8Bits_ObjByVector ) ); + InitHandlerFunc( Func8Bits_HeadByNumber, "8Bits_HeadByNumber" ); AssGVar( GVarName( "8Bits_HeadByNumber" ), NewFunctionC( "8Bits_HeadByNumber", 2L, "16_bits_word, gen_num", Func8Bits_HeadByNumber ) ); + InitHandlerFunc( Func8Bits_Power, "8Bits_Power" ); AssGVar( GVarName( "8Bits_Power" ), NewFunctionC( "8Bits_Power", 2L, "8_bits_word, small_integer", Func8Bits_Power ) ); + InitHandlerFunc( Func8Bits_Product, "8Bits_Product" ); AssGVar( GVarName( "8Bits_Product" ), NewFunctionC( "8Bits_Product", 2L, "8_bits_word, 8_bits_word", Func8Bits_Product ) ); + InitHandlerFunc( Func8Bits_Quotient, "8Bits_Quotient" ); AssGVar( GVarName( "8Bits_Quotient" ), NewFunctionC( "8Bits_Quotient", 2L, "8_bits_word, 8_bits_word", Func8Bits_Quotient ) ); /* '16Bits' methods */ + InitHandlerFunc( Func16Bits_Equal, "16Bits_Equal" ); AssGVar( GVarName( "16Bits_Equal" ), NewFunctionC( "16Bits_Equal", 2L, "16_bits_word, 16_bits_word", Func16Bits_Equal ) ); + InitHandlerFunc( Func16Bits_ExponentSums1, "16Bits_ExponentSums1" ); AssGVar( GVarName( "16Bits_ExponentSums1" ), NewFunctionC( "16Bits_ExponentSums1", 1L, "16_bits_word", Func16Bits_ExponentSums1 ) ); + InitHandlerFunc( Func16Bits_ExponentSums3, "16Bits_ExponentSums3" ); AssGVar( GVarName( "16Bits_ExponentSums3" ), NewFunctionC( "16Bits_ExponentSums3", 3L, "16_bits_word, start, end", Func16Bits_ExponentSums3 ) ); + InitHandlerFunc( Func16Bits_ExponentSyllable, "16Bits_ExponentSyllable" ); AssGVar( GVarName( "16Bits_ExponentSyllable" ), NewFunctionC( "16Bits_ExponentSyllable", 2L, "16_bits_word, position", Func16Bits_ExponentSyllable ) ); + InitHandlerFunc( Func16Bits_ExtRepOfObj, "16Bits_ExtRepOfObj" ); AssGVar( GVarName( "16Bits_ExtRepOfObj" ), NewFunctionC( "16Bits_ExtRepOfObj", 1L, "16_bits_word", Func16Bits_ExtRepOfObj ) ); + InitHandlerFunc( Func16Bits_GeneratorSyllable, "16Bits_GeneratorSyllable" ); AssGVar( GVarName( "16Bits_GeneratorSyllable" ), NewFunctionC( "16Bits_GeneratorSyllable", 2L, "16_bits_word, pos", Func16Bits_GeneratorSyllable ) ); + InitHandlerFunc( Func16Bits_Less, "16Bits_Less" ); AssGVar( GVarName( "16Bits_Less" ), NewFunctionC( "16Bits_Less", 2L, "16_bits_word, 16_bits_word", Func16Bits_Less ) ); + InitHandlerFunc( Func16Bits_AssocWord, "16Bits_AssocWord" ); AssGVar( GVarName( "16Bits_AssocWord" ), NewFunctionC( "16Bits_AssocWord", 2L, "kind, data", Func16Bits_AssocWord ) ); + InitHandlerFunc( FuncNBits_NumberSyllables, "NBits_NumberSyllables" ); AssGVar( GVarName( "16Bits_NumberSyllables" ), NewFunctionC( "NBits_NumberSyllables", 1L, "16_bits_word", FuncNBits_NumberSyllables ) ); + InitHandlerFunc( Func16Bits_ObjByVector, "16Bits_ObjByVector" ); AssGVar( GVarName( "16Bits_ObjByVector" ), NewFunctionC( "16Bits_ObjByVector", 2L, "kind, data", Func16Bits_ObjByVector ) ); + InitHandlerFunc( Func16Bits_HeadByNumber, "16Bits_HeadByNumber" ); AssGVar( GVarName( "16Bits_HeadByNumber" ), NewFunctionC( "16Bits_HeadByNumber", 2L, "16_bits_word, gen_num", Func16Bits_HeadByNumber ) ); + InitHandlerFunc( Func16Bits_Power, "16Bits_Power" ); AssGVar( GVarName( "16Bits_Power" ), NewFunctionC( "16Bits_Power", 2L, "16_bits_word, small_integer", Func16Bits_Power ) ); + InitHandlerFunc( Func16Bits_Product, "16Bits_Product" ); AssGVar( GVarName( "16Bits_Product" ), NewFunctionC( "16Bits_Product", 2L, "16_bits_word, 16_bits_word", Func16Bits_Product ) ); + InitHandlerFunc( Func16Bits_Quotient, "16Bits_Quotient" ); AssGVar( GVarName( "16Bits_Quotient" ), NewFunctionC( "16Bits_Quotient", 2L, "16_bits_word, 16_bits_word", Func16Bits_Quotient ) ); /* '32Bits' methods */ + InitHandlerFunc( Func32Bits_Equal, "32Bits_Equal" ); AssGVar( GVarName( "32Bits_Equal" ), NewFunctionC( "32Bits_Equal", 2L, "32_bits_word, 32_bits_word", Func32Bits_Equal ) ); + InitHandlerFunc( Func32Bits_ExponentSums1, "32Bits_ExponentSums1" ); AssGVar( GVarName( "32Bits_ExponentSums1" ), NewFunctionC( "32Bits_ExponentSums1", 1L, "32_bits_word", Func32Bits_ExponentSums1 ) ); + InitHandlerFunc( Func32Bits_ExponentSums3, "32Bits_ExponentSums3" ); AssGVar( GVarName( "32Bits_ExponentSums3" ), NewFunctionC( "32Bits_ExponentSums3", 3L, "32_bits_word, start, end", Func32Bits_ExponentSums3 ) ); + InitHandlerFunc( Func32Bits_ExponentSyllable, "32Bits_ExponentSyllable" ); AssGVar( GVarName( "32Bits_ExponentSyllable" ), NewFunctionC( "32Bits_ExponentSyllable", 2L, "32_bits_word, position", Func32Bits_ExponentSyllable ) ); + InitHandlerFunc( Func32Bits_ExtRepOfObj, "32Bits_ExtRepOfObj" ); AssGVar( GVarName( "32Bits_ExtRepOfObj" ), NewFunctionC( "32Bits_ExtRepOfObj", 1L, "32_bits_word", Func32Bits_ExtRepOfObj ) ); + InitHandlerFunc( Func32Bits_GeneratorSyllable, "32Bits_GeneratorSyllable" ); AssGVar( GVarName( "32Bits_GeneratorSyllable" ), NewFunctionC( "32Bits_GeneratorSyllable", 2L, "32_bits_word, pos", Func32Bits_GeneratorSyllable ) ); + InitHandlerFunc( Func32Bits_Less, "32Bits_Less" ); AssGVar( GVarName( "32Bits_Less" ), NewFunctionC( "32Bits_Less", 2L, "32_bits_word, 32_bits_word", Func32Bits_Less ) ); + InitHandlerFunc( Func32Bits_AssocWord, "32Bits_AssocWord" ); AssGVar( GVarName( "32Bits_AssocWord" ), NewFunctionC( "32Bits_AssocWord", 2L, "kind, data", Func32Bits_AssocWord ) ); + InitHandlerFunc( FuncNBits_NumberSyllables, "NBits_NumberSyllables" ); AssGVar( GVarName( "32Bits_NumberSyllables" ), NewFunctionC( "NBits_NumberSyllables", 1L, "32_bits_word", FuncNBits_NumberSyllables ) ); + InitHandlerFunc( Func32Bits_ObjByVector, "32Bits_ObjByVector" ); AssGVar( GVarName( "32Bits_ObjByVector" ), NewFunctionC( "32Bits_ObjByVector", 2L, "kind, data", Func32Bits_ObjByVector ) ); + InitHandlerFunc( Func32Bits_HeadByNumber, "32Bits_HeadByNumber" ); AssGVar( GVarName( "32Bits_HeadByNumber" ), NewFunctionC( "32Bits_HeadByNumber", 2L, "16_bits_word, gen_num", Func32Bits_HeadByNumber ) ); + InitHandlerFunc( Func32Bits_Power, "32Bits_Power" ); AssGVar( GVarName( "32Bits_Power" ), NewFunctionC( "32Bits_Power", 2L, "32_bits_word, small_integer", Func32Bits_Power ) ); + InitHandlerFunc( Func32Bits_Product, "32Bits_Product" ); AssGVar( GVarName( "32Bits_Product" ), NewFunctionC( "32Bits_Product", 2L, "32_bits_word, 32_bits_word", Func32Bits_Product ) ); + InitHandlerFunc( Func32Bits_Quotient, "32Bits_Quotient" ); AssGVar( GVarName( "32Bits_Quotient" ), NewFunctionC( "32Bits_Quotient", 2L, "32_bits_word, 32_bits_word", Func32Bits_Quotient ) ); diff --git a/src/objpcgel.c b/src/objpcgel.c index 39783d4ec9..efed0a3a87 100644 --- a/src/objpcgel.c +++ b/src/objpcgel.c @@ -10,10 +10,11 @@ char * Revision_objpcgel_c = "@(#)$Id$"; #include "system.h" /* Ints, UInts */ -#include "scanner.h" /* Pr */ -#include "gasman.h" /* NewBag, CHANGED_BAG */ +#include "gasman.h" /* NewBag, CHANGED_BAG */ #include "objects.h" /* Obj, TYPE_OBJ, types */ +#include "scanner.h" /* Pr */ + #include "gvars.h" /* AssGVar, GVarName */ #include "gap.h" /* Error */ @@ -434,41 +435,54 @@ void InitPcElements ( void ) /* methods for boxed objs */ + InitHandlerFunc( FuncLessBoxedObj, "LessBoxedObj" ); AssGVar( GVarName( "LessBoxedObj" ), NewFunctionC( "LessBoxedObj", 2L, "lobj, lobj", FuncLessBoxedObj ) ); + InitHandlerFunc( FuncEqualBoxedObj, "EqualBoxedObj" ); AssGVar( GVarName( "EqualBoxedObj" ), NewFunctionC( "EqualBoxedObj", 2L, "lobj, lobj", FuncEqualBoxedObj ) ); /* finite power conjugate collector words */ + InitHandlerFunc( FuncNBitsPcWord_Comm, "NBitsPcWord_Comm" ); AssGVar( GVarName( "NBitsPcWord_Comm" ), NewFunctionC( "NBitsPcWord_Comm", 2L, "n_bits_pcword, n_bits_pcword", FuncNBitsPcWord_Comm ) ); + InitHandlerFunc( FuncNBitsPcWord_Conjugate, + "NBitsPcWord_Conjugate" ); AssGVar( GVarName( "NBitsPcWord_Conjugate" ), NewFunctionC( "NBitsPcWord_Conjugate", 2L, "n_bits_pcword, n_bits_pcword", FuncNBitsPcWord_Conjugate ) ); + InitHandlerFunc( FuncNBitsPcWord_LeftQuotient, + "NBitsPcWord_LeftQuotient" ); AssGVar( GVarName( "NBitsPcWord_LeftQuotient" ), NewFunctionC( "NBitsPcWord_LeftQuotient", 2L, "n_bits_pcword, n_bits_pcword", FuncNBitsPcWord_LeftQuotient ) ); + InitHandlerFunc( FuncNBitsPcWord_PowerSmallInt, + "NBitsPcWord_PowerSmallInt" ); AssGVar( GVarName( "NBitsPcWord_PowerSmallInt" ), NewFunctionC( "NBitsPcWord_PowerSmallInt", 2L, "n_bits_pcword, small_integer", FuncNBitsPcWord_PowerSmallInt ) ); + InitHandlerFunc( FuncNBitsPcWord_Product, + "NBitsPcWord_Product" ); AssGVar( GVarName( "NBitsPcWord_Product" ), NewFunctionC( "NBitsPcWord_Product", 2L, "n_bits_pcword, n_bits_pcword", FuncNBitsPcWord_Product ) ); + InitHandlerFunc( FuncNBitsPcWord_Quotient, + "NBitsPcWord_Quotient" ); AssGVar( GVarName( "NBitsPcWord_Quotient" ), NewFunctionC( "NBitsPcWord_Quotient", 2L, "n_bits_pcword, n_bits_pcword", @@ -476,48 +490,66 @@ void InitPcElements ( void ) /* 8 bits word */ + InitHandlerFunc( Func8Bits_DepthOfPcElement, + "8Bits_DepthOfPcElement" ); AssGVar( GVarName( "8Bits_DepthOfPcElement" ), NewFunctionC( "8Bits_DepthOfPcElement", 2L, "8_bits_pcgs, 8_bits_pcword", Func8Bits_DepthOfPcElement ) ); + InitHandlerFunc( Func8Bits_ExponentOfPcElement, + "8Bits_ExponentOfPcElement" ); AssGVar( GVarName( "8Bits_ExponentOfPcElement" ), NewFunctionC( "8Bits_ExponentOfPcElement", 3L, "8_bits_pcgs, 8_bits_pcword, int", Func8Bits_ExponentOfPcElement ) ); + InitHandlerFunc( Func8Bits_LeadingExponentOfPcElement, + "8Bits_LeadingExponentOfPcElement" ); AssGVar( GVarName( "8Bits_LeadingExponentOfPcElement" ), NewFunctionC( "8Bits_LeadingExponentOfPcElement", 2L, "8_bits_pcgs, 8_bits_word", Func8Bits_LeadingExponentOfPcElement ) ); /* 16 bits word */ + InitHandlerFunc( Func16Bits_DepthOfPcElement, + "16Bits_DepthOfPcElement" ); AssGVar( GVarName( "16Bits_DepthOfPcElement" ), NewFunctionC( "16Bits_DepthOfPcElement", 2L, "16_bits_pcgs, 16_bits_pcword", Func16Bits_DepthOfPcElement ) ); + InitHandlerFunc( Func16Bits_ExponentOfPcElement, + "16Bits_ExponentOfPcElement" ); AssGVar( GVarName( "16Bits_ExponentOfPcElement" ), NewFunctionC( "16Bits_ExponentOfPcElement", 3L, "16_bits_pcgs, 16_bits_pcword, int", Func16Bits_ExponentOfPcElement ) ); + InitHandlerFunc( Func16Bits_LeadingExponentOfPcElement, + "16Bits_LeadingExponentOfPcElement" ); AssGVar( GVarName( "16Bits_LeadingExponentOfPcElement" ), NewFunctionC( "16Bits_LeadingExponentOfPcElement", 2L, "16_bits_pcgs, 16_bits_word", Func16Bits_LeadingExponentOfPcElement ) ); /* 32 bits word */ + InitHandlerFunc( Func32Bits_DepthOfPcElement, + "32Bits_DepthOfPcElement" ); AssGVar( GVarName( "32Bits_DepthOfPcElement" ), NewFunctionC( "32Bits_DepthOfPcElement", 2L, "32_bits_pcgs, 32_bits_pcword", Func32Bits_DepthOfPcElement ) ); + InitHandlerFunc( Func32Bits_ExponentOfPcElement, + "32Bits_ExponentOfPcElement" ); AssGVar( GVarName( "32Bits_ExponentOfPcElement" ), NewFunctionC( "32Bits_ExponentOfPcElement", 3L, "32_bits_pcgs, 32_bits_pcword, int", Func32Bits_ExponentOfPcElement ) ); + InitHandlerFunc( Func32Bits_LeadingExponentOfPcElement, + "32Bits_LeadingExponentOfPcElement" ); AssGVar( GVarName( "32Bits_LeadingExponentOfPcElement" ), NewFunctionC( "32Bits_LeadingExponentOfPcElement", 2L, "32_bits_pcgs, 32_bits_word", diff --git a/src/objscoll.c b/src/objscoll.c index 02046b4c27..9a842061b8 100644 --- a/src/objscoll.c +++ b/src/objscoll.c @@ -24,10 +24,11 @@ char * Revision_objscoll_c = "@(#)$Id$"; #include "system.h" /* Ints, UInts */ -#include "scanner.h" /* Pr */ -#include "gasman.h" /* NewBag, CHANGED_BAG */ +#include "gasman.h" /* NewBag, CHANGED_BAG */ #include "objects.h" /* Obj, TYPE_OBJ, types */ +#include "scanner.h" /* Pr */ + #include "gvars.h" /* AssGVar, GVarName */ #include "gap.h" /* Error */ @@ -2019,36 +2020,50 @@ void InitSingleCollector ( void ) /* collector methods */ + InitHandlerFunc( FuncFinPowConjCol_CollectWordOrFail, + "FinPowConjCol_CollectWordOrFail" ); AssGVar( GVarName( "FinPowConjCol_CollectWordOrFail" ), NewFunctionC( "FinPowConjCol_CollectWordOrFail", 3L, "collector, list, word", FuncFinPowConjCol_CollectWordOrFail ) ); + InitHandlerFunc( FuncFinPowConjCol_ReducedComm, + "FinPowConjCol_ReducedComm" ); AssGVar( GVarName( "FinPowConjCol_ReducedComm" ), NewFunctionC( "FinPowConjCol_ReducedComm", 3L, "collector, word, word", FuncFinPowConjCol_ReducedComm ) ); + InitHandlerFunc( FuncFinPowConjCol_ReducedForm, + "FinPowConjCol_ReducedForm" ); AssGVar( GVarName( "FinPowConjCol_ReducedForm" ), NewFunctionC( "FinPowConjCol_ReducedForm", 2L, "collector, word", FuncFinPowConjCol_ReducedForm ) ); + InitHandlerFunc( FuncFinPowConjCol_ReducedLeftQuotient, + "FinPowConjCol_ReducedLeftQuotient" ); AssGVar( GVarName( "FinPowConjCol_ReducedLeftQuotient" ), NewFunctionC( "FinPowConjCol_ReducedLeftQuotient", 3L, "collector, word, word", FuncFinPowConjCol_ReducedLeftQuotient ) ); + InitHandlerFunc( FuncFinPowConjCol_ReducedPowerSmallInt, + "FinPowConjCol_ReducedPowerSmallInt" ); AssGVar( GVarName( "FinPowConjCol_ReducedPowerSmallInt" ), NewFunctionC( "FinPowConjCol_ReducedPowerSmallInt", 3L, "collector, word, small_int", FuncFinPowConjCol_ReducedPowerSmallInt ) ); + InitHandlerFunc( FuncFinPowConjCol_ReducedProduct, + "FinPowConjCol_ReducedProduct" ); AssGVar( GVarName( "FinPowConjCol_ReducedProduct" ), NewFunctionC( "FinPowConjCol_ReducedProduct", 3L, "collector, word, word", FuncFinPowConjCol_ReducedProduct ) ); + InitHandlerFunc( FuncFinPowConjCol_ReducedQuotient, + "FinPowConjCol_ReducedQuotient" ); AssGVar( GVarName( "FinPowConjCol_ReducedQuotient" ), NewFunctionC( "FinPowConjCol_ReducedQuotient", 3L, "collector, word, word", diff --git a/src/opers.c b/src/opers.c index 2d150e173d..9789cbdd59 100644 --- a/src/opers.c +++ b/src/opers.c @@ -17,10 +17,11 @@ char * Revision_opers_c = #include #include "system.h" /* Ints, UInts */ -#include "scanner.h" /* Pr */ -#include "gasman.h" /* NewBag, CHANGED_BAG */ +#include "gasman.h" /* NewBag, CHANGED_BAG */ #include "objects.h" /* Obj, TYPE_OBJ, types */ +#include "scanner.h" /* Pr */ + #include "gvars.h" /* AssGVar, GVarName */ #include "calls.h" /* generic call mechanism */ @@ -5114,39 +5115,108 @@ void InitOpers ( void ) { Int i; + /* declare the handlers used in various places */ + InitHandlerFunc( DoFilter, "DoFilter"); + InitHandlerFunc( DoSetFilter, "DoSetFilter"); + InitHandlerFunc( DoAndFilter, "DoAndFilter"); + InitHandlerFunc( DoSetAndFilter, "DoSetAndFilter"); + InitHandlerFunc( DoReturnTrueFilter, "DoReturnTrueFilter"); + InitHandlerFunc( DoSetReturnTrueFilter, "DoSetReturnTrueFilter"); + + InitHandlerFunc( DoAttribute, "DoAttribute"); + InitHandlerFunc( DoSetAttribute, "DoSetAttribute"); + InitHandlerFunc( DoTestAttribute, "DoTestAttribute"); + InitHandlerFunc( DoVerboseAttribute, "DoVerboseAttribute"); + InitHandlerFunc( DoMutableAttribute, "DoMutableAttribute"); + InitHandlerFunc( DoVerboseMutableAttribute, "DoVerboseMutableAttribute"); + + InitHandlerFunc( DoProperty, "DoProperty"); + InitHandlerFunc( DoSetProperty, "DoSetProperty"); + InitHandlerFunc( DoTestProperty, "DoTestProperty"); + InitHandlerFunc( DoVerboseProperty, "DoVerboseProperty"); + + InitHandlerFunc( DoSetterFunction, "DoSetterFunction"); + InitHandlerFunc( DoGetterFunction, "DoGetterFunction"); + + InitHandlerFunc( DoOperation0Args, "DoOperation0Args"); + InitHandlerFunc( DoOperation1Args, "DoOperation1Args"); + InitHandlerFunc( DoOperation2Args, "DoOperation2Args"); + InitHandlerFunc( DoOperation3Args, "DoOperation3Args"); + InitHandlerFunc( DoOperation4Args, "DoOperation4Args"); + InitHandlerFunc( DoOperation5Args, "DoOperation5Args"); + InitHandlerFunc( DoOperation6Args, "DoOperation6Args"); + InitHandlerFunc( DoOperationXArgs, "DoOperationXArgs"); + + InitHandlerFunc( DoVerboseOperation0Args, "DoVerboseOperation0Args"); + InitHandlerFunc( DoVerboseOperation1Args, "DoVerboseOperation1Args"); + InitHandlerFunc( DoVerboseOperation2Args, "DoVerboseOperation2Args"); + InitHandlerFunc( DoVerboseOperation3Args, "DoVerboseOperation3Args"); + InitHandlerFunc( DoVerboseOperation4Args, "DoVerboseOperation4Args"); + InitHandlerFunc( DoVerboseOperation5Args, "DoVerboseOperation5Args"); + InitHandlerFunc( DoVerboseOperation6Args, "DoVerboseOperation6Args"); + InitHandlerFunc( DoVerboseOperationXArgs, "DoVerboseOperationXArgs"); + + InitHandlerFunc( DoConstructor0Args, "DoConstructor0Args"); + InitHandlerFunc( DoConstructor1Args, "DoConstructor1Args"); + InitHandlerFunc( DoConstructor2Args, "DoConstructor2Args"); + InitHandlerFunc( DoConstructor3Args, "DoConstructor3Args"); + InitHandlerFunc( DoConstructor4Args, "DoConstructor4Args"); + InitHandlerFunc( DoConstructor5Args, "DoConstructor5Args"); + InitHandlerFunc( DoConstructor6Args, "DoConstructor6Args"); + InitHandlerFunc( DoConstructorXArgs, "DoConstructorXArgs"); + + InitHandlerFunc( DoVerboseConstructor0Args, "DoVerboseConstructor0Args"); + InitHandlerFunc( DoVerboseConstructor1Args, "DoVerboseConstructor1Args"); + InitHandlerFunc( DoVerboseConstructor2Args, "DoVerboseConstructor2Args"); + InitHandlerFunc( DoVerboseConstructor3Args, "DoVerboseConstructor3Args"); + InitHandlerFunc( DoVerboseConstructor4Args, "DoVerboseConstructor4Args"); + InitHandlerFunc( DoVerboseConstructor5Args, "DoVerboseConstructor5Args"); + InitHandlerFunc( DoVerboseConstructor6Args, "DoVerboseConstructor6Args"); + InitHandlerFunc( DoVerboseConstructorXArgs, "DoVerboseConstructorXArgs"); + + /* make the property blist functions */ + InitHandlerFunc( FuncAND_FLAGS, "AND_FLAGS" ); AssGVar( GVarName( "AND_FLAGS" ), NewFunctionC( "AND_FLAGS", 2L, "oper1, oper2", FuncAND_FLAGS ) ); + InitHandlerFunc( FuncSUB_FLAGS, "SUB_FLAGS" ); AssGVar( GVarName( "SUB_FLAGS" ), NewFunctionC( "SUB_FLAGS", 2L, "oper1, oper2", FuncSUB_FLAGS ) ); + InitHandlerFunc( FuncHASH_FLAGS, "HASH_FLAGS" ); AssGVar( GVarName( "HASH_FLAGS" ), NewFunctionC( "HASH_FLAGS", 1L, "flags", FuncHASH_FLAGS ) ); + InitHandlerFunc( FuncIS_EQUAL_FLAGS, "IS_EQUAL_FLAGS" ); AssGVar( GVarName( "IS_EQUAL_FLAGS" ), NewFunctionC( "IS_EQUAL_FLAGS", 2L, "flags1, flags2", FuncIS_EQUAL_FLAGS ) ); + InitHandlerFunc( FuncIS_SUBSET_FLAGS, "IS_SUBSET_FLAGS" ); AssGVar( GVarName( "IS_SUBSET_FLAGS" ), NewFunctionC( "IS_SUBSET_FLAGS", 2L, "flags1, flags2", FuncIS_SUBSET_FLAGS ) ); + InitHandlerFunc( FuncTRUES_FLAGS, "TRUES_FLAGS" ); AssGVar( GVarName( "TRUES_FLAGS" ), NewFunctionC( "TRUES_FLAGS", 1L, "flags", FuncTRUES_FLAGS ) ); + InitHandlerFunc( FuncSIZE_FLAGS, "SIZE_FLAGS" ); AssGVar( GVarName( "SIZE_FLAGS" ), NewFunctionC( "SIZE_FLAGS", 1L, "flags", FuncSIZE_FLAGS ) ); + InitHandlerFunc( FuncLEN_FLAGS, "LEN_FLAGS" ); AssGVar( GVarName( "LEN_FLAGS" ), NewFunctionC( "LEN_FLAGS", 1L, "flags", FuncLEN_FLAGS ) ); + InitHandlerFunc( FuncELM_FLAGS, "ELM_FLAGS" ); AssGVar( GVarName( "ELM_FLAGS" ), NewFunctionC( "ELM_FLAGS", 2L, "flags, pos", FuncELM_FLAGS ) ); @@ -5166,102 +5236,126 @@ void InitOpers ( void ) /* make the functions that support new operations */ + InitHandlerFunc( FuncIsOperation, "IS_OPERATION" ); AssGVar( GVarName( "IS_OPERATION" ), NewFunctionC( "IS_OPERATION", 1L, "value", FuncIsOperation ) ); + InitHandlerFunc( FuncFlag1Filter, "FLAG1_FILTER" ); AssGVar( GVarName( "FLAG1_FILTER" ), NewFunctionC( "FLAG1_FILTER", 1L, "oper", FuncFlag1Filter ) ); + InitHandlerFunc( FuncSetFlag1Filter, "SET_FLAG1_FILTER" ); AssGVar( GVarName( "SET_FLAG1_FILTER" ), NewFunctionC( "SET_FLAG1_FILTER", 2L, "oper, flag1", FuncSetFlag1Filter ) ); + InitHandlerFunc( FuncFlag2Filter, "FLAG2_FILTER" ); AssGVar( GVarName( "FLAG2_FILTER" ), NewFunctionC( "FLAG2_FILTER", 1L, "oper", FuncFlag2Filter ) ); + InitHandlerFunc( FuncSetFlag2Filter, "SET_FLAG2_FILTER" ); AssGVar( GVarName( "SET_FLAG2_FILTER" ), NewFunctionC( "SET_FLAG2_FILTER", 2L, "oper, flag2", FuncSetFlag2Filter ) ); + InitHandlerFunc( FuncFlagsFilter, "FLAGS_FILTER" ); AssGVar( GVarName( "FLAGS_FILTER" ), NewFunctionC( "FLAGS_FILTER", 1L, "oper", FuncFlagsFilter ) ); + InitHandlerFunc( FuncSetFlagsFilter, "SET_FLAGS_FILTER" ); AssGVar( GVarName( "SET_FLAGS_FILTER" ), NewFunctionC( "SET_FLAGS_FILTER", 2L, "oper, flags", FuncSetFlagsFilter ) ); + InitHandlerFunc( FuncSetterFilter, "SETTER_FILTER" ); AssGVar( GVarName( "SETTER_FILTER" ), NewFunctionC( "SETTER_FILTER", 1L, "oper", FuncSetterFilter ) ); + InitHandlerFunc( FuncSetSetterFilter, "SET_SETTER_FILTER" ); AssGVar( GVarName( "SET_SETTER_FILTER" ), NewFunctionC( "SET_SETTER_FILTER", 2L, "oper, other", FuncSetSetterFilter ) ); + InitHandlerFunc( FuncTesterFilter, "TESTER_FILTER" ); AssGVar( GVarName( "TESTER_FILTER" ), NewFunctionC( "TESTER_FILTER", 1L, "oper", FuncTesterFilter ) ); + InitHandlerFunc( FuncSetTesterFilter, "SET_TESTER_FILTER" ); AssGVar( GVarName( "SET_TESTER_FILTER" ), NewFunctionC( "SET_TESTER_FILTER", 2L, "oper, other", FuncSetTesterFilter ) ); + InitHandlerFunc( FuncMethodsOperation, "METHODS_OPERATION" ); AssGVar( GVarName( "METHODS_OPERATION" ), NewFunctionC( "METHODS_OPERATION", 2L, "oper, narg", FuncMethodsOperation ) ); + InitHandlerFunc( FuncSetMethodsOperation, "SET_METHODS_OPERATION" ); AssGVar( GVarName( "SET_METHODS_OPERATION" ), NewFunctionC( "SET_METHODS_OPERATION", 3L, "oper, narg, meths", FuncSetMethodsOperation ) ); + InitHandlerFunc( FuncChangedMethodsOperation, "CHANGED_METHODS_OPERATION" ); AssGVar( GVarName( "CHANGED_METHODS_OPERATION" ), NewFunctionC( "CHANGED_METHODS_OPERATION", 2L, "oper, narg", FuncChangedMethodsOperation) ); /* make the functions for filter, operations, properties, attributes */ + InitHandlerFunc( NewFilterHandler, "NewFilter" ); NewFilterFunc = NewFunctionC( "NewFilter", 1L, "name", NewFilterHandler ); AssGVar( GVarName( "NEW_FILTER" ), NewFilterFunc ); + InitHandlerFunc( NewOperationHandler, "NewOperation" ); NewOperationFunc = NewFunctionC( "NewOperation", 1L, "name", NewOperationHandler ); AssGVar( GVarName( "NEW_OPERATION" ), NewOperationFunc ); + InitHandlerFunc( NewConstructorHandler, "NewConstructor" ); NewConstructorFunc = NewFunctionC( "NewConstructor", 1L, "name", NewConstructorHandler ); AssGVar( GVarName( "NEW_CONSTRUCTOR" ), NewConstructorFunc ); + InitHandlerFunc( NewAttributeHandler, "NewAttribute" ); NewAttributeFunc = NewFunctionC( "NewAttribute", 1L, "name", NewAttributeHandler ); AssGVar( GVarName( "NEW_ATTRIBUTE" ), NewAttributeFunc ); + InitHandlerFunc( NewMutableAttributeHandler, "NewMutableAttribute" ); NewMutableAttributeFunc = NewFunctionC( "NewMutableAttribute", 1L, "name", NewMutableAttributeHandler ); AssGVar( GVarName( "NEW_MUTABLE_ATTRIBUTE" ), NewMutableAttributeFunc ); + InitHandlerFunc( NewPropertyHandler, "NewProperty" ); NewPropertyFunc = NewFunctionC( "NewProperty", 1L, "name", NewPropertyHandler ); AssGVar( GVarName( "NEW_PROPERTY" ), NewPropertyFunc ); + InitHandlerFunc( FuncSetterFunction, "SetterFunction" ); SetterFunctionFunc = NewFunctionC( "SetterFunction", 2L, "name, filter", FuncSetterFunction ); AssGVar( GVarName( "SETTER_FUNCTION" ), SetterFunctionFunc ); + InitHandlerFunc( FuncGetterFunction, "GetterFunction" ); GetterFunctionFunc = NewFunctionC( "GetterFunction", 1L, "name", FuncGetterFunction ); AssGVar( GVarName( "GETTER_FUNCTION" ), GetterFunctionFunc ); /* make the trace functions */ + InitHandlerFunc( FuncTraceMethods, "TRACE_METHODS" ); AssGVar( GVarName( "TRACE_METHODS" ), NewFunctionC( "TRACE_METHODS", 1L, "oper", FuncTraceMethods ) ); + InitHandlerFunc( FuncUntraceMethods, "UNTRACE_METHODS" ); AssGVar( GVarName( "UNTRACE_METHODS" ), NewFunctionC( "UNTRACE_METHODS", 1L, "oper", FuncUntraceMethods ) ); @@ -5366,10 +5460,12 @@ void InitOpers ( void ) } #endif + InitHandlerFunc( FuncOPERS_CACHE_INFO, "OPERS_CACHE_INFO" ); AssGVar( GVarName( "OPERS_CACHE_INFO" ), NewFunctionC( "OPERS_CACHE_INFO", 0L, "", FuncOPERS_CACHE_INFO ) ); + InitHandlerFunc( FuncCLEAR_CACHE_INFO, "CLEAR_CACHE_INFO" ); AssGVar( GVarName( "CLEAR_CACHE_INFO" ), NewFunctionC( "CLEAR_CACHE_INFO", 0L, "", FuncCLEAR_CACHE_INFO ) ); diff --git a/src/permutat.c b/src/permutat.c index 32949e9433..a3bcdd2396 100644 --- a/src/permutat.c +++ b/src/permutat.c @@ -40,10 +40,11 @@ char * Revision_permutat_c = "@(#)$Id$"; #include "system.h" /* Ints, UInts */ -#include "scanner.h" /* Pr */ -#include "gasman.h" /* NewBag, CHANGED_BAG */ +#include "gasman.h" /* NewBag, CHANGED_BAG */ #include "objects.h" /* Obj, TYPE_OBJ, types */ +#include "scanner.h" /* Pr */ + #include "gvars.h" /* AssGVar, GVarName */ #include "calls.h" /* Function */ @@ -3458,34 +3459,42 @@ void InitPermutat ( void ) /* install the internal functions */ + InitHandlerFunc( IsPermHandler, "IS_PERM" ); IsPermFilt = NewFilterC( "IS_PERM", 1L, "obj", IsPermHandler ); AssGVar( GVarName( "IS_PERM" ), IsPermFilt ); + InitHandlerFunc( FuncPermList, "PermList" ); AssGVar( GVarName( "PermList" ), NewFunctionC( "PermList", 1L, "list", FuncPermList ) ); + InitHandlerFunc( FuncLargestMovedPointPerm, "LargestMovedPointPerm" ); AssGVar( GVarName( "LargestMovedPointPerm" ), NewFunctionC( "LargestMovedPointPerm", 1L, "perm", FuncLargestMovedPointPerm ) ); + InitHandlerFunc( FuncCycleLengthPermInt, "CycleLengthPermInt" ); AssGVar( GVarName( "CycleLengthPermInt" ), NewFunctionC( "CycleLengthPermInt", 2L, "perm, point", FuncCycleLengthPermInt ) ); + InitHandlerFunc( FuncCyclePermInt, "CyclePermInt" ); AssGVar( GVarName( "CyclePermInt" ), NewFunctionC( "CyclePermInt", 2L, "perm, point", FuncCyclePermInt ) ); + InitHandlerFunc( FuncOrderPerm, "OrderPerm" ); AssGVar( GVarName( "OrderPerm" ), NewFunctionC( "OrderPerm", 1L, "perm", FuncOrderPerm ) ); + InitHandlerFunc( FuncSignPerm, "SignPerm" ); AssGVar( GVarName( "SignPerm" ), NewFunctionC( "SignPerm", 1L, "perm", FuncSignPerm ) ); + InitHandlerFunc( FuncSmallestGeneratorPerm, "SmallestGeneratorPerm" ); AssGVar( GVarName( "SmallestGeneratorPerm" ), NewFunctionC( "SmallestGeneratorPerm", 1L, "perm", FuncSmallestGeneratorPerm ) ); @@ -3493,12 +3502,12 @@ void InitPermutat ( void ) /* make the buffer bag */ TmpPerm = NEW_PERM4( 1000 ); - InitGlobalBag( &TmpPerm ); + InitGlobalBag( &TmpPerm, "permutation: buffer" ); /* make the identity permutation */ IdentityPerm = NEW_PERM2( 0 ); - InitGlobalBag( &IdentityPerm ); + InitGlobalBag( &IdentityPerm, "permutation: ()" ); /* install the 'ONE' function for permutations */ diff --git a/src/plist.c b/src/plist.c index 1a26e8b885..e049f3907e 100644 --- a/src/plist.c +++ b/src/plist.c @@ -37,10 +37,11 @@ char * Revision_plist_c = "@(#)$Id$"; #include "system.h" /* system dependent functions */ -#include "scanner.h" /* Pr */ -#include "gasman.h" /* NewBag, ResizeBag, CHANGED_BAG */ +#include "gasman.h" /* NewBag, ResizeBag, CHANGED_BAG */ #include "objects.h" /* Obj, TYPE_OBJ, SIZE_OBJ, ... */ +#include "scanner.h" /* Pr */ + #include "gvars.h" /* AssGVar, GVarName */ #include "calls.h" /* generic call mechanism */ diff --git a/src/precord.c b/src/precord.c index ce2e6011b8..4d9358fcd3 100644 --- a/src/precord.c +++ b/src/precord.c @@ -16,10 +16,11 @@ char * Revision_precord_c = "@(#)$Id$"; #include "system.h" /* Ints, UInts */ -#include "scanner.h" /* Pr */ -#include "gasman.h" /* NewBag, CHANGED_BAG */ +#include "gasman.h" /* NewBag, CHANGED_BAG */ #include "objects.h" /* Obj, TYPE_OBJ, types */ +#include "scanner.h" /* Pr */ + #include "gvars.h" /* global variables */ #include "calls.h" /* generic call mechanism */ @@ -1230,6 +1231,7 @@ void InitPRecord ( void ) /* install the internal functions */ + InitHandlerFunc( RecNamesHandler, "REC_NAMES" ); RecNamesFunc = NewFunctionC( "REC_NAMES", 1L, "rec", RecNamesHandler ); AssGVar( GVarName( "REC_NAMES" ), RecNamesFunc ); diff --git a/src/range.c b/src/range.c index 7bfa6b97ac..1207a2662f 100644 --- a/src/range.c +++ b/src/range.c @@ -52,10 +52,11 @@ char * Revision_range_c = "@(#)$Id$"; #include "system.h" /* system dependent functions */ -#include "scanner.h" /* Pr */ -#include "gasman.h" /* NewBag, ResizeBag, CHANGED_BAG */ +#include "gasman.h" /* NewBag, ResizeBag, CHANGED_BAG */ #include "objects.h" /* Obj, TYPE_OBJ, SIZE_OBJ, ... */ +#include "scanner.h" /* Pr */ + #include "gvars.h" /* AssGVar, GVarName */ #include "calls.h" /* generic call mechanism */ @@ -1203,6 +1204,7 @@ void InitRange ( void ) PlainListFuncs [ T_RANGE_SSORT +IMMUTABLE ] = PlainRange; /* install the internal function */ + InitHandlerFunc( IsRangeHandler, "IsRange" ); IsRangeFilt = NewFilterC( "IsRange", 1L, "obj", IsRangeHandler ); AssGVar( GVarName( "IS_RANGE" ), IsRangeFilt ); diff --git a/src/rational.c b/src/rational.c index b8e315d845..76d1d40972 100644 --- a/src/rational.c +++ b/src/rational.c @@ -45,10 +45,11 @@ char * Revision_rational_c = "@(#)$Id$"; #include "system.h" /* Ints, UInts */ -#include "scanner.h" /* Pr */ -#include "gasman.h" /* NewBag, CHANGED_BAG */ +#include "gasman.h" /* NewBag, CHANGED_BAG */ #include "objects.h" /* Obj, TYPE_OBJ, types */ +#include "scanner.h" /* Pr */ + #include "gvars.h" /* AssGVar, GVarName */ #include "calls.h" /* NewFunctionC */ @@ -883,11 +884,14 @@ void InitRat ( void ) /* install the internal functions */ + InitHandlerFunc( IsRatHandler, "IS_RAT" ); IsRatFilt = NewFilterC( "IS_RAT", 1L, "obj", IsRatHandler ); AssGVar( GVarName( "IS_RAT" ), IsRatFilt ); + InitHandlerFunc( FuncNumeratorRat, "NUMERATOR_RAT" ); AssGVar( GVarName( "NUMERATOR_RAT" ), NewFunctionC( "NUMERATOR_RAT", 1L, "rat", FuncNumeratorRat ) ); + InitHandlerFunc( FuncDenominatorRat, "DENOMINATOR_RAT" ); AssGVar( GVarName( "DENOMINATOR_RAT" ), NewFunctionC( "DENOMINATOR_RAT", 1L, "rat", FuncDenominatorRat ) ); } diff --git a/src/read.c b/src/read.c index 32c8da9b96..1b786eba4d 100644 --- a/src/read.c +++ b/src/read.c @@ -11,13 +11,15 @@ char * Revision_read_c = "@(#)$Id$"; + #include /* jmp_buf, setjmp, longjmp */ #include "system.h" /* Ints, UInts */ -#include "scanner.h" /* Pr */ -#include "gasman.h" /* NewBag, CHANGED_BAG */ +#include "gasman.h" /* NewBag, CHANGED_BAG */ #include "objects.h" /* Obj, TYPE_OBJ, types */ +#include "scanner.h" /* Pr */ + #include "gvars.h" /* Tilde, VAL_GVAR, AssGVar */ #include "calls.h" /* NAMS_FUNC, ENVI_FUNC */ @@ -1684,7 +1686,7 @@ UInt ReadEvalCommand ( void ) ** It does not expect the first symbol of its input already read and wont ** reads to the end of the input (unless an error happens). */ -UInt ReadEvalFile ( void ) +UInt ReadEvalFile ( void ) { UInt type; Obj stackNams; @@ -1694,6 +1696,10 @@ UInt ReadEvalFile ( void ) UInt currLHSGVar; jmp_buf readJmpError; UInt nr; + Obj name; + Obj nams; + Int nloc; + Int i; /* get the first symbol from the input */ Match( Symbol, "", 0UL ); @@ -1720,8 +1726,37 @@ UInt ReadEvalFile ( void ) CurrLHSGVar = 0; IntrBegin(); + /* check for local variables */ + nloc = 0; + nams = NEW_PLIST( T_PLIST, nloc ); + SET_LEN_PLIST( nams, nloc ); + CountNams += 1; + ASS_LIST( StackNams, CountNams, nams ); + if ( Symbol == S_LOCAL ) { + Match( S_LOCAL, "local", 0L ); + name = NEW_STRING( SyStrlen(Value) ); + SyStrncat( CSTR_STRING(name), Value, SyStrlen(Value) ); + nloc += 1; + ASS_LIST( nams, nloc, name ); + Match( S_IDENT, "identifier", STATBEGIN|S_END ); + while ( Symbol == S_COMMA ) { + Match( S_COMMA, ",", 0L ); + for ( i = 1; i <= nloc; i++ ) { + if ( SyStrcmp(CSTR_STRING(ELM_LIST(nams,i)),Value) == 0 ) { + SyntaxError("name used for two locals"); + } + } + name = NEW_STRING( SyStrlen(Value) ); + SyStrncat( CSTR_STRING(name), Value, SyStrlen(Value) ); + nloc += 1; + ASS_LIST( nams, nloc, name ); + Match( S_IDENT, "identifier", STATBEGIN|S_END ); + } + Match( S_SEMICOLON, ";", STATBEGIN|S_END ); + } + /* fake the 'function ()' */ - IntrFuncExprBegin( 0L, 0L, (Obj)0 ); + IntrFuncExprBegin( 0L, nloc, nams ); /* read the statements */ nr = ReadStats( S_SEMICOLON | S_EOF ); @@ -1777,8 +1812,8 @@ void ReadEvalError ( void ) */ void InitRead ( void ) { - InitGlobalBag( &ReadEvalResult ); - InitGlobalBag( &StackNams ); + InitGlobalBag( &ReadEvalResult, "read: ReadEvalResult" ); + InitGlobalBag( &StackNams, "read: names stack" ); } diff --git a/src/records.c b/src/records.c index b144c4a1ea..549f1c4e8a 100644 --- a/src/records.c +++ b/src/records.c @@ -15,10 +15,11 @@ char * Revision_records_c = "@(#)$Id$"; #include "system.h" /* Ints, UInts */ -#include "scanner.h" /* Pr */ -#include "gasman.h" /* NewBag, CHANGED_BAG */ +#include "gasman.h" /* NewBag, CHANGED_BAG */ #include "objects.h" /* Obj, TYPE_OBJ, types */ +#include "scanner.h" /* Pr */ + #include "gvars.h" /* AssGVar, GVarName */ #include "calls.h" /* NewFunctionC */ @@ -543,23 +544,26 @@ void InitRecords ( void ) /* make the list of names of record names */ CountRNam = 0; - InitGlobalBag( &NamesRNam ); + InitGlobalBag( &NamesRNam, "record: NamesRNam" ); NamesRNam = NEW_PLIST( T_PLIST, 0 ); SET_LEN_PLIST( NamesRNam, 0 ); /* make the hash list of record names */ SizeRNam = 997; - InitGlobalBag( &HashRNam ); + InitGlobalBag( &HashRNam, "record: HashRNam" ); HashRNam = NEW_PLIST( T_PLIST, SizeRNam ); SET_LEN_PLIST( HashRNam, SizeRNam ); /* make and install the 'RNamObj' and 'NameRName' functions */ + InitHandlerFunc( RNamObjHandler, "RNamObj" ); RNamObjFunc = NewFunctionC( "RNamObj", 1L, "obj", RNamObjHandler ); AssGVar( GVarName( "RNamObj" ), RNamObjFunc ); + InitHandlerFunc( NameRNamHandler, "NameRNam" ); NameRNamFunc = NewFunctionC( "NameRNam", 1L, "rnam", NameRNamHandler ); AssGVar( GVarName( "NameRNam" ), NameRNamFunc ); /* make and install the 'IS_REC' filter */ + InitHandlerFunc( IsRecHandler, "IS_REC" ); IsRecFilt = NewFilterC( "IS_REC", 1L, "obj", IsRecHandler ); AssGVar( GVarName( "IS_REC" ), IsRecFilt ); for ( type = FIRST_REAL_TYPE; type <= LAST_REAL_TYPE; type++ ) { @@ -573,6 +577,7 @@ void InitRecords ( void ) } /* make and install the 'ELM_REC' operations */ + InitHandlerFunc( ElmRecHandler, "ELM_REC" ); ElmRecOper = NewOperationC( "ELM_REC", 2L, "obj, rnam", ElmRecHandler ); AssGVar( GVarName( "ELM_REC" ), ElmRecOper ); @@ -584,6 +589,7 @@ void InitRecords ( void ) } /* make and install the 'ISB_REC' operation */ + InitHandlerFunc( IsbRecHandler, "ISB_REC" ); IsbRecOper = NewOperationC( "ISB_REC", 2L, "obj, rnam", IsbRecHandler ); AssGVar( GVarName( "ISB_REC" ), IsbRecOper ); @@ -595,6 +601,7 @@ void InitRecords ( void ) } /* make and install the 'ASS_REC' operation */ + InitHandlerFunc( AssRecHandler, "ASS_REC" ); AssRecOper = NewOperationC( "ASS_REC", 3L, "obj, rnam, val", AssRecHandler ); AssGVar( GVarName( "ASS_REC" ), AssRecOper ); @@ -606,6 +613,7 @@ void InitRecords ( void ) } /* make and install the 'UNB_REC' operation */ + InitHandlerFunc( UnbRecHandler, "UNB_REC" ); UnbRecOper = NewOperationC( "UNB_REC", 2L, "obj, rnam", UnbRecHandler ); AssGVar( GVarName( "UNB_REC" ), UnbRecOper ); diff --git a/src/records.h b/src/records.h index 438f8668ef..bae0bd6f13 100644 --- a/src/records.h +++ b/src/records.h @@ -144,7 +144,25 @@ extern void (*AssRecFuncs[LAST_REAL_TYPE+1]) ( Obj rec, UInt rnam, O ((*UnbRecFuncs[ TYPE_OBJ(rec) ])( rec, rnam )) extern void (*UnbRecFuncs[LAST_REAL_TYPE+1]) ( Obj rec, UInt rnam ); - + + +/**************************************************************************** +** +*F iscomplete_rnam( , ) . . . . . . . . . . . . . check +*/ +extern UInt iscomplete_rnam ( + Char * name, + UInt len ); + + +/**************************************************************************** +** +*F completion_rnam( , ) . . . . . . . . . . . . find completion +*/ +extern UInt completion_rnam ( + Char * name, + UInt len ); + /**************************************************************************** ** diff --git a/src/scanner.c b/src/scanner.c index 1d04f0dd33..91ba649d9c 100644 --- a/src/scanner.c +++ b/src/scanner.c @@ -29,13 +29,23 @@ char * Revision_scanner_c = #include "system.h" /* system dependent functions */ +#include "gasman.h" /* NewBag, CHANGED_BAG */ +#include "objects.h" /* Obj, TYPE_OBJ, types */ + #define INCLUDE_DECLARATION_PART #include "scanner.h" /* declaration part of the package */ #undef INCLUDE_DECLARATION_PART +#include "calls.h" /* CALL_1ARGS, Function */ + +#include "bool.h" /* True, False */ + +#include "string.h" /* ObjsChar, NEW_STRING, CSTR_ST...*/ + /**************************************************************************** ** + *V Symbol . . . . . . . . . . . . . . . . . current symbol read from input ** ** The variable 'Symbol' contains the current symbol read from the input. @@ -252,6 +262,7 @@ Char * Prompt; /**************************************************************************** ** + *T TypInputFile . . . . . . . . . . structure of an open input file, local *V InputFiles[] . . . . . . . . . . . . . stack of open input files, local *V Input . . . . . . . . . . . . . . . pointer to current input file, local @@ -277,15 +288,6 @@ Char * Prompt; ** 'In' is a pointer to the current input character, i.e., '*In' is the ** current input character. It points into the buffer 'Input->line'. */ -typedef struct { - Int file; - Char name [64]; - Char line [256]; - Char * ptr; - UInt symbol; - Int number; -} TypInputFile; - TypInputFile InputFiles [16]; TypInputFile * Input; Char * In; @@ -309,15 +311,6 @@ Char * In; ** 'Output' is a pointer to the current output file. It points to the top ** of the stack 'OutputFiles'. */ -typedef struct { - Int file; - Char line [256]; - Int pos; - Int indent; - Int spos; - Int sindent; -} TypOutputFile; - TypOutputFile OutputFiles [16]; TypOutputFile * Output; @@ -350,1683 +343,1829 @@ Int OutputLog = -1; *V TestOutput . . . . . . . . . . . . file identifier of test output, local *V TestLine . . . . . . . . . . . . . . . . one line from test input, local ** -** 'TestInput' is the file identifier of the file for test input. If this -** is not -1 and 'GetLine' reads a line from 'TestInput' that begins with -** '#>' 'GetLine' assumes that this was expected as output that did not -** appear and echoes this input line to 'TestOutput'. +** 'TestInput' is the file identifier of the file for test input. If this +** is not -1 and 'GetLine' reads a line from 'TestInput' that does not +** begins with 'gap>' 'GetLine' assumes that this was expected as output +** that did not appear and echoes this input line to 'TestOutput'. ** ** 'TestOutput' is the current output file for test output. If 'TestInput' -** is not -1 then 'PutLine' compares every line that is about to be printed -** to 'TestOutput' with the next line from 'TestInput'. If this line starts -** with '#>' and the rest of it matches the output line the output line is -** not printed and the input comment line is discarded. Otherwise 'PutLine' -** prints the output line and does not discard the input line. +** is not -1 then 'PutLine' compares every line that is about to be printed +** to 'TestOutput' with the next line from 'TestInput'. If this line does +** not starts with 'gap>' and the rest of it matches the output line the +** output line is not printed and the input comment line is discarded. +** Otherwise 'PutLine' prints the output line and does not discard the input +** line. ** ** 'TestLine' holds the one line that is read from 'TestInput' to compare it ** with a line that is about to be printed to 'TestOutput'. */ -Int TestInput = -1; -Int TestOutput = -1; +TypInputFile * TestInput = 0; +TypOutputFile * TestOutput = 0; Char TestLine [256]; /**************************************************************************** ** -*F GetLine() . . . . . . . . . . . . . . . . . . . . . . . get a line, local + +*F * * * * * * * * * * * open input/output functions * * * * * * * * * * * * +*/ + + +/**************************************************************************** ** -** 'GetLine' fetches another line from the input file 'Input->file' into the -** buffer 'Input->line', sets the pointer 'In' to the beginning of this -** buffer and returns the first character from the line. + +*F OpenInput( ) . . . . . . . . . . open a file as current input ** -** If the input file is '*stdin*' or '*errin*' 'GetLine' first prints -** 'Prompt', unless it is '*stdin*' and GAP was called with option '-q'. +** 'OpenInput' opens the file with the name as current input. +** All subsequent input will be taken from that file, until it is closed +** again with 'CloseInput' or another file is opened with 'OpenInput'. +** 'OpenInput' will not close the current file, i.e., if is +** closed again, input will again be taken from the current input file. ** -** If there is an input logfile in use and the input file is '*stdin*' or -** '*errin*' 'GetLine' echoes the new line to the logfile. +** 'OpenInput' returns 1 if it could successfully open for +** reading and 0 to indicate failure. 'OpenInput' will fail if the file +** does not exist or if you do not have permissions to read it. 'OpenInput' +** may also fail if you have too many files open at once. It is system +** dependent how many are too many, but 16 files should work everywhere. +** +** Directely after the 'OpenInput' call the variable 'Symbol' has the value +** 'S_ILLEGAL' to indicate that no symbol has yet been read from this file. +** The first symbol is read by 'Read' in the first call to 'Match' call. +** +** You can open '*stdin*' to read from the standard input file, which is +** usually the terminal, or '*errin*' to read from the standard error file, +** which is the terminal even if '*stdin*' is redirected from a file. +** 'OpenInput' passes those file names to 'SyFopen' like any other name, +** they are just a convention between the main and the system package. +** 'SyFopen' and thus 'OpenInput' will fail to open '*errin*' if the file +** 'stderr' (Unix file descriptor 2) is not a terminal, because of a +** redirection say, to avoid that break loops take their input from a file. +** +** It is not neccessary to open the initial input file, 'InitScanner' opens +** '*stdin*' for that purpose. This file on the other hand cannot be +** closed by 'CloseInput'. */ -Char GetLine ( void ) +UInt OpenInput ( + Char * filename ) { - /* if file is '*stdin*' or '*errin*' print the prompt and flush it */ - if ( Input->file == 0 ) { - if ( ! SyQuiet ) Pr( "%s%c", (Int)Prompt, (Int)'\03' ); - else Pr( "%c", (Int)'\03', 0L ); - } - else if ( Input->file == 2 ) { - Pr( "%s%c", (Int)Prompt, (Int)'\03' ); - } - - /* bump the line number */ - if ( Input->line < In && (*(In-1) == '\n' || *(In-1) == '\r') ) { - Input->number++; - } - - /* initialize 'In', no errors on this line so far */ - In = Input->line; In[0] = '\0'; - NrErrLine = 0; + Int file; - /* read a line from an ordinary input file */ - if ( Input->file != TestInput ) { + /* fail if we can not handle another open input file */ + if ( Input+1 == InputFiles+(sizeof(InputFiles)/sizeof(InputFiles[0])) ) + return 0; - /* try to read a line */ - if ( ! SyFgets( In, sizeof(Input->line), Input->file ) ) { - In[0] = '\377'; In[1] = '\0'; - } + /* in test mode keep reading from test input file for break loop input */ + if ( TestInput != 0 && ! SyStrcmp( filename, "*errin*" ) ) + return 1; - /* if neccessary echo the line to the logfile */ - if ( InputLog != -1 && (Input->file == 0 || Input->file == 2) ) { - SyFputs( In, InputLog ); - } + /* try to open the input file */ + file = SyFopen( filename, "r" ); + if ( file == -1 ) + return 0; + /* remember the current position in the current file */ + if ( Input != InputFiles-1 ) { + Input->ptr = In; + Input->symbol = Symbol; } - /* read a line for test input file */ - else { - - /* continue until we got an input line */ - while ( In[0] == '\0' ) { + /* enter the file identifier and the file name */ + Input++; + Input->isstream = 0; + Input->file = file; + Input->name[0] = '\0'; + SyStrncat( Input->name, filename, sizeof(Input->name) ); - /* there may be one line waiting */ - if ( TestLine[0] != '\0' ) { - SyStrncat( In, TestLine, sizeof(Input->line) ); - TestLine[0] = '\0'; - } + /* start with an empty line and no symbol */ + In = Input->line; + In[0] = In[1] = '\0'; + Symbol = S_ILLEGAL; + Input->number = 1; - /* otherwise try to read a line */ - else if ( ! SyFgets( In, sizeof(Input->line), Input->file ) ) { - In[0] = '\377'; In[1] = '\0'; - } + /* indicate success */ + return 1; +} - /* if the line starts with a prompt its an input line */ - if ( In[0] == 'g' && In[1] == 'a' && In[2] == 'p' - && In[3] == '>' && In[4] == ' ' ) { - In = In + 5; - } - else if ( In[0] == '>' && In[1] == ' ' ) { - In = In + 2; - } - /* if the line is not empty or a comment, print it */ - else if ( In[0] != '\n' && In[0] != '#' && In[0] != '\377' ) { - SyFputs( "- ", TestOutput ); - SyFputs( In, TestOutput ); - In[0] = '\0'; - } +/**************************************************************************** +** +*F OpenInputStream( ) . . . . . . . open a stream as current input +*/ +UInt OpenInputStream ( + Obj stream ) +{ + Int file; - } + /* fail if we can not handle another open input file */ + if ( Input+1 == InputFiles+(sizeof(InputFiles)/sizeof(InputFiles[0])) ) + return 0; + /* remember the current position in the current file */ + if ( Input != InputFiles-1 ) { + Input->ptr = In; + Input->symbol = Symbol; } - /* return the current character */ - return *In; -} + /* enter the file identifier and the file name */ + Input++; + Input->isstream = 1; + Input->stream = stream; + Input->sline = 0; + Input->name[0] = '\0'; + SyStrncat( Input->name, "stream", 6 ); + /* start with an empty line and no symbol */ + In = Input->line; + In[0] = In[1] = '\0'; + Symbol = S_ILLEGAL; + Input->number = 1; -/**************************************************************************** -** -*F GET_CHAR() . . . . . . . . . . . . . . . . get the next character, local -** -** 'GET_CHAR' returns the next character from the current input file. This -** character is afterwords also available as '*In'. -** -** For efficiency reasons 'GET_CHAR' is a macro that just increments the -** pointer 'In' and checks that there is another character. If not, for -** example at the end a line, 'GET_CHAR' calls 'GetLine' to fetch a new line -** from the input file. -*/ -#define GET_CHAR() (*++In != '\0' ? *In : GetLine()) + /* indicate success */ + return 1; +} /**************************************************************************** ** -*F GetIdent() . . . . . . . . . . . . . get an identifier or keyword, local -** -** 'GetIdent' reads an identifier from the current input file into the -** variable 'Value' and sets 'Symbol' to 'S_IDENT'. The first character of -** the identifier is the current character pointed to by 'In'. If the -** characters make up a keyword 'GetIdent' will set 'Symbol' to the -** corresponding value. The parser will ignore 'Value' in this case. +*F CloseInput() . . . . . . . . . . . . . . . . . close current input file ** -** An identifier consists of a letter followed by more letters, digits and -** underscores '_'. An identifier is terminated by the first character not -** in this class. The escape sequence '\' is ignored, making it -** possible to split long identifiers over multiple lines. The backslash -** '\' can be used to include special characters like '(' in identifiers. -** For example 'G\(2\,5\)' is an identifier not a call to a function 'G'. +** 'CloseInput' will close the current input file. Subsequent input will +** again be taken from the previous input file. 'CloseInput' will return 1 +** to indicate success. ** -** The size of 'Value' limits the number of significant characters in an -** identifier. If an identifier has more characters 'GetIdent' will -** silently truncate it. +** 'CloseInput' will not close the initial input file '*stdin*', and returns +** 0 if such an attempt is made. This is used in 'Error' which calls +** 'CloseInput' until it returns 0, therebye closing all open input files. ** -** After reading the identifier 'GetIdent' looks at the first and the last -** character of 'Value' to see if it could possibly be a keyword. For -** example 'test' could not be a keyword because there is no keyword -** starting and ending with a 't'. After that test either 'GetIdent' knows -** that 'Value' is not a keyword, or there is a unique possible keyword that -** could match, because no two keywords have identical first and last -** characters. For example if 'Value' starts with 'f' and ends with 'n' the -** only possible keyword is 'function'. Thus in this case 'GetIdent' can -** decide with one string comparison if 'Value' holds a keyword or not. +** Calling 'CloseInput' if the corresponding 'OpenInput' call failed will +** close the current output file, which will lead to very strange behaviour. */ -void GetSymbol ( void ); - -void GetIdent ( void ) +UInt CloseInput ( void ) { - Int i; - Int isQuoted; - - /* initially it could be a keyword */ - isQuoted = 0; + /* refuse to close the initial input file */ + if ( Input == InputFiles ) + return 0; - /* read all characters into 'Value' */ - for ( i=0; IsAlpha(*In) || IsDigit(*In) || *In=='_' || *In=='\\'; i++ ) { + /* refuse to close the test input file */ + if ( Input == TestInput ) + return 0; - /* handle escape sequences */ - /* we ignore '\ newline' by decrementing i, except at the - very start of the identifier, when we cannot do that - so we recurse instead */ - if ( *In == '\\' ) { - GET_CHAR(); - if ( *In == '\n' && i == 0 ) { GetSymbol(); return; } - else if ( *In == '\n' && i < sizeof(Value)-1 ) i--; - else if ( *In == 'n' && i < sizeof(Value)-1 ) Value[i] = '\n'; - else if ( *In == 't' && i < sizeof(Value)-1 ) Value[i] = '\t'; - else if ( *In == 'r' && i < sizeof(Value)-1 ) Value[i] = '\r'; - else if ( *In == 'b' && i < sizeof(Value)-1 ) Value[i] = '\b'; - else if ( i < sizeof(Value)-1 ) { - Value[i] = *In; - isQuoted = 1; - } - } + /* close the input file */ + if ( ! Input->isstream ) { + SyFclose( Input->file ); + } - /* put normal chars into 'Value' but only if there is room */ - else { - if ( i < sizeof(Value)-1 ) Value[i] = *In; - } + /* revert to last file */ + Input--; + In = Input->ptr; + Symbol = Input->symbol; - /* read the next character */ - GET_CHAR(); + /* indicate success */ + return 1; +} - } - /* terminate the identifier and lets assume that it is not a keyword */ - if ( i < sizeof(Value)-1 ) Value[i] = '\0'; - Symbol = S_IDENT; +/**************************************************************************** +** - /* now check if 'Value' holds a keyword */ - switch ( 256*Value[0]+Value[i-1] ) { - case 256*'a'+'d': if(!SyStrcmp(Value,"and")) Symbol=S_AND; break; - case 256*'b'+'k': if(!SyStrcmp(Value,"break")) Symbol=S_BREAK; break; - case 256*'d'+'o': if(!SyStrcmp(Value,"do")) Symbol=S_DO; break; - case 256*'e'+'f': if(!SyStrcmp(Value,"elif")) Symbol=S_ELIF; break; - case 256*'e'+'e': if(!SyStrcmp(Value,"else")) Symbol=S_ELSE; break; - case 256*'e'+'d': if(!SyStrcmp(Value,"end")) Symbol=S_END; break; - case 256*'f'+'e': if(!SyStrcmp(Value,"false")) Symbol=S_FALSE; break; - case 256*'f'+'i': if(!SyStrcmp(Value,"fi")) Symbol=S_FI; break; - case 256*'f'+'r': if(!SyStrcmp(Value,"for")) Symbol=S_FOR; break; - case 256*'f'+'n': if(!SyStrcmp(Value,"function"))Symbol=S_FUNCTION;break; - case 256*'i'+'f': if(!SyStrcmp(Value,"if")) Symbol=S_IF; break; - case 256*'i'+'n': if(!SyStrcmp(Value,"in")) Symbol=S_IN; break; - case 256*'l'+'l': if(!SyStrcmp(Value,"local")) Symbol=S_LOCAL; break; - case 256*'m'+'d': if(!SyStrcmp(Value,"mod")) Symbol=S_MOD; break; - case 256*'n'+'t': if(!SyStrcmp(Value,"not")) Symbol=S_NOT; break; - case 256*'o'+'d': if(!SyStrcmp(Value,"od")) Symbol=S_OD; break; - case 256*'o'+'r': if(!SyStrcmp(Value,"or")) Symbol=S_OR; break; - case 256*'r'+'c': if(!SyStrcmp(Value,"rec")) Symbol=S_REC; break; - case 256*'r'+'t': if(!SyStrcmp(Value,"repeat")) Symbol=S_REPEAT; break; - case 256*'r'+'n': if(!SyStrcmp(Value,"return")) Symbol=S_RETURN; break; - case 256*'t'+'n': if(!SyStrcmp(Value,"then")) Symbol=S_THEN; break; - case 256*'t'+'e': if(!SyStrcmp(Value,"true")) Symbol=S_TRUE; break; - case 256*'u'+'l': if(!SyStrcmp(Value,"until")) Symbol=S_UNTIL; break; - case 256*'w'+'e': if(!SyStrcmp(Value,"while")) Symbol=S_WHILE; break; - case 256*'q'+'t': if(!SyStrcmp(Value,"quit")) Symbol=S_QUIT; break; - case 256*'I'+'d': if(!SyStrcmp(Value,"IsBound")) Symbol=S_ISBOUND; break; - case 256*'U'+'d': if(!SyStrcmp(Value,"Unbind")) Symbol=S_UNBIND; break; - case 256*'T'+'d': if(!SyStrcmp(Value,"TryNextMethod")) - Symbol=S_TRYNEXT; break; - case 256*'I'+'o': if(!SyStrcmp(Value,"Info")) Symbol=S_INFO; break; - case 256*'A'+'t': if(!SyStrcmp(Value,"Assert")) Symbol=S_ASSERT; break; - default: ; - } - - /* if it is quoted it is an identifier */ - if ( isQuoted ) Symbol = S_IDENT; - -} - - -/**************************************************************************** +*F OpenTest( ) . . . . . . . . open an input file for test mode ** -*F GetInt() . . . . . . . . . . . . . . . . . . . . . get an integer, local +** 'OpenTest' opens the file with the name as current input for +** test mode. All subsequent input will be taken from that file, until it +** is closed again with 'CloseTest' or another file is opened with +** 'OpenInput'. 'OpenTest' will not close the current file, i.e., if +** is closed again, input will be taken again from the current +** input file. ** -** 'GetInt' reads an integer number from the current input file into the -** variable 'Value' and sets 'Symbol' to 'S_INT'. The first character of -** the integer is the current character pointed to by 'In'. +** Test mode works as follows. If the scanner is about to print a line to +** the current output file (or to be more precise to the output file that +** was current when 'OpenTest' was called) this line is compared with the +** next line from the test input file, i.e., the one opened by 'OpenTest'. +** If this line starts with '#>' and the rest of it matches the output line +** the output line is not printed and the input comment line is discarded. +** Otherwise the scanner prints the output line and does not discard the +** input line. ** -** An integer is a sequence of digits '0..9'. The escape sequence -** '\' is ignored, making it possible to split long integers over -** multiple lines. +** On the other hand if an input line is encountered on the test input that +** starts with '#>' the scanner assumes that this is an expected output line +** that did not appear and echoes this line to the current output file. ** -** If the sequence contains characters which are not digits 'GetInt' will -** interpret the sequence as an identifier and set 'Symbol' to 'S_IDENT'. +** The upshot is that you can write test files that consist of alternating +** input and, as '#>' test comment lines the expected output. If GAP +** behaves normal and produces the expected output then nothing is printed. +** But if something goes wrong you see what actually was printed and what +** was expected instead. ** -** The size of 'Value' limits the maximal number of digits of an integer. -** If an integer has more digits 'GetInt' issues a warning and truncates it. +** As a convention GAP test files should end with a print statement like: +** +** Print("prime 3.002 06-Jul-90 ",417000000/Runtime()," GAPstones\n"); +** +** without a matching '#>' comment line. This tells the user that the test +** file completed and also how much time it took. The constant should be +** such that a VAX 11/780 gets roughly 1000 GAPstones. +** +** 'OpenTest' returns 1 if it could successfully open for reading +** and 0 to indicate failure. 'OpenTest' will fail if the file does not +** exist or if you have no permissions to read it. 'OpenTest' may also fail +** if you have too many files open at once. It is system dependent how many +** are too may, but 16 files shoule work everywhere. +** +** Directely after the 'OpenTest' call the variable 'Symbol' has the value +** 'S_ILLEGAL' to indicate that no symbol has yet been read from this file. +** The first symbol is read by 'Read' in the first call to 'Match' call. */ -void GetInt ( void ) +UInt OpenTest ( + Char * filename ) { - Int i; - Int isInt; - - isInt = 1; - - /* read the digits into 'Value' */ - for ( i=0; IsDigit(*In) || IsAlpha(*In) || *In=='_' || *In=='\\'; i++ ) { - - /* handle escape sequences */ - if ( *In == '\\' ) { - GET_CHAR(); - if ( *In == '\n' && i < sizeof(Value)-1 ) i--; - else if ( *In == 'n' && i < sizeof(Value)-1 ) Value[i] = '\n'; - else if ( *In == 't' && i < sizeof(Value)-1 ) Value[i] = '\t'; - else if ( *In == 'r' && i < sizeof(Value)-1 ) Value[i] = '\r'; - else if ( *In == 'b' && i < sizeof(Value)-1 ) Value[i] = '\b'; - else if ( *In == 'c' && i < sizeof(Value)-1 ) Value[i] = '\03'; - else if ( i < sizeof(Value)-1 ) Value[i] = *In; - } - - /* put normal chars into 'Value' but only if there is room */ - else { - if ( i < sizeof(Value)-1 ) Value[i] = *In; - } - - /* if the characters contain non digits it is a variable */ - if ( ! IsDigit(*In) && *In != '\n' ) isInt = 0; - - /* get the next character */ - GET_CHAR(); + /* do not allow to nest test files */ + if ( TestInput != 0 ) + return 0; - } + /* try to open the file as input file */ + if ( ! OpenInput( filename ) ) + return 0; - /* check for numbers with too many digits */ - if ( sizeof(Value)-1 <= i ) - SyntaxError("integer must have less than 1024 digits"); + /* remember this is a test input */ + TestInput = Input; + TestOutput = Output; + TestLine[0] = '\0'; - /* terminate the integer */ - if ( i < sizeof(Value)-1 ) Value[i] = '\0'; - if ( isInt ) Symbol = S_INT; - else Symbol = S_IDENT; + /* indicate success */ + return 1; } /**************************************************************************** ** -*F GetStr() . . . . . . . . . . . . . . . . . . . . . . get a string, local -** -** 'GetStr' reads a string from the current input file into the variable -** 'Value' and sets 'Symbol' to 'S_STRING'. The opening double quote '"' -** of the string is the current character pointed to by 'In'. -** -** A string is a sequence of characters delimited by double quotes '"'. It -** must not include '"' or characters, but the escape sequences -** '\"' or '\n' can be used instead. The escape sequence '\' is -** ignored, making it possible to split long strings over multiple lines. -** -** An error is raised if the string includes a character or if the -** file ends before the closing '"'. -** -** The size of 'Value' limits the maximal number of characters in a string. -** If a string has more characters 'GetStr' issues a error and truncates it. +*F OpenTestStream( ) . . . . . open an input stream for test mode */ -void GetStr ( void ) +UInt OpenTestStream ( + Obj stream ) { - Int i = 0; - - /* skip '"' */ - GET_CHAR(); - - /* read all characters into 'Value' */ - for ( i = 0; *In != '"' && *In != '\n' && *In != '\377'; i++ ) { - - /* handle escape sequences */ - if ( *In == '\\' ) { - GET_CHAR(); - if ( *In == '\n' && i < sizeof(Value)-1 ) i--; - else if ( *In == 'n' && i < sizeof(Value)-1 ) Value[i] = '\n'; - else if ( *In == 't' && i < sizeof(Value)-1 ) Value[i] = '\t'; - else if ( *In == 'r' && i < sizeof(Value)-1 ) Value[i] = '\r'; - else if ( *In == 'b' && i < sizeof(Value)-1 ) Value[i] = '\b'; - else if ( *In == 'c' && i < sizeof(Value)-1 ) Value[i] = '\03'; - else if ( i < sizeof(Value)-1 ) Value[i] = *In; - } - - /* put normal chars into 'Value' but only if there is room */ - else { - if ( i < sizeof(Value)-1 ) Value[i] = *In; - } - - /* read the next character */ - GET_CHAR(); + /* do not allow to nest test files */ + if ( TestInput != 0 ) + return 0; - } + /* try to open the file as input file */ + if ( ! OpenInputStream( stream ) ) + return 0; - /* check for error conditions */ - if ( *In == '\n' ) - SyntaxError("string must not include "); - if ( *In == '\377' ) - SyntaxError("string must end with \" before end of file"); - if ( sizeof(Value)-1 <= i ) - SyntaxError("string must have less than 1024 characters"); + /* remember this is a test input */ + TestInput = Input; + TestOutput = Output; + TestLine[0] = '\0'; - /* terminate the string, set 'Symbol' and skip trailing '"' */ - if ( i < sizeof(Value)-1 ) Value[i] = '\0'; - Symbol = S_STRING; - if ( *In == '"' ) GET_CHAR(); + /* indicate success */ + return 1; } /**************************************************************************** ** -*F GetChar() . . . . . . . . . . . . . . . . . get a single character, local +*F CloseTest() . . . . . . . . . . . . . . . . . . close the test input file ** -** 'GetChar' reads the next character from the current input file into the -** variable 'Value' and sets 'Symbol' to 'S_CHAR'. The opening single quote -** '\'' of the character is the current character pointed to by 'In'. +** 'CloseTest' closes the current test input file and ends test mode. +** Subsequent input will again be taken from the previous input file. +** Output will no longer be compared with comment lines from the test input +** file. 'CloseTest' will return 1 to indicate success. ** -** A character is a single character delimited by single quotes '\''. It -** must not be '\'' or , but the escape sequences '\\\'' or '\n' -** can be used instead. +** 'CloseTest' will not close a non test input file and returns 0 if such an +** attempt is made. */ -void GetChar ( void ) +UInt CloseTest ( void ) { - /* skip '\'' */ - GET_CHAR(); - - /* handle escape equences */ - if ( *In == '\\' ) { - GET_CHAR(); - if ( *In == 'n' ) Value[0] = '\n'; - else if ( *In == 't' ) Value[0] = '\t'; - else if ( *In == 'r' ) Value[0] = '\r'; - else if ( *In == 'b' ) Value[0] = '\b'; - else if ( *In == 'c' ) Value[0] = '\03'; - else Value[0] = *In; - } + /* refuse to a non test file */ + if ( TestInput != Input ) + return 0; - /* put normal chars into 'Value' */ - else { - Value[0] = *In; + /* close the input file */ + if ( ! Input->isstream ) { + SyFclose( Input->file ); } - /* read the next character */ - GET_CHAR(); + /* revert to last file */ + Input--; + In = Input->ptr; + Symbol = Input->symbol; - /* check for terminating single quote */ - if ( *In != '\'' ) - SyntaxError("missing single quote in character constant"); + /* we are no longer in test mode */ + TestInput = 0; + TestOutput = 0; + TestLine[0] = '\0'; - /* skip the closing quote */ - Symbol = S_CHAR; - if ( *In == '\'' ) GET_CHAR(); + /* indicate success */ + return 1; } /**************************************************************************** ** -*F GetSymbol() . . . . . . . . . . . . . . . . . get the next symbol, local + +*F OpenOutput( ) . . . . . . . . . open a file as current output ** -** 'GetSymbol' reads the next symbol from the input, storing it in the -** variable 'Symbol'. If 'Symbol' is 'T_IDENT', 'T_INT' or 'T_STRING' the -** value of the symbol is stored in the variable 'Value'. 'GetSymbol' first -** skips all , and characters and comments. +** 'OpenOutput' opens the file with the name as current output. +** All subsequent output will go to that file, until either it is closed +** again with 'CloseOutput' or another file is opened with 'OpenOutput'. +** The file is truncated to size 0 if it existed, otherwise it is created. +** 'OpenOutput' does not close the current file, i.e., if is +** closed again, output will go again to the current output file. ** -** After reading a symbol the current character is the first character -** beyond that symbol. +** 'OpenOutput' returns 1 if it could successfully open for +** writing and 0 to indicate failure. 'OpenOutput' will fail if you do not +** have permissions to create the file or write to it. 'OpenOutput' may +** also fail if you have too many files open at once. It is system +** dependent how many are too many, but 16 files should work everywhere. +** +** You can open '*stdout*' to write to the standard output file, which is +** usually the terminal, or '*errout*' to write to the standard error file, +** which is the terminal even if '*stdout*' is redirected to a file. +** 'OpenOutput' passes those file names to 'SyFopen' like any other name, +** they are just a convention between the main and the system package. +** +** It is not neccessary to open the initial output file, 'InitScanner' opens +** '*stdout*' for that purpose. This file on the other hand can not be +** closed by 'CloseOutput'. */ -void GetSymbol ( void ) +UInt OpenOutput ( + Char * filename ) { - /* if no character is available then get one */ - if ( *In == '\0' ) - GET_CHAR(); + Int file; - /* skip over , , and comments */ - while (*In==' '||*In=='\t'||*In=='\n'||*In=='\r'||*In=='\f'||*In=='#') { - if ( *In == '#' ) { - while ( *In != '\n' && *In != '\r' && *In != '\377' ) - GET_CHAR(); - } - GET_CHAR(); - } + /* fail if we can not handle another open output file */ + if ( Output+1==OutputFiles+(sizeof(OutputFiles)/sizeof(OutputFiles[0])) ) + return 0; - /* switch according to the character */ - switch ( *In ) { + /* in test mode keep printing to test output file for breakloop output */ + if ( TestInput != 0 && ! SyStrcmp( filename, "*errout*" ) ) + return 1; - case '.': Symbol = S_DOT; GET_CHAR(); - if ( *In == '.' ) { Symbol = S_DOTDOT; GET_CHAR(); break; } - break; - case '!': Symbol = S_ILLEGAL; GET_CHAR(); - if ( *In == '\\' ) { GET_CHAR(); - if ( *In == '\n' ) { GET_CHAR(); } } - if ( *In == '.' ) { Symbol = S_BDOT; GET_CHAR(); break; } - if ( *In == '[' ) { Symbol = S_BLBRACK; GET_CHAR(); break; } - if ( *In == '{' ) { Symbol = S_BLBRACE; GET_CHAR(); break; } - break; - case '[': Symbol = S_LBRACK; GET_CHAR(); break; - case ']': Symbol = S_RBRACK; GET_CHAR(); break; - case '{': Symbol = S_LBRACE; GET_CHAR(); break; - case '}': Symbol = S_RBRACE; GET_CHAR(); break; - case '(': Symbol = S_LPAREN; GET_CHAR(); break; - case ')': Symbol = S_RPAREN; GET_CHAR(); break; - case ',': Symbol = S_COMMA; GET_CHAR(); break; + /* try to open the file */ + file = SyFopen( filename, "w" ); + if ( file == -1 ) + return 0; - case ':': Symbol = S_ILLEGAL; GET_CHAR(); - if ( *In == '\\' ) { GET_CHAR(); - if ( *In == '\n' ) { GET_CHAR(); } } - if ( *In == '=' ) { Symbol = S_ASSIGN; GET_CHAR(); break; } - break; + /* put the file on the stack, start at position 0 on an empty line */ + Output++; + Output->file = file; + Output->line[0] = '\0'; + Output->pos = 0; + Output->indent = 0; - case ';': Symbol = S_SEMICOLON; GET_CHAR(); break; + /* variables related to line splitting, very bad place to split */ + Output->spos = 0; + Output->sindent = 666; - case '=': Symbol = S_EQ; GET_CHAR(); break; - case '<': Symbol = S_LT; GET_CHAR(); - if ( *In == '\\' ) { GET_CHAR(); - if ( *In == '\n' ) { GET_CHAR(); } } - if ( *In == '=' ) { Symbol = S_LE; GET_CHAR(); break; } - if ( *In == '>' ) { Symbol = S_NE; GET_CHAR(); break; } - break; - case '>': Symbol = S_GT; GET_CHAR(); - if ( *In == '\\' ) { GET_CHAR(); - if ( *In == '\n' ) { GET_CHAR(); } } - if ( *In == '=' ) { Symbol = S_GE; GET_CHAR(); break; } - break; + /* indicate success */ + return 1; +} - case '+': Symbol = S_PLUS; GET_CHAR(); break; - case '-': Symbol = S_MINUS; GET_CHAR(); - if ( *In == '>' ) { Symbol=S_MAPTO; GET_CHAR(); break; } - break; - case '*': Symbol = S_MULT; GET_CHAR(); break; - case '/': Symbol = S_DIV; GET_CHAR(); break; - case '^': Symbol = S_POW; GET_CHAR(); break; - case '"': GetStr(); break; - case '\'': GetChar(); break; - case '\\': GetIdent(); break; - case '_': GetIdent(); break; - case '~': Value[0] = '~'; Value[1] = '\0'; - Symbol = S_IDENT; GET_CHAR(); break; +/**************************************************************************** +** +*F CloseOutput() . . . . . . . . . . . . . . . . . close current output file +** +** 'CloseOutput' will first flush all pending output and then close the +** current output file. Subsequent output will again go to the previous +** output file. 'CloseOutput' returns 1 to indicate success. +** +** 'CloseOutput' will not close the initial output file '*stdout*', and +** returns 0 if such attempt is made. This is used in 'Error' which calls +** 'CloseOutput' until it returns 0, thereby closing all open output files. +** +** Calling 'CloseOutput' if the corresponding 'OpenOutput' call failed will +** close the current output file, which will lead to very strange behaviour. +** On the other hand if you forget to call 'CloseOutput' at the end of a +** 'PrintTo' call or an error will not yield much better results. +*/ +UInt CloseOutput ( void ) +{ + /* refuse to close the initial output file '*stdout*' */ + if ( Output == OutputFiles ) + return 0; - case '0': case '1': case '2': case '3': case '4': - case '5': case '6': case '7': case '8': case '9': GetInt(); break; + /* refuse to close the test output file */ + if ( Output == TestOutput ) + return 0; - case '\377': Symbol = S_EOF; *In = '\0'; break; + /* flush output and close the file */ + Pr( "%c", (Int)'\03', 0L ); + SyFclose( Output->file ); - default : if ( IsAlpha(*In) ) { GetIdent(); break; } - Symbol = S_ILLEGAL; GET_CHAR(); break; - } + /* revert to previous output file and indicate success */ + Output--; + return 1; } /**************************************************************************** ** -*F SyntaxError( ) . . . . . . . . . . . . . . . raise a syntax error -** -** 'SyntaxError' prints the current line, followed by the error message: -** -** ^ syntax error, in -** -** with the '^' pointing to the current symbol on the current line. If the -** is '*stdin*' it is not printed. -** -** 'SyntaxError' is called from the parser to print error messages for those -** errors that are not cought by 'Match', for example if the left hand side -** of an assignment is not a variable, a list element or a record component, -** or if two formal arguments of a function have the same identifier. It is -** also called for warnings, for example if a statement has no effect. -** -** 'SyntaxError' first increments 'NrError' by 1. If 'NrError' is greater -** than zero the parser functions will not create new bags. This prevents -** the parser from creating new bags after an error occured. +*F OpenAppend( ) . . open a file as current output for appending ** -** 'SyntaxError' also increments 'NrErrLine' by 1. If 'NrErrLine' is -** greater than zero 'SyntaxError' will not print an error message. This -** prevents the printing of multiple error messages for one line, since they -** probabely just reflect the fact that the parser has not resynchronized -** yet. 'NrErrLine' is reset to 0 if a new line is read in 'GetLine'. +** 'OpenAppend' opens the file with the name as current output. +** All subsequent output will go to that file, until either it is closed +** again with 'CloseAppend' or another file is opened with 'OpenOutput'. +** Unlike 'OpenOutput' 'OpenAppend' does not truncate the file to size 0 if +** it exists. Appart from that 'OpenAppend' is equal to 'OpenOutput' so its +** description applies to 'OpenAppend' too. */ -void SyntaxError ( - Char * msg ) +UInt OpenAppend ( + Char * filename ) { - Int i; + Int file; - /* open error output */ - OpenOutput( "*errout*" ); + /* fail if we can not handle another open output file */ + if ( Output+1==OutputFiles+(sizeof(OutputFiles)/sizeof(OutputFiles[0])) ) + return 0; - /* one more error */ - NrError++; - NrErrLine++; + /* in test mode keep printing to test output file for breakloop output */ + if ( TestInput != 0 && ! SyStrcmp( filename, "*errout*" ) ) + return 1; - /* do not print a message if we found one already on the current line */ - if ( NrErrLine != 1 ) - return; + /* try to open the file */ + file = SyFopen( filename, "a" ); + if ( file == -1 ) + return 0; - /* print the message and the filename, unless it is '*stdin*' */ - Pr( "Syntax error: %s", (Int)msg, 0L ); - if ( SyStrcmp( "*stdin*", Input->name ) != 0 ) - Pr( " in %s line %d", (Int)Input->name, (Int)Input->number ); - Pr( "\n", 0L, 0L ); + /* put the file on the stack, start at position 0 on an empty line */ + Output++; + Output->file = file; + Output->line[0] = '\0'; + Output->pos = 0; + Output->indent = 0; - /* print the current line */ - Pr( "%s", (Int)Input->line, 0L ); + /* variables related to line splitting, very bad place to split */ + Output->spos = 0; + Output->sindent = 666; - /* print a '^' pointing to the current position */ - for ( i = 0; i < In - Input->line - 1; i++ ) { - if ( Input->line[i] == '\t' ) Pr("\t",0L,0L); - else Pr(" ",0L,0L); - } - Pr( "^\n", 0L, 0L ); + /* indicate success */ + return 1; +} - /* close error output */ - CloseOutput(); + +/**************************************************************************** +** +*F CloseAppend() . . . . . . . . . . . . . . . . . close current output file +** +** 'CloseAppend' will first flush all pending output and then close the +** current output file. Subsequent output will again go to the previous +** output file. 'CloseAppend' returns 1 to indicate success. 'CloseAppend' +** is exactely equal to 'CloseOutput' so its description applies. +*/ +UInt CloseAppend ( void ) +{ + /* refuse to close the initial output file '*stdout*' */ + if ( Output == OutputFiles ) + return 0; + + /* refuse to close the test output file */ + if ( Output == TestOutput ) + return 0; + + /* flush output and close the file */ + Pr( "%c", (Int)'\03', 0L ); + SyFclose( Output->file ); + + /* revert to previous output file and indicate success */ + Output--; + return 1; } /**************************************************************************** ** -*F Match( , , ) . match current symbol and fetch next +*F OpenInputLog( ) . . . . . . . . . . . . . log input to a file ** -** 'Match' is the main interface between the scanner and the parser. It -** performs the 4 most common actions in the scanner with just one call. -** First it checks that the current symbol stored in the variable 'Symbol' -** is the expected symbol as passed in the argument . If it is, -** 'Match' reads the next symbol from input and returns. Otherwise 'Match' -** first prints the current input line followed by the syntax error message: -** '^ syntax error, expected' with '^' pointing to the current symbol. -** It then skips symbols up to one in the resynchronisation set . -** Actually 'Match' calls 'SyntaxError' so its comments apply here too. +** 'OpenInputLog' instructs the scanner to echo all input from the files +** '*stdin*' and '*errin*' to the file with name . The file is +** truncated to size 0 if it existed, otherwise it is created. ** -** One kind of typical 'Match' call has the form +** 'OpenInputLog' returns 1 if it could successfully open for +** writing and 0 to indicate failure. 'OpenInputLog' will fail if you do +** not have permissions to create the file or write to it. 'OpenInputLog' +** may also fail if you have too many files open at once. It is system +** dependent how many are too many, but 16 files should work everywhere. +** Finally 'OpenInputLog' will fail if there is already a current logfile. +*/ +UInt OpenInputLog ( + Char * filename ) +{ + + /* refuse to open a logfile if we already log to one */ + if ( InputLog != -1 ) + return 0; + + /* try to open the file */ + InputLog = SyFopen( filename, "w" ); + if ( InputLog == -1 ) + return 0; + + /* otherwise indicate success */ + return 1; +} + + +/**************************************************************************** ** -** 'Match( Symbol, "", 0L );'. +*F CloseInputLog() . . . . . . . . . . . . . . . . close the current logfile ** -** This is used if the parser knows that the current symbol is correct, for -** example in 'RdReturn' the first symbol must be 'S_RETURN', otherwise -** 'RdReturn' would not have been called. Called this way 'Match' will of -** course never raise an syntax error, therefore and are of -** no concern, they are passed nevertheless to please lint. The effect of -** this call is merely to read the next symbol from input. +** 'CloseInputLog' closes the current logfile again, so that input from +** '*stdin*' and '*errin*' will no longer be echoed to a file. +** 'CloseInputLog' will return 1 to indicate success. ** -** Another typical 'Match' call is in 'RdIf' after we read the if symbol and -** the condition following, and now expect to see the 'then' symbol: +** 'CloseInputLog' will fail if there is no logfile active and will return 0 +** in this case. +*/ +UInt CloseInputLog ( void ) +{ + /* refuse to close a non existent logfile */ + if ( InputLog == -1 ) + return 0; + + /* close the logfile */ + SyFclose( InputLog ); + InputLog = -1; + + /* indicate success */ + return 1; +} + + +/**************************************************************************** ** -** Match( S_THEN, "then", STATBEGIN|S_ELIF|S_ELSE|S_FI|follow ); +*F OpenOutputLog( ) . . . . . . . . . . . log output to a file ** -** If the current symbol is 'S_THEN' it is matched and the next symbol is -** read. Otherwise 'Match' prints the current line followed by the error -** message: '^ syntax error, then expected'. Then 'Match' skips all symbols -** until finding either a symbol that can begin a statment, an 'elif' or -** 'else' or 'fi' symbol, or a symbol that is contained in the set -** which is passed to 'RdIf' and contains all symbols allowing one of the -** calling functions to resynchronize, for example 'S_OD' if 'RdIf' has been -** called from 'RdFor'. always contain 'S_EOF', which 'Read' uses -** to resynchronise. +** 'OpenInputLog' instructs the scanner to echo all output to the files +** '*stdout*' and '*errout*' to the file with name . The file is +** truncated to size 0 if it existed, otherwise it is created. ** -** If 'Match' needs to read a new line from '*stdin*' or '*errin*' to get -** the next symbol it prints the string pointed to by 'Prompt'. +** 'OpenOutputLog' returns 1 if it could successfully open for +** writing and 0 to indicate failure. 'OpenOutputLog' will fail if you do +** not have permissions to create the file or write to it. 'OpenOutputLog' +** may also fail if you have too many files open at once. It is system +** dependent how many are too many, but 16 files should work everywhere. +** Finally 'OpenOutputLog' will fail if there is already a current logfile. */ -void Match ( - UInt symbol, - Char * msg, - TypSymbolSet skipto ) +UInt OpenOutputLog ( + Char * filename ) { - Char errmsg [256]; - /* if 'Symbol' is the expected symbol match it away */ - if ( symbol == Symbol ) { - GetSymbol(); - } + /* refuse to open a logfile if we already log to one */ + if ( OutputLog != -1 ) + return 0; - /* else generate an error message and skip to a symbol in */ - else { - errmsg[0] ='\0'; - SyStrncat( errmsg, msg, sizeof(errmsg)-1 ); - SyStrncat( errmsg, " expected", - (Int)(sizeof(errmsg)-1-SyStrlen(errmsg)) ); - SyntaxError( errmsg ); - while ( ! IS_IN( Symbol, skipto ) ) - GetSymbol(); - } + /* try to open the file */ + OutputLog = SyFopen( filename, "w" ); + if ( OutputLog == -1 ) + return 0; + + /* otherwise indicate success */ + return 1; } /**************************************************************************** ** -*F PutLine() . . . . . . . . . . . . . . . . . . . . . . print a line, local -** -** 'PutLine' prints the current output line 'Output->line' to the current -** output file 'Output->file'. It is called from 'PutChr'. -** -** 'PutLine' also compares the output line with the next line from the test -** input file 'TestInput' if 'TestInput' is not -1. If this input line -** starts with '#>' and the rest of the line matches the output line then -** the output line is not printed and the input line is discarded. +*F CloseOutputLog() . . . . . . . . . . . . . . . close the current logfile ** -** 'PutLine' also echoes the output line to the logfile 'OutputLog' if -** 'OutputLog' is not -1 and the output file is '*stdout*' or '*errout*'. +** 'CloseInputLog' closes the current logfile again, so that output to +** '*stdout*' and '*errout*' will no longer be echoed to a file. +** 'CloseOutputLog' will return 1 to indicate success. ** -** Finally 'PutLine' checks whether the user has hit '-C' to interrupt -** the printing. +** 'CloseOutputLog' will fail if there is no logfile active and will return +** 0 in this case. */ -void PutLine ( void ) +UInt CloseOutputLog ( void ) { - /* if in test mode and the next input line matches print nothing */ - if ( TestInput != -1 && TestOutput == Output->file ) { - if ( TestLine[0] == '\0' ) { - if ( ! SyFgets( TestLine, sizeof(TestLine), TestInput ) ) { - TestLine[0] = '\0'; - } - } - if ( ! SyStrcmp( TestLine, Output->line ) ) { - TestLine[0] = '\0'; - } - else { - SyFputs( "+ ", Output->file ); - SyFputs( Output->line, Output->file ); - } - } + /* refuse to close a non existent logfile */ + if ( OutputLog == -1 ) + return 0; - /* otherwise output this line */ - else { - SyFputs( Output->line, Output->file ); - } + /* close the logfile */ + SyFclose( OutputLog ); + OutputLog = -1; - /* if neccessary echo it to the logfile */ - if ( OutputLog != -1 && (Output->file == 1 || Output->file == 3)) - SyFputs( Output->line, OutputLog ); + /* indicate success */ + return 1; } /**************************************************************************** ** -*F PutChr( ) . . . . . . . . . . . . . . . print character , local -** -** 'PutChr' prints the single character to the current output file. +*F OpenLog( ) . . . . . . . . . . . . . log interaction to a file ** -** 'PutChr' buffers the output characters until either is , -** is '\03' () or the buffer fills up. +** 'OpenLog' instructs the scanner to echo all input from the files +** '*stdin*' and '*errin*' and all output to the files '*stdout*' and +** '*errout*' to the file with name . The file is truncated to +** size 0 if it existed, otherwise it is created. ** -** In the later case 'PutChr' has to decide where to split the output line. -** It takes the point at which $linelength - pos + 8 * indent$ is minimal. +** 'OpenLog' returns 1 if it could successfully open for writing +** and 0 to indicate failure. 'OpenLog' will fail if you do not have +** permissions to create the file or write to it. 'OpenOutput' may also +** fail if you have too many files open at once. It is system dependent how +** many are too many, but 16 files should work everywhere. Finally +** 'OpenLog' will fail if there is already a current logfile. */ -void PutChr ( - Char ch ) +UInt OpenLog ( + Char * filename ) { - Int i; - Char str [ 256 ]; - /* '\01', increment indentation level */ - if ( ch == '\01' ) { + /* refuse to open a logfile if we already log to one */ + if ( InputLog != -1 || OutputLog != -1 ) + return 0; - /* if this is a better place to split the line remember it */ - if ( Output->indent < Output->pos - && SyNrCols-Output->pos + 16*Output->indent - <= SyNrCols-Output->spos + 16*Output->sindent ) { - Output->spos = Output->pos; - Output->sindent = Output->indent; - } + /* try to open the file */ + InputLog = SyFopen( filename, "w" ); + OutputLog = InputLog; + if ( InputLog == -1 ) + return 0; - Output->indent++; + /* otherwise indicate success */ + return 1; +} - } - /* '\02', decrement indentation level */ - else if ( ch == '\02' ) { +/**************************************************************************** +** +*F CloseLog() . . . . . . . . . . . . . . . . . . close the current logfile +** +** 'CloseLog' closes the current logfile again, so that input from '*stdin*' +** and '*errin*' and output to '*stdout*' and '*errout*' will no longer be +** echoed to a file. 'CloseLog' will return 1 to indicate success. +** +** 'CloseLog' will fail if there is no logfile active and will return 0 in +** this case. +*/ +UInt CloseLog ( void ) +{ + /* refuse to close a non existent logfile */ + if ( InputLog == -1 || OutputLog == -1 || InputLog != OutputLog ) + return 0; - /* if this is a better place to split the line remember it */ - if ( Output->indent < Output->pos - && SyNrCols-Output->pos + 16*Output->indent - <= SyNrCols-Output->spos + 16*Output->sindent ) { - Output->spos = Output->pos; - Output->sindent = Output->indent; - } + /* close the logfile */ + SyFclose( InputLog ); + InputLog = -1; + OutputLog = -1; - Output->indent--; + /* indicate success */ + return 1; +} - } - /* '\03', print line */ - else if ( ch == '\03' ) { +/**************************************************************************** +** - /* print the line */ - Output->line[ Output->pos ] = '\0'; - PutLine(); - - /* start the next line */ - Output->pos = 0; +*V ReadLineFunc . . . . . . . . . . . . . . . . . . . . . . . . 'ReadLine' +*/ +Obj ReadLineFunc; - /* first character is a very bad place to split */ - Output->spos = 0; - Output->sindent = 666; +/**************************************************************************** +** +*F GetLine() . . . . . . . . . . . . . . . . . . . . . . . get a line, local +** +** 'GetLine' fetches another line from the input file 'Input->file' into the +** buffer 'Input->line', sets the pointer 'In' to the beginning of this +** buffer and returns the first character from the line. +** +** If the input file is '*stdin*' or '*errin*' 'GetLine' first prints +** 'Prompt', unless it is '*stdin*' and GAP was called with option '-q'. +** +** If there is an input logfile in use and the input file is '*stdin*' or +** '*errin*' 'GetLine' echoes the new line to the logfile. +*/ +static void GetLine2 ( void ) +{ + if ( Input->isstream ) { + if ( Input->sline == 0 + || SyStrlen(CSTR_STRING(Input->sline)) <= Input->spos ) + { + Input->sline = CALL_1ARGS( ReadLineFunc, Input->stream ); + Input->spos = 0; + } + if ( Input->sline == Fail ) { + In[0] = '\377'; In[1] = '\0'; + } + else { + SyStrncat( In, Input->spos + CSTR_STRING(Input->sline), + sizeof(Input->line) ); + Input->spos += SyStrlen(In); + } } + else { + if ( ! SyFgets( In, sizeof(Input->line), Input->file ) ) { + In[0] = '\377'; In[1] = '\0'; + } + } +} - /* or , print line, indent next */ - else if ( ch == '\n' || ch == '\r' ) { - - /* put the character on the line and terminate it */ - Output->line[ Output->pos++ ] = ch; - Output->line[ Output->pos ] = '\0'; - - /* print the line */ - PutLine(); - /* indent for next line */ - Output->pos = 0; - for ( i = 0; i < Output->indent; i++ ) - Output->line[ Output->pos++ ] = ' '; +Char GetLine ( void ) +{ + Char buf[200]; + Char * p; + Char * q; - /* set up new split positions */ - Output->spos = 0; - Output->sindent = 666; + /* if file is '*stdin*' or '*errin*' print the prompt and flush it */ + if ( ! Input->isstream ) { + if ( Input->file == 0 ) { + if ( ! SyQuiet ) Pr( "%s%c", (Int)Prompt, (Int)'\03' ); + else Pr( "%c", (Int)'\03', 0L ); + } + else if ( Input->file == 2 ) { + Pr( "%s%c", (Int)Prompt, (Int)'\03' ); + } + } + /* bump the line number */ + if ( Input->line < In && (*(In-1) == '\n' || *(In-1) == '\r') ) { + Input->number++; } - /* normal character, room on the current line */ - else if ( Output->pos < SyNrCols-2 ) { + /* initialize 'In', no errors on this line so far */ + In = Input->line; In[0] = '\0'; + NrErrLine = 0; - /* put the character on this line */ - Output->line[ Output->pos++ ] = ch; + /* read a line from an ordinary input file */ + if ( TestInput != Input ) { - } + /* try to read a line */ + GetLine2(); + + /* convert '?' at the beginning into 'HELP' */ + if ( In[0] == '?' ) { + buf[0] = '\0'; + SyStrncat( buf, In+1, 199 ); + In[0] = '\0'; + SyStrncat( In, "HELP(\"", 6 ); + for ( p = In+6, q = buf; *q; q++ ) { + if ( *q != '"' && *q != '\n' ) { + *p++ = *q; + } + } + *p = '\0'; + SyStrncat( In, "\");\n", 4 ); + } + + /* if neccessary echo the line to the logfile */ + if ( ! Input->isstream ) { + if ( InputLog != -1 && (Input->file == 0 || Input->file == 2) ) { + SyFputs( In, InputLog ); + } + } - /* if we are going to split at the end of the line, discard blanks */ - else if ( Output->spos == Output->pos && ch == ' ' ) { - ; } - /* full line, acceptable split position */ - else if ( Output->spos != 0 ) { + /* read a line for test input file */ + else { - /* add character to the line, terminate it */ - Output->line[ Output->pos++ ] = ch; - Output->line[ Output->pos++ ] = '\0'; + /* continue until we got an input line */ + while ( In[0] == '\0' ) { - /* copy the rest after the best split position to a safe place */ - for ( i = Output->spos; i < Output->pos; i++ ) - str[ i-Output->spos ] = Output->line[ i ]; + /* there may be one line waiting */ + if ( TestLine[0] != '\0' ) { + SyStrncat( In, TestLine, sizeof(Input->line) ); + TestLine[0] = '\0'; + } - /* print line up to the best split position */ - Output->line[ Output->spos++ ] = '\n'; - Output->line[ Output->spos ] = '\0'; - PutLine(); + /* otherwise try to read a line */ + else { + GetLine2(); + } - /* indent for the rest */ - Output->pos = 0; - for ( i = 0; i < Output->sindent; i++ ) - Output->line[ Output->pos++ ] = ' '; + /* if the line starts with a prompt its an input line */ + if ( In[0] == 'g' && In[1] == 'a' && In[2] == 'p' + && In[3] == '>' && In[4] == ' ' ) { + In = In + 5; + } + else if ( In[0] == '>' && In[1] == ' ' ) { + In = In + 2; + } - /* copy the rest onto the next line */ - for ( i = 0; str[ i ] != '\0'; i++ ) - Output->line[ Output->pos++ ] = str[ i ]; + /* if the line is not empty or a comment, print it */ + else if ( In[0] != '\n' && In[0] != '#' && In[0] != '\377' ) { + SyFputs( "- ", TestOutput->file ); + SyFputs( In, TestOutput->file ); + In[0] = '\0'; + } - /* set new split position */ - Output->spos = 0; - Output->sindent = 666; + } } - /* full line, no splitt position */ - else { - - /* append a '\', and print the line */ - Output->line[ Output->pos++ ] = '\\'; - Output->line[ Output->pos++ ] = '\n'; - Output->line[ Output->pos ] = '\0'; - PutLine(); + /* return the current character */ + return *In; +} - /* add the character to the next line */ - Output->pos = 0; - Output->line[ Output->pos++ ] = ch; - /* the first character is a very bad place to split */ - Output->spos = 0; - Output->sindent = 666; +/**************************************************************************** +** - } -} +*F GET_CHAR() . . . . . . . . . . . . . . . . get the next character, local +** +** 'GET_CHAR' returns the next character from the current input file. This +** character is afterwords also available as '*In'. +** +** For efficiency reasons 'GET_CHAR' is a macro that just increments the +** pointer 'In' and checks that there is another character. If not, for +** example at the end a line, 'GET_CHAR' calls 'GetLine' to fetch a new line +** from the input file. +*/ +#define GET_CHAR() (*++In != '\0' ? *In : GetLine()) /**************************************************************************** ** -*F Pr( , , ) . . . . . . . . . print formatted output +*F GetIdent() . . . . . . . . . . . . . get an identifier or keyword, local ** -** 'Pr' is the output function. The first argument is a 'printf' like format -** string containing up to 2 '%' format fields, specifing how the -** corresponding arguments are to be printed. The two arguments are passed -** as 'Int' integers. This is possible since every C object ('int', -** 'char', pointers) except 'float' or 'double', which are not used in GAP, -** can be converted to a 'Int' without loss of information. +** 'GetIdent' reads an identifier from the current input file into the +** variable 'Value' and sets 'Symbol' to 'S_IDENT'. The first character of +** the identifier is the current character pointed to by 'In'. If the +** characters make up a keyword 'GetIdent' will set 'Symbol' to the +** corresponding value. The parser will ignore 'Value' in this case. ** -** The function 'Pr' currently support the following '%' format fields: -** '%c' the corresponding argument represents a character, usually it is -** its ASCII or EBCDIC code, and this character is printed. -** '%s' the corresponding argument is the address of a null terminated -** character string which is printed. -** '%d' the corresponding argument is a signed integer, which is printed. -** Between the '%' and the 'd' an integer might be used to specify -** the width of a field in which the integer is right justified. If -** the first character is '0' 'Pr' pads with '0' instead of . -** '%>' increment the indentation level. -** '%<' decrement the indentation level. -** '%%' can be used to print a single '%' character. No argument is used. +** An identifier consists of a letter followed by more letters, digits and +** underscores '_'. An identifier is terminated by the first character not +** in this class. The escape sequence '\' is ignored, making it +** possible to split long identifiers over multiple lines. The backslash +** '\' can be used to include special characters like '(' in identifiers. +** For example 'G\(2\,5\)' is an identifier not a call to a function 'G'. ** -** You must always cast the arguments to '(Int)' to avoid problems with -** those compilers with a default integer size of 16 instead of 32 bit. You -** must pass 0L if you don't make use of an argument to please lint. +** The size of 'Value' limits the number of significant characters in an +** identifier. If an identifier has more characters 'GetIdent' will +** silently truncate it. +** +** After reading the identifier 'GetIdent' looks at the first and the last +** character of 'Value' to see if it could possibly be a keyword. For +** example 'test' could not be a keyword because there is no keyword +** starting and ending with a 't'. After that test either 'GetIdent' knows +** that 'Value' is not a keyword, or there is a unique possible keyword that +** could match, because no two keywords have identical first and last +** characters. For example if 'Value' starts with 'f' and ends with 'n' the +** only possible keyword is 'function'. Thus in this case 'GetIdent' can +** decide with one string comparison if 'Value' holds a keyword or not. */ -void Pr ( - Char * format, - Int arg1, - Int arg2 ) +void GetSymbol ( void ); + +void GetIdent ( void ) { - Char * p; - Char * q; - Int prec, n; - Char fill; + Int i; + Int isQuoted; - /* loop over the characters of the string */ - for ( p = format; *p != '\0'; p++ ) { + /* initially it could be a keyword */ + isQuoted = 0; - /* if the character is '%' do something special */ - if ( *p == '%' ) { + /* read all characters into 'Value' */ + for ( i=0; IsAlpha(*In) || IsDigit(*In) || *In=='_' || *In=='\\'; i++ ) { - /* first look for a precision field */ - p++; - prec = 0; - fill = (*p == '0' ? '0' : ' '); - while ( IsDigit(*p) ) { - prec = 10 * prec + *p - '0'; - p++; - } + /* handle escape sequences */ + /* we ignore '\ newline' by decrementing i, except at the + very start of the identifier, when we cannot do that + so we recurse instead */ + if ( *In == '\\' ) { + GET_CHAR(); + if ( *In == '\n' && i == 0 ) { GetSymbol(); return; } + else if ( *In == '\n' && i < sizeof(Value)-1 ) i--; + else if ( *In == 'n' && i < sizeof(Value)-1 ) Value[i] = '\n'; + else if ( *In == 't' && i < sizeof(Value)-1 ) Value[i] = '\t'; + else if ( *In == 'r' && i < sizeof(Value)-1 ) Value[i] = '\r'; + else if ( *In == 'b' && i < sizeof(Value)-1 ) Value[i] = '\b'; + else if ( i < sizeof(Value)-1 ) { + Value[i] = *In; + isQuoted = 1; + } + } - /* '%d' print an integer */ - if ( *p == 'd' ) { - if ( arg1 < 0 ) { - prec--; - for ( n=1; n <= -(arg1/10); n*=10 ) - prec--; - while ( --prec > 0 ) PutChr(fill); - PutChr('-'); - for ( ; n > 0; n /= 10 ) - PutChr( (Char)(-((arg1/n)%10) + '0') ); - arg1 = arg2; - } - else { - for ( n=1; n<=arg1/10; n*=10 ) - prec--; - while ( --prec > 0 ) PutChr(fill); - for ( ; n > 0; n /= 10 ) - PutChr( (Char)(((arg1/n)%10) + '0') ); - arg1 = arg2; - } - } + /* put normal chars into 'Value' but only if there is room */ + else { + if ( i < sizeof(Value)-1 ) Value[i] = *In; + } - /* '%s' print a string */ - else if ( *p == 's' ) { + /* read the next character */ + GET_CHAR(); - /* compute how many characters this identifier requires */ - for ( q = (Char*)arg1; *q != '\0'; q++ ) { - prec--; - } + } - /* if wanted push an appropriate number of -s */ - while ( prec-- > 0 ) PutChr(' '); + /* terminate the identifier and lets assume that it is not a keyword */ + if ( i < sizeof(Value)-1 ) Value[i] = '\0'; + Symbol = S_IDENT; - /* print the string */ - for ( q = (Char*)arg1; *q != '\0'; q++ ) { - PutChr( *q ); - } + /* now check if 'Value' holds a keyword */ + switch ( 256*Value[0]+Value[i-1] ) { + case 256*'a'+'d': if(!SyStrcmp(Value,"and")) Symbol=S_AND; break; + case 256*'b'+'k': if(!SyStrcmp(Value,"break")) Symbol=S_BREAK; break; + case 256*'d'+'o': if(!SyStrcmp(Value,"do")) Symbol=S_DO; break; + case 256*'e'+'f': if(!SyStrcmp(Value,"elif")) Symbol=S_ELIF; break; + case 256*'e'+'e': if(!SyStrcmp(Value,"else")) Symbol=S_ELSE; break; + case 256*'e'+'d': if(!SyStrcmp(Value,"end")) Symbol=S_END; break; + case 256*'f'+'e': if(!SyStrcmp(Value,"false")) Symbol=S_FALSE; break; + case 256*'f'+'i': if(!SyStrcmp(Value,"fi")) Symbol=S_FI; break; + case 256*'f'+'r': if(!SyStrcmp(Value,"for")) Symbol=S_FOR; break; + case 256*'f'+'n': if(!SyStrcmp(Value,"function"))Symbol=S_FUNCTION;break; + case 256*'i'+'f': if(!SyStrcmp(Value,"if")) Symbol=S_IF; break; + case 256*'i'+'n': if(!SyStrcmp(Value,"in")) Symbol=S_IN; break; + case 256*'l'+'l': if(!SyStrcmp(Value,"local")) Symbol=S_LOCAL; break; + case 256*'m'+'d': if(!SyStrcmp(Value,"mod")) Symbol=S_MOD; break; + case 256*'n'+'t': if(!SyStrcmp(Value,"not")) Symbol=S_NOT; break; + case 256*'o'+'d': if(!SyStrcmp(Value,"od")) Symbol=S_OD; break; + case 256*'o'+'r': if(!SyStrcmp(Value,"or")) Symbol=S_OR; break; + case 256*'r'+'c': if(!SyStrcmp(Value,"rec")) Symbol=S_REC; break; + case 256*'r'+'t': if(!SyStrcmp(Value,"repeat")) Symbol=S_REPEAT; break; + case 256*'r'+'n': if(!SyStrcmp(Value,"return")) Symbol=S_RETURN; break; + case 256*'t'+'n': if(!SyStrcmp(Value,"then")) Symbol=S_THEN; break; + case 256*'t'+'e': if(!SyStrcmp(Value,"true")) Symbol=S_TRUE; break; + case 256*'u'+'l': if(!SyStrcmp(Value,"until")) Symbol=S_UNTIL; break; + case 256*'w'+'e': if(!SyStrcmp(Value,"while")) Symbol=S_WHILE; break; + case 256*'q'+'t': if(!SyStrcmp(Value,"quit")) Symbol=S_QUIT; break; + case 256*'I'+'d': if(!SyStrcmp(Value,"IsBound")) Symbol=S_ISBOUND; break; + case 256*'U'+'d': if(!SyStrcmp(Value,"Unbind")) Symbol=S_UNBIND; break; + case 256*'T'+'d': if(!SyStrcmp(Value,"TryNextMethod")) + Symbol=S_TRYNEXT; break; + case 256*'I'+'o': if(!SyStrcmp(Value,"Info")) Symbol=S_INFO; break; + case 256*'A'+'t': if(!SyStrcmp(Value,"Assert")) Symbol=S_ASSERT; break; + default: ; + } - /* on to the next argument */ - arg1 = arg2; - } + /* if it is quoted it is an identifier */ + if ( isQuoted ) Symbol = S_IDENT; - /* '%S' print a string with the necessary escapes */ - else if ( *p == 'S' ) { +} - /* compute how many characters this identifier requires */ - for ( q = (Char*)arg1; *q != '\0'; q++ ) { - if ( *q == '\n' ) { prec -= 2; } - else if ( *q == '\t' ) { prec -= 2; } - else if ( *q == '\r' ) { prec -= 2; } - else if ( *q == '\b' ) { prec -= 2; } - else if ( *q == '\03' ) { prec -= 2; } - else if ( *q == '"' ) { prec -= 2; } - else if ( *q == '\\' ) { prec -= 2; } - else { prec -= 1; } - } - /* if wanted push an appropriate number of -s */ - while ( prec-- > 0 ) PutChr(' '); +/**************************************************************************** +** +*F GetInt() . . . . . . . . . . . . . . . . . . . . . get an integer, local +** +** 'GetInt' reads an integer number from the current input file into the +** variable 'Value' and sets 'Symbol' to 'S_INT'. The first character of +** the integer is the current character pointed to by 'In'. +** +** An integer is a sequence of digits '0..9'. The escape sequence +** '\' is ignored, making it possible to split long integers over +** multiple lines. +** +** If the sequence contains characters which are not digits 'GetInt' will +** interpret the sequence as an identifier and set 'Symbol' to 'S_IDENT'. +** +** The size of 'Value' limits the maximal number of digits of an integer. +** If an integer has more digits 'GetInt' issues a warning and truncates it. +*/ +void GetInt ( void ) +{ + Int i; + Int isInt; - /* print the string */ - for ( q = (Char*)arg1; *q != '\0'; q++ ) { - if ( *q == '\n' ) { PutChr('\\'); PutChr('n'); } - else if ( *q == '\t' ) { PutChr('\\'); PutChr('t'); } - else if ( *q == '\r' ) { PutChr('\\'); PutChr('r'); } - else if ( *q == '\b' ) { PutChr('\\'); PutChr('b'); } - else if ( *q == '\03' ) { PutChr('\\'); PutChr('c'); } - else if ( *q == '"' ) { PutChr('\\'); PutChr('"'); } - else if ( *q == '\\' ) { PutChr('\\'); PutChr('\\'); } - else { PutChr( *q ); } - } + isInt = 1; - /* on to the next argument */ - arg1 = arg2; - } + /* read the digits into 'Value' */ + for ( i=0; IsDigit(*In) || IsAlpha(*In) || *In=='_' || *In=='\\'; i++ ) { - /* '%C' print a string with the necessary C escapes */ - else if ( *p == 'C' ) { + /* handle escape sequences */ + if ( *In == '\\' ) { + GET_CHAR(); + if ( *In == '\n' && i < sizeof(Value)-1 ) i--; + else if ( *In == 'n' && i < sizeof(Value)-1 ) Value[i] = '\n'; + else if ( *In == 't' && i < sizeof(Value)-1 ) Value[i] = '\t'; + else if ( *In == 'r' && i < sizeof(Value)-1 ) Value[i] = '\r'; + else if ( *In == 'b' && i < sizeof(Value)-1 ) Value[i] = '\b'; + else if ( *In == 'c' && i < sizeof(Value)-1 ) Value[i] = '\03'; + else if ( i < sizeof(Value)-1 ) Value[i] = *In; + } - /* compute how many characters this identifier requires */ - for ( q = (Char*)arg1; *q != '\0'; q++ ) { - if ( *q == '\n' ) { prec -= 2; } - else if ( *q == '\t' ) { prec -= 2; } - else if ( *q == '\r' ) { prec -= 2; } - else if ( *q == '\b' ) { prec -= 2; } - else if ( *q == '\03' ) { prec -= 3; } - else if ( *q == '"' ) { prec -= 2; } - else if ( *q == '\\' ) { prec -= 2; } - else { prec -= 1; } - } + /* put normal chars into 'Value' but only if there is room */ + else { + if ( i < sizeof(Value)-1 ) Value[i] = *In; + } - /* if wanted push an appropriate number of -s */ - while ( prec-- > 0 ) PutChr(' '); + /* if the characters contain non digits it is a variable */ + if ( ! IsDigit(*In) && *In != '\n' ) isInt = 0; - /* print the string */ - for ( q = (Char*)arg1; *q != '\0'; q++ ) { - if ( *q == '\n' ) { PutChr('\\'); PutChr('n'); } - else if ( *q == '\t' ) { PutChr('\\'); PutChr('t'); } - else if ( *q == '\r' ) { PutChr('\\'); PutChr('r'); } - else if ( *q == '\b' ) { PutChr('\\'); PutChr('b'); } - else if ( *q == '\03' ) { PutChr('\\'); PutChr('0'); - PutChr('3'); } - else if ( *q == '"' ) { PutChr('\\'); PutChr('"'); } - else if ( *q == '\\' ) { PutChr('\\'); PutChr('\\'); } - else { PutChr( *q ); } - } + /* get the next character */ + GET_CHAR(); - /* on to the next argument */ - arg1 = arg2; - } + } - /* '%I' print an identifier */ - else if ( *p == 'I' ) { + /* check for numbers with too many digits */ + if ( sizeof(Value)-1 <= i ) + SyntaxError("integer must have less than 1024 digits"); - /* compute how many characters this identifier requires */ - q = (Char*)arg1; - if ( !SyStrcmp(q,"and") || !SyStrcmp(q,"break") - || !SyStrcmp(q,"do") || !SyStrcmp(q,"elif") - || !SyStrcmp(q,"else") || !SyStrcmp(q,"end") - || !SyStrcmp(q,"fi") || !SyStrcmp(q,"for") - || !SyStrcmp(q,"function") || !SyStrcmp(q,"if") - || !SyStrcmp(q,"in") || !SyStrcmp(q,"local") - || !SyStrcmp(q,"mod") || !SyStrcmp(q,"not") - || !SyStrcmp(q,"od") || !SyStrcmp(q,"or") - || !SyStrcmp(q,"repeat") || !SyStrcmp(q,"return") - || !SyStrcmp(q,"then") || !SyStrcmp(q,"until") - || !SyStrcmp(q,"while") || !SyStrcmp(q,"quit") - || !SyStrcmp(q,"IsBound") || !SyStrcmp(q,"IsBound")) { - prec--; - } - for ( q = (Char*)arg1; *q != '\0'; q++ ) { - if ( ! IsAlpha(*q) && ! IsDigit(*q) && *q != '_' ) { - prec--; - } - prec--; - } + /* terminate the integer */ + if ( i < sizeof(Value)-1 ) Value[i] = '\0'; + if ( isInt ) Symbol = S_INT; + else Symbol = S_IDENT; +} - /* if wanted push an appropriate number of -s */ - while ( prec-- > 0 ) { PutChr(' '); } - /* print the identifier */ - q = (Char*)arg1; - if ( !SyStrcmp(q,"and") || !SyStrcmp(q,"break") - || !SyStrcmp(q,"do") || !SyStrcmp(q,"elif") - || !SyStrcmp(q,"else") || !SyStrcmp(q,"end") - || !SyStrcmp(q,"fi") || !SyStrcmp(q,"for") - || !SyStrcmp(q,"function") || !SyStrcmp(q,"if") - || !SyStrcmp(q,"in") || !SyStrcmp(q,"local") - || !SyStrcmp(q,"mod") || !SyStrcmp(q,"not") - || !SyStrcmp(q,"od") || !SyStrcmp(q,"or") - || !SyStrcmp(q,"repeat") || !SyStrcmp(q,"return") - || !SyStrcmp(q,"then") || !SyStrcmp(q,"until") - || !SyStrcmp(q,"while") || !SyStrcmp(q,"quit") - || !SyStrcmp(q,"IsBound") || !SyStrcmp(q,"IsBound")) { - PutChr( '\\' ); - } - for ( q = (Char*)arg1; *q != '\0'; q++ ) { - if ( ! IsAlpha(*q) && ! IsDigit(*q) && *q != '_' ) { - PutChr( '\\' ); - } - PutChr( *q ); - } +/**************************************************************************** +** +*F GetStr() . . . . . . . . . . . . . . . . . . . . . . get a string, local +** +** 'GetStr' reads a string from the current input file into the variable +** 'Value' and sets 'Symbol' to 'S_STRING'. The opening double quote '"' +** of the string is the current character pointed to by 'In'. +** +** A string is a sequence of characters delimited by double quotes '"'. It +** must not include '"' or characters, but the escape sequences +** '\"' or '\n' can be used instead. The escape sequence '\' is +** ignored, making it possible to split long strings over multiple lines. +** +** An error is raised if the string includes a character or if the +** file ends before the closing '"'. +** +** The size of 'Value' limits the maximal number of characters in a string. +** If a string has more characters 'GetStr' issues a error and truncates it. +*/ +void GetStr ( void ) +{ + Int i = 0; + + /* skip '"' */ + GET_CHAR(); + + /* read all characters into 'Value' */ + for ( i = 0; *In != '"' && *In != '\n' && *In != '\377'; i++ ) { + + /* handle escape sequences */ + if ( *In == '\\' ) { + GET_CHAR(); + if ( *In == '\n' && i < sizeof(Value)-1 ) i--; + else if ( *In == 'n' && i < sizeof(Value)-1 ) Value[i] = '\n'; + else if ( *In == 't' && i < sizeof(Value)-1 ) Value[i] = '\t'; + else if ( *In == 'r' && i < sizeof(Value)-1 ) Value[i] = '\r'; + else if ( *In == 'b' && i < sizeof(Value)-1 ) Value[i] = '\b'; + else if ( *In == 'c' && i < sizeof(Value)-1 ) Value[i] = '\03'; + else if ( i < sizeof(Value)-1 ) Value[i] = *In; + } + + /* put normal chars into 'Value' but only if there is room */ + else { + if ( i < sizeof(Value)-1 ) Value[i] = *In; + } + + /* read the next character */ + GET_CHAR(); + + } + + /* check for error conditions */ + if ( *In == '\n' ) + SyntaxError("string must not include "); + if ( *In == '\377' ) + SyntaxError("string must end with \" before end of file"); + if ( sizeof(Value)-1 <= i ) + SyntaxError("string must have less than 1024 characters"); + + /* terminate the string, set 'Symbol' and skip trailing '"' */ + if ( i < sizeof(Value)-1 ) Value[i] = '\0'; + Symbol = S_STRING; + if ( *In == '"' ) GET_CHAR(); +} + + +/**************************************************************************** +** +*F GetChar() . . . . . . . . . . . . . . . . . get a single character, local +** +** 'GetChar' reads the next character from the current input file into the +** variable 'Value' and sets 'Symbol' to 'S_CHAR'. The opening single quote +** '\'' of the character is the current character pointed to by 'In'. +** +** A character is a single character delimited by single quotes '\''. It +** must not be '\'' or , but the escape sequences '\\\'' or '\n' +** can be used instead. +*/ +void GetChar ( void ) +{ + /* skip '\'' */ + GET_CHAR(); + + /* handle escape equences */ + if ( *In == '\\' ) { + GET_CHAR(); + if ( *In == 'n' ) Value[0] = '\n'; + else if ( *In == 't' ) Value[0] = '\t'; + else if ( *In == 'r' ) Value[0] = '\r'; + else if ( *In == 'b' ) Value[0] = '\b'; + else if ( *In == 'c' ) Value[0] = '\03'; + else Value[0] = *In; + } + + /* put normal chars into 'Value' */ + else { + Value[0] = *In; + } + + /* read the next character */ + GET_CHAR(); + + /* check for terminating single quote */ + if ( *In != '\'' ) + SyntaxError("missing single quote in character constant"); + + /* skip the closing quote */ + Symbol = S_CHAR; + if ( *In == '\'' ) GET_CHAR(); +} + + +/**************************************************************************** +** +*F GetSymbol() . . . . . . . . . . . . . . . . . get the next symbol, local +** +** 'GetSymbol' reads the next symbol from the input, storing it in the +** variable 'Symbol'. If 'Symbol' is 'T_IDENT', 'T_INT' or 'T_STRING' the +** value of the symbol is stored in the variable 'Value'. 'GetSymbol' first +** skips all , and characters and comments. +** +** After reading a symbol the current character is the first character +** beyond that symbol. +*/ +void GetSymbol ( void ) +{ + /* if no character is available then get one */ + if ( *In == '\0' ) + GET_CHAR(); - /* on to the next argument */ - arg1 = arg2; - } + /* skip over , , and comments */ + while (*In==' '||*In=='\t'||*In=='\n'||*In=='\r'||*In=='\f'||*In=='#') { + if ( *In == '#' ) { + while ( *In != '\n' && *In != '\r' && *In != '\377' ) + GET_CHAR(); + } + GET_CHAR(); + } - /* '%c' print a character */ - else if ( *p == 'c' ) { - PutChr( (Char)arg1 ); - arg1 = arg2; - } + /* switch according to the character */ + switch ( *In ) { - /* '%%' print a '%' character */ - else if ( *p == '%' ) { - PutChr( '%' ); - } + case '.': Symbol = S_DOT; GET_CHAR(); + if ( *In == '.' ) { Symbol = S_DOTDOT; GET_CHAR(); break; } + break; + case '!': Symbol = S_ILLEGAL; GET_CHAR(); + if ( *In == '\\' ) { GET_CHAR(); + if ( *In == '\n' ) { GET_CHAR(); } } + if ( *In == '.' ) { Symbol = S_BDOT; GET_CHAR(); break; } + if ( *In == '[' ) { Symbol = S_BLBRACK; GET_CHAR(); break; } + if ( *In == '{' ) { Symbol = S_BLBRACE; GET_CHAR(); break; } + break; + case '[': Symbol = S_LBRACK; GET_CHAR(); break; + case ']': Symbol = S_RBRACK; GET_CHAR(); break; + case '{': Symbol = S_LBRACE; GET_CHAR(); break; + case '}': Symbol = S_RBRACE; GET_CHAR(); break; + case '(': Symbol = S_LPAREN; GET_CHAR(); break; + case ')': Symbol = S_RPAREN; GET_CHAR(); break; + case ',': Symbol = S_COMMA; GET_CHAR(); break; - /* '%>' increment the indentation level */ - else if ( *p == '>' ) { - PutChr( '\01' ); - while ( --prec > 0 ) - PutChr( '\01' ); - } + case ':': Symbol = S_ILLEGAL; GET_CHAR(); + if ( *In == '\\' ) { GET_CHAR(); + if ( *In == '\n' ) { GET_CHAR(); } } + if ( *In == '=' ) { Symbol = S_ASSIGN; GET_CHAR(); break; } + break; - /* '%<' decrement the indentation level */ - else if ( *p == '<' ) { - PutChr( '\02' ); - while ( --prec > 0 ) - PutChr( '\02' ); - } + case ';': Symbol = S_SEMICOLON; GET_CHAR(); break; - /* else raise an error */ - else { - for ( p = "%format error"; *p != '\0'; p++ ) - PutChr( *p ); - } + case '=': Symbol = S_EQ; GET_CHAR(); break; + case '<': Symbol = S_LT; GET_CHAR(); + if ( *In == '\\' ) { GET_CHAR(); + if ( *In == '\n' ) { GET_CHAR(); } } + if ( *In == '=' ) { Symbol = S_LE; GET_CHAR(); break; } + if ( *In == '>' ) { Symbol = S_NE; GET_CHAR(); break; } + break; + case '>': Symbol = S_GT; GET_CHAR(); + if ( *In == '\\' ) { GET_CHAR(); + if ( *In == '\n' ) { GET_CHAR(); } } + if ( *In == '=' ) { Symbol = S_GE; GET_CHAR(); break; } + break; - } + case '+': Symbol = S_PLUS; GET_CHAR(); break; + case '-': Symbol = S_MINUS; GET_CHAR(); + if ( *In == '>' ) { Symbol=S_MAPTO; GET_CHAR(); break; } + break; + case '*': Symbol = S_MULT; GET_CHAR(); break; + case '/': Symbol = S_DIV; GET_CHAR(); break; + case '^': Symbol = S_POW; GET_CHAR(); break; - /* not a '%' character, simply print it */ - else { - PutChr( *p ); - } + case '"': GetStr(); break; + case '\'': GetChar(); break; + case '\\': GetIdent(); break; + case '_': GetIdent(); break; + case '~': Value[0] = '~'; Value[1] = '\0'; + Symbol = S_IDENT; GET_CHAR(); break; + + case '0': case '1': case '2': case '3': case '4': + case '5': case '6': case '7': case '8': case '9': GetInt(); break; + case '\377': Symbol = S_EOF; *In = '\0'; break; + + default : if ( IsAlpha(*In) ) { GetIdent(); break; } + Symbol = S_ILLEGAL; GET_CHAR(); break; } } /**************************************************************************** ** -*F OpenInput( ) . . . . . . . . . . open a file as current input +*F SyntaxError( ) . . . . . . . . . . . . . . . raise a syntax error ** -** 'OpenInput' opens the file with the name as current input. -** All subsequent input will be taken from that file, until it is closed -** again with 'CloseInput' or another file is opened with 'OpenInput'. -** 'OpenInput' will not close the current file, i.e., if is -** closed again, input will again be taken from the current input file. +** 'SyntaxError' prints the current line, followed by the error message: ** -** 'OpenInput' returns 1 if it could successfully open for -** reading and 0 to indicate failure. 'OpenInput' will fail if the file -** does not exist or if you do not have permissions to read it. 'OpenInput' -** may also fail if you have too many files open at once. It is system -** dependent how many are too many, but 16 files should work everywhere. +** ^ syntax error, in ** -** Directely after the 'OpenInput' call the variable 'Symbol' has the value -** 'S_ILLEGAL' to indicate that no symbol has yet been read from this file. -** The first symbol is read by 'Read' in the first call to 'Match' call. +** with the '^' pointing to the current symbol on the current line. If the +** is '*stdin*' it is not printed. ** -** You can open '*stdin*' to read from the standard input file, which is -** usually the terminal, or '*errin*' to read from the standard error file, -** which is the terminal even if '*stdin*' is redirected from a file. -** 'OpenInput' passes those file names to 'SyFopen' like any other name, -** they are just a convention between the main and the system package. -** 'SyFopen' and thus 'OpenInput' will fail to open '*errin*' if the file -** 'stderr' (Unix file descriptor 2) is not a terminal, because of a -** redirection say, to avoid that break loops take their input from a file. +** 'SyntaxError' is called from the parser to print error messages for those +** errors that are not cought by 'Match', for example if the left hand side +** of an assignment is not a variable, a list element or a record component, +** or if two formal arguments of a function have the same identifier. It is +** also called for warnings, for example if a statement has no effect. ** -** It is not neccessary to open the initial input file, 'InitScanner' opens -** '*stdin*' for that purpose. This file on the other hand can not be -** closed by 'CloseInput'. +** 'SyntaxError' first increments 'NrError' by 1. If 'NrError' is greater +** than zero the parser functions will not create new bags. This prevents +** the parser from creating new bags after an error occured. +** +** 'SyntaxError' also increments 'NrErrLine' by 1. If 'NrErrLine' is +** greater than zero 'SyntaxError' will not print an error message. This +** prevents the printing of multiple error messages for one line, since they +** probabely just reflect the fact that the parser has not resynchronized +** yet. 'NrErrLine' is reset to 0 if a new line is read in 'GetLine'. */ -UInt OpenInput ( - Char * filename ) +void SyntaxError ( + Char * msg ) { - Int file; + Int i; - /* fail if we can not handle another open input file */ - if ( Input+1 == InputFiles+(sizeof(InputFiles)/sizeof(InputFiles[0])) ) - return 0; + /* open error output */ + OpenOutput( "*errout*" ); - /* in test mode keep reading from test input file for break loop input */ - if ( TestInput != -1 && ! SyStrcmp( filename, "*errin*" ) ) - return 1; + /* one more error */ + NrError++; + NrErrLine++; - /* try to open the input file */ - file = SyFopen( filename, "r" ); - if ( file == -1 ) - return 0; + /* do not print a message if we found one already on the current line */ + if ( NrErrLine != 1 ) + return; - /* remember the current position in the current file */ - if ( Input != InputFiles-1 ) { - Input->ptr = In; - Input->symbol = Symbol; + /* print the message and the filename, unless it is '*stdin*' */ + Pr( "Syntax error: %s", (Int)msg, 0L ); + if ( SyStrcmp( "*stdin*", Input->name ) != 0 ) + Pr( " in %s line %d", (Int)Input->name, (Int)Input->number ); + Pr( "\n", 0L, 0L ); + + /* print the current line */ + Pr( "%s", (Int)Input->line, 0L ); + + /* print a '^' pointing to the current position */ + for ( i = 0; i < In - Input->line - 1; i++ ) { + if ( Input->line[i] == '\t' ) Pr("\t",0L,0L); + else Pr(" ",0L,0L); } + Pr( "^\n", 0L, 0L ); - /* enter the file identifier and the file name */ - Input++; - Input->file = file; - Input->name[0] = '\0'; - SyStrncat( Input->name, filename, sizeof(Input->name) ); + /* close error output */ + CloseOutput(); +} - /* start with an empty line and no symbol */ - In = Input->line; - In[0] = In[1] = '\0'; - Symbol = S_ILLEGAL; - Input->number = 1; - /* indicate success */ - return 1; +/**************************************************************************** +** +*F Match( , , ) . match current symbol and fetch next +** +** 'Match' is the main interface between the scanner and the parser. It +** performs the 4 most common actions in the scanner with just one call. +** First it checks that the current symbol stored in the variable 'Symbol' +** is the expected symbol as passed in the argument . If it is, +** 'Match' reads the next symbol from input and returns. Otherwise 'Match' +** first prints the current input line followed by the syntax error message: +** '^ syntax error, expected' with '^' pointing to the current symbol. +** It then skips symbols up to one in the resynchronisation set . +** Actually 'Match' calls 'SyntaxError' so its comments apply here too. +** +** One kind of typical 'Match' call has the form +** +** 'Match( Symbol, "", 0L );'. +** +** This is used if the parser knows that the current symbol is correct, for +** example in 'RdReturn' the first symbol must be 'S_RETURN', otherwise +** 'RdReturn' would not have been called. Called this way 'Match' will of +** course never raise an syntax error, therefore and are of +** no concern, they are passed nevertheless to please lint. The effect of +** this call is merely to read the next symbol from input. +** +** Another typical 'Match' call is in 'RdIf' after we read the if symbol and +** the condition following, and now expect to see the 'then' symbol: +** +** Match( S_THEN, "then", STATBEGIN|S_ELIF|S_ELSE|S_FI|follow ); +** +** If the current symbol is 'S_THEN' it is matched and the next symbol is +** read. Otherwise 'Match' prints the current line followed by the error +** message: '^ syntax error, then expected'. Then 'Match' skips all symbols +** until finding either a symbol that can begin a statment, an 'elif' or +** 'else' or 'fi' symbol, or a symbol that is contained in the set +** which is passed to 'RdIf' and contains all symbols allowing one of the +** calling functions to resynchronize, for example 'S_OD' if 'RdIf' has been +** called from 'RdFor'. always contain 'S_EOF', which 'Read' uses +** to resynchronise. +** +** If 'Match' needs to read a new line from '*stdin*' or '*errin*' to get +** the next symbol it prints the string pointed to by 'Prompt'. +*/ +void Match ( + UInt symbol, + Char * msg, + TypSymbolSet skipto ) +{ + Char errmsg [256]; + + /* if 'Symbol' is the expected symbol match it away */ + if ( symbol == Symbol ) { + GetSymbol(); + } + + /* else generate an error message and skip to a symbol in */ + else { + errmsg[0] ='\0'; + SyStrncat( errmsg, msg, sizeof(errmsg)-1 ); + SyStrncat( errmsg, " expected", + (Int)(sizeof(errmsg)-1-SyStrlen(errmsg)) ); + SyntaxError( errmsg ); + while ( ! IS_IN( Symbol, skipto ) ) + GetSymbol(); + } } /**************************************************************************** ** -*F CloseInput() . . . . . . . . . . . . . . . . . close current input file +*F PutLine() . . . . . . . . . . . . . . . . . . . . . . print a line, local ** -** 'CloseInput' will close the current input file. Subsequent input will -** again be taken from the previous input file. 'CloseInput' will return 1 -** to indicate success. +** 'PutLine' prints the current output line 'Output->line' to the current +** output file 'Output->file'. It is called from 'PutChr'. ** -** 'CloseInput' will not close the initial input file '*stdin*', and returns -** 0 if such an attempt is made. This is used in 'Error' which calls -** 'CloseInput' until it returns 0, therebye closing all open input files. +** 'PutLine' also compares the output line with the next line from the test +** input file 'TestInput' if 'TestInput' is not -1. If this input line +** starts with '#>' and the rest of the line matches the output line then +** the output line is not printed and the input line is discarded. ** -** Calling 'CloseInput' if the corresponding 'OpenInput' call failed will -** close the current output file, which will lead to very strange behaviour. +** 'PutLine' also echoes the output line to the logfile 'OutputLog' if +** 'OutputLog' is not -1 and the output file is '*stdout*' or '*errout*'. +** +** Finally 'PutLine' checks whether the user has hit '-C' to interrupt +** the printing. */ -UInt CloseInput ( void ) +void PutLine ( void ) { - /* refuse to close the initial input file */ - if ( Input == InputFiles ) - return 0; + Char * p; - /* refuse to close the test input file */ - if ( Input->file == TestInput ) - return 0; - - /* close the input file */ - SyFclose( Input->file ); + /* if in test mode and the next input line matches print nothing */ + if ( TestInput != 0 && TestOutput == Output ) { + if ( TestLine[0] == '\0' ) { + if ( ! SyFgets( TestLine, sizeof(TestLine), TestInput->file ) ) { + TestLine[0] = '\0'; + } + } + p = TestLine + (SyStrlen(TestLine)-2); + while ( TestLine <= p && ( *p == ' ' || *p == '\t' ) ) { + p[1] = '\0'; p[0] = '\n'; p--; + } + p = Output->line + (SyStrlen(Output->line)-2); + while ( Output->line <= p && ( *p == ' ' || *p == '\t' ) ) { + p[1] = '\0'; p[0] = '\n'; p--; + } + if ( ! SyStrcmp( TestLine, Output->line ) ) { + TestLine[0] = '\0'; + } + else { + SyFputs( "+ ", Output->file ); + SyFputs( Output->line, Output->file ); + } + } - /* revert to last file */ - Input--; - In = Input->ptr; - Symbol = Input->symbol; + /* otherwise output this line */ + else { + SyFputs( Output->line, Output->file ); + } - /* indicate success */ - return 1; + /* if neccessary echo it to the logfile */ + if ( OutputLog != -1 && (Output->file == 1 || Output->file == 3)) + SyFputs( Output->line, OutputLog ); } /**************************************************************************** ** -*F OpenOutput( ) . . . . . . . . . open a file as current output -** -** 'OpenOutput' opens the file with the name as current output. -** All subsequent output will go to that file, until either it is closed -** again with 'CloseOutput' or another file is opened with 'OpenOutput'. -** The file is truncated to size 0 if it existed, otherwise it is created. -** 'OpenOutput' does not close the current file, i.e., if is -** closed again, output will go again to the current output file. +*F PutChr( ) . . . . . . . . . . . . . . . print character , local ** -** 'OpenOutput' returns 1 if it could successfully open for -** writing and 0 to indicate failure. 'OpenOutput' will fail if you do not -** have permissions to create the file or write to it. 'OpenOutput' may -** also fail if you have too many files open at once. It is system -** dependent how many are too many, but 16 files should work everywhere. +** 'PutChr' prints the single character to the current output file. ** -** You can open '*stdout*' to write to the standard output file, which is -** usually the terminal, or '*errout*' to write to the standard error file, -** which is the terminal even if '*stdout*' is redirected to a file. -** 'OpenOutput' passes those file names to 'SyFopen' like any other name, -** they are just a convention between the main and the system package. +** 'PutChr' buffers the output characters until either is , +** is '\03' () or the buffer fills up. ** -** It is not neccessary to open the initial output file, 'InitScanner' opens -** '*stdout*' for that purpose. This file on the other hand can not be -** closed by 'CloseOutput'. +** In the later case 'PutChr' has to decide where to split the output line. +** It takes the point at which $linelength - pos + 8 * indent$ is minimal. */ -UInt OpenOutput ( - Char * filename ) +void PutChr ( + Char ch ) { - Int file; + Int i; + Char str [ 256 ]; - /* fail if we can not handle another open output file */ - if ( Output+1==OutputFiles+(sizeof(OutputFiles)/sizeof(OutputFiles[0])) ) - return 0; + /* '\01', increment indentation level */ + if ( ch == '\01' ) { - /* in test mode keep printing to test output file for breakloop output */ - if ( TestInput != -1 && ! SyStrcmp( filename, "*errout*" ) ) - return 1; + /* if this is a better place to split the line remember it */ + if ( Output->indent < Output->pos + && SyNrCols-Output->pos + 16*Output->indent + <= SyNrCols-Output->spos + 16*Output->sindent ) { + Output->spos = Output->pos; + Output->sindent = Output->indent; + } - /* try to open the file */ - file = SyFopen( filename, "w" ); - if ( file == -1 ) - return 0; + Output->indent++; - /* put the file on the stack, start at position 0 on an empty line */ - Output++; - Output->file = file; - Output->line[0] = '\0'; - Output->pos = 0; - Output->indent = 0; + } - /* variables related to line splitting, very bad place to split */ - Output->spos = 0; - Output->sindent = 666; + /* '\02', decrement indentation level */ + else if ( ch == '\02' ) { - /* indicate success */ - return 1; -} + /* if this is a better place to split the line remember it */ + if ( Output->indent < Output->pos + && SyNrCols-Output->pos + 16*Output->indent + <= SyNrCols-Output->spos + 16*Output->sindent ) { + Output->spos = Output->pos; + Output->sindent = Output->indent; + } + Output->indent--; -/**************************************************************************** -** -*F CloseOutput() . . . . . . . . . . . . . . . . . close current output file -** -** 'CloseOutput' will first flush all pending output and then close the -** current output file. Subsequent output will again go to the previous -** output file. 'CloseOutput' returns 1 to indicate success. -** -** 'CloseOutput' will not close the initial output file '*stdout*', and -** returns 0 if such attempt is made. This is used in 'Error' which calls -** 'CloseOutput' until it returns 0, thereby closing all open output files. -** -** Calling 'CloseOutput' if the corresponding 'OpenOutput' call failed will -** close the current output file, which will lead to very strange behaviour. -** On the other hand if you forget to call 'CloseOutput' at the end of a -** 'PrintTo' call or an error will not yield much better results. -*/ -UInt CloseOutput ( void ) -{ - /* refuse to close the initial output file '*stdout*' */ - if ( Output == OutputFiles ) - return 0; + } - /* refuse to close the test output file */ - if ( Output->file == TestOutput ) - return 0; + /* '\03', print line */ + else if ( ch == '\03' ) { - /* flush output and close the file */ - Pr( "%c", (Int)'\03', 0L ); - SyFclose( Output->file ); + /* print the line */ + Output->line[ Output->pos ] = '\0'; + PutLine(); - /* revert to previous output file and indicate success */ - Output--; - return 1; -} + /* start the next line */ + Output->pos = 0; + /* first character is a very bad place to split */ + Output->spos = 0; + Output->sindent = 666; -/**************************************************************************** -** -*F OpenAppend( ) . . open a file as current output for appending -** -** 'OpenAppend' opens the file with the name as current output. -** All subsequent output will go to that file, until either it is closed -** again with 'CloseAppend' or another file is opened with 'OpenOutput'. -** Unlike 'OpenOutput' 'OpenAppend' does not truncate the file to size 0 if -** it exists. Appart from that 'OpenAppend' is equal to 'OpenOutput' so its -** description applies to 'OpenAppend' too. -*/ -UInt OpenAppend ( - Char * filename ) -{ - Int file; + } - /* fail if we can not handle another open output file */ - if ( Output+1==OutputFiles+(sizeof(OutputFiles)/sizeof(OutputFiles[0])) ) - return 0; + /* or , print line, indent next */ + else if ( ch == '\n' || ch == '\r' ) { - /* in test mode keep printing to test output file for breakloop output */ - if ( TestInput != -1 && ! SyStrcmp( filename, "*errout*" ) ) - return 1; + /* put the character on the line and terminate it */ + Output->line[ Output->pos++ ] = ch; + Output->line[ Output->pos ] = '\0'; - /* try to open the file */ - file = SyFopen( filename, "a" ); - if ( file == -1 ) - return 0; + /* print the line */ + PutLine(); - /* put the file on the stack, start at position 0 on an empty line */ - Output++; - Output->file = file; - Output->line[0] = '\0'; - Output->pos = 0; - Output->indent = 0; + /* indent for next line */ + Output->pos = 0; + for ( i = 0; i < Output->indent; i++ ) + Output->line[ Output->pos++ ] = ' '; - /* variables related to line splitting, very bad place to split */ - Output->spos = 0; - Output->sindent = 666; + /* set up new split positions */ + Output->spos = 0; + Output->sindent = 666; - /* indicate success */ - return 1; -} + } + /* normal character, room on the current line */ + else if ( Output->pos < SyNrCols-2 ) { -/**************************************************************************** -** -*F CloseAppend() . . . . . . . . . . . . . . . . . close current output file -** -** 'CloseAppend' will first flush all pending output and then close the -** current output file. Subsequent output will again go to the previous -** output file. 'CloseAppend' returns 1 to indicate success. 'CloseAppend' -** is exactely equal to 'CloseOutput' so its description applies. -*/ -UInt CloseAppend ( void ) -{ - /* refuse to close the initial output file '*stdout*' */ - if ( Output == OutputFiles ) - return 0; + /* put the character on this line */ + Output->line[ Output->pos++ ] = ch; + + } - /* refuse to close the test output file */ - if ( Output->file == TestOutput ) - return 0; + /* if we are going to split at the end of the line, discard blanks */ + else if ( Output->spos == Output->pos && ch == ' ' ) { + ; + } - /* flush output and close the file */ - Pr( "%c", (Int)'\03', 0L ); - SyFclose( Output->file ); + /* full line, acceptable split position */ + else if ( Output->spos != 0 ) { - /* revert to previous output file and indicate success */ - Output--; - return 1; -} + /* add character to the line, terminate it */ + Output->line[ Output->pos++ ] = ch; + Output->line[ Output->pos++ ] = '\0'; + /* copy the rest after the best split position to a safe place */ + for ( i = Output->spos; i < Output->pos; i++ ) + str[ i-Output->spos ] = Output->line[ i ]; -/**************************************************************************** -** -*F OpenInputLog( ) . . . . . . . . . . . . . log input to a file -** -** 'OpenInputLog' instructs the scanner to echo all input from the files -** '*stdin*' and '*errin*' to the file with name . The file is -** truncated to size 0 if it existed, otherwise it is created. -** -** 'OpenInputLog' returns 1 if it could successfully open for -** writing and 0 to indicate failure. 'OpenInputLog' will fail if you do -** not have permissions to create the file or write to it. 'OpenInputLog' -** may also fail if you have too many files open at once. It is system -** dependent how many are too many, but 16 files should work everywhere. -** Finally 'OpenInputLog' will fail if there is already a current logfile. -*/ -UInt OpenInputLog ( - Char * filename ) -{ + /* print line up to the best split position */ + Output->line[ Output->spos++ ] = '\n'; + Output->line[ Output->spos ] = '\0'; + PutLine(); - /* refuse to open a logfile if we already log to one */ - if ( InputLog != -1 ) - return 0; + /* indent for the rest */ + Output->pos = 0; + for ( i = 0; i < Output->sindent; i++ ) + Output->line[ Output->pos++ ] = ' '; - /* try to open the file */ - InputLog = SyFopen( filename, "w" ); - if ( InputLog == -1 ) - return 0; + /* copy the rest onto the next line */ + for ( i = 0; str[ i ] != '\0'; i++ ) + Output->line[ Output->pos++ ] = str[ i ]; - /* otherwise indicate success */ - return 1; -} + /* set new split position */ + Output->spos = 0; + Output->sindent = 666; + + } + /* full line, no splitt position */ + else { -/**************************************************************************** -** -*F CloseInputLog() . . . . . . . . . . . . . . . . close the current logfile -** -** 'CloseInputLog' closes the current logfile again, so that input from -** '*stdin*' and '*errin*' will no longer be echoed to a file. -** 'CloseInputLog' will return 1 to indicate success. -** -** 'CloseInputLog' will fail if there is no logfile active and will return 0 -** in this case. -*/ -UInt CloseInputLog ( void ) -{ - /* refuse to close a non existent logfile */ - if ( InputLog == -1 ) - return 0; + /* append a '\', and print the line */ + Output->line[ Output->pos++ ] = '\\'; + Output->line[ Output->pos++ ] = '\n'; + Output->line[ Output->pos ] = '\0'; + PutLine(); - /* close the logfile */ - SyFclose( InputLog ); - InputLog = -1; + /* add the character to the next line */ + Output->pos = 0; + Output->line[ Output->pos++ ] = ch; - /* indicate success */ - return 1; + /* the first character is a very bad place to split */ + Output->spos = 0; + Output->sindent = 666; + + } } /**************************************************************************** ** -*F OpenOutputLog( ) . . . . . . . . . . . log output to a file +*F Pr( , , ) . . . . . . . . . print formatted output ** -** 'OpenInputLog' instructs the scanner to echo all output to the files -** '*stdout*' and '*errout*' to the file with name . The file is -** truncated to size 0 if it existed, otherwise it is created. +** 'Pr' is the output function. The first argument is a 'printf' like format +** string containing up to 2 '%' format fields, specifing how the +** corresponding arguments are to be printed. The two arguments are passed +** as 'Int' integers. This is possible since every C object ('int', +** 'char', pointers) except 'float' or 'double', which are not used in GAP, +** can be converted to a 'Int' without loss of information. ** -** 'OpenOutputLog' returns 1 if it could successfully open for -** writing and 0 to indicate failure. 'OpenOutputLog' will fail if you do -** not have permissions to create the file or write to it. 'OpenOutputLog' -** may also fail if you have too many files open at once. It is system -** dependent how many are too many, but 16 files should work everywhere. -** Finally 'OpenOutputLog' will fail if there is already a current logfile. +** The function 'Pr' currently support the following '%' format fields: +** '%c' the corresponding argument represents a character, usually it is +** its ASCII or EBCDIC code, and this character is printed. +** '%s' the corresponding argument is the address of a null terminated +** character string which is printed. +** '%d' the corresponding argument is a signed integer, which is printed. +** Between the '%' and the 'd' an integer might be used to specify +** the width of a field in which the integer is right justified. If +** the first character is '0' 'Pr' pads with '0' instead of . +** '%>' increment the indentation level. +** '%<' decrement the indentation level. +** '%%' can be used to print a single '%' character. No argument is used. +** +** You must always cast the arguments to '(Int)' to avoid problems with +** those compilers with a default integer size of 16 instead of 32 bit. You +** must pass 0L if you don't make use of an argument to please lint. */ -UInt OpenOutputLog ( - Char * filename ) +void Pr ( + Char * format, + Int arg1, + Int arg2 ) { + Char * p; + Char * q; + Int prec, n; + Char fill; - /* refuse to open a logfile if we already log to one */ - if ( OutputLog != -1 ) - return 0; + /* loop over the characters of the string */ + for ( p = format; *p != '\0'; p++ ) { - /* try to open the file */ - OutputLog = SyFopen( filename, "w" ); - if ( OutputLog == -1 ) - return 0; + /* if the character is '%' do something special */ + if ( *p == '%' ) { - /* otherwise indicate success */ - return 1; -} + /* first look for a precision field */ + p++; + prec = 0; + fill = (*p == '0' ? '0' : ' '); + while ( IsDigit(*p) ) { + prec = 10 * prec + *p - '0'; + p++; + } + /* '%d' print an integer */ + if ( *p == 'd' ) { + if ( arg1 < 0 ) { + prec--; + for ( n=1; n <= -(arg1/10); n*=10 ) + prec--; + while ( --prec > 0 ) PutChr(fill); + PutChr('-'); + for ( ; n > 0; n /= 10 ) + PutChr( (Char)(-((arg1/n)%10) + '0') ); + arg1 = arg2; + } + else { + for ( n=1; n<=arg1/10; n*=10 ) + prec--; + while ( --prec > 0 ) PutChr(fill); + for ( ; n > 0; n /= 10 ) + PutChr( (Char)(((arg1/n)%10) + '0') ); + arg1 = arg2; + } + } -/**************************************************************************** -** -*F CloseOutputLog() . . . . . . . . . . . . . . . close the current logfile -** -** 'CloseInputLog' closes the current logfile again, so that output to -** '*stdout*' and '*errout*' will no longer be echoed to a file. -** 'CloseOutputLog' will return 1 to indicate success. -** -** 'CloseOutputLog' will fail if there is no logfile active and will return -** 0 in this case. -*/ -UInt CloseOutputLog ( void ) -{ - /* refuse to close a non existent logfile */ - if ( OutputLog == -1 ) - return 0; + /* '%s' print a string */ + else if ( *p == 's' ) { - /* close the logfile */ - SyFclose( OutputLog ); - OutputLog = -1; + /* compute how many characters this identifier requires */ + for ( q = (Char*)arg1; *q != '\0'; q++ ) { + prec--; + } - /* indicate success */ - return 1; -} + /* if wanted push an appropriate number of -s */ + while ( prec-- > 0 ) PutChr(' '); + /* print the string */ + for ( q = (Char*)arg1; *q != '\0'; q++ ) { + PutChr( *q ); + } -/**************************************************************************** -** -*F OpenLog( ) . . . . . . . . . . . . . log interaction to a file -** -** 'OpenLog' instructs the scanner to echo all input from the files -** '*stdin*' and '*errin*' and all output to the files '*stdout*' and -** '*errout*' to the file with name . The file is truncated to -** size 0 if it existed, otherwise it is created. -** -** 'OpenLog' returns 1 if it could successfully open for writing -** and 0 to indicate failure. 'OpenLog' will fail if you do not have -** permissions to create the file or write to it. 'OpenOutput' may also -** fail if you have too many files open at once. It is system dependent how -** many are too many, but 16 files should work everywhere. Finally -** 'OpenLog' will fail if there is already a current logfile. -*/ -UInt OpenLog ( - Char * filename ) -{ + /* on to the next argument */ + arg1 = arg2; + } + + /* '%S' print a string with the necessary escapes */ + else if ( *p == 'S' ) { + + /* compute how many characters this identifier requires */ + for ( q = (Char*)arg1; *q != '\0'; q++ ) { + if ( *q == '\n' ) { prec -= 2; } + else if ( *q == '\t' ) { prec -= 2; } + else if ( *q == '\r' ) { prec -= 2; } + else if ( *q == '\b' ) { prec -= 2; } + else if ( *q == '\03' ) { prec -= 2; } + else if ( *q == '"' ) { prec -= 2; } + else if ( *q == '\\' ) { prec -= 2; } + else { prec -= 1; } + } - /* refuse to open a logfile if we already log to one */ - if ( InputLog != -1 || OutputLog != -1 ) - return 0; + /* if wanted push an appropriate number of -s */ + while ( prec-- > 0 ) PutChr(' '); - /* try to open the file */ - InputLog = SyFopen( filename, "w" ); - OutputLog = InputLog; - if ( InputLog == -1 ) - return 0; + /* print the string */ + for ( q = (Char*)arg1; *q != '\0'; q++ ) { + if ( *q == '\n' ) { PutChr('\\'); PutChr('n'); } + else if ( *q == '\t' ) { PutChr('\\'); PutChr('t'); } + else if ( *q == '\r' ) { PutChr('\\'); PutChr('r'); } + else if ( *q == '\b' ) { PutChr('\\'); PutChr('b'); } + else if ( *q == '\03' ) { PutChr('\\'); PutChr('c'); } + else if ( *q == '"' ) { PutChr('\\'); PutChr('"'); } + else if ( *q == '\\' ) { PutChr('\\'); PutChr('\\'); } + else { PutChr( *q ); } + } - /* otherwise indicate success */ - return 1; -} + /* on to the next argument */ + arg1 = arg2; + } + /* '%C' print a string with the necessary C escapes */ + else if ( *p == 'C' ) { -/**************************************************************************** -** -*F CloseLog() . . . . . . . . . . . . . . . . . . close the current logfile -** -** 'CloseLog' closes the current logfile again, so that input from '*stdin*' -** and '*errin*' and output to '*stdout*' and '*errout*' will no longer be -** echoed to a file. 'CloseLog' will return 1 to indicate success. -** -** 'CloseLog' will fail if there is no logfile active and will return 0 in -** this case. -*/ -UInt CloseLog ( void ) -{ - /* refuse to close a non existent logfile */ - if ( InputLog == -1 || OutputLog == -1 || InputLog != OutputLog ) - return 0; + /* compute how many characters this identifier requires */ + for ( q = (Char*)arg1; *q != '\0'; q++ ) { + if ( *q == '\n' ) { prec -= 2; } + else if ( *q == '\t' ) { prec -= 2; } + else if ( *q == '\r' ) { prec -= 2; } + else if ( *q == '\b' ) { prec -= 2; } + else if ( *q == '\03' ) { prec -= 3; } + else if ( *q == '"' ) { prec -= 2; } + else if ( *q == '\\' ) { prec -= 2; } + else { prec -= 1; } + } - /* close the logfile */ - SyFclose( InputLog ); - InputLog = -1; - OutputLog = -1; + /* if wanted push an appropriate number of -s */ + while ( prec-- > 0 ) PutChr(' '); - /* indicate success */ - return 1; -} + /* print the string */ + for ( q = (Char*)arg1; *q != '\0'; q++ ) { + if ( *q == '\n' ) { PutChr('\\'); PutChr('n'); } + else if ( *q == '\t' ) { PutChr('\\'); PutChr('t'); } + else if ( *q == '\r' ) { PutChr('\\'); PutChr('r'); } + else if ( *q == '\b' ) { PutChr('\\'); PutChr('b'); } + else if ( *q == '\03' ) { PutChr('\\'); PutChr('0'); + PutChr('3'); } + else if ( *q == '"' ) { PutChr('\\'); PutChr('"'); } + else if ( *q == '\\' ) { PutChr('\\'); PutChr('\\'); } + else { PutChr( *q ); } + } + /* on to the next argument */ + arg1 = arg2; + } -/**************************************************************************** -** -*F OpenTest( ) . . . . . . . . open an input file for test mode -** -** 'OpenTest' opens the file with the name as current input for -** test mode. All subsequent input will be taken from that file, until it -** is closed again with 'CloseTest' or another file is opened with -** 'OpenInput'. 'OpenTest' will not close the current file, i.e., if -** is closed again, input will be taken again from the current -** input file. -** -** Test mode works as follows. If the scanner is about to print a line to -** the current output file (or to be more precise to the output file that -** was current when 'OpenTest' was called) this line is compared with the -** next line from the test input file, i.e., the one opened by 'OpenTest'. -** If this line starts with '#>' and the rest of it matches the output line -** the output line is not printed and the input comment line is discarded. -** Otherwise the scanner prints the output line and does not discard the -** input line. -** -** On the other hand if an input line is encountered on the test input that -** starts with '#>' the scanner assumes that this is an expected output line -** that did not appear and echoes this line to the current output file. -** -** The upshot is that you can write test files that consist of alternating -** input and, as '#>' test comment lines the expected output. If GAP -** behaves normal and produces the expected output then nothing is printed. -** But if something goes wrong you see what actually was printed and what -** was expected instead. -** -** As a convention GAP test files should end with a print statement like: -** -** Print("prime 3.002 06-Jul-90 ",417000000/Runtime()," GAPstones\n"); -** -** without a matching '#>' comment line. This tells the user that the test -** file completed and also how much time it took. The constant should be -** such that a VAX 11/780 gets roughly 1000 GAPstones. -** -** 'OpenTest' returns 1 if it could successfully open for reading -** and 0 to indicate failure. 'OpenTest' will fail if the file does not -** exist or if you have no permissions to read it. 'OpenTest' may also fail -** if you have too many files open at once. It is system dependent how many -** are too may, but 16 files shoule work everywhere. -** -** Directely after the 'OpenTest' call the variable 'Symbol' has the value -** 'S_ILLEGAL' to indicate that no symbol has yet been read from this file. -** The first symbol is read by 'Read' in the first call to 'Match' call. -*/ -UInt OpenTest ( - Char * filename ) -{ - /* do not allow to nest test files */ - if ( TestInput != -1 ) - return 0; + /* '%I' print an identifier */ + else if ( *p == 'I' ) { - /* try to open the file as input file */ - if ( ! OpenInput( filename ) ) - return 0; + /* compute how many characters this identifier requires */ + q = (Char*)arg1; + if ( !SyStrcmp(q,"and") || !SyStrcmp(q,"break") + || !SyStrcmp(q,"do") || !SyStrcmp(q,"elif") + || !SyStrcmp(q,"else") || !SyStrcmp(q,"end") + || !SyStrcmp(q,"fi") || !SyStrcmp(q,"for") + || !SyStrcmp(q,"function") || !SyStrcmp(q,"if") + || !SyStrcmp(q,"in") || !SyStrcmp(q,"local") + || !SyStrcmp(q,"mod") || !SyStrcmp(q,"not") + || !SyStrcmp(q,"od") || !SyStrcmp(q,"or") + || !SyStrcmp(q,"repeat") || !SyStrcmp(q,"return") + || !SyStrcmp(q,"then") || !SyStrcmp(q,"until") + || !SyStrcmp(q,"while") || !SyStrcmp(q,"quit") + || !SyStrcmp(q,"IsBound") || !SyStrcmp(q,"IsBound")) { + prec--; + } + for ( q = (Char*)arg1; *q != '\0'; q++ ) { + if ( ! IsAlpha(*q) && ! IsDigit(*q) && *q != '_' ) { + prec--; + } + prec--; + } - /* remember this is a test input */ - TestInput = Input->file; - TestOutput = Output->file; - TestLine[0] = '\0'; + /* if wanted push an appropriate number of -s */ + while ( prec-- > 0 ) { PutChr(' '); } - /* indicate success */ - return 1; -} + /* print the identifier */ + q = (Char*)arg1; + if ( !SyStrcmp(q,"and") || !SyStrcmp(q,"break") + || !SyStrcmp(q,"do") || !SyStrcmp(q,"elif") + || !SyStrcmp(q,"else") || !SyStrcmp(q,"end") + || !SyStrcmp(q,"fi") || !SyStrcmp(q,"for") + || !SyStrcmp(q,"function") || !SyStrcmp(q,"if") + || !SyStrcmp(q,"in") || !SyStrcmp(q,"local") + || !SyStrcmp(q,"mod") || !SyStrcmp(q,"not") + || !SyStrcmp(q,"od") || !SyStrcmp(q,"or") + || !SyStrcmp(q,"repeat") || !SyStrcmp(q,"return") + || !SyStrcmp(q,"then") || !SyStrcmp(q,"until") + || !SyStrcmp(q,"while") || !SyStrcmp(q,"quit") + || !SyStrcmp(q,"IsBound") || !SyStrcmp(q,"IsBound")) { + PutChr( '\\' ); + } + for ( q = (Char*)arg1; *q != '\0'; q++ ) { + if ( ! IsAlpha(*q) && ! IsDigit(*q) && *q != '_' ) { + PutChr( '\\' ); + } + PutChr( *q ); + } + + /* on to the next argument */ + arg1 = arg2; + } + /* '%c' print a character */ + else if ( *p == 'c' ) { + PutChr( (Char)arg1 ); + arg1 = arg2; + } -/**************************************************************************** -** -*F CloseTest() . . . . . . . . . . . . . . . . . . close the test input file -** -** 'CloseTest' closes the current test input file and ends test mode. -** Subsequent input will again be taken from the previous input file. -** Output will no longer be compared with comment lines from the test input -** file. 'CloseTest' will return 1 to indicate success. -** -** 'CloseTest' will not close a non test input file and returns 0 if such an -** attempt is made. -*/ -UInt CloseTest ( void ) -{ - /* refuse to a non test file */ - if ( TestInput != Input->file ) - return 0; + /* '%%' print a '%' character */ + else if ( *p == '%' ) { + PutChr( '%' ); + } - /* close the input file */ - SyFclose( Input->file ); + /* '%>' increment the indentation level */ + else if ( *p == '>' ) { + PutChr( '\01' ); + while ( --prec > 0 ) + PutChr( '\01' ); + } - /* revert to last file */ - Input--; - In = Input->ptr; - Symbol = Input->symbol; + /* '%<' decrement the indentation level */ + else if ( *p == '<' ) { + PutChr( '\02' ); + while ( --prec > 0 ) + PutChr( '\02' ); + } - /* we are no longer in test mode */ - TestInput = -1; - TestOutput = -1; - TestLine[0] = '\0'; + /* else raise an error */ + else { + for ( p = "%format error"; *p != '\0'; p++ ) + PutChr( *p ); + } - /* indicate success */ - return 1; + } + + /* not a '%' character, simply print it */ + else { + PutChr( *p ); + } + + } } /**************************************************************************** ** + *F InitScanner() . . . . . . . . . . . . . . initialize the scanner package ** ** 'InitScanner' initializes the scanner package. This justs sets the @@ -2035,12 +2174,27 @@ UInt CloseTest ( void ) void InitScanner ( void ) { Int ignore; + Int i; + static Char cookie[sizeof(InputFiles)/sizeof(InputFiles[0])][9]; Input = InputFiles-1; ignore = OpenInput( "*stdin*" ); Output = OutputFiles-1; ignore = OpenOutput( "*stdout*" ); InputLog = -1; OutputLog = -1; - TestInput = -1; TestOutput = -1; + TestInput = 0; TestOutput = 0; + + for ( i = 0; i < sizeof(InputFiles)/sizeof(InputFiles[0]); i++ ) { + cookie[i][0] = 's'; + cookie[i][1] = 't'; + cookie[i][2] = 'r'; + cookie[i][3] = 'e'; + cookie[i][4] = 'a'; + cookie[i][5] = 'm'; + cookie[i][6] = ' '; + cookie[i][7] = '0'+i; + cookie[i][8] = '\0'; + InitGlobalBag(&(InputFiles[i].stream), &(cookie[i][0])); + } } diff --git a/src/scanner.h b/src/scanner.h index 7ee0db1442..116f795336 100644 --- a/src/scanner.h +++ b/src/scanner.h @@ -32,6 +32,7 @@ char * Revision_scanner_h = /**************************************************************************** ** + *V Symbol . . . . . . . . . . . . . . . . . current symbol read from input ** ** The variable 'Symbol' contains the current symbol read from the input. @@ -373,6 +374,149 @@ extern void Pr ( Int arg2 ); +/**************************************************************************** +** + +*T TypInputFile . . . . . . . . . . structure of an open input file, local +** +** 'TypInputFile' describes the information stored for open input files: +** +** 'isstream' is 'true' if input come from a stream. +** +** 'file' holds the file identifier which is received from 'SyFopen' and +** which is passed to 'SyFgets' and 'SyFclose' to identify this file. +** +** 'name' is the name of the file, this is only used in error messages. +** +** 'line' is a buffer that holds the current input line. This is always +** terminated by the character '\0'. Because 'line' holds only part of the +** line for very long lines the last character need not be a . +** +** 'ptr' points to the current character within that line. This is not used +** for the current input file, where 'In' points to the current character. +** +** 'number' is the number of the current line, is used in error messages. +** +** 'stream' is none zero if the input points to a stream. +** +** 'sline' contains the next line from the stream as GAP string. +** +*/ +typedef struct { + UInt isstream; + Int file; + Char name [256]; + Char line [256]; + Char * ptr; + UInt symbol; + Int number; + Obj stream; + Obj sline; + Int spos; +} TypInputFile; + + + +/**************************************************************************** +** +*V InputFiles[] . . . . . . . . . . . . . stack of open input files, local +*V Input . . . . . . . . . . . . . . . pointer to current input file, local +*V In . . . . . . . . . . . . . . . . . pointer to current character, local +** +** 'InputFiles' is the stack of the open input files. It is represented as +** an array of structures of type 'TypInputFile'. +** +** 'Input' is a pointer to the current input file. It points to the top of +** the stack 'InputFiles'. +** +** 'In' is a pointer to the current input character, i.e., '*In' is the +** current input character. It points into the buffer 'Input->line'. +*/ + +extern TypInputFile InputFiles [16]; +extern TypInputFile * Input; +extern Char * In; + + +/**************************************************************************** +** +*T TypOutputFiles . . . . . . . . . structure of an open output file, local +*V OutputFiles . . . . . . . . . . . . . . stack of open output files, local +*V Output . . . . . . . . . . . . . . pointer to current output file, local +** +** 'TypOutputFile' describes the information stored for open output files: +** 'file' holds the file identifier which is received from 'SyFopen' and +** which is passed to 'SyFputs' and 'SyFclose' to identify this file. +** 'line' is a buffer that holds the current output line. +** 'pos' is the position of the current character on that line. +** +** 'OutputFiles' is the stack of open output files. It is represented as +** an array of structures of type 'TypOutputFile'. +** +** 'Output' is a pointer to the current output file. It points to the top +** of the stack 'OutputFiles'. +*/ +typedef struct { + Int file; + Char line [256]; + Int pos; + Int indent; + Int spos; + Int sindent; +} TypOutputFile; + +extern TypOutputFile OutputFiles [16]; +extern TypOutputFile * Output; + + +/**************************************************************************** +** +*V InputLog . . . . . . . . . . . . . . . file identifier of logfile, local +** +** 'InputLog' is the file identifier of the current input logfile. If it is +** not -1 the scanner echoes all input from the files '*stdin*' and +** '*errin*' to this file. +*/ +extern Int InputLog; + + +/**************************************************************************** +** +*V OutputLog . . . . . . . . . . . . . . . file identifier of logfile, local +** +** 'OutputLog' is the file identifier of the current output logfile. If it +** is not -1 the scanner echoes all output to the files '*stdout*' and +** '*errout*' to this file. +*/ +extern Int OutputLog; + + +/**************************************************************************** +** +*V TestInput . . . . . . . . . . . . . file identifier of test input, local +*V TestOutput . . . . . . . . . . . . file identifier of test output, local +*V TestLine . . . . . . . . . . . . . . . . one line from test input, local +** +** 'TestInput' is the file identifier of the file for test input. If this +** is not -1 and 'GetLine' reads a line from 'TestInput' that begins with +** '#>' 'GetLine' assumes that this was expected as output that did not +** appear and echoes this input line to 'TestOutput'. +** +** 'TestOutput' is the current output file for test output. If 'TestInput' +** is not -1 then 'PutLine' compares every line that is about to be printed +** to 'TestOutput' with the next line from 'TestInput'. If this line starts +** with '#>' and the rest of it matches the output line the output line is +** not printed and the input comment line is discarded. Otherwise 'PutLine' +** prints the output line and does not discard the input line. +** +** 'TestLine' holds the one line that is read from 'TestInput' to compare it +** with a line that is about to be printed to 'TestOutput'. +*/ +extern TypInputFile * TestInput; +extern TypOutputFile * TestOutput; +extern Char TestLine [256]; + + /**************************************************************************** ** *F OpenInput( ) . . . . . . . . . . open a file as current input @@ -643,6 +787,7 @@ extern UInt CloseTest ( void ); /**************************************************************************** ** + *F InitScanner() . . . . . . . . . . . . . . initialize the scanner package ** ** 'InitScanner' initializes the scanner package. This justs sets the diff --git a/src/sctable.c b/src/sctable.c index 8ae657b846..2281ab8475 100644 --- a/src/sctable.c +++ b/src/sctable.c @@ -39,10 +39,11 @@ char * Revision_sctable_c = "@(#)$Id$"; #include "system.h" /* Ints, UInts */ -#include "scanner.h" /* Pr */ -#include "gasman.h" /* Bag, NewBag */ +#include "gasman.h" /* Bag, NewBag */ #include "objects.h" /* Obj, TYPE_OBJ, types */ +#include "scanner.h" /* Pr */ + #include "gvars.h" /* AssGVar, GVarName */ #include "calls.h" /* NewFunctionC */ @@ -367,9 +368,11 @@ Obj SCTableProductHandler ( */ void InitSCTable ( void ) { + InitHandlerFunc( SCTableEntryHandler, "SC_TABLE_ENTRY" ); SCTableEntryFunc = NewFunctionC( "SC_TABLE_ENTRY", 4L, "table,i,j,k", SCTableEntryHandler ); AssGVar( GVarName( "SC_TABLE_ENTRY" ), SCTableEntryFunc ); + InitHandlerFunc( SCTableProductHandler, "SC_TABLE_PRODUCT" ); SCTableProductFunc = NewFunctionC( "SC_TABLE_PRODUCT", 3L, "table,list1,list2", SCTableProductHandler ); AssGVar( GVarName( "SC_TABLE_PRODUCT" ), SCTableProductFunc ); diff --git a/src/set.c b/src/set.c index 12d73abc68..accf626dc5 100644 --- a/src/set.c +++ b/src/set.c @@ -24,10 +24,11 @@ char * Revision_set_c = #include /* assert */ #include "system.h" /* system dependent functions */ -#include "scanner.h" /* Pr */ -#include "gasman.h" /* NewBag, ResizeBag, CHANGED_BAG */ +#include "gasman.h" /* NewBag, ResizeBag, CHANGED_BAG */ #include "objects.h" /* Obj, TYPE_OBJ, SIZE_OBJ, ... */ +#include "scanner.h" /* Pr */ + #include "gvars.h" /* AssGVar, GVarName */ #include "calls.h" /* generic call mechanism */ @@ -872,34 +873,42 @@ Obj SubtractSetHandler ( void InitSet ( void ) { /* install internal functions */ + InitHandlerFunc( SetListHandler, "LIST_SORTED_LIST" ); SetListFunc = NewFunctionC( "LIST_SORTED_LIST", 1L, "list", SetListHandler ); AssGVar( GVarName( "LIST_SORTED_LIST" ), SetListFunc ); + InitHandlerFunc( IsEqualSetHandler, "IS_EQUAL_SET" ); IsEqualSetFunc = NewFunctionC( "IS_EQUAL_SET", 2L, "set1, set2", IsEqualSetHandler ); AssGVar( GVarName( "IS_EQUAL_SET" ), IsEqualSetFunc ); + InitHandlerFunc( IsSubsetSetHandler, "IS_SUBSET_SET" ); IsSubsetSetFunc = NewFunctionC( "IS_SUBSET_SET", 2L, "set1, set2", IsSubsetSetHandler ); AssGVar( GVarName( "IS_SUBSET_SET" ), IsSubsetSetFunc ); + InitHandlerFunc( AddSetHandler, "ADD_SET" ); AddSetFunc = NewFunctionC( "ADD_SET", 2L, "set, val", AddSetHandler ); AssGVar( GVarName( "ADD_SET" ), AddSetFunc ); + InitHandlerFunc( RemoveSetHandler, "REM_SET" ); RemoveSetFunc = NewFunctionC( "REM_SET", 2L, "set, val", RemoveSetHandler ); AssGVar( GVarName( "REM_SET" ), RemoveSetFunc ); + InitHandlerFunc( UniteSetHandler, "UNITE_SET" ); UniteSetFunc = NewFunctionC( "UNITE_SET", 2L, "set1, set2", UniteSetHandler ); AssGVar( GVarName( "UNITE_SET" ), UniteSetFunc ); + InitHandlerFunc( IntersectSetHandler, "INTER_SET" ); IntersectSetFunc = NewFunctionC( "INTER_SET", 2L, "set1, set2", IntersectSetHandler ); AssGVar( GVarName( "INTER_SET" ), IntersectSetFunc ); + InitHandlerFunc( SubtractSetHandler, "SUBTR_SET" ); SubtractSetFunc = NewFunctionC( "SUBTR_SET", 2L, "set1, set2", SubtractSetHandler ); AssGVar( GVarName( "SUBTR_SET" ), SubtractSetFunc ); /* create the temporary union bag */ - InitGlobalBag( &TmpUnion ); + InitGlobalBag( &TmpUnion, "set: temporary union" ); TmpUnion = NEW_PLIST( T_PLIST_HOM_SSORT, 1024 ); SET_LEN_PLIST( TmpUnion, 1024 ); } diff --git a/src/stats.c b/src/stats.c index 7f337e760c..a670ec9ef7 100644 --- a/src/stats.c +++ b/src/stats.c @@ -16,10 +16,11 @@ char * Revision_stats_c = #include "system.h" /* Ints, UInts */ -#include "scanner.h" /* Pr */ -#include "gasman.h" /* NewBag, CHANGED_BAG */ +#include "gasman.h" /* NewBag, CHANGED_BAG */ #include "objects.h" /* Obj, TYPE_OBJ, types */ +#include "scanner.h" /* Pr */ + #include "gvars.h" /* AssGVar */ #include "calls.h" /* NAMI_FUNC used by EVAL_EXPR */ @@ -1845,7 +1846,7 @@ void InitStats ( void ) /* for a lot of trouble if 'CurrStat' ever becomes the last reference. */ /* furthermore, statements are no longer bags */ /* InitGlobalBag( &CurrStat ); */ - InitGlobalBag( &ReturnObjStat ); + InitGlobalBag( &ReturnObjStat, "stats: returned object" ); /* install executors for non-statements */ for ( i = 0; i < sizeof(ExecStatFuncs)/sizeof(ExecStatFuncs[0]); i++ ) { diff --git a/src/streams.c b/src/streams.c new file mode 100644 index 0000000000..77b3839d9f --- /dev/null +++ b/src/streams.c @@ -0,0 +1,1012 @@ +/**************************************************************************** +** +*W streams.c GAP source Frank Celler +** +*H @(#)$Id$ +** +*Y Copyright (C) 1996, Lehrstuhl D fuer Mathematik, RWTH Aachen, Germany +** +** This file contains the various read-eval-print loops and related stuff. +*/ +char * Revision_streams_c = + "@(#)$Id$"; + + +#include + +#include "system.h" /* Ints, UInts */ +extern char * In; +#include "gasman.h" /* NewBag, CHANGED_BAG */ +#include "objects.h" /* Obj, TYPE_OBJ, types */ +#include "scanner.h" /* Pr */ + +#include "gvars.h" /* InitGVars */ + +#include "calls.h" /* InitCalls */ +#include "opers.h" /* InitOpers */ + +#include "ariths.h" /* InitAriths */ +#include "records.h" /* InitRecords */ +#include "lists.h" /* InitLists */ + +#include "bool.h" /* InitBool */ + +#include "integer.h" /* InitInt */ +#include "rational.h" /* InitRat */ +#include "cyclotom.h" /* InitCyc */ + +#include "finfield.h" /* InitFinfield */ +#include "permutat.h" /* InitPermutat */ + +#include "precord.h" /* InitPRecord */ + +#include "listoper.h" /* InitListOper */ +#include "listfunc.h" /* InitListFunc */ + +#include "plist.h" /* InitPlist */ +#include "set.h" /* InitSet */ +#include "vector.h" /* InitVector */ + +#include "blister.h" /* InitBlist */ +#include "range.h" /* InitRange */ +#include "string.h" /* InitString */ + +#include "objfgelm.h" /* InitFreeGroupElements */ +#include "objscoll.h" /* InitSingleCollector */ +#include "objpcgel.h" /* InitPcElements */ +#include "objcftl.h" /* Init polycyclic collector */ + +#include "sctable.h" /* InitSCTable */ +#include "costab.h" /* InitCosetTable */ + +#include "code.h" /* InitCode */ + +#include "vars.h" /* InitVars */ +#include "exprs.h" /* InitExprs */ +#include "stats.h" /* InitStats */ +#include "funcs.h" /* InitFuncs */ + +#include "dt.h" /* InitDeepThought */ +#include "dteval.h" /* InitDTEvaluation */ + +#include "intrprtr.h" /* InitInterpreter */ + +#include "compiler.h" /* InitCompiler */ + +#include "read.h" /* ReadEvalCommand, ReadEvalResult */ + +#include "compstat.h" /* statically linked modules */ + +#include "gap.h" + +#define INCLUDE_DECLARATION_PART +#include "streams.h" /* declaration part of the package */ +#undef INCLUDE_DECLARATION_PART + + +/**************************************************************************** +** + +*F * * * * * * * * * streams and files related functions * * * * * * * * * * +*/ + + +/**************************************************************************** +** + +*F READ_AS_FUNC( ) . . . . . . . . . . . . . . . . . read a file +*/ +Obj READ_AS_FUNC ( + Char * filename ) +{ + Obj func; + UInt type; + + /* try to open the file */ + if ( ! OpenInput( filename ) ) { + return Fail; + } + NrError = 0; + + /* now do the reading */ + type = ReadEvalFile(); + + /* get the function */ + if ( type == 0 ) { + func = ReadEvalResult; + } + else { + func = Fail; + } + + /* close the input file again, and return 'true' */ + if ( ! CloseInput() ) { + ErrorQuit( + "Panic: READ_AS_FUNC cannot close input, this should not happen", + 0L, 0L ); + } + NrError = 0; + + /* return the function */ + return func; +} + + +/**************************************************************************** +** +*F READ_GAP_ROOT( ) . . . read from gap root, dyn-load or static +** +** 'READ_GAP_ROOT' tries to find a file under the root directory, it will +** search all directories given in 'SyGapRootPaths', check dynamically +** loadable modules and statically linked modules. +*/ +Int READ_GAP_ROOT ( Char * filename ) +{ + Char result[256]; + Int res; + UInt type; + StructCompInitInfo* info; + Obj func; + UInt4 crc; + Char * file; + + /* try to find the file */ + file = SyFindGapRootFile(filename); + if ( file ) { + crc = SyGAPCRC(file); + } + else { + crc = 0; + } + res = SyFindOrLinkGapRootFile( filename, crc, result, 256 ); + + /* not found */ + if ( res == 0 ) { + return 0; + } + + /* dynamically linked */ + else if ( res == 1 ) { + if ( SyDebugLoading ) { + Pr( "#I READ_GAP_ROOT: loading '%s' dynamically\n", + (Int)filename, 0L ); + } + info = *(StructCompInitInfo**)result; + (info->link)(); + func = (Obj)(info->function1)(); + CALL_0ARGS(func); + return 1; + } + + /* statically linked */ + else if ( res == 2 ) { + if ( SyDebugLoading ) { + Pr( "#I READ_GAP_ROOT: loading '%s' statically\n", + (Int)filename, 0L ); + } + info = *(StructCompInitInfo**)result; + (info->link)(); + func = (Obj)(info->function1)(); + CALL_0ARGS(func); + return 1; + } + + /* ordinary gap file */ + else if ( res == 3 ) { + if ( SyDebugLoading ) { + Pr( "#I READ_GAP_ROOT: loading '%s' as GAP file\n", + (Int)filename, 0L ); + } + if ( OpenInput(result) ) { + NrError = 0; + while ( 1 ) { + type = ReadEvalCommand(); + if ( type == 1 || type == 2 ) { + Pr( "'return' must not be used in file", 0L, 0L ); + } + else if ( type == 8 || type == 16 ) { + break; + } + } + CloseInput(); + NrError = 0; + return 1; + } + else { + return 0; + } + } + + /* don't know */ + else { + ErrorQuit( "unknown result code %d from 'SyFindGapRoot'", res, 0L ); + return 0; + } +} + + +/**************************************************************************** +** + +*F FuncLogTo( ) . . . . . . . . . . . . internal function 'LogTo' +** +** 'FunLogTo' implements the internal function 'LogTo'. +** +** 'LogTo( )' \\ +** 'LogTo()' +** +** 'LogTo' instructs GAP to echo all input from the standard input files, +** '*stdin*' and '*errin*' and all output to the standard output files, +** '*stdout*' and '*errout*', to the file with the name . +** The file is created if it does not exist, otherwise it is truncated. +** +** 'LogTo' called with no argument closes the current logfile again, so that +** input from '*stdin*' and '*errin*' and output to '*stdout*' and +** '*errout*' will no longer be echoed to a file. +*/ +Obj FuncLogTo ( + Obj self, + Obj args ) +{ + Obj filename; + + /* 'LogTo()' */ + if ( LEN_LIST(args) == 0 ) { + if ( ! CloseLog() ) { + ErrorQuit("LogTo: can not close the logfile",0L,0L); + return 0; + } + } + + /* 'LogTo( )' */ + else if ( LEN_LIST(args) == 1 ) { + filename = ELM_LIST(args,1); + while ( ! IsStringConv(filename) ) { + filename = ErrorReturnObj( + "LogTo: must be a string (not a %s)", + (Int)(InfoBags[TYPE_OBJ(filename)].name), 0L, + "you can return a string for " ); + } + if ( ! OpenLog( CSTR_STRING(filename) ) ) { + ErrorReturnVoid( + "LogTo: cannot log to %s", + (Int)CSTR_STRING(filename), 0L, + "you can return" ); + return 0; + } + } + + return 0; +} + + +/**************************************************************************** +** +*F FuncPrint( , ) . . . . . . . . . . . . . . . . print +*/ +Obj FuncPrint ( + Obj self, + Obj args ) +{ + Obj arg; + UInt i; + + /* print all the arguments, take care of strings and functions */ + for ( i = 1; i <= LEN_PLIST(args); i++ ) { + arg = ELM_LIST(args,i); + if ( IsStringConv(arg) && MUTABLE_TYPE(TYPE_OBJ(arg))==T_STRING ) { + PrintString1(arg); + } + else if ( TYPE_OBJ( arg ) == T_FUNCTION ) { + PrintObjFull = 1; + PrintFunction( arg ); + PrintObjFull = 0; + } + else { + PrintObj( arg ); + } + } + + return 0; +} + + +/**************************************************************************** +** +*F FuncREAD( , ) . . . . . . . . . . . . . . . read a file +*/ +Obj FuncREAD ( + Obj self, + Obj filename ) +{ + UInt type; + + /* check the argument */ + while ( ! IsStringConv( filename ) ) { + filename = ErrorReturnObj( + "READ: must be a string (not a %s)", + (Int)(InfoBags[TYPE_OBJ(filename)].name), 0L, + "you can return a string for " ); + } + + /* try to open the file */ + if ( ! OpenInput( CSTR_STRING(filename) ) ) { + return False; + } + NrError = 0; + + /* now do the reading */ + while ( 1 ) { + type = ReadEvalCommand(); + + /* handle return-value or return-void command */ + if ( type == 1 || type == 2 ) { + Pr( + "'return' must not be used in file read-eval loop", + 0L, 0L ); + } + + /* handle quit command or */ + else if ( type == 8 || type == 16 ) { + break; + } + + } + + /* close the input file again, and return 'true' */ + if ( ! CloseInput() ) { + ErrorQuit( + "Panic: READ cannot close input, this should not happen", + 0L, 0L ); + } + NrError = 0; + return True; +} + + +/**************************************************************************** +** +*F FuncREAD_STREAM( , ) . . . . . . . . . . . read a stream +*/ +Obj FuncREAD_STREAM ( + Obj self, + Obj stream ) +{ + UInt type; + + /* try to open the file */ + if ( ! OpenInputStream(stream) ) { + return False; + } + NrError = 0; + + /* now do the reading */ + while ( 1 ) { + type = ReadEvalCommand(); + + /* handle return-value or return-void command */ + if ( type == 1 || type == 2 ) { + Pr( + "'return' must not be used in file read-eval loop", + 0L, 0L ); + } + + /* handle quit command or */ + else if ( type == 8 || type == 16 ) { + break; + } + + } + + /* close the input file again, and return 'true' */ + if ( ! CloseInput() ) { + ErrorQuit( + "Panic: READ cannot close input, this should not happen", + 0L, 0L ); + } + NrError = 0; + return True; +} + + +/**************************************************************************** +** +*F FuncREAD_TEST( , ) . . . . . . . . . . read a test file +*/ +Obj FuncREAD_TEST ( + Obj self, + Obj filename ) +{ + UInt type; + UInt time; + + /* check the argument */ + while ( ! IsStringConv( filename ) ) { + filename = ErrorReturnObj( + "ReadTest: must be a string (not a %s)", + (Int)(InfoBags[TYPE_OBJ(filename)].name), 0L, + "you can return a string for " ); + } + + /* try to open the file */ + if ( ! OpenTest( CSTR_STRING(filename) ) ) { + return False; + } + NrError = 0; + + /* get the starting time */ + time = SyTime(); + + /* now do the reading */ + while ( 1 ) { + + /* read and evaluate the command */ + type = ReadEvalCommand(); + + /* stop the stopwatch */ + AssGVar( Time, INTOBJ_INT( SyTime() - time ) ); + + /* handle ordinary command */ + if ( type == 0 && ReadEvalResult != 0 ) { + + /* print the result */ + if ( *In != ';' ) { + IsStringConv( ReadEvalResult ); + PrintObj( ReadEvalResult ); + Pr( "\n", 0L, 0L ); + } + else { + Match( S_SEMICOLON, ";", 0UL ); + } + + } + + /* handle return-value or return-void command */ + else if ( type == 1 || type == 2 ) { + Pr( + "'return' must not be used in file read-eval loop", + 0L, 0L ); + } + + /* handle quit command or */ + else if ( type == 8 || type == 16 ) { + break; + } + + } + + /* close the input file again, and return 'true' */ + if ( ! CloseTest() ) { + ErrorQuit( + "Panic: ReadTest cannot close input, this should not happen", + 0L, 0L ); + } + NrError = 0; + return True; +} + + +/**************************************************************************** +** +*F FuncREAD_TEST_STREAM( , ) . . . . . . read a test stream +*/ +Obj FuncREAD_TEST_STREAM ( + Obj self, + Obj stream ) +{ + UInt type; + UInt time; + + /* try to open the file */ + if ( ! OpenTestStream(stream) ) { + return False; + } + NrError = 0; + + /* get the starting time */ + time = SyTime(); + + /* now do the reading */ + while ( 1 ) { + + /* read and evaluate the command */ + type = ReadEvalCommand(); + + /* stop the stopwatch */ + AssGVar( Time, INTOBJ_INT( SyTime() - time ) ); + + /* handle ordinary command */ + if ( type == 0 && ReadEvalResult != 0 ) { + + /* print the result */ + if ( *In != ';' ) { + IsStringConv( ReadEvalResult ); + PrintObj( ReadEvalResult ); + Pr( "\n", 0L, 0L ); + } + else { + Match( S_SEMICOLON, ";", 0UL ); + } + + } + + /* handle return-value or return-void command */ + else if ( type == 1 || type == 2 ) { + Pr( + "'return' must not be used in file read-eval loop", + 0L, 0L ); + } + + /* handle quit command or */ + else if ( type == 8 || type == 16 ) { + break; + } + + } + + /* close the input file again, and return 'true' */ + if ( ! CloseTest() ) { + ErrorQuit( + "Panic: ReadTest cannot close input, this should not happen", + 0L, 0L ); + } + NrError = 0; + return True; +} + + +/**************************************************************************** +** +*F FuncREAD_AS_FUNC( , ) . . . . . . . . . . . read a file +*/ +Obj FuncREAD_AS_FUNC ( + Obj self, + Obj filename ) +{ + /* check the argument */ + while ( ! IsStringConv( filename ) ) { + filename = ErrorReturnObj( + "READ_AS_FUNC: must be a string (not a %s)", + (Int)(InfoBags[TYPE_OBJ(filename)].name), 0L, + "you can return a string for " ); + } + + /* read the function */ + return READ_AS_FUNC( CSTR_STRING(filename) ); +} + + +/**************************************************************************** +** +*F FuncREAD_GAP_ROOT( ) . . . . . . . . . . . . . . . read a file +*/ +Obj FuncREAD_GAP_ROOT ( + Obj self, + Obj filename ) +{ + /* check the argument */ + while ( ! IsStringConv( filename ) ) { + filename = ErrorReturnObj( + "READ: must be a string (not a %s)", + (Int)(InfoBags[TYPE_OBJ(filename)].name), 0L, + "you can return a string for " ); + } + + /* try to open the file */ + if ( READ_GAP_ROOT( CSTR_STRING(filename) ) ) { + return True; + } + else { + return False; + } +} + + +/**************************************************************************** +** + +*F * * * * * * * * * * * file access test functions * * * * * * * * * * * * * +*/ + + +/**************************************************************************** +** + +*F FuncIsExistingFile( , ) . . . . . . does file exists +*/ +Obj FuncIsExistingFile ( + Obj self, + Obj filename ) +{ + /* check the argument */ + while ( ! IsStringConv( filename ) ) { + filename = ErrorReturnObj( + " must be a string (not a %s)", + (Int)(InfoBags[TYPE_OBJ(filename)].name), 0L, + "you can return a string for " ); + } + + /* call the system dependent function */ + return SyIsExistingFile( CSTR_STRING(filename) ) ? True : False; +} + + +/**************************************************************************** +** +*F FuncIsReadableFile( , ) . . . . . . is file readable +*/ +Obj FuncIsReadableFile ( + Obj self, + Obj filename ) +{ + /* check the argument */ + while ( ! IsStringConv( filename ) ) { + filename = ErrorReturnObj( + " must be a string (not a %s)", + (Int)(InfoBags[TYPE_OBJ(filename)].name), 0L, + "you can return a string for " ); + } + + /* call the system dependent function */ + return SyIsReadableFile( CSTR_STRING(filename) ) ? True : False; +} + + +/**************************************************************************** +** +*F FuncIsWritableFile( , ) . . . . . . is file writable +*/ +Obj FuncIsWritableFile ( + Obj self, + Obj filename ) +{ + /* check the argument */ + while ( ! IsStringConv( filename ) ) { + filename = ErrorReturnObj( + " must be a string (not a %s)", + (Int)(InfoBags[TYPE_OBJ(filename)].name), 0L, + "you can return a string for " ); + } + + /* call the system dependent function */ + return SyIsWritableFile( CSTR_STRING(filename) ) ? True : False; +} + + +/**************************************************************************** +** +*F FuncIsExecutableFile( , ) . . . . is file executable +*/ +Obj FuncIsExecutableFile ( + Obj self, + Obj filename ) +{ + /* check the argument */ + while ( ! IsStringConv( filename ) ) { + filename = ErrorReturnObj( + " must be a string (not a %s)", + (Int)(InfoBags[TYPE_OBJ(filename)].name), 0L, + "you can return a string for " ); + } + + /* call the system dependent function */ + return SyIsExecutableFile( CSTR_STRING(filename) ) ? True : False; +} + + +/**************************************************************************** +** + +*F * * * * * * * * * * * * text stream functions * * * * * * * * * * * * * * +*/ + +/**************************************************************************** +** + +*F FuncCLOSE_FILE( , ) . . . . . . . . . . . . . close a stream +*/ +Obj FuncCLOSE_FILE ( + Obj self, + Obj fid ) +{ + Int ret; + + /* check the argument */ + while ( ! IS_INTOBJ(fid) ) { + fid = ErrorReturnObj( + " must be an integer (not a %s)", + (Int)(InfoBags[TYPE_OBJ(fid)].name), 0L, + "you can return an integer for " ); + } + + /* call the system dependent function */ + ret = SyFclose( INT_INTOBJ(fid) ); + return ret == -1 ? Fail : True; +} + + +/**************************************************************************** +** +*F FuncINPUT_TEXT_FILE( , ) . . . . . . . . . . open a stream +*/ +Obj FuncINPUT_TEXT_FILE ( + Obj self, + Obj filename ) +{ + Int fid; + + /* check the argument */ + while ( ! IsStringConv( filename ) ) { + filename = ErrorReturnObj( + " must be a string (not a %s)", + (Int)(InfoBags[TYPE_OBJ(filename)].name), 0L, + "you can return a string for " ); + } + + /* call the system dependent function */ + fid = SyFopen( CSTR_STRING(filename), "r" ); + return fid == -1 ? Fail : INTOBJ_INT(fid); +} + + +/**************************************************************************** +** +*F FuncIS_END_OF_FILE( , ) . . . . . . . . . . . is end of file +*/ +Obj FuncIS_END_OF_FILE ( + Obj self, + Obj fid ) +{ + Int ret; + + /* check the argument */ + while ( ! IS_INTOBJ(fid) ) { + fid = ErrorReturnObj( + " must be an integer (not a %s)", + (Int)(InfoBags[TYPE_OBJ(fid)].name), 0L, + "you can return an integer for " ); + } + + ret = SyIsEndOfFile( INT_INTOBJ(fid) ); + return ret == -1 ? Fail : ( ret == 0 ? False : True ); +} + + +/**************************************************************************** +** +*F FuncPOSITION_FILE( , ) . . . . . . . . . position of stream +*/ +Obj FuncPOSITION_FILE ( + Obj self, + Obj fid ) +{ + Int ret; + + /* check the argument */ + while ( ! IS_INTOBJ(fid) ) { + fid = ErrorReturnObj( + " must be an integer (not a %s)", + (Int)(InfoBags[TYPE_OBJ(fid)].name), 0L, + "you can return an integer for " ); + } + + ret = SyFtell( INT_INTOBJ(fid) ); + return ret == -1 ? Fail : INTOBJ_INT(ret); +} + + +/**************************************************************************** +** +*F FuncREAD_BYTE_FILE( , ) . . . . . . . . . . . . . read a byte +*/ +Obj FuncREAD_BYTE_FILE ( + Obj self, + Obj fid ) +{ + Int ret; + + /* check the argument */ + while ( ! IS_INTOBJ(fid) ) { + fid = ErrorReturnObj( + " must be an integer (not a %s)", + (Int)(InfoBags[TYPE_OBJ(fid)].name), 0L, + "you can return an integer for " ); + } + + /* call the system dependent function */ + ret = SyGetch( INT_INTOBJ(fid) ); + return ret == -1 ? Fail : INTOBJ_INT(ret); +} + + +/**************************************************************************** +** +*F FuncREAD_LINE_FILE( , ) . . . . . . . . . . . . . read a line +*/ +Obj FuncREAD_LINE_FILE ( + Obj self, + Obj fid ) +{ + Char buf[256]; + Char * cstr; + Int len; + Obj str; + + /* check the argument */ + while ( ! IS_INTOBJ(fid) ) { + fid = ErrorReturnObj( + " must be an integer (not a %s)", + (Int)(InfoBags[TYPE_OBJ(fid)].name), 0L, + "you can return an integer for " ); + } + + /* read until we see a newline or eof */ + str = NEW_STRING(0); + len = 0; + while (1) { + ResizeBag( str, 1+len ); + if ( SyFgets( buf, 256, INT_INTOBJ(fid) ) == 0 ) + break; + cstr = CSTR_STRING(str); + SyStrncat( cstr, buf, 255 ); + if ( buf[SyStrlen(buf)-1] == '\n' ) + break; + len += 255; + } + + /* fix the length of */ + len = SyStrlen( CSTR_STRING(str) ); + ResizeBag( str, len+1 ); + + /* and return */ + return len == 0 ? Fail : str; +} + + +/**************************************************************************** +** +*F FuncSEEK_POSITION_FILE( , , ) . seek position of stream +*/ +Obj FuncSEEK_POSITION_FILE ( + Obj self, + Obj fid, + Obj pos ) +{ + Int ret; + + /* check the argument */ + while ( ! IS_INTOBJ(fid) ) { + fid = ErrorReturnObj( + " must be an integer (not a %s)", + (Int)(InfoBags[TYPE_OBJ(fid)].name), 0L, + "you can return an integer for " ); + } + while ( ! IS_INTOBJ(pos) ) { + pos = ErrorReturnObj( + " must be an integer (not a %s)", + (Int)(InfoBags[TYPE_OBJ(pos)].name), 0L, + "you can return an integer for " ); + } + + ret = SyFseek( INT_INTOBJ(fid), INT_INTOBJ(pos) ); + return ret == -1 ? Fail : True; +} + + +/**************************************************************************** +** + +*F * * * * * * * * * * * * * initialize package * * * * * * * * * * * * * * * +*/ + +/**************************************************************************** +** + +*F InitStreams() . . . . . . . . . . . . . . . . . . . . . intialize streams +*/ +void InitStreams () +{ + /* import functions from the library */ + ImportGVarFromLibrary( "ReadLine", &ReadLineFunc ); + + /* streams and files related functions */ + InitHandlerFunc( FuncREAD, "READ" ); + AssGVar( GVarName( "READ" ), + NewFunctionC( "READ", 1L, "filename", + FuncREAD ) ); + + InitHandlerFunc( FuncREAD_STREAM, "READ_STREAM" ); + AssGVar( GVarName( "READ_STREAM" ), + NewFunctionC( "READ_STREAM", 1L, "stream", + FuncREAD_STREAM ) ); + + InitHandlerFunc( FuncREAD_TEST, "READ_TEST" ); + AssGVar( GVarName( "READ_TEST" ), + NewFunctionC( "READ_TEST", 1L, "filename", + FuncREAD_TEST ) ); + + InitHandlerFunc( FuncREAD_TEST_STREAM, "READ_TEST_STREAM" ); + AssGVar( GVarName( "READ_TEST_STREAM" ), + NewFunctionC( "READ_TEST_STREAM", 1L, "filename", + FuncREAD_TEST_STREAM ) ); + + InitHandlerFunc( FuncREAD_AS_FUNC, "READ_AS_FUNC" ); + AssGVar( GVarName( "READ_AS_FUNC" ), + NewFunctionC( "READ_AS_FUNC", 1L, "filename", + FuncREAD_AS_FUNC ) ); + + InitHandlerFunc( FuncREAD_GAP_ROOT, "READ_GAP_ROOT" ); + AssGVar( GVarName( "READ_GAP_ROOT" ), + NewFunctionC( "READ_GAP_ROOT", 1L, "filename", + FuncREAD_GAP_ROOT ) ); + + InitHandlerFunc( FuncLogTo, "LogTo" ); + AssGVar( GVarName( "LogTo" ), + NewFunctionC( "LogTo", -1L, "args", + FuncLogTo ) ); + + /* file access test functions */ + InitHandlerFunc( FuncIsExistingFile, "IsExistingFile" ); + AssGVar( GVarName( "IsExistingFile" ), + NewFunctionC( "IsExistingFile", 1L, "filename", + FuncIsExistingFile ) ); + + InitHandlerFunc( FuncIsReadableFile, "IsReadableFile" ); + AssGVar( GVarName( "IsReadableFile" ), + NewFunctionC( "IsReadableFile", 1L, "filename", + FuncIsReadableFile ) ); + + InitHandlerFunc( FuncIsWritableFile, "IsWritableFile" ); + AssGVar( GVarName( "IsWritableFile" ), + NewFunctionC( "IsWritableFile", 1L, "filename", + FuncIsWritableFile ) ); + + InitHandlerFunc( FuncIsExecutableFile, "IsExecutableFile" ); + AssGVar( GVarName( "IsExecutableFile" ), + NewFunctionC( "IsExecutableFile", 1L, "filename", + FuncIsExecutableFile ) ); + + + /* stream functions */ + InitHandlerFunc( FuncCLOSE_FILE, "CLOSE_FILE" ); + AssGVar( GVarName( "CLOSE_FILE" ), + NewFunctionC( "CLOSE_FILE", 1L, "fid", + FuncCLOSE_FILE ) ); + + InitHandlerFunc( FuncINPUT_TEXT_FILE, "INPUT_TEXT_FILE" ); + AssGVar( GVarName( "INPUT_TEXT_FILE" ), + NewFunctionC( "INPUT_TEXT_FILE", 1L, "filename", + FuncINPUT_TEXT_FILE ) ); + + InitHandlerFunc( FuncIS_END_OF_FILE, "IS_END_OF_FILE" ); + AssGVar( GVarName( "IS_END_OF_FILE" ), + NewFunctionC( "IS_END_OF_FILE", 1L, "fid", + FuncIS_END_OF_FILE ) ); + + InitHandlerFunc( FuncPOSITION_FILE, "POSITION_FILE" ); + AssGVar( GVarName( "POSITION_FILE" ), + NewFunctionC( "POSITION_FILE", 1L, "fid", + FuncPOSITION_FILE ) ); + + InitHandlerFunc( FuncREAD_BYTE_FILE, "READ_BYTE_FILE" ); + AssGVar( GVarName( "READ_BYTE_FILE" ), + NewFunctionC( "READ_BYTE_FILE", 1L, "fid", + FuncREAD_BYTE_FILE ) ); + + InitHandlerFunc( FuncREAD_LINE_FILE, "READ_LINE_FILE" ); + AssGVar( GVarName( "READ_LINE_FILE" ), + NewFunctionC( "READ_LINE_FILE", 1L, "fid", + FuncREAD_LINE_FILE ) ); + + InitHandlerFunc( FuncSEEK_POSITION_FILE, "SEEK_POSITION_FILE" ); + AssGVar( GVarName( "SEEK_POSITION_FILE" ), + NewFunctionC( "SEEK_POSITION_FILE", 2L, "fid, pos", + FuncSEEK_POSITION_FILE ) ); +} + + +/**************************************************************************** +** + +*E streams.c . . . . . . . . . . . . . . . . . . . . . . . . . . . ends here +*/ diff --git a/src/streams.h b/src/streams.h new file mode 100644 index 0000000000..ee25b09d7e --- /dev/null +++ b/src/streams.h @@ -0,0 +1,4 @@ +char * Revision_streams_h = + "@(#)$Id$"; + +extern Obj ReadLineFunc; diff --git a/src/string.c b/src/string.c index 20025416e5..a6e57d45f1 100644 --- a/src/string.c +++ b/src/string.c @@ -49,10 +49,11 @@ char * Revision_string_c = "@(#)$Id$"; #include "system.h" /* system dependent functions */ -#include "scanner.h" /* Pr */ -#include "gasman.h" /* NewBag, ResizeBag, CHANGED_BAG */ +#include "gasman.h" /* NewBag, ResizeBag, CHANGED_BAG */ #include "objects.h" /* Obj, TYPE_OBJ, SIZE_OBJ, ... */ +#include "scanner.h" /* Pr */ + #include "gvars.h" /* AssGVar, GVarName */ #include "calls.h" /* generic call mechanism */ @@ -174,7 +175,7 @@ Obj FuncCHAR_INT ( val = ErrorReturnObj( " must be an integer (not a %s)", (Int)(InfoBags[TYPE_OBJ(val)].name), 0L, - "you can return a string for " ); + "you can return an integer for " ); } chr = INT_INTOBJ(val); if ( 255 < chr || chr < 0 ) { @@ -189,6 +190,27 @@ Obj FuncCHAR_INT ( } +/**************************************************************************** +** +*F FuncINT_CHAR( , ) . . . . . . . . . . . . . integer by char +*/ +Obj FuncINT_CHAR ( + Obj self, + Obj val ) +{ + /* get and check the character */ + while ( ! IS_INTOBJ(val) ) { + val = ErrorReturnObj( + " must be a character (not a %s)", + (Int)(InfoBags[TYPE_OBJ(val)].name), 0L, + "you can return a character for " ); + } + + /* return the character */ + return INTOBJ_INT(*(UChar*)ADDR_OBJ(val)); +} + + /**************************************************************************** ** @@ -334,7 +356,7 @@ Obj KindString ( ** ** 'CleanString' is the function in 'CleanObjFuncs' for strings. */ -Obj CopyString ( +Obj CopyString ( Obj list, Int mut ) { @@ -1110,24 +1132,39 @@ Obj IsStringConvHandler ( /**************************************************************************** ** + *F InitString() . . . . . . . . . . . . . . . . initializes string package ** ** 'InitString' initializes the string package. +** +** CharCookie is a space for the cookies passed into InitGlobalBags with the +** character constants. This must be static, and different for each +** character, as the cookies are only copied as pointers in InitGlobalBags. +** */ -void InitString ( void ) +static Char CharCookie[256][17]; + +void InitString ( void ) { - Int i; + Int i,j; Int t1, t2; - + Char * cookie_base = "string: char "; + /* install the marking function */ - InfoBags[ T_CHAR ].name = "character"; - InitMarkFuncBags( T_CHAR , MarkNoSubBags ); + InfoBags[ T_CHAR ].name = "character"; + InitMarkFuncBags( T_CHAR , MarkNoSubBags ); /* make all the character constants once and for all */ for ( i = 0; i < 256; i++ ) { ObjsChar[i] = NewBag( T_CHAR, 1L ); *(UChar*)ADDR_OBJ(ObjsChar[i]) = (UChar)i; - InitGlobalBag( &ObjsChar[i] ); + for (j = 0; j < 13; j++) + CharCookie[i][j] = cookie_base[j]; + CharCookie[i][13] = '0' + i/100; + CharCookie[i][14] = '0' + (i % 100)/10; + CharCookie[i][15] = '0' + i % 10; + CharCookie[i][16] = '\0'; + InitGlobalBag( &ObjsChar[i], &(CharCookie[i][0]) ); } /* install the kind method */ @@ -1242,10 +1279,12 @@ void InitString ( void ) for ( t1 = FIRST_EXTERNAL_TYPE; t1 <= LAST_EXTERNAL_TYPE; t1++ ) { IsStringFuncs[ t1 ] = IsStringObject; } + InitHandlerFunc( IsStringHandler, "IS_STRING" ); IsStringFilt = NewFilterC( "IS_STRING", 1L, "obj", IsStringHandler ); AssGVar( GVarName( "IS_STRING" ), IsStringFilt ); + InitHandlerFunc( ConvStringHandler, "CONV_STRING" ); ConvStringFunc = NewFunctionC( "CONV_STRING", 1L, "string", ConvStringHandler ); AssGVar( GVarName( "CONV_STRING" ), ConvStringFunc ); @@ -1255,12 +1294,19 @@ void InitString ( void ) for ( i = 0; i < SIZE_OBJ(IsStringFilt)/sizeof(Obj); i++ ) { ADDR_OBJ(IsStringConvFilt)[i] = ADDR_OBJ(IsStringFilt)[i]; } + InitHandlerFunc( IsStringConvHandler, "IS_STRING_CONV" ); HDLR_FUNC(IsStringConvFilt,1) = IsStringConvHandler; AssGVar( GVarName( "IS_STRING_CONV" ), IsStringConvFilt ); + InitHandlerFunc( FuncCHAR_INT, "CHAR_INT" ); AssGVar( GVarName( "CHAR_INT" ), NewFunctionC( "CHAR_INT", 1L, "integer", FuncCHAR_INT ) ); + + InitHandlerFunc( FuncINT_CHAR, "INT_CHAR" ); + AssGVar( GVarName( "INT_CHAR" ), + NewFunctionC( "INT_CHAR", 1L, "character", + FuncINT_CHAR ) ); } diff --git a/src/sysfiles.c b/src/sysfiles.c new file mode 100644 index 0000000000..7b8a64567b --- /dev/null +++ b/src/sysfiles.c @@ -0,0 +1,1534 @@ +/**************************************************************************** +** +*W sysfiles.c GAP source Frank Celler +*W & Martin Schoenert +** +*H @(#)$Id$ +** +*Y Copyright (C) 1996, Lehrstuhl D fuer Mathematik, RWTH Aachen, Germany +** +** The files "system.c" and "sysfiles.c" contain all operating system +** dependent functions. File and stream operations are implemented in this +** files, all the other system dependent functions in "system.c". There are +** various labels determine which operating system is actually used, they +** are described in "system.c". +*/ +char * Revision_sysfiles_c = + "@(#)$Id$"; + + +#include "system.h" /* system dependent stuff */ + +#include "gasman.h" /* NewBag, CHANGED_BAG */ +#include "objects.h" /* Obj, TYPE_OBJ, types */ +#include "scanner.h" /* Pr */ + +#define INCLUDE_DECLARATION_PART +#include "sysfiles.h" /* declaration part of the package */ +#undef INCLUDE_DECLARATION_PART + +#include "lists.h" /* LEN_LIST, ELM_LIST, ShallowCopy */ + +#include "plist.h" /* LEN_PLIST, SET_LEN_PLIST, ... */ +#include "string.h" /* IsString */ + + +#ifndef SYS_HAS_STDIO_PROTO /* ANSI/TRAD decl. from H&S 15 */ +extern FILE * fopen ( SYS_CONST char *, SYS_CONST char * ); +extern int fclose ( FILE * ); +extern void setbuf ( FILE *, char * ); +extern char * fgets ( char *, int, FILE * ); +extern int fputs ( SYS_CONST char *, FILE * ); +#endif + + +/**************************************************************************** +** + +*F * * * * * * * * * * * * * * * * input/output * * * * * * * * * * * * * * * +*/ + + +/**************************************************************************** +** + +*F IS_SPEC( ) . . . . . . . . . . . . . . . . . . . is a separator +** +** 'IS_SPEC' is defined as follows +** +#define IS_SEP(C) (!IsAlpha(C) && !IsDigit(C) && (C)!='_') +*/ + + +/**************************************************************************** +** +*V syBuf . . . . . . . . . . . . . . buffer and other info for files, local +** +** 'syBuf' is a array used as buffers for file I/O to prevent the C I/O +** routines from allocating their buffers using 'malloc', which would +** otherwise confuse Gasman. +*/ +SYS_SY_BUF syBuf [256]; + + +/**************************************************************************** +** +*F SyFopen( , ) . . . . . . . . open the file with name +** +** The function 'SyFopen' is called to open the file with the name . +** If is "r" it is opened for reading, in this case it must exist. +** If is "w" it is opened for writing, it is created if neccessary. +** If is "a" it is opened for appending, i.e., it is not truncated. +** +** 'SyFopen' returns an integer used by the scanner to identify the file. +** 'SyFopen' returns -1 if it cannot open the file. +** +** The following standard files names and file identifiers are guaranteed: +** 'SyFopen( "*stdin*", "r")' returns 0 identifying the standard input file. +** 'SyFopen( "*stdout*","w")' returns 1 identifying the standard outpt file. +** 'SyFopen( "*errin*", "r")' returns 2 identifying the brk loop input file. +** 'SyFopen( "*errout*","w")' returns 3 identifying the error messages file. +** +** If it is necessary to adjust the filename this should be done here, the +** filename convention used in GAP is that '/' is the directory separator. +** +** Right now GAP does not read nonascii files, but if this changes sometimes +** 'SyFopen' must adjust the mode argument to open the file in binary mode. +*/ +Int SyFopen ( + Char * name, + Char * mode ) +{ + Int fid; + Char namegz [1024]; + Char cmd [1024]; + + /* handle standard files */ + if ( SyStrcmp( name, "*stdin*" ) == 0 ) { + if ( SyStrcmp( mode, "r" ) != 0 ) + return -1; + else + return 0; + } + else if ( SyStrcmp( name, "*stdout*" ) == 0 ) { + if ( SyStrcmp( mode, "w" ) != 0 ) + return -1; + else + return 1; + } + else if ( SyStrcmp( name, "*errin*" ) == 0 ) { + if ( SyStrcmp( mode, "r" ) != 0 ) + return -1; + else if ( syBuf[2].fp == (FILE*)0 ) + return -1; + else + return 2; + } + else if ( SyStrcmp( name, "*errout*" ) == 0 ) { + if ( SyStrcmp( mode, "w" ) != 0 ) + return -1; + else + return 3; + } + + /* try to find an unused file identifier */ + for ( fid = 4; fid < sizeof(syBuf)/sizeof(syBuf[0]); ++fid ) + if ( syBuf[fid].fp == (FILE*)0 ) + break; + if ( fid == sizeof(syBuf)/sizeof(syBuf[0]) ) + return (Int)-1; + + /* set up and for pipe command */ + namegz[0] = '\0'; + SyStrncat( namegz, name, sizeof(namegz)-5 ); + SyStrncat( namegz, ".gz", 4 ); + cmd[0] = '\0'; + SyStrncat( cmd, "gunzip <", 9 ); + SyStrncat( cmd, namegz, sizeof(cmd)-10 ); + + /* try to open the file */ + if ( (syBuf[fid].fp = fopen(name,mode)) ) { + syBuf[fid].pipe = 0; + } + else if ( SyStrcmp(mode,"r") == 0 + && SyIsReadableFile(namegz) + && (syBuf[fid].fp = popen(cmd,mode)) ) { + syBuf[fid].pipe = 1; + } + else { + return (Int)-1; + } + + /* allocate the buffer */ + setbuf( syBuf[fid].fp, syBuf[fid].buf ); + + /* return file identifier */ + return fid; +} + + +/**************************************************************************** +** +*F SyFclose( ) . . . . . . . . . . . . . . . . . close the file +** +** 'SyFclose' closes the file with the identifier which is obtained +** from 'SyFopen'. +*/ +Int SyFclose ( + Int fid ) +{ + /* check file identifier */ + if ( sizeof(syBuf)/sizeof(syBuf[0]) <= fid || fid < 0 ) { + fputs("gap: panic 'SyFclose' asked to close illegal fid!\n",stderr); + return -1; + } + if ( syBuf[fid].fp == (FILE*)0 ) { + fputs("gap: panic 'SyFclose' asked to close closed file!\n",stderr); + return -1; + } + + /* refuse to close the standard files */ + if ( fid == 0 || fid == 1 || fid == 2 || fid == 3 ) { + return -1; + } + + /* try to close the file */ + if ( (syBuf[fid].pipe == 0 && fclose( syBuf[fid].fp ) == EOF) + || (syBuf[fid].pipe == 1 && pclose( syBuf[fid].fp ) == -1) ) + { + fputs("gap: 'SyFclose' cannot close file, ",stderr); + fputs("maybe your file system is full?\n",stderr); + syBuf[fid].fp = (FILE*)0; + return -1; + } + + /* mark the buffer as unused */ + syBuf[fid].fp = (FILE*)0; + return 0; +} + + +/**************************************************************************** +** +*F SyIsEndOfFile( ) . . . . . . . . . . . . . . . end of file reached +*/ +Int SyIsEndOfFile ( + Int fid ) +{ + /* check file identifier */ + if ( sizeof(syBuf)/sizeof(syBuf[0]) <= fid || fid < 0 ) { + return -1; + } + if ( syBuf[fid].fp == (FILE*)0 ) { + return -1; + } + + /* *stdin* and *errin* are never at end of file */ + if ( fid < 4 ) + return 0; + + return feof(syBuf[fid].fp); +} + + +/**************************************************************************** +** +*F SyFtell( ) . . . . . . . . . . . . . . . . . . position of stream +*/ +Int SyFtell ( + Int fid ) +{ + /* check file identifier */ + if ( sizeof(syBuf)/sizeof(syBuf[0]) <= fid || fid < 0 ) { + return -1; + } + if ( syBuf[fid].fp == (FILE*)0 ) { + return -1; + } + + /* cannot seek in a pipe */ + if ( syBuf[fid].pipe ) { + return -1; + } + + /* get the position */ + return (Int) ftell(syBuf[fid].fp); +} + + +/**************************************************************************** +** +*F SyFseek( , ) . . . . . . . . . . . seek a position of stream +*/ +Int SyFseek ( + Int fid, + Int pos ) +{ + /* check file identifier */ + if ( sizeof(syBuf)/sizeof(syBuf[0]) <= fid || fid < 0 ) { + return -1; + } + if ( syBuf[fid].fp == (FILE*)0 ) { + return -1; + } + + /* cannot seek in a pipe */ + if ( syBuf[fid].pipe ) { + return -1; + } + + /* get the position */ + fseek( syBuf[fid].fp, pos, SEEK_SET ); + return 0; +} + + +/**************************************************************************** +** +*F syGetch( ) . . . . . . . . . . . . . . . . . get a char from +** +** 'SyGetch' reads a character from , which is switch to raw mode if it +** is *stdin* or *errin*. +*/ + + + +/**************************************************************************** +** +*f syGetch( ) . . . . . . . . . . . . . . . . . . . . . . . BSD/MACH +*/ +#if SYS_BSD || SYS_MACH + +Int syGetch ( + Int fid ) +{ + Char ch; + + /* read a character */ + while ( read( fileno(syBuf[fid].fp), &ch, 1 ) != 1 || ch == '\0' ) + ; + + /* if running under a window handler, handle special characters */ + if ( SyWindow && ch == '@' ) { + do { + while ( read(fileno(syBuf[fid].fp), &ch, 1) != 1 || ch == '\0' ) + ; + } while ( ch < '@' || 'z' < ch ); + if ( ch == 'y' ) { + syWinPut( fileno(syBuf[fid].echo), "@s", "" ); + ch = syGetch(fid); + } + else if ( 'A' <= ch && ch <= 'Z' ) + ch = CTR(ch); + } + + /* return the character */ + return (UChar)ch; +} + +#endif + + +/**************************************************************************** +** +*f syGetch( ) . . . . . . . . . . . . . . . . . . . . . . . . . . USG +*/ +#if SYS_USG + +Int syGetch ( + Int fid ) +{ + Char ch; + + /* read a character */ + while ( read( fileno(syBuf[fid].fp), &ch, 1 ) != 1 || ch == '\0' ) + ; + + /* if running under a window handler, handle special characters */ + if ( SyWindow && ch == '@' ) { + do { + while ( read(fileno(syBuf[fid].fp), &ch, 1) != 1 || ch == '\0' ) + ; + } while ( ch < '@' || 'z' < ch ); + if ( ch == 'y' ) { + syWinPut( fileno(syBuf[fid].echo), "@s", "" ); + ch = syGetch(fid); + } + else if ( 'A' <= ch && ch <= 'Z' ) + ch = CTR(ch); + } + + /* return the character */ + return (UChar)ch; +} + +#endif + + +/**************************************************************************** +** +*f syGetch( ) . . . . . . . . . . . . . . . . . . . . . . . . OS2 EMX +*/ +#if SYS_OS2_EMX + +#ifndef SYS_KBD_H /* keyboard scan codes */ +# include +# define SYS_KBD_H +#endif + +Int syGetch ( + Int fid ) +{ + UChar ch; + Int ch2; + +syGetchAgain: + /* read a character */ + while ( read( fileno(syBuf[fid].fp), &ch, 1 ) != 1 ) + ; + + /* if running under a window handler, handle special characters */ + if ( SyWindow && ch == '@' ) { + do { + while ( read(fileno(syBuf[fid].fp), &ch, 1) != 1 ) + ; + } while ( ch < '@' || 'z' < ch ); + if ( ch == 'y' ) { + syWinPut( fileno(syBuf[fid].echo), "@s", "" ); + ch = syGetch(fid); + } + else if ( 'A' <= ch && ch <= 'Z' ) + ch = CTR(ch); + } + + ch2 = ch; + + /* handle function keys */ + if ( ch == '\0' ) { + while ( read( fileno(syBuf[fid].fp), &ch, 1 ) != 1 ) + ; + switch ( ch ) { + case K_LEFT: ch2 = CTR('B'); break; + case K_RIGHT: ch2 = CTR('F'); break; + case K_UP: + case K_PAGEUP: ch2 = CTR('P'); break; + case K_DOWN: + case K_PAGEDOWN: ch2 = CTR('N'); break; + case K_DEL: ch2 = CTR('D'); break; + case K_HOME: ch2 = CTR('A'); break; + case K_END: ch2 = CTR('E'); break; + case K_CTRL_END: ch2 = CTR('K'); break; + case K_CTRL_LEFT: + case K_ALT_B: ch2 = ESC('B'); break; + case K_CTRL_RIGHT: + case K_ALT_F: ch2 = ESC('F'); break; + case K_ALT_D: ch2 = ESC('D'); break; + case K_ALT_DEL: + case K_ALT_BACKSPACE: ch2 = ESC(127); break; + case K_ALT_U: ch2 = ESC('U'); break; + case K_ALT_L: ch2 = ESC('L'); break; + case K_ALT_C: ch2 = ESC('C'); break; + case K_CTRL_PAGEUP: ch2 = ESC('<'); break; + case K_CTRL_PAGEDOWN: ch2 = ESC('>'); break; + default: goto syGetchAgain; + } + } + + /* return the character */ + return (UChar)ch2; +} + +#endif + + +/**************************************************************************** +** +*f syGetch( ) . . . . . . . . . . . . . . . . . . . . . . . . MS-DOS +*/ +#if SYS_MSDOS_DJGPP + +Int syGetch ( + Int fid ) +{ + Int ch; + + /* if chars have been typed ahead and read by 'SyIsIntr' read them */ + if ( syTypeahead[0] != '\0' ) { + ch = syTypeahead[0]; + strcpy( syTypeahead, syTypeahead+1 ); + } + + /* otherwise read from the keyboard */ + else { + ch = GETKEY(); + } + + /* postprocess the character */ + if ( 0x110 <= ch && ch <= 0x132 ) ch = ESC( syAltMap[ch-0x110] ); + else if ( ch == 0x147 ) ch = CTR('A'); + else if ( ch == 0x14f ) ch = CTR('E'); + else if ( ch == 0x148 ) ch = CTR('P'); + else if ( ch == 0x14b ) ch = CTR('B'); + else if ( ch == 0x14d ) ch = CTR('F'); + else if ( ch == 0x150 ) ch = CTR('N'); + else if ( ch == 0x153 ) ch = CTR('D'); + else ch &= 0xFF; + + /* return the character */ + return ch; +} + +#endif + + +/**************************************************************************** +** +*f syGetch( ) . . . . . . . . . . . . . . . . . . . . . . . . . . TOS +*/ +#if SYS_TOS_GCC2 + +Int syGetch ( + Int fid ) +{ + Int ch; + + /* if chars have been typed ahead and read by 'SyIsIntr' read them */ + if ( syTypeahead[0] != '\0' ) { + ch = syTypeahead[0]; + strcpy( syTypeahead, syTypeahead+1 ); + } + + /* otherwise read from the keyboard */ + else { + ch = GETKEY(); + } + + /* postprocess the character */ + if ( ch == 0x00480000 ) ch = CTR('P'); + else if ( ch == 0x004B0000 ) ch = CTR('B'); + else if ( ch == 0x004D0000 ) ch = CTR('F'); + else if ( ch == 0x00500000 ) ch = CTR('N'); + else if ( ch == 0x00730000 ) ch = CTR('Y'); + else if ( ch == 0x00740000 ) ch = CTR('Z'); + else ch = ch & 0xFF; + + /* return the character */ + return ch; +} + +#endif + + +/**************************************************************************** +** +*f syGetch( ) . . . . . . . . . . . . . . . . . . . . . . . . . . VMS +*/ +#if SYS_VMS + +Int syGetch ( + Int fid ) +{ + Char ch; + + /* read a character */ + smg$read_keystroke( &syVirKbd, &ch ); + + /* return the character */ + return (UChar)ch; +} + +#endif + + +/**************************************************************************** +** +*f syGetch( ) . . . . . . . . . . . . . . . . . . . . . . . . MAC MPW +*/ +#if SYS_MAC_MPW + +int syGetch ( + Int fid ) +{ + return 0; +} + +#endif + + +/**************************************************************************** +** +*f syGetch( ) . . . . . . . . . . . . . . . . . . . . . . . . MAC SYC +*/ +#if SYS_MAC_SYC + +Int syGetch2 ( + Int fid, + Int cur ) +{ + Int ch; + + /* probably only paranoid */ + if ( ! isatty( fileno(syBuf[fid].fp) ) ) + return EOF; + + /* make the current character reverse to simulate a cursor */ + syEchoch( (cur != '\0' ? cur : ' ') | 0x80, fid ); + syEchoch( '\b', fid ); + + /* get a character, ignore EOF and chars beyond 0x7F (reverse video) */ + while ( ((ch = getchar()) == EOF) || (0x7F < ch) ) + ; + + /* handle special characters */ + if ( ch == 28 ) ch = CTR('B'); + else if ( ch == 29 ) ch = CTR('F'); + else if ( ch == 30 ) ch = CTR('P'); + else if ( ch == 31 ) ch = CTR('N'); + + /* make the current character normal again */ + syEchoch( (cur != '\0' ? cur : ' '), fid ); + syEchoch( '\b', fid ); + + /* return the character */ + return ch; +} + +Int syGetch ( + Int fid ) +{ + /* return character */ + return syGetch2( fid, '\0' ); +} + +#endif + + +/**************************************************************************** +** +*F SyGetch( ) . . . . . . . . . . . . . . . . . get a char from +** +** 'SyGetch' reads a character from , which is switch to raw mode if it +** is *stdin* or *errin*. +*/ +Int SyGetch ( + Int fid ) +{ + Int ch; + + /* check file identifier */ + if ( sizeof(syBuf)/sizeof(syBuf[0]) <= fid || fid < 0 ) { + return -1; + } + if ( syBuf[fid].fp == (FILE*)0 ) { + return -1; + } + + /* if we are reading stdin or errin use raw mode */ + if ( fid == 0 || fid == 2 ) { + syStartraw(fid); + } + ch = syGetch(fid); + if ( fid == 0 || fid == 2 ) { + syStopraw(fid); + } + return ch; +} + + + +/**************************************************************************** +** +*F SyFgets( , , ) . . . . . get a line from file +** +** 'SyFgets' is called to read a line from the file with identifier . +** 'SyFgets' (like 'fgets') reads characters until either -1 chars +** have been read or until a or an character is encoutered. +** It retains the '\n' (unlike 'gets'), if any, and appends '\0' to . +** 'SyFgets' returns if any char has been read, otherwise '(char*)0'. +** +** 'SyFgets' allows to edit the input line if the file refers to a +** terminal with the following commands: +** +** -A move the cursor to the beginning of the line. +** -B move the cursor to the beginning of the previous word. +** -B move the cursor backward one character. +** -F move the cursor forward one character. +** -F move the cursor to the end of the next word. +** -E move the cursor to the end of the line. +** +** -H, delete the character left of the cursor. +** -D delete the character under the cursor. +** -K delete up to the end of the line. +** -D delete forward to the end of the next word. +** - delete backward to the beginning of the last word. +** -X delete entire input line, and discard all pending input. +** -Y insert (yank) a just killed text. +** +** -T exchange (twiddle) current and previous character. +** -U uppercase next word. +** -L lowercase next word. +** -C capitalize next word. +** +** complete the identifier before the cursor. +** -L insert last input line before current character. +** -P redisplay the last input line, another -P will redisplay +** the line before that, etc. If the cursor is not in the first +** column only the lines starting with the string to the left of +** the cursor are taken. The history is limitied to ~8000 chars. +** -N Like -P but goes the other way round through the history +** -< goes to the beginning of the history. +** -> goes to the end of the history. +** -O accept this line and perform a -N. +** +** -V enter next character literally. +** -U execute the next command 4 times. +** - execute the next command times. +** --L repaint input line. +** +** Not yet implemented commands: +** +** -S search interactive for a string forward. +** -R search interactive for a string backward. +** -Y replace yanked string with previously killed text. +** -_ undo a command. +** -T exchange two words. +*/ +UInt syNrchar; /* nr of chars already on the line */ +Char syPrompt [256]; /* characters alread on the line */ + +Char syHistory [8192]; /* history of command lines */ +Char * syHi = syHistory; /* actual position in history */ +UInt syCTRO; /* number of '-O' pending */ + + +Char * SyFgets ( + Char * line, + UInt length, + Int fid ) +{ + Int ch, ch2, ch3, last; + Char * p, * q, * r, * s, * t; + Char * h; + static Char yank [512]; + Char old [512], new [512]; + Int oldc, newc; + Int rep; + Char buffer [512]; + Int rn; + + /* check file identifier */ + if ( sizeof(syBuf)/sizeof(syBuf[0]) <= fid || fid < 0 ) { + return (Char*)0; + } + if ( syBuf[fid].fp == (FILE*)0 ) { + return (Char*)0; + } + + /* no line editing if the file is not '*stdin*' or '*errin*' */ + if ( fid != 0 && fid != 2 ) { + p = fgets( line, (int)length, syBuf[fid].fp ); + return p; + } + + /* no line editing if the user disabled it */ + if ( SyLineEdit == 0 ) { + SyStopTime = SyTime(); + p = fgets( line, (int)length, syBuf[fid].fp ); + SyStartTime += SyTime() - SyStopTime; + return p; + } + + /* no line editing if the file cannot be turned to raw mode */ + if ( SyLineEdit == 1 && ! syStartraw(fid) ) { + SyStopTime = SyTime(); + p = fgets( line, (int)length, syBuf[fid].fp ); + SyStartTime += SyTime() - SyStopTime; + return p; + } + + /* stop the clock, reading should take no time */ + SyStopTime = SyTime(); + + /* the line starts out blank */ + line[0] = '\0'; p = line; h = syHistory; + for ( q = old; q < old+sizeof(old); ++q ) *q = ' '; + oldc = 0; + last = 0; + + while ( 1 ) { + + /* get a character, handle V, and U */ + rep = 1; ch2 = 0; + do { + if ( syCTRO % 2 == 1 ) { ch = CTR('N'); syCTRO = syCTRO - 1; } + else if ( syCTRO != 0 ) { ch = CTR('O'); rep = syCTRO / 2; } +#if ! SYS_MAC_SYC + else ch = syGetch(fid); +#endif +#if SYS_MAC_SYC + else ch = syGetch2(fid,*p); +#endif + if ( ch2==0 && ch==CTR('V') ) { ch2=ch; ch=0;} + if ( ch2==0 && ch==CTR('[') ) { ch2=ch; ch=0;} + if ( ch2==0 && ch==CTR('U') ) { ch2=ch; ch=0;} + if ( ch2==CTR('[') && ch==CTR('V') ) { ch2=ESC(CTR('V')); ch=0;} + if ( ch2==CTR('[') && isdigit(ch) ) { rep=ch-'0'; ch2=ch; ch=0;} + if ( ch2==CTR('[') && ch=='[' ) { ch2=ch; ch=0;} + if ( ch2==CTR('U') && ch==CTR('V') ) { rep=4*rep; ch2=ch; ch=0;} + if ( ch2==CTR('U') && ch==CTR('[') ) { rep=4*rep; ch2=ch; ch=0;} + if ( ch2==CTR('U') && ch==CTR('U') ) { rep=4*rep; ch2=ch; ch=0;} + if ( ch2==CTR('U') && isdigit(ch) ) { rep=ch-'0'; ch2=ch; ch=0;} + if ( isdigit(ch2) && ch==CTR('V') ) { ch2=ch; ch=0;} + if ( isdigit(ch2) && ch==CTR('[') ) { ch2=ch; ch=0;} + if ( isdigit(ch2) && ch==CTR('U') ) { ch2=ch; ch=0;} + if ( isdigit(ch2) && isdigit(ch) ) { rep=10*rep+ch-'0'; ch=0;} + } while ( ch == 0 ); + if ( ch2==CTR('V') ) ch = CTV(ch); + if ( ch2==ESC(CTR('V')) ) ch = CTV(ch | 0x80); + if ( ch2==CTR('[') ) ch = ESC(ch); + if ( ch2==CTR('U') ) rep = 4*rep; + if ( ch2=='[' && ch=='A') ch = CTR('P'); + if ( ch2=='[' && ch=='B') ch = CTR('N'); + if ( ch2=='[' && ch=='C') ch = CTR('F'); + if ( ch2=='[' && ch=='D') ch = CTR('B'); + + /* now perform the requested action times in the input line */ + while ( rep-- > 0 ) { + switch ( ch ) { + + case CTR('A'): /* move cursor to the start of the line */ + while ( p > line ) --p; + break; + + case ESC('B'): /* move cursor one word to the left */ + case ESC('b'): + if ( p > line ) do { + --p; + } while ( p>line && (!IS_SEP(*(p-1)) || IS_SEP(*p))); + break; + + case CTR('B'): /* move cursor one character to the left */ + if ( p > line ) --p; + break; + + case CTR('F'): /* move cursor one character to the right */ + if ( *p != '\0' ) ++p; + break; + + case ESC('F'): /* move cursor one word to the right */ + case ESC('f'): + if ( *p != '\0' ) do { + ++p; + } while ( *p!='\0' && (IS_SEP(*(p-1)) || !IS_SEP(*p))); + break; + + case CTR('E'): /* move cursor to the end of the line */ + while ( *p != '\0' ) ++p; + break; + + case CTR('H'): /* delete the character left of the cursor */ + case 127: + if ( p == line ) break; + --p; + /* let '-D' do the work */ + + case CTR('D'): /* delete the character at the cursor */ + /* on an empty line '-D' is */ + if ( p == line && *p == '\0' && SyCTRD ) { + ch = EOF; rep = 0; break; + } + if ( *p != '\0' ) { + for ( q = p; *(q+1) != '\0'; ++q ) + *q = *(q+1); + *q = '\0'; + } + break; + + case CTR('X'): /* delete the line */ + p = line; + /* let '-K' do the work */ + + case CTR('K'): /* delete to end of line */ + if ( last!=CTR('X') && last!=CTR('K') && last!=ESC(127) + && last!=ESC('D') && last!=ESC('d') ) yank[0] = '\0'; + for ( r = yank; *r != '\0'; ++r ) ; + for ( s = p; *s != '\0'; ++s ) r[s-p] = *s; + r[s-p] = '\0'; + *p = '\0'; + break; + + case ESC(127): /* delete the word left of the cursor */ + q = p; + if ( p > line ) do { + --p; + } while ( p>line && (!IS_SEP(*(p-1)) || IS_SEP(*p))); + if ( last!=CTR('X') && last!=CTR('K') && last!=ESC(127) + && last!=ESC('D') && last!=ESC('d') ) yank[0] = '\0'; + for ( r = yank; *r != '\0'; ++r ) ; + for ( ; yank <= r; --r ) r[q-p] = *r; + for ( s = p; s < q; ++s ) yank[s-p] = *s; + for ( r = p; *q != '\0'; ++q, ++r ) + *r = *q; + *r = '\0'; + break; + + case ESC('D'): /* delete the word right of the cursor */ + case ESC('d'): + q = p; + if ( *q != '\0' ) do { + ++q; + } while ( *q!='\0' && (IS_SEP(*(q-1)) || !IS_SEP(*q))); + if ( last!=CTR('X') && last!=CTR('K') && last!=ESC(127) + && last!=ESC('D') && last!=ESC('d') ) yank[0] = '\0'; + for ( r = yank; *r != '\0'; ++r ) ; + for ( s = p; s < q; ++s ) r[s-p] = *s; + r[s-p] = '\0'; + for ( r = p; *q != '\0'; ++q, ++r ) + *r = *q; + *r = '\0'; + break; + + case CTR('T'): /* twiddle characters */ + if ( p == line ) break; + if ( *p == '\0' ) --p; + if ( p == line ) break; + ch2 = *(p-1); *(p-1) = *p; *p = ch2; + ++p; + break; + + case CTR('L'): /* insert last input line */ + for ( r = syHistory; *r != '\0' && *r != '\n'; ++r ) { + ch2 = *r; + for ( q = p; ch2; ++q ) { + ch3 = *q; *q = ch2; ch2 = ch3; + } + *q = '\0'; ++p; + } + break; + + case CTR('Y'): /* insert (yank) deleted text */ + for ( r = yank; *r != '\0' && *r != '\n'; ++r ) { + ch2 = *r; + for ( q = p; ch2; ++q ) { + ch3 = *q; *q = ch2; ch2 = ch3; + } + *q = '\0'; ++p; + } + break; + + case CTR('P'): /* fetch old input line */ + while ( *h != '\0' ) { + for ( q = line; q < p; ++q ) + if ( *q != h[q-line] ) break; + if ( q == p ) break; + while ( *h != '\n' && *h != '\0' ) ++h; + if ( *h == '\n' ) ++h; + } + q = p; + while ( *h!='\0' && h[q-line]!='\n' && h[q-line]!='\0' ) { + *q = h[q-line]; ++q; + } + *q = '\0'; + while ( *h != '\0' && *h != '\n' ) ++h; + if ( *h == '\n' ) ++h; else h = syHistory; + syHi = h; + break; + + case CTR('N'): /* fetch next input line */ + h = syHi; + if ( h > syHistory ) { + do {--h;} while (h>syHistory && *(h-1)!='\n'); + if ( h==syHistory ) while ( *h != '\0' ) ++h; + } + while ( *h != '\0' ) { + if ( h==syHistory ) while ( *h != '\0' ) ++h; + do {--h;} while (h>syHistory && *(h-1)!='\n'); + for ( q = line; q < p; ++q ) + if ( *q != h[q-line] ) break; + if ( q == p ) break; + if ( h==syHistory ) while ( *h != '\0' ) ++h; + } + q = p; + while ( *h!='\0' && h[q-line]!='\n' && h[q-line]!='\0' ) { + *q = h[q-line]; ++q; + } + *q = '\0'; + while ( *h != '\0' && *h != '\n' ) ++h; + if ( *h == '\n' ) ++h; else h = syHistory; + syHi = h; + break; + + case ESC('<'): /* goto beginning of the history */ + while ( *h != '\0' ) ++h; + do {--h;} while (h>syHistory && *(h-1)!='\n'); + q = p = line; + while ( *h!='\0' && h[q-line]!='\n' && h[q-line]!='\0' ) { + *q = h[q-line]; ++q; + } + *q = '\0'; + while ( *h != '\0' && *h != '\n' ) ++h; + if ( *h == '\n' ) ++h; else h = syHistory; + syHi = h; + break; + + case ESC('>'): /* goto end of the history */ + h = syHistory; + p = line; + *p = '\0'; + syHi = h; + break; + + case CTR('S'): /* search for a line forward */ + /* search for a line forward, not fully implemented !!! */ + if ( *p != '\0' ) { + ch2 = syGetch(fid); + q = p+1; + while ( *q != '\0' && *q != ch2 ) ++q; + if ( *q == ch2 ) p = q; + } + break; + + case CTR('R'): /* search for a line backward */ + /* search for a line backward, not fully implemented !!! */ + if ( p > line ) { + ch2 = syGetch(fid); + q = p-1; + while ( q > line && *q != ch2 ) --q; + if ( *q == ch2 ) p = q; + } + break; + + case ESC('U'): /* uppercase word */ + case ESC('u'): + if ( *p != '\0' ) do { + if ('a' <= *p && *p <= 'z') *p = *p + 'A' - 'a'; + ++p; + } while ( *p!='\0' && (IS_SEP(*(p-1)) || !IS_SEP(*p))); + break; + + case ESC('C'): /* capitalize word */ + case ESC('c'): + while ( *p!='\0' && IS_SEP(*p) ) ++p; + if ( 'a' <= *p && *p <= 'z' ) *p = *p + 'A'-'a'; + if ( *p != '\0' ) ++p; + /* lowercase rest of the word */ + + case ESC('L'): /* lowercase word */ + case ESC('l'): + if ( *p != '\0' ) do { + if ('A' <= *p && *p <= 'Z') *p = *p + 'a' - 'A'; + ++p; + } while ( *p!='\0' && (IS_SEP(*(p-1)) || !IS_SEP(*p))); + break; + + case ESC(CTR('L')): /* repaint input line */ + syEchoch('\n',fid); + for ( q = syPrompt; q < syPrompt+syNrchar; ++q ) + syEchoch( *q, fid ); + for ( q = old; q < old+sizeof(old); ++q ) *q = ' '; + oldc = 0; + break; + + case EOF: /* end of file on input */ + break; + + case CTR('M'): /* append \n and exit */ + case CTR('J'): + while ( *p != '\0' ) ++p; + *p++ = '\n'; *p = '\0'; + rep = 0; + break; + + case CTR('O'): /* accept line, perform '-N' next time */ + while ( *p != '\0' ) ++p; + *p++ = '\n'; *p = '\0'; + syCTRO = 2 * rep + 1; + rep = 0; + break; + + case CTR('I'): /* try to complete the identifier before dot */ + if ( p == line || IS_SEP(p[-1]) ) { + ch2 = ch & 0xff; + for ( q = p; ch2; ++q ) { + ch3 = *q; *q = ch2; ch2 = ch3; + } + *q = '\0'; ++p; + } + else { + if ( (q = p) > line ) do { + --q; + } while ( q>line && (!IS_SEP(*(q-1)) || IS_SEP(*q))); + rn = (line < q && *(q-1) == '.'); + r = buffer; s = q; + while ( s < p ) *r++ = *s++; + *r = '\0'; + if ( (rn ? iscomplete_rnam( buffer, p-q ) + : iscomplete_gvar( buffer, p-q )) ) { + if ( last != CTR('I') ) + syEchoch( CTR('G'), fid ); + else { + syWinPut( fid, "@c", "" ); + syEchos( "\n ", fid ); + syEchos( buffer, fid ); + while ( (rn ? completion_rnam( buffer, p-q ) + : completion_gvar( buffer, p-q )) ) { + syEchos( "\n ", fid ); + syEchos( buffer, fid ); + } + syEchos( "\n", fid ); + for ( q=syPrompt; q= new+SyNrCols-syNrchar-2 ) { + if ( q >= p ) { q++; break; } + new[0] = '$'; new[1] = r[-5]; new[2] = r[-4]; + new[3] = r[-3]; new[4] = r[-2]; new[5] = r[-1]; + r = new+6; + } + } + if ( q == p ) newc = r-new; + for ( ; r < new+sizeof(new); ++r ) *r = ' '; + if ( q[0] != '\0' && q[1] != '\0' ) + new[SyNrCols-syNrchar-2] = '$'; + else if ( q[1] == '\0' && ' ' <= *q && *q < 0x7F ) + new[SyNrCols-syNrchar-2] = *q; + else if ( q[1] == '\0' && q[0] != '\0' ) + new[SyNrCols-syNrchar-2] = '$'; + for ( q = old, r = new; r < new+sizeof(new); ++r, ++q ) { + if ( *q == *r ) continue; + while (oldc<(q-old)) { syEchoch(old[oldc],fid); ++oldc; } + while (oldc>(q-old)) { syEchoch('\b',fid); --oldc; } + *q = *r; syEchoch( *q, fid ); ++oldc; + } + while ( oldc < newc ) { syEchoch(old[oldc],fid); ++oldc; } + while ( oldc > newc ) { syEchoch('\b',fid); --oldc; } + + } + + /* Now we put the new string into the history, first all old strings */ + /* are moved backwards, then we enter the new string in syHistory[]. */ + for ( q = syHistory+sizeof(syHistory)-3; q >= syHistory+(p-line); --q ) + *q = *(q-(p-line)); + for ( p = line, q = syHistory; *p != '\0'; ++p, ++q ) + *q = *p; + syHistory[sizeof(syHistory)-3] = '\n'; + if ( syHi != syHistory ) + syHi = syHi + (p-line); + if ( syHi > syHistory+sizeof(syHistory)-2 ) + syHi = syHistory+sizeof(syHistory)-2; + + /* send the whole line (unclipped) to the window handler */ + syWinPut( fid, (*line != '\0' ? "@r" : "@x"), line ); + + /* strip away prompts (usefull for pasting old stuff) */ + if (line[0]=='g'&&line[1]=='a'&&line[2]=='p'&&line[3]=='>'&&line[4]==' ') + for ( p = line, q = line+5; q[-1] != '\0'; p++, q++ ) *p = *q; + if (line[0]=='b'&&line[1]=='r'&&line[2]=='k'&&line[3]=='>'&&line[4]==' ') + for ( p = line, q = line+5; q[-1] != '\0'; p++, q++ ) *p = *q; + if (line[0]=='>'&&line[1]==' ') + for ( p = line, q = line+2; q[-1] != '\0'; p++, q++ ) *p = *q; + + /* switch back to cooked mode */ + if ( SyLineEdit == 1 ) + syStopraw(fid); + + /* start the clock again */ + SyStartTime += SyTime() - SyStopTime; + + /* return the line (or '0' at end-of-file) */ + if ( *line == '\0' ) + return (Char*)0; + return line; +} + + +/**************************************************************************** +** + +*F * * * * * * * * * * * * * file and execution * * * * * * * * * * * * * * * +*/ + + +/**************************************************************************** +** + +*F SyIsExistingFile( ) . . . . . . . . . . . does file exists +** +** 'SyIsExistingFile' returns 1 if the file exists and 0 otherwise. +** It does not check if the file is readable, writable or excuteable. +** is a system dependent description of the file. +*/ + + +/**************************************************************************** +** +*f SyIsExistingFile( ) . . . . . . . . . . . . . . . . BSD/Mach/USG +*/ +#if SYS_BSD || SYS_MACH || SYS_USG + +Int SyIsExistingFile ( Char * name ) +{ + if ( access( name, F_OK ) == 0 ) { + return 1; + } + else { + return 0; + } +} + +#endif + + +/**************************************************************************** +** +*F SyIsReadableFile( ) . . . . . . . . . . . is file readable +** +** 'SyIsReadableFile' returns 1 if the file is readable and 0 +** otherwise. is a system dependent description of the file. +*/ + + +/**************************************************************************** +** +*f SyIsReadableFile( ) . . . . . . . . . . . . . . . . BSD/Mach/USG +*/ +#if SYS_BSD || SYS_MACH || SYS_USG + +Int SyIsReadableFile ( Char * name ) +{ + if ( access( name, R_OK ) == 0 ) { + return 1; + } + else { + return 0; + } +} + +#endif + + +/**************************************************************************** +** +*F SyIsWritable( ) . . . . . . . . . . . is the file writable +** +** 'SyIsWriteableFile' returns 1 if the file is writable and 0 +** otherwise. is a system dependent description of the file. +*/ + + +/**************************************************************************** +** +*f SyIsWritable( ) . . . . . . . . . . . . . . . . . . BSD/Mach/USG +*/ +#if SYS_BSD || SYS_MACH || SYS_USG + +Int SyIsWritableFile ( Char * name ) +{ + if ( access( name, W_OK ) == 0 ) { + return 1; + } + else { + return 0; + } +} + +#endif + + +/**************************************************************************** +** +*F SyIsExecutableFile( ) . . . . . . . . . is file executable +** +** 'SyIsExecutableFile' returns 1 if the file is executable and 0 +** otherwise. is a system dependent description of the file. +*/ + + +/**************************************************************************** +** +*f SyIsExecutableFile( ) . . . . . . . . . . . . . . . BSD/Mach/USG +*/ +#if SYS_BSD || SYS_MACH || SYS_USG + +Int SyIsExecutableFile ( Char * name ) +{ + if ( access( name, X_OK ) == 0 ) { + return 1; + } + else { + return 0; + } +} + +#endif + + +/**************************************************************************** +** +*F SyFindGapRootFile( ) . . . . . . . . find file in system area +*/ +Char * SyFindGapRootFile ( Char * filename ) +{ + static Char result [256]; + Int k; + + for ( k=0; k ) . . . . . . . . . . . execute command in operating system +** +** 'SyExec' executes the command (a string) in the operating system. +** +** 'SyExec' should call a command interpreter to execute the command, so +** that file name expansion and other common actions take place. If the OS +** does not support this 'SyExec' should print a message and return. +** +** For UNIX we can use 'system', which does exactly what we want. +*/ +#ifndef SYS_STDLIB_H /* ANSI standard functions */ +# if SYS_ANSI +# include +# endif +# define SYS_STDLIB_H +#endif +#ifndef SYS_HAS_MISC_PROTO /* ANSI/TRAD decl. from H&S 19.2 */ +extern int system ( SYS_CONST char * ); +#endif + +#if ! (SYS_MAC_MPW || SYS_MAC_SYC) + +void SyExec ( + Char * cmd ) +{ + Int ignore; + + syWinPut( 0, "@z", "" ); + ignore = system( cmd ); + syWinPut( 0, "@mAgIc", "" ); +} + +#endif + +#if SYS_MAC_MPW || SYS_MAC_SYC + +void SyExec ( + Char * cmd; +{ +} + +#endif + + +/**************************************************************************** +** +*F SyTmpname() . . . . . . . . . . . . . . . . . return a temporary filename +** +** 'SyTmpname' creates and returns a new temporary name. +*/ +#ifndef SYS_STDIO_H /* standard input/output functions */ +# include +# define SYS_STDIO_H +#endif + +#ifndef SYS_HAS_MISC_PROTO /* ANSI/TRAD decl. from H&S 15.16 */ +extern char * tmpnam ( char * ); +#endif + +#ifdef SYS_HAS_BROKEN_TMPNAM + +Char * SyTmpname () +{ + static Char * base = 0; + static Char name[1024]; + static Int count = 0; + Char cnt[4]; + + count++; + if ( base == 0 ) { + base = tmpnam( (char*)0 ); + } + if ( base == 0 ) { + return 0; + } + name[0] = 0; + SyStrncat( name, base, SyStrlen(base) ); + SyStrncat( name, ".", 1 ); + cnt[0] = (count/100) % 10 + '0'; + cnt[1] = (count/ 10) % 10 + '0'; + cnt[2] = (count/ 1) % 10 + '0'; + cnt[3] = 0; + SyStrncat( name, cnt, 4 ); + return name; +} + +#else + +Char * SyTmpname ( void ) +{ + return tmpnam( (char*)0 ); +} + +#endif + + +/**************************************************************************** +** + +*F * * * * * * * * * * * * * initialize package * * * * * * * * * * * * * * * +*/ + +/**************************************************************************** +** + +*F InitSysFiles() . . . . . . . . . . . . . . . . . initialize the packages +*/ +void InitSysFiles( void ) +{ + Obj list; + Obj tmp; + UInt gvar; + Int len; + Int i; + Int j; + + /* GAP_ARCHITECTURE */ + tmp = NEW_STRING(SyStrlen(SyArchitecture)); + SyStrncat( CSTR_STRING(tmp), SyArchitecture, SyStrlen(SyArchitecture) ); + gvar = GVarName("GAP_ARCHITECTURE"); + AssGVar( gvar, tmp ); + MakeReadOnlyGVar(gvar); + + + /* GAP_ROOT_PATH */ + list = NEW_PLIST( T_PLIST, MAX_GAP_DIRS ); + for ( i = 0, j = 1; i < MAX_GAP_DIRS; i++ ) { + if ( SyGapRootPaths[i][0] ) { + len = SyStrlen(SyGapRootPaths[i]); + tmp = NEW_STRING(len); + SyStrncat( CSTR_STRING(tmp), SyGapRootPaths[i], len ); + SET_ELM_PLIST( list, j, tmp ); + j++; + } + } + SET_LEN_PLIST( list, j-1 ); + gvar = GVarName("GAP_ROOT_PATHS"); + AssGVar( gvar, list ); + MakeReadOnlyGVar(gvar); +} + + +/**************************************************************************** +** + +*E sysfiles.h . . . . . . . . . . . . . . . . . . . . . . . . . . ends here +*/ diff --git a/src/sysfiles.h b/src/sysfiles.h new file mode 100644 index 0000000000..840d103445 --- /dev/null +++ b/src/sysfiles.h @@ -0,0 +1,42 @@ +/**************************************************************************** +** +*W sysfiles.c GAP source Frank Celler +*W & Martin Schoenert +** +*H @(#)$Id$ +** +*Y Copyright (C) 1996, Lehrstuhl D fuer Mathematik, RWTH Aachen, Germany +** +** The file 'system.c' declares all operating system dependent functions +** except file/stream handling which is done in "sysfiles.h". +*/ +#ifdef INCLUDE_DECLARATION_PART +char * Revision_sysfiles_h = + "@(#)$Id$"; +#endif + + + +extern void syWinPut ( + Int fid, + Char * cmd, + Char * str ); + + +extern Char syPrompt [256]; /* characters alread on the line */ +extern UInt syNrchar; /* nr of chars already on the line */ + + +/**************************************************************************** +** + +*F IS_SPEC( ) . . . . . . . . . . . . . . . . . . . is a separator +*/ +#define IS_SEP(C) (!IsAlpha(C) && !IsDigit(C) && (C)!='_') + + +/**************************************************************************** +** + +*E sysfiles.h . . . . . . . . . . . . . . . . . . . . . . . . . . ends here +*/ diff --git a/src/system.c b/src/system.c index 415bedb2c3..2f17dcf0d8 100644 --- a/src/system.c +++ b/src/system.c @@ -12,7 +12,9 @@ ** *Y Copyright (C) 1996, Lehrstuhl D fuer Mathematik, RWTH Aachen, Germany ** -** The file 'system.c' contains all operating system dependent functions. +** The files "system.c" and "sysfiles.c" contains all operating system +** dependent functions. This file contains all system dependent functions +** except file and stream operations, which are implemented in "sysfiles.c". ** The following labels determine which operating system is actually used. ** ** SYS_IS_BSD @@ -137,40 +139,8 @@ char * Revision_system_c = #include "system.h" /* declaration part of the package */ #undef INCLUDE_DECLARATION_PART -#ifdef SYS_HAS_ANSI -# define SYS_ANSI SYS_HAS_ANSI -#else -# ifdef __STDC__ -# define SYS_ANSI 1 -# else -# define SYS_ANSI 0 -# endif -#endif +#include "sysfiles.h" /* file input/output */ -#ifdef SYS_HAS_CONST -# define SYS_CONST SYS_HAS_CONST -#else -# ifdef __STDC__ -# define SYS_CONST const -# else -# define SYS_CONST -# endif -#endif - -#ifdef __MWERKS__ -# define SYS_IS_MAC_MPW 1 -# define SYS_HAS_CALLOC_PROTO 1 -#endif - -#ifndef SYS_STDIO_H /* standard input/output functions */ -# include -# define SYS_STDIO_H -#endif - -#ifndef SYS_UNISTD_H /* definition of 'R_OK' */ -# include -# define SYS_UNISTD_H -#endif #ifndef SYS_HAS_STDIO_PROTO /* ANSI/TRAD decl. from H&S 15 */ extern FILE * fopen ( SYS_CONST char *, SYS_CONST char * ); @@ -180,6 +150,12 @@ extern char * fgets ( char *, int, FILE * ); extern int fputs ( SYS_CONST char *, FILE * ); #endif +#ifdef __MWERKS__ +# define SYS_IS_MAC_MPW 1 +# define SYS_HAS_CALLOC_PROTO 1 +#endif + + /**************************************************************************** ** @@ -241,65 +217,38 @@ Char SyFlags [] = { #ifdef SYS_IS_BSD 'b', 's', 'd', -# define SYS_BSD 1 -#else -# define SYS_BSD 0 #endif #ifdef SYS_IS_MACH 'm', 'a', 'c', 'h', -# define SYS_MACH 1 -#else -# define SYS_MACH 0 #endif #ifdef SYS_IS_USG 'u', 's', 'g', -# define SYS_USG 1 -#else -# define SYS_USG 0 #endif #ifdef SYS_IS_OS2_EMX 'o', 's', '2', ' ', 'e', 'm', 'x', -# define SYS_OS2_EMX 1 -#else -# define SYS_OS2_EMX 0 #endif #ifdef SYS_IS_MSDOS_DJGPP 'm', 's', 'd', 'o', 's', ' ', 'd', 'j', 'g', 'p', 'p', -# define SYS_MSDOS_DJGPP 1 -#else -# define SYS_MSDOS_DJGPP 0 #endif #ifdef SYS_IS_TOS_GCC2 't', 'o', 's', ' ', 'g', 'c', 'c', '2', -# define SYS_TOS_GCC2 1 -#else -# define SYS_TOS_GCC2 0 #endif #ifdef SYS_IS_VMS 'v', 'm', 's', -# define SYS_VMS 1 -#else -# define SYS_VMS 0 #endif #ifdef SYS_IS_MAC_MPW 'm', 'a', 'c', ' ', 'm', 'p', 'w', -# define SYS_MAC_MPW 1 -#else -# define SYS_MAC_MPW 0 #endif #ifdef SYS_IS_MAC_SYC 'm', 'a', 'c', ' ', 's', 'y', 'c', -# define SYS_MAC_SYC 1 -#else -# define SYS_MAC_SYC 0 #endif #if __GNUC__ @@ -325,23 +274,27 @@ Char SyFlags [] = { /**************************************************************************** ** -*V syStackSpace . . . . . . . . . . . . . . . . . . . amount of stack space +*F SyStackAlign . . . . . . . . . . . . . . . . . . alignment of the stack ** -** 'syStackSpace' is the amount of stackspace that GAP gets. +** 'SyStackAlign' is the alignment of items on the stack. It must be a +** divisor of 'sizof(Bag)'. The addresses of all identifiers on the stack +** must be divisable by 'SyStackAlign'. So if it is 1, identifiers may be +** anywhere on the stack, and if it is 'sizeof(Bag)', identifiers may only +** be at addresses divisible by 'sizeof(Bag)'. This value is initialized +** from a macro passed from the makefile, because it is machine dependent. ** -** Under TOS and on the Mac special actions must be taken to ensure that -** enough space is available. +** This value is passed to 'InitBags'. */ -#if SYS_TOS_GCC2 -# define __NO_INLINE__ -int _stksize = 64 * 1024; /* GNU C, amount of stack space */ -static UInt syStackSpace = 64 * 1024; +#ifdef SYS_HAS_STACK_ALIGN +#define SYS_STACK_ALIGN SYS_HAS_STACK_ALIGN #endif -#if SYS_MAC_MPW || SYS_MAC_SYC -static UInt syStackSpace = 64 * 1024; +#ifndef SYS_HAS_STACK_ALIGN +#define SYS_STACK_ALIGN sizeof(UInt *) #endif +UInt SyStackAlign = SYS_STACK_ALIGN; + /**************************************************************************** ** @@ -354,6 +307,94 @@ Char * SyArchitecture = SYS_ARCH; #endif +/**************************************************************************** +** +*V SyBanner . . . . . . . . . . . . . . . . . . . . . . . . surpress banner +** +** 'SyBanner' determines whether GAP should print the banner. +** +** Per default it is true, i.e., GAP prints the nice banner. It can be +** changed by the '-b' option to have GAP surpress the banner. +** +** It is copied into the GAP variable 'BANNER', which is used in 'init.g'. +** +** Put in this package because the command line processing takes place here. +*/ +UInt SyBanner = 1; + + +/**************************************************************************** +** +*V SyCTRD . . . . . . . . . . . . . . . . . . . true if '-D' is +*/ +UInt SyCTRD = 1; + + +/**************************************************************************** +** +*V SyCacheSize . . . . . . . . . . . . . . . . . . . . . . size of the cache +** +** 'SyCacheSize' is the size of the data cache. +** +** This is per default 0, which means that there is no usuable data cache. +** It is usually changed with the '-c' option in the script that starts GAP. +** +** This value is passed to 'InitBags'. +** +** Put in this package because the command line processing takes place here. +*/ +UInt SyCacheSize = 0; + + +/**************************************************************************** +** +*V SyCheckForCompFiles . . . . . . . . . . . . . check for completion files +*/ +Int SyCheckForCompFiles = 1; + + +/**************************************************************************** +** +*V SyCompileInput . . . . . . . . . . . . . . . . . . from this input file +*/ +Char SyCompileInput [256]; + + +/**************************************************************************** +** +*V SyCompileMagic1 . . . . . . . . . . . . . . . . . . and this magic string +*/ +Char * SyCompileMagic1; + + +/**************************************************************************** +** +*V SyCompileName . . . . . . . . . . . . . . . . . . . . . . with this name +*/ +Char SyCompileName [256]; + + +/**************************************************************************** +** +*V SyCompileOutput . . . . . . . . . . . . . . . . . . into this output file +*/ +Char SyCompileOutput [256]; + + +/**************************************************************************** +** +*V SyCompilePlease . . . . . . . . . . . . . . . tell GAP to compile a file +*/ +Int SyCompilePlease = 0; + + +/**************************************************************************** +** +*V SyDebugLoading . . . . . . . . . output messages about loading of files +*/ +Int SyDebugLoading = 0; + + /**************************************************************************** ** *V SyGapRootPath . . . . . . . . . . . . . . . . . . . . . . . . . root path @@ -373,8 +414,9 @@ Char * SyArchitecture = SYS_ARCH; ** filename. Further neccessary transformation of the filename are done in ** 'SyOpen'. ** -** Put in this package because the command line processing takes place here. */ -Char SyGapRootPath [16*256]; +** Put in this package because the command line processing takes place here. +*/ +Char SyGapRootPath [MAX_GAP_DIRS*256]; /**************************************************************************** @@ -384,48 +426,55 @@ Char SyGapRootPath [16*256]; ** 'SyGapRootPaths' conatins the names of the directories where the GAP ** files are located, it is derived from 'SyGapRootPath'. ** -** Put in this package because the command line processing takes place here. */ -Char SyGapRootPaths [16] [256]; +** Put in this package because the command line processing takes place here. +*/ +Char SyGapRootPaths [MAX_GAP_DIRS] [256]; /**************************************************************************** ** -*V SyBanner . . . . . . . . . . . . . . . . . . . . . . . . surpress banner +*V SyInitfiles[] . . . . . . . . . . . list of filenames to be read in init ** -** 'SyBanner' determines whether GAP should print the banner. +** 'SyInitfiles' is a list of file to read upon startup of GAP. ** -** Per default it is true, i.e., GAP prints the nice banner. It can be -** changed by the '-b' option to have GAP surpress the banner. +** It contains the 'init.g' file and a user specific init file if it exists. +** It also contains all names all the files specified on the command line. ** -** It is copied into the GAP variable 'BANNER', which is used in 'init.g'. +** This is used in 'InitGap' which tries to read those files upon startup. ** ** Put in this package because the command line processing takes place here. +** +** For UNIX this list contains 'LIBNAME/init.g' and '$HOME/.gaprc'. */ -UInt SyBanner = 1; +Char SyInitfiles [16] [256]; /**************************************************************************** ** -*V SyQuiet . . . . . . . . . . . . . . . . . . . . . . . . . surpress prompt -** -** 'SyQuit' determines whether GAP should print the prompt and the banner. -** -** Per default its false, i.e. GAP prints the prompt and the nice banner. -** It can be changed by the '-q' option to have GAP operate in silent mode. -** -** It is used by the functions in 'gap.c' to surpress printing the prompts. -** Is also copied into the GAP variable 'QUIET' which is used in 'init.g'. +*V SyLineEdit . . . . . . . . . . . . . . . . . . . . support line editing ** -** Put in this package because the command line processing takes place here. +** 0: no line editing +** 1: line editing if terminal +** 2: always line editing (EMACS) */ -UInt SyQuiet = 0; +UInt SyLineEdit = 1; /**************************************************************************** ** -*V SyDebugLoading . . . . . . . . . output messages about loading of files +*V SyMsgsFlagBags . . . . . . . . . . . . . . . . . enable gasman messages +** +** 'SyMsgsFlagBags' determines whether garabage collections are reported or +** not. +** +** Per default it is false, i.e. Gasman is silent about garbage collections. +** It can be changed by using the '-g' option on the GAP command line. +** +** This is used in the function 'SyMsgsBags' below. +** +** Put in this package because the command line processing takes place here. */ -Int SyDebugLoading = 0; +UInt SyMsgsFlagBags = 0; /**************************************************************************** @@ -461,19 +510,35 @@ UInt SyNrRows = 24; /**************************************************************************** ** -*V SyMsgsFlagBags . . . . . . . . . . . . . . . . . enable gasman messages +*V SyQuiet . . . . . . . . . . . . . . . . . . . . . . . . . surpress prompt ** -** 'SyMsgsFlagBags' determines whether garabage collections are reported or -** not. +** 'SyQuit' determines whether GAP should print the prompt and the banner. ** -** Per default it is false, i.e. Gasman is silent about garbage collections. -** It can be changed by using the '-g' option on the GAP command line. +** Per default its false, i.e. GAP prints the prompt and the nice banner. +** It can be changed by the '-q' option to have GAP operate in silent mode. ** -** This is used in the function 'SyMsgsBags' below. +** It is used by the functions in 'gap.c' to surpress printing the prompts. +** Is also copied into the GAP variable 'QUIET' which is used in 'init.g'. ** ** Put in this package because the command line processing takes place here. */ -UInt SyMsgsFlagBags = 0; +UInt SyQuiet = 0; + + +/**************************************************************************** +** +*V SyStorMax . . . . . . . . . . . . . . . . . . . maximal size of workspace +** +** 'SyStorMax' is the maximal size of the workspace allocated by Gasman. +** +** This is per default 64 MByte, which is often a reasonable value. It is +** usually changed with the '-t' option in the script that starts GAP. +** +** This is used in the function 'SyAllocBags'below. +** +** Put in this package because the command line processing takes place here. +*/ +Int SyStorMax = 64 * 1024 * 1024L; /**************************************************************************** @@ -510,62 +575,6 @@ Int SyStorMin = 0; #endif -/**************************************************************************** -** -*V SyStorMax . . . . . . . . . . . . . . . . . . . maximal size of workspace -** -** 'SyStorMax' is the maximal size of the workspace allocated by Gasman. -** -** This is per default 64 MByte, which is often a reasonable value. It is -** usually changed with the '-t' option in the script that starts GAP. -** -** This is used in the function 'SyAllocBags'below. -** -** Put in this package because the command line processing takes place here. -*/ -Int SyStorMax = 64 * 1024 * 1024L; - - -/**************************************************************************** -** -*F SyStackAlign . . . . . . . . . . . . . . . . . . alignment of the stack -** -** 'SyStackAlign' is the alignment of items on the stack. It must be a -** divisor of 'sizof(Bag)'. The addresses of all identifiers on the stack -** must be divisable by 'SyStackAlign'. So if it is 1, identifiers may be -** anywhere on the stack, and if it is 'sizeof(Bag)', identifiers may only -** be at addresses divisible by 'sizeof(Bag)'. This value is initialized -** from a macro passed from the makefile, because it is machine dependent. -** -** This value is passed to 'InitBags'. -*/ -#ifdef SYS_HAS_STACK_ALIGN -#define SYS_STACK_ALIGN SYS_HAS_STACK_ALIGN -#endif - -#ifndef SYS_HAS_STACK_ALIGN -#define SYS_STACK_ALIGN sizeof(UInt *) -#endif - -UInt SyStackAlign = SYS_STACK_ALIGN; - - -/**************************************************************************** -** -*V SyCacheSize . . . . . . . . . . . . . . . . . . . . . . size of the cache -** -** 'SyCacheSize' is the size of the data cache. -** -** This is per default 0, which means that there is no usuable data cache. -** It is usually changed with the '-c' option in the script that starts GAP. -** -** This value is passed to 'InitBags'. -** -** Put in this package because the command line processing takes place here. -*/ -UInt SyCacheSize = 0; - - /**************************************************************************** ** *V SySystemInitFile . . . . . . . . . . . name of the system "init.g" file @@ -573,71 +582,11 @@ UInt SyCacheSize = 0; Char SySystemInitFile [256]; -/**************************************************************************** -** -*V SyInitfiles[] . . . . . . . . . . . list of filenames to be read in init -** -** 'SyInitfiles' is a list of file to read upon startup of GAP. -** -** It contains the 'init.g' file and a user specific init file if it exists. -** It also contains all names all the files specified on the command line. -** -** This is used in 'InitGap' which tries to read those files upon startup. -** -** Put in this package because the command line processing takes place here. -** -** For UNIX this list contains 'LIBNAME/init.g' and '$HOME/.gaprc'. -*/ -Char SyInitfiles [16] [256]; - - -/**************************************************************************** -** -*V SyCheckForCompFiles . . . . . . . . . . . . . check for completion files -*/ -Int SyCheckForCompFiles = 1; - - /**************************************************************************** ** *V SyUseModule . . . . . check for dynamic/static modules in 'READ_GAP_ROOT' */ -int SyUseModule = 1; - - -/**************************************************************************** -** -*V SyCompilePlease . . . . . . . . . . . . . . . tell GAP to compile a file -*/ -Int SyCompilePlease = 0; - - -/**************************************************************************** -** -*V SyCompileOutput . . . . . . . . . . . . . . . . . . into this output file -*/ -Char SyCompileOutput [256]; - - -/**************************************************************************** -** -*V SyCompileInput . . . . . . . . . . . . . . . . . . from this input file -*/ -Char SyCompileInput [256]; - - -/**************************************************************************** -** -*V SyCompileName . . . . . . . . . . . . . . . . . . . . . . with this name -*/ -Char SyCompileName [256]; - - -/**************************************************************************** -** -*V SyCompileMagic1 . . . . . . . . . . . . . . . . . . and this magic string -*/ -Char * SyCompileMagic1; +int SyUseModule = 1; /**************************************************************************** @@ -653,6 +602,26 @@ Char * SyCompileMagic1; UInt SyWindow = 0; +/**************************************************************************** +** +*V syStackSpace . . . . . . . . . . . . . . . . . . . amount of stack space +** +** 'syStackSpace' is the amount of stackspace that GAP gets. +** +** Under TOS and on the Mac special actions must be taken to ensure that +** enough space is available. +*/ +#if SYS_TOS_GCC2 +# define __NO_INLINE__ +int _stksize = 64 * 1024; /* GNU C, amount of stack space */ +static UInt syStackSpace = 64 * 1024; +#endif + +#if SYS_MAC_MPW || SYS_MAC_SYC +static UInt syStackSpace = 64 * 1024; +#endif + + /**************************************************************************** ** @@ -662,11 +631,16 @@ UInt SyWindow = 0; /**************************************************************************** ** -*V syStartTime . . . . . . . . . . . . . . . . . . time when GAP was started -*V syStopTime . . . . . . . . . . . . . . . . . . time when reading started +*V SyStartTime . . . . . . . . . . . . . . . . . . time when GAP was started +*/ +UInt SyStartTime; + + +/**************************************************************************** +** +*V SyStopTime . . . . . . . . . . . . . . . . . . time when reading started */ -UInt syStartTime; -UInt syStopTime; +UInt SyStopTime; /**************************************************************************** @@ -708,7 +682,7 @@ UInt SyTime ( void ) fputs("gap: panic 'SyTime' cannot get time!\n",stderr); SyExit( 1 ); } - return buf.ru_utime.tv_sec*1000 + buf.ru_utime.tv_usec/1000 -syStartTime; + return buf.ru_utime.tv_sec*1000 + buf.ru_utime.tv_usec/1000 -SyStartTime; } #endif @@ -732,7 +706,7 @@ UInt SyTime ( void ) fputs("gap: panic 'SyTime' cannot get time!\n",stderr); SyExit( 1 ); } - return 100 * tbuf.tms_utime / (60/10) - syStartTime; + return 100 * tbuf.tms_utime / (60/10) - SyStartTime; } #endif @@ -767,7 +741,7 @@ UInt SyTime ( void ) fputs("gap: panic 'SyTime' cannot get time!\n",stderr); SyExit( 1 ); } - return 100 * tbuf.tms_utime / (HZ / 10) - syStartTime; + return 100 * tbuf.tms_utime / (HZ / 10) - SyStartTime; } #endif @@ -801,7 +775,7 @@ extern long clock ( void ); UInt SyTime ( void ) { - return 100 * (UInt)clock() / (SYS_CLOCKS/10) - syStartTime; + return 100 * (UInt)clock() / (SYS_CLOCKS/10) - SyStartTime; } #endif @@ -828,7 +802,7 @@ UInt SyTime ( void ) UInt SyTime ( void ) { - return 100 * (UInt)TickCount() / (60/10) - syStartTime; + return 100 * (UInt)TickCount() / (60/10) - SyStartTime; } #endif @@ -980,147 +954,6 @@ Char * SyStrncat ( #endif -/**************************************************************************** -** - -*F * * * * * * * * * * * * * * * * input/output * * * * * * * * * * * * * * * -*/ - - -/**************************************************************************** -** - -*V syBuf . . . . . . . . . . . . . . buffer and other info for files, local -** -** 'syBuf' is a array used as buffers for file I/O to prevent the C I/O -** routines from allocating their buffers using 'malloc', which would -** otherwise confuse Gasman. -*/ -struct { - FILE * fp; /* file pointer for this file */ - FILE * echo; /* file pointer for the echo */ - UInt pipe; /* file is really a pipe */ - Char buf [BUFSIZ]; /* the buffer for this file */ -} syBuf [16]; - - -/**************************************************************************** -** -*F SyFopen( , ) . . . . . . . . open the file with name -** -** The function 'SyFopen' is called to open the file with the name . -** If is "r" it is opened for reading, in this case it must exist. -** If is "w" it is opened for writing, it is created if neccessary. -** If is "a" it is opened for appending, i.e., it is not truncated. -** -** 'SyFopen' returns an integer used by the scanner to identify the file. -** 'SyFopen' returns -1 if it cannot open the file. -** -** The following standard files names and file identifiers are guaranteed: -** 'SyFopen( "*stdin*", "r")' returns 0 identifying the standard input file. -** 'SyFopen( "*stdout*","w")' returns 1 identifying the standard outpt file. -** 'SyFopen( "*errin*", "r")' returns 2 identifying the brk loop input file. -** 'SyFopen( "*errout*","w")' returns 3 identifying the error messages file. -** -** If it is necessary to adjust the filename this should be done here. -** Right now GAP does not read nonascii files, but if this changes sometimes -** 'SyFopen' must adjust the mode argument to open the file in binary mode. -*/ -Int SyFopen ( - Char * name, - Char * mode ) -{ - Int fid; - Char namegz [1024]; - Char cmd [1024]; - - /* handle standard files */ - if ( SyStrcmp( name, "*stdin*" ) == 0 ) { - if ( SyStrcmp( mode, "r" ) != 0 ) return -1; - return 0; - } - else if ( SyStrcmp( name, "*stdout*" ) == 0 ) { - if ( SyStrcmp( mode, "w" ) != 0 ) return -1; - return 1; - } - else if ( SyStrcmp( name, "*errin*" ) == 0 ) { - if ( SyStrcmp( mode, "r" ) != 0 ) return -1; - if ( syBuf[2].fp == (FILE*)0 ) return -1; - return 2; - } - else if ( SyStrcmp( name, "*errout*" ) == 0 ) { - if ( SyStrcmp( mode, "w" ) != 0 ) return -1; - return 3; - } - - /* try to find an unused file identifier */ - for ( fid = 4; fid < sizeof(syBuf)/sizeof(syBuf[0]); ++fid ) - if ( syBuf[fid].fp == (FILE*)0 ) break; - if ( fid == sizeof(syBuf)/sizeof(syBuf[0]) ) - return (Int)-1; - - /* set up and for pipe command */ - namegz[0] = '\0'; - SyStrncat( namegz, name, sizeof(namegz)-5 ); - SyStrncat( namegz, ".gz", 4 ); - cmd[0] = '\0'; - SyStrncat( cmd, "gunzip <", 9 ); - SyStrncat( cmd, namegz, sizeof(cmd)-10 ); - - /* try to open the file */ - if ( (syBuf[fid].fp = fopen(name,mode)) ) { - syBuf[fid].pipe = 0; - } - else if ( SyStrcmp(mode,"r") == 0 - && access(namegz,R_OK) == 0 - && (syBuf[fid].fp = popen(cmd,mode)) ) { - syBuf[fid].pipe = 1; - } - else { - return (Int)-1; - } - - /* allocate the buffer */ - setbuf( syBuf[fid].fp, syBuf[fid].buf ); - - /* return file identifier */ - return fid; -} - - -/**************************************************************************** -** -*F SyFclose( ) . . . . . . . . . . . . . . . . . close the file -** -** 'SyFclose' closes the file with the identifier which is obtained -** from 'SyFopen'. -*/ -void SyFclose ( - Int fid ) -{ - /* check file identifier */ - if ( syBuf[fid].fp == (FILE*)0 ) { - fputs("gap: panic 'SyFclose' asked to close closed file!\n",stderr); - SyExit( 1 ); - } - - /* refuse to close the standard files */ - if ( fid == 0 || fid == 1 || fid == 2 || fid == 3 ) { - return; - } - - /* try to close the file */ - if ( (syBuf[fid].pipe == 0 && fclose( syBuf[fid].fp ) == EOF) - || (syBuf[fid].pipe == 1 && pclose( syBuf[fid].fp ) == -1) ) { - fputs("gap: 'SyFclose' cannot close file, ",stderr); - fputs("maybe your file system is full?\n",stderr); - } - - /* mark the buffer as unused */ - syBuf[fid].fp = (FILE*)0; -} - - /**************************************************************************** ** @@ -1796,346 +1629,28 @@ void syStopraw ( #if SYS_MAC_MPW void syStopraw ( - Int fid ) -{ -} - -#endif - - -/**************************************************************************** -** -*f syStopraw( ) . . . . . . . . . . . . . . . . . . . . . . . MAC SYC -*/ -#if SYS_MAC_SYC - -void syStopraw ( - Int fid ) -{ - /* probably only paranoid */ - if ( isatty( fileno(syBuf[fid].fp) ) ) - return; - - /* turn terminal back to echo mode */ - csetmode( C_ECHO, syBuf[fid].fp ); -} - -#endif - - -/**************************************************************************** -** -*F syGetch( ) . . . . . . . . . . . . . get a char from , local -*/ -#define CTR(C) ((C) & 0x1F) /* character */ -#define ESC(C) ((C) | 0x100) /* character */ -#define CTV(C) ((C) | 0x200) /* V quotes characters */ - - -/**************************************************************************** -** -*f syGetch( ) . . . . . . . . . . . . . . . . . . . . . . . BSD/MACH -*/ -#if SYS_BSD || SYS_MACH - -Int syGetch ( - Int fid ) -{ - Char ch; - - /* read a character */ - while ( read( fileno(syBuf[fid].fp), &ch, 1 ) != 1 || ch == '\0' ) - ; - - /* if running under a window handler, handle special characters */ - if ( SyWindow && ch == '@' ) { - do { - while ( read(fileno(syBuf[fid].fp), &ch, 1) != 1 || ch == '\0' ) - ; - } while ( ch < '@' || 'z' < ch ); - if ( ch == 'y' ) { - syWinPut( fileno(syBuf[fid].echo), "@s", "" ); - ch = syGetch(fid); - } - else if ( 'A' <= ch && ch <= 'Z' ) - ch = CTR(ch); - } - - /* return the character */ - return ch; -} - -#endif - - -/**************************************************************************** -** -*f syGetch( ) . . . . . . . . . . . . . . . . . . . . . . . . . . USG -*/ -#if SYS_USG - -Int syGetch ( - Int fid ) -{ - Char ch; - - /* read a character */ - while ( read( fileno(syBuf[fid].fp), &ch, 1 ) != 1 || ch == '\0' ) - ; - - /* if running under a window handler, handle special characters */ - if ( SyWindow && ch == '@' ) { - do { - while ( read(fileno(syBuf[fid].fp), &ch, 1) != 1 || ch == '\0' ) - ; - } while ( ch < '@' || 'z' < ch ); - if ( ch == 'y' ) { - syWinPut( fileno(syBuf[fid].echo), "@s", "" ); - ch = syGetch(fid); - } - else if ( 'A' <= ch && ch <= 'Z' ) - ch = CTR(ch); - } - - /* return the character */ - return ch; -} - -#endif - - -/**************************************************************************** -** -*f syGetch( ) . . . . . . . . . . . . . . . . . . . . . . . . OS2 EMX -*/ -#if SYS_OS2_EMX - -#ifndef SYS_KBD_H /* keyboard scan codes */ -# include -# define SYS_KBD_H -#endif - -Int syGetch ( - Int fid ) -{ - UChar ch; - Int ch2; - -syGetchAgain: - /* read a character */ - while ( read( fileno(syBuf[fid].fp), &ch, 1 ) != 1 ) - ; - - /* if running under a window handler, handle special characters */ - if ( SyWindow && ch == '@' ) { - do { - while ( read(fileno(syBuf[fid].fp), &ch, 1) != 1 ) - ; - } while ( ch < '@' || 'z' < ch ); - if ( ch == 'y' ) { - syWinPut( fileno(syBuf[fid].echo), "@s", "" ); - ch = syGetch(fid); - } - else if ( 'A' <= ch && ch <= 'Z' ) - ch = CTR(ch); - } - - ch2 = ch; - - /* handle function keys */ - if ( ch == '\0' ) { - while ( read( fileno(syBuf[fid].fp), &ch, 1 ) != 1 ) - ; - switch ( ch ) { - case K_LEFT: ch2 = CTR('B'); break; - case K_RIGHT: ch2 = CTR('F'); break; - case K_UP: - case K_PAGEUP: ch2 = CTR('P'); break; - case K_DOWN: - case K_PAGEDOWN: ch2 = CTR('N'); break; - case K_DEL: ch2 = CTR('D'); break; - case K_HOME: ch2 = CTR('A'); break; - case K_END: ch2 = CTR('E'); break; - case K_CTRL_END: ch2 = CTR('K'); break; - case K_CTRL_LEFT: - case K_ALT_B: ch2 = ESC('B'); break; - case K_CTRL_RIGHT: - case K_ALT_F: ch2 = ESC('F'); break; - case K_ALT_D: ch2 = ESC('D'); break; - case K_ALT_DEL: - case K_ALT_BACKSPACE: ch2 = ESC(127); break; - case K_ALT_U: ch2 = ESC('U'); break; - case K_ALT_L: ch2 = ESC('L'); break; - case K_ALT_C: ch2 = ESC('C'); break; - case K_CTRL_PAGEUP: ch2 = ESC('<'); break; - case K_CTRL_PAGEDOWN: ch2 = ESC('>'); break; - default: goto syGetchAgain; - } - } - - /* return the character */ - return ch2; -} - -#endif - - -/**************************************************************************** -** -*f syGetch( ) . . . . . . . . . . . . . . . . . . . . . . . . MS-DOS -*/ -#if SYS_MSDOS_DJGPP - -Int syGetch ( - Int fid ) -{ - Int ch; - - /* if chars have been typed ahead and read by 'SyIsIntr' read them */ - if ( syTypeahead[0] != '\0' ) { - ch = syTypeahead[0]; - strcpy( syTypeahead, syTypeahead+1 ); - } - - /* otherwise read from the keyboard */ - else { - ch = GETKEY(); - } - - /* postprocess the character */ - if ( 0x110 <= ch && ch <= 0x132 ) ch = ESC( syAltMap[ch-0x110] ); - else if ( ch == 0x147 ) ch = CTR('A'); - else if ( ch == 0x14f ) ch = CTR('E'); - else if ( ch == 0x148 ) ch = CTR('P'); - else if ( ch == 0x14b ) ch = CTR('B'); - else if ( ch == 0x14d ) ch = CTR('F'); - else if ( ch == 0x150 ) ch = CTR('N'); - else if ( ch == 0x153 ) ch = CTR('D'); - else ch &= 0xFF; - - /* return the character */ - return ch; -} - -#endif - - -/**************************************************************************** -** -*f syGetch( ) . . . . . . . . . . . . . . . . . . . . . . . . . . TOS -*/ -#if SYS_TOS_GCC2 - -Int syGetch ( - Int fid ) -{ - Int ch; - - /* if chars have been typed ahead and read by 'SyIsIntr' read them */ - if ( syTypeahead[0] != '\0' ) { - ch = syTypeahead[0]; - strcpy( syTypeahead, syTypeahead+1 ); - } - - /* otherwise read from the keyboard */ - else { - ch = GETKEY(); - } - - /* postprocess the character */ - if ( ch == 0x00480000 ) ch = CTR('P'); - else if ( ch == 0x004B0000 ) ch = CTR('B'); - else if ( ch == 0x004D0000 ) ch = CTR('F'); - else if ( ch == 0x00500000 ) ch = CTR('N'); - else if ( ch == 0x00730000 ) ch = CTR('Y'); - else if ( ch == 0x00740000 ) ch = CTR('Z'); - else ch = ch & 0xFF; - - /* return the character */ - return ch; -} - -#endif - - -/**************************************************************************** -** -*f syGetch( ) . . . . . . . . . . . . . . . . . . . . . . . . . . VMS -*/ -#if SYS_VMS - -Int syGetch ( - Int fid ) -{ - Char ch; - - /* read a character */ - smg$read_keystroke( &syVirKbd, &ch ); - - /* return the character */ - return ch; -} - -#endif - - -/**************************************************************************** -** -*f syGetch( ) . . . . . . . . . . . . . . . . . . . . . . . . MAC MPW -*/ -#if SYS_MAC_MPW - -int syGetch ( - Int fid ) -{ -} - -#endif - - -/**************************************************************************** -** -*f syGetch( ) . . . . . . . . . . . . . . . . . . . . . . . . MAC SYC -*/ -#if SYS_MAC_SYC - -Int syGetch2 ( - Int fid, - Int cur ) -{ - Int ch; - - /* probably only paranoid */ - if ( ! isatty( fileno(syBuf[fid].fp) ) ) - return EOF; - - /* make the current character reverse to simulate a cursor */ - syEchoch( (cur != '\0' ? cur : ' ') | 0x80, fid ); - syEchoch( '\b', fid ); - - /* get a character, ignore EOF and chars beyond 0x7F (reverse video) */ - while ( ((ch = getchar()) == EOF) || (0x7F < ch) ) - ; + Int fid ) +{ +} - /* handle special characters */ - if ( ch == 28 ) ch = CTR('B'); - else if ( ch == 29 ) ch = CTR('F'); - else if ( ch == 30 ) ch = CTR('P'); - else if ( ch == 31 ) ch = CTR('N'); +#endif - /* make the current character normal again */ - syEchoch( (cur != '\0' ? cur : ' '), fid ); - syEchoch( '\b', fid ); - /* return the character */ - return ch; -} +/**************************************************************************** +** +*f syStopraw( ) . . . . . . . . . . . . . . . . . . . . . . . MAC SYC +*/ +#if SYS_MAC_SYC -Int syGetch ( +void syStopraw ( Int fid ) { - /* return character */ - return syGetch2( fid, '\0' ); + /* probably only paranoid */ + if ( isatty( fileno(syBuf[fid].fp) ) ) + return; + + /* turn terminal back to echo mode */ + csetmode( C_ECHO, syBuf[fid].fp ); } #endif @@ -2501,625 +2016,6 @@ void syEchos ( /**************************************************************************** ** -*F SyFgets( , , ) . . . . . get a line from file -** -** 'SyFgets' is called to read a line from the file with identifier . -** 'SyFgets' (like 'fgets') reads characters until either -1 chars -** have been read or until a or an character is encoutered. -** It retains the '\n' (unlike 'gets'), if any, and appends '\0' to . -** 'SyFgets' returns if any char has been read, otherwise '(char*)0'. -** -** 'SyFgets' allows to edit the input line if the file refers to a -** terminal with the following commands: -** -** -A move the cursor to the beginning of the line. -** -B move the cursor to the beginning of the previous word. -** -B move the cursor backward one character. -** -F move the cursor forward one character. -** -F move the cursor to the end of the next word. -** -E move the cursor to the end of the line. -** -** -H, delete the character left of the cursor. -** -D delete the character under the cursor. -** -K delete up to the end of the line. -** -D delete forward to the end of the next word. -** - delete backward to the beginning of the last word. -** -X delete entire input line, and discard all pending input. -** -Y insert (yank) a just killed text. -** -** -T exchange (twiddle) current and previous character. -** -U uppercase next word. -** -L lowercase next word. -** -C capitalize next word. -** -** complete the identifier before the cursor. -** -L insert last input line before current character. -** -P redisplay the last input line, another -P will redisplay -** the line before that, etc. If the cursor is not in the first -** column only the lines starting with the string to the left of -** the cursor are taken. The history is limitied to ~8000 chars. -** -N Like -P but goes the other way round through the history -** -< goes to the beginning of the history. -** -> goes to the end of the history. -** -O accept this line and perform a -N. -** -** -V enter next character literally. -** -U execute the next command 4 times. -** - execute the next command times. -** --L repaint input line. -** -** Not yet implemented commands: -** -** -S search interactive for a string forward. -** -R search interactive for a string backward. -** -Y replace yanked string with previously killed text. -** -_ undo a command. -** -T exchange two words. -*/ -extern UInt iscomplete_rnam ( - Char * name, - UInt len ); - -extern UInt completion_rnam ( - Char * name, - UInt len ); - -extern UInt iscomplete_gvar ( - Char * name, - UInt len ); - -extern UInt completion_gvar ( - Char * name, - UInt len ); - -extern void syWinPut ( - Int fid, - Char * cmd, - Char * str ); - -UInt syLineEdit = 1; /* 0: no line editing */ - /* 1: line editing if terminal */ - /* 2: always line editing (EMACS) */ -UInt syCTRD = 1; /* true if '-D' is */ -UInt syNrchar; /* nr of chars already on the line */ -Char syPrompt [256]; /* characters alread on the line */ - -Char syHistory [8192]; /* history of command lines */ -Char * syHi = syHistory; /* actual position in history */ -UInt syCTRO; /* number of '-O' pending */ - -#define IS_SEP(C) (!IsAlpha(C) && !IsDigit(C) && (C)!='_') - -Char * SyFgets ( - Char * line, - UInt length, - Int fid ) -{ - Int ch, ch2, ch3, last; - Char * p, * q, * r, * s, * t; - Char * h; - static Char yank [512]; - Char old [512], new [512]; - Int oldc, newc; - Int rep; - Char buffer [512]; - Int rn; - - /* no line editing if the file is not '*stdin*' or '*errin*' */ - if ( fid != 0 && fid != 2 ) { - p = fgets( line, (int)length, syBuf[fid].fp ); - return p; - } - - /* no line editing if the user disabled it */ - if ( syLineEdit == 0 ) { - syStopTime = SyTime(); - p = fgets( line, (int)length, syBuf[fid].fp ); - syStartTime += SyTime() - syStopTime; - return p; - } - - /* no line editing if the file cannot be turned to raw mode */ - if ( syLineEdit == 1 && ! syStartraw(fid) ) { - syStopTime = SyTime(); - p = fgets( line, (int)length, syBuf[fid].fp ); - syStartTime += SyTime() - syStopTime; - return p; - } - - /* stop the clock, reading should take no time */ - syStopTime = SyTime(); - - /* the line starts out blank */ - line[0] = '\0'; p = line; h = syHistory; - for ( q = old; q < old+sizeof(old); ++q ) *q = ' '; - oldc = 0; - last = 0; - - while ( 1 ) { - - /* get a character, handle V, and U */ - rep = 1; ch2 = 0; - do { - if ( syCTRO % 2 == 1 ) { ch = CTR('N'); syCTRO = syCTRO - 1; } - else if ( syCTRO != 0 ) { ch = CTR('O'); rep = syCTRO / 2; } -#if ! SYS_MAC_SYC - else ch = syGetch(fid); -#endif -#if SYS_MAC_SYC - else ch = syGetch2(fid,*p); -#endif - if ( ch2==0 && ch==CTR('V') ) { ch2=ch; ch=0;} - if ( ch2==0 && ch==CTR('[') ) { ch2=ch; ch=0;} - if ( ch2==0 && ch==CTR('U') ) { ch2=ch; ch=0;} - if ( ch2==CTR('[') && ch==CTR('V') ) { ch2=ESC(CTR('V')); ch=0;} - if ( ch2==CTR('[') && isdigit(ch) ) { rep=ch-'0'; ch2=ch; ch=0;} - if ( ch2==CTR('[') && ch=='[' ) { ch2=ch; ch=0;} - if ( ch2==CTR('U') && ch==CTR('V') ) { rep=4*rep; ch2=ch; ch=0;} - if ( ch2==CTR('U') && ch==CTR('[') ) { rep=4*rep; ch2=ch; ch=0;} - if ( ch2==CTR('U') && ch==CTR('U') ) { rep=4*rep; ch2=ch; ch=0;} - if ( ch2==CTR('U') && isdigit(ch) ) { rep=ch-'0'; ch2=ch; ch=0;} - if ( isdigit(ch2) && ch==CTR('V') ) { ch2=ch; ch=0;} - if ( isdigit(ch2) && ch==CTR('[') ) { ch2=ch; ch=0;} - if ( isdigit(ch2) && ch==CTR('U') ) { ch2=ch; ch=0;} - if ( isdigit(ch2) && isdigit(ch) ) { rep=10*rep+ch-'0'; ch=0;} - } while ( ch == 0 ); - if ( ch2==CTR('V') ) ch = CTV(ch); - if ( ch2==ESC(CTR('V')) ) ch = CTV(ch | 0x80); - if ( ch2==CTR('[') ) ch = ESC(ch); - if ( ch2==CTR('U') ) rep = 4*rep; - if ( ch2=='[' && ch=='A') ch = CTR('P'); - if ( ch2=='[' && ch=='B') ch = CTR('N'); - if ( ch2=='[' && ch=='C') ch = CTR('F'); - if ( ch2=='[' && ch=='D') ch = CTR('B'); - - /* now perform the requested action times in the input line */ - while ( rep-- > 0 ) { - switch ( ch ) { - - case CTR('A'): /* move cursor to the start of the line */ - while ( p > line ) --p; - break; - - case ESC('B'): /* move cursor one word to the left */ - case ESC('b'): - if ( p > line ) do { - --p; - } while ( p>line && (!IS_SEP(*(p-1)) || IS_SEP(*p))); - break; - - case CTR('B'): /* move cursor one character to the left */ - if ( p > line ) --p; - break; - - case CTR('F'): /* move cursor one character to the right */ - if ( *p != '\0' ) ++p; - break; - - case ESC('F'): /* move cursor one word to the right */ - case ESC('f'): - if ( *p != '\0' ) do { - ++p; - } while ( *p!='\0' && (IS_SEP(*(p-1)) || !IS_SEP(*p))); - break; - - case CTR('E'): /* move cursor to the end of the line */ - while ( *p != '\0' ) ++p; - break; - - case CTR('H'): /* delete the character left of the cursor */ - case 127: - if ( p == line ) break; - --p; - /* let '-D' do the work */ - - case CTR('D'): /* delete the character at the cursor */ - /* on an empty line '-D' is */ - if ( p == line && *p == '\0' && syCTRD ) { - ch = EOF; rep = 0; break; - } - if ( *p != '\0' ) { - for ( q = p; *(q+1) != '\0'; ++q ) - *q = *(q+1); - *q = '\0'; - } - break; - - case CTR('X'): /* delete the line */ - p = line; - /* let '-K' do the work */ - - case CTR('K'): /* delete to end of line */ - if ( last!=CTR('X') && last!=CTR('K') && last!=ESC(127) - && last!=ESC('D') && last!=ESC('d') ) yank[0] = '\0'; - for ( r = yank; *r != '\0'; ++r ) ; - for ( s = p; *s != '\0'; ++s ) r[s-p] = *s; - r[s-p] = '\0'; - *p = '\0'; - break; - - case ESC(127): /* delete the word left of the cursor */ - q = p; - if ( p > line ) do { - --p; - } while ( p>line && (!IS_SEP(*(p-1)) || IS_SEP(*p))); - if ( last!=CTR('X') && last!=CTR('K') && last!=ESC(127) - && last!=ESC('D') && last!=ESC('d') ) yank[0] = '\0'; - for ( r = yank; *r != '\0'; ++r ) ; - for ( ; yank <= r; --r ) r[q-p] = *r; - for ( s = p; s < q; ++s ) yank[s-p] = *s; - for ( r = p; *q != '\0'; ++q, ++r ) - *r = *q; - *r = '\0'; - break; - - case ESC('D'): /* delete the word right of the cursor */ - case ESC('d'): - q = p; - if ( *q != '\0' ) do { - ++q; - } while ( *q!='\0' && (IS_SEP(*(q-1)) || !IS_SEP(*q))); - if ( last!=CTR('X') && last!=CTR('K') && last!=ESC(127) - && last!=ESC('D') && last!=ESC('d') ) yank[0] = '\0'; - for ( r = yank; *r != '\0'; ++r ) ; - for ( s = p; s < q; ++s ) r[s-p] = *s; - r[s-p] = '\0'; - for ( r = p; *q != '\0'; ++q, ++r ) - *r = *q; - *r = '\0'; - break; - - case CTR('T'): /* twiddle characters */ - if ( p == line ) break; - if ( *p == '\0' ) --p; - if ( p == line ) break; - ch2 = *(p-1); *(p-1) = *p; *p = ch2; - ++p; - break; - - case CTR('L'): /* insert last input line */ - for ( r = syHistory; *r != '\0' && *r != '\n'; ++r ) { - ch2 = *r; - for ( q = p; ch2; ++q ) { - ch3 = *q; *q = ch2; ch2 = ch3; - } - *q = '\0'; ++p; - } - break; - - case CTR('Y'): /* insert (yank) deleted text */ - for ( r = yank; *r != '\0' && *r != '\n'; ++r ) { - ch2 = *r; - for ( q = p; ch2; ++q ) { - ch3 = *q; *q = ch2; ch2 = ch3; - } - *q = '\0'; ++p; - } - break; - - case CTR('P'): /* fetch old input line */ - while ( *h != '\0' ) { - for ( q = line; q < p; ++q ) - if ( *q != h[q-line] ) break; - if ( q == p ) break; - while ( *h != '\n' && *h != '\0' ) ++h; - if ( *h == '\n' ) ++h; - } - q = p; - while ( *h!='\0' && h[q-line]!='\n' && h[q-line]!='\0' ) { - *q = h[q-line]; ++q; - } - *q = '\0'; - while ( *h != '\0' && *h != '\n' ) ++h; - if ( *h == '\n' ) ++h; else h = syHistory; - syHi = h; - break; - - case CTR('N'): /* fetch next input line */ - h = syHi; - if ( h > syHistory ) { - do {--h;} while (h>syHistory && *(h-1)!='\n'); - if ( h==syHistory ) while ( *h != '\0' ) ++h; - } - while ( *h != '\0' ) { - if ( h==syHistory ) while ( *h != '\0' ) ++h; - do {--h;} while (h>syHistory && *(h-1)!='\n'); - for ( q = line; q < p; ++q ) - if ( *q != h[q-line] ) break; - if ( q == p ) break; - if ( h==syHistory ) while ( *h != '\0' ) ++h; - } - q = p; - while ( *h!='\0' && h[q-line]!='\n' && h[q-line]!='\0' ) { - *q = h[q-line]; ++q; - } - *q = '\0'; - while ( *h != '\0' && *h != '\n' ) ++h; - if ( *h == '\n' ) ++h; else h = syHistory; - syHi = h; - break; - - case ESC('<'): /* goto beginning of the history */ - while ( *h != '\0' ) ++h; - do {--h;} while (h>syHistory && *(h-1)!='\n'); - q = p = line; - while ( *h!='\0' && h[q-line]!='\n' && h[q-line]!='\0' ) { - *q = h[q-line]; ++q; - } - *q = '\0'; - while ( *h != '\0' && *h != '\n' ) ++h; - if ( *h == '\n' ) ++h; else h = syHistory; - syHi = h; - break; - - case ESC('>'): /* goto end of the history */ - h = syHistory; - p = line; - *p = '\0'; - syHi = h; - break; - - case CTR('S'): /* search for a line forward */ - /* search for a line forward, not fully implemented !!! */ - if ( *p != '\0' ) { - ch2 = syGetch(fid); - q = p+1; - while ( *q != '\0' && *q != ch2 ) ++q; - if ( *q == ch2 ) p = q; - } - break; - - case CTR('R'): /* search for a line backward */ - /* search for a line backward, not fully implemented !!! */ - if ( p > line ) { - ch2 = syGetch(fid); - q = p-1; - while ( q > line && *q != ch2 ) --q; - if ( *q == ch2 ) p = q; - } - break; - - case ESC('U'): /* uppercase word */ - case ESC('u'): - if ( *p != '\0' ) do { - if ('a' <= *p && *p <= 'z') *p = *p + 'A' - 'a'; - ++p; - } while ( *p!='\0' && (IS_SEP(*(p-1)) || !IS_SEP(*p))); - break; - - case ESC('C'): /* capitalize word */ - case ESC('c'): - while ( *p!='\0' && IS_SEP(*p) ) ++p; - if ( 'a' <= *p && *p <= 'z' ) *p = *p + 'A'-'a'; - if ( *p != '\0' ) ++p; - /* lowercase rest of the word */ - - case ESC('L'): /* lowercase word */ - case ESC('l'): - if ( *p != '\0' ) do { - if ('A' <= *p && *p <= 'Z') *p = *p + 'a' - 'A'; - ++p; - } while ( *p!='\0' && (IS_SEP(*(p-1)) || !IS_SEP(*p))); - break; - - case ESC(CTR('L')): /* repaint input line */ - syEchoch('\n',fid); - for ( q = syPrompt; q < syPrompt+syNrchar; ++q ) - syEchoch( *q, fid ); - for ( q = old; q < old+sizeof(old); ++q ) *q = ' '; - oldc = 0; - break; - - case EOF: /* end of file on input */ - break; - - case CTR('M'): /* append \n and exit */ - case CTR('J'): - while ( *p != '\0' ) ++p; - *p++ = '\n'; *p = '\0'; - rep = 0; - break; - - case CTR('O'): /* accept line, perform '-N' next time */ - while ( *p != '\0' ) ++p; - *p++ = '\n'; *p = '\0'; - syCTRO = 2 * rep + 1; - rep = 0; - break; - - case CTR('I'): /* try to complete the identifier before dot */ - if ( p == line || IS_SEP(p[-1]) ) { - ch2 = ch & 0xff; - for ( q = p; ch2; ++q ) { - ch3 = *q; *q = ch2; ch2 = ch3; - } - *q = '\0'; ++p; - } - else { - if ( (q = p) > line ) do { - --q; - } while ( q>line && (!IS_SEP(*(q-1)) || IS_SEP(*q))); - rn = (line < q && *(q-1) == '.'); - r = buffer; s = q; - while ( s < p ) *r++ = *s++; - *r = '\0'; - if ( (rn ? iscomplete_rnam( buffer, p-q ) - : iscomplete_gvar( buffer, p-q )) ) { - if ( last != CTR('I') ) - syEchoch( CTR('G'), fid ); - else { - syWinPut( fid, "@c", "" ); - syEchos( "\n ", fid ); - syEchos( buffer, fid ); - while ( (rn ? completion_rnam( buffer, p-q ) - : completion_gvar( buffer, p-q )) ) { - syEchos( "\n ", fid ); - syEchos( buffer, fid ); - } - syEchos( "\n", fid ); - for ( q=syPrompt; q= new+SyNrCols-syNrchar-2 ) { - if ( q >= p ) { q++; break; } - new[0] = '$'; new[1] = r[-5]; new[2] = r[-4]; - new[3] = r[-3]; new[4] = r[-2]; new[5] = r[-1]; - r = new+6; - } - } - if ( q == p ) newc = r-new; - for ( ; r < new+sizeof(new); ++r ) *r = ' '; - if ( q[0] != '\0' && q[1] != '\0' ) - new[SyNrCols-syNrchar-2] = '$'; - else if ( q[1] == '\0' && ' ' <= *q && *q < 0x7F ) - new[SyNrCols-syNrchar-2] = *q; - else if ( q[1] == '\0' && q[0] != '\0' ) - new[SyNrCols-syNrchar-2] = '$'; - for ( q = old, r = new; r < new+sizeof(new); ++r, ++q ) { - if ( *q == *r ) continue; - while (oldc<(q-old)) { syEchoch(old[oldc],fid); ++oldc; } - while (oldc>(q-old)) { syEchoch('\b',fid); --oldc; } - *q = *r; syEchoch( *q, fid ); ++oldc; - } - while ( oldc < newc ) { syEchoch(old[oldc],fid); ++oldc; } - while ( oldc > newc ) { syEchoch('\b',fid); --oldc; } - - } - - /* Now we put the new string into the history, first all old strings */ - /* are moved backwards, then we enter the new string in syHistory[]. */ - for ( q = syHistory+sizeof(syHistory)-3; q >= syHistory+(p-line); --q ) - *q = *(q-(p-line)); - for ( p = line, q = syHistory; *p != '\0'; ++p, ++q ) - *q = *p; - syHistory[sizeof(syHistory)-3] = '\n'; - if ( syHi != syHistory ) - syHi = syHi + (p-line); - if ( syHi > syHistory+sizeof(syHistory)-2 ) - syHi = syHistory+sizeof(syHistory)-2; - - /* send the whole line (unclipped) to the window handler */ - syWinPut( fid, (*line != '\0' ? "@r" : "@x"), line ); - - /* strip away prompts (usefull for pasting old stuff) */ - if (line[0]=='g'&&line[1]=='a'&&line[2]=='p'&&line[3]=='>'&&line[4]==' ') - for ( p = line, q = line+5; q[-1] != '\0'; p++, q++ ) *p = *q; - if (line[0]=='b'&&line[1]=='r'&&line[2]=='k'&&line[3]=='>'&&line[4]==' ') - for ( p = line, q = line+5; q[-1] != '\0'; p++, q++ ) *p = *q; - if (line[0]=='>'&&line[1]==' ') - for ( p = line, q = line+2; q[-1] != '\0'; p++, q++ ) *p = *q; - - /* switch back to cooked mode */ - if ( syLineEdit == 1 ) - syStopraw(fid); - - /* start the clock again */ - syStartTime += SyTime() - syStopTime; - - /* return the line (or '0' at end-of-file) */ - if ( *line == '\0' ) - return (Char*)0; - return line; -} - - -/**************************************************************************** -** *F SyFputs( , ) . . . . . . . . write a line to the file ** ** 'SyFputs' is called to put the to the file identified by . @@ -3354,7 +2250,7 @@ UInt SyIsIntr ( void ) syIsIntrCount = syIsIntrFreq; /* check for interrupts stuff the rest in typeahead buffer */ - if ( syLineEdit && KBHIT() ) { + if ( SyLineEdit && KBHIT() ) { while ( KBHIT() ) { ch = GETKEY(); if ( ch == CTR('C') || ch == CTR('Z') || ch == 0x12E ) { @@ -3818,192 +2714,71 @@ Char * SyWinCmd ( *b++ = (len % 10) + '0'; len /= 10; } - *b = '\0'; - syWinPut( 1, "@w", buf ); - - /* send the string to the window handler */ - syWinPut( 1, "", str ); - - /* read the length of the answer */ - s = WinCmdBuffer; - i = 10; - do { - while ( 0 < i ) { - len = read( 0, s, i ); - i -= len; - s += len; - } - if ( WinCmdBuffer[0] == '@' && WinCmdBuffer[1] == 'y' ) { - for ( i = 2; i < 10; i++ ) - WinCmdBuffer[i-2] = WinCmdBuffer[i]; - s -= 2; - i = 2; - } - } while ( 0 < i ); - if ( WinCmdBuffer[0] != '@' || WinCmdBuffer[1] != 'a' ) - return "I1+S41000000Illegal Answer"; - for ( len = 0, i = 9; 1 < i; i-- ) - len = len*10 + (WinCmdBuffer[i]-'0'); - - /* read the arguments of the answer */ - s = WinCmdBuffer; - i = len; - while ( 0 < i ) { - len = read( 0, s, i ); - i -= len; - s += len; - } - - /* shrink '@@' into '@' */ - for ( b = s = WinCmdBuffer; 0 < len; len-- ) { - if ( *s == '@' ) { - s++; - if ( *s == '@' ) - *b++ = '@'; - else if ( 'A' <= *s && *s <= 'Z' ) - *b++ = CTR(*s); - s++; - } - else { - *b++ = *s++; - } - } - *b = 0; - - /* return the string */ - return WinCmdBuffer; -} - -#endif - -#if SYS_MAC_MPW || SYS_MAC_SYC - -Char * SyWinCmd ( - Char * str, - UInt len ) -{ - return 0; -} - -#endif - - -/**************************************************************************** -** - -*F * * * * * * * * * * * * * file and execution * * * * * * * * * * * * * * * -*/ - - -/**************************************************************************** -** - -*F SyIsExistingFile( ) . . . . . . . . . . . does file exists -** -** 'SyIsExistingFile' returns 1 if the file exists and 0 otherwise. -** It does not check if the file is readable, writable or excuteable. -** is a system dependent description of the file. -*/ - - -/**************************************************************************** -** -*f SyIsExistingFile( ) . . . . . . . . . . . . . . . . BSD/Mach/USG -*/ -#if SYS_BSD || SYS_MACH || SYS_USG - -Int SyIsExistingFile ( Char * name ) -{ - if ( access( name, F_OK ) == 0 ) { - return 1; - } - else { - return 0; - } -} - -#endif - - -/**************************************************************************** -** -*F SyIsReadableFile( ) . . . . . . . . . . . is file readable -** -** 'SyIsReadableFile' returns 1 if the file is readable and 0 -** otherwise. is a system dependent description of the file. -*/ - - -/**************************************************************************** -** -*f SyIsReadableFile( ) . . . . . . . . . . . . . . . . BSD/Mach/USG -*/ -#if SYS_BSD || SYS_MACH || SYS_USG - -Int SyIsReadableFile ( Char * name ) -{ - if ( access( name, R_OK ) == 0 ) { - return 1; - } - else { - return 0; - } -} - -#endif - - -/**************************************************************************** -** -*F SyIsWritable( ) . . . . . . . . . . . is the file writable -** -** 'SyIsWriteableFile' returns 1 if the file is writable and 0 -** otherwise. is a system dependent description of the file. -*/ + *b = '\0'; + syWinPut( 1, "@w", buf ); + /* send the string to the window handler */ + syWinPut( 1, "", str ); -/**************************************************************************** -** -*f SyIsWritable( ) . . . . . . . . . . . . . . . . . . BSD/Mach/USG -*/ -#if SYS_BSD || SYS_MACH || SYS_USG + /* read the length of the answer */ + s = WinCmdBuffer; + i = 10; + do { + while ( 0 < i ) { + len = read( 0, s, i ); + i -= len; + s += len; + } + if ( WinCmdBuffer[0] == '@' && WinCmdBuffer[1] == 'y' ) { + for ( i = 2; i < 10; i++ ) + WinCmdBuffer[i-2] = WinCmdBuffer[i]; + s -= 2; + i = 2; + } + } while ( 0 < i ); + if ( WinCmdBuffer[0] != '@' || WinCmdBuffer[1] != 'a' ) + return "I1+S41000000Illegal Answer"; + for ( len = 0, i = 9; 1 < i; i-- ) + len = len*10 + (WinCmdBuffer[i]-'0'); -Int SyIsWritableFile ( Char * name ) -{ - if ( access( name, W_OK ) == 0 ) { - return 1; + /* read the arguments of the answer */ + s = WinCmdBuffer; + i = len; + while ( 0 < i ) { + len = read( 0, s, i ); + i -= len; + s += len; } - else { - return 0; + + /* shrink '@@' into '@' */ + for ( b = s = WinCmdBuffer; 0 < len; len-- ) { + if ( *s == '@' ) { + s++; + if ( *s == '@' ) + *b++ = '@'; + else if ( 'A' <= *s && *s <= 'Z' ) + *b++ = CTR(*s); + s++; + } + else { + *b++ = *s++; + } } + *b = 0; + + /* return the string */ + return WinCmdBuffer; } #endif +#if SYS_MAC_MPW || SYS_MAC_SYC -/**************************************************************************** -** -*F SyIsExecutableFile( ) . . . . . . . . . is file executable -** -** 'SyIsExecutableFile' returns 1 if the file is executable and 0 -** otherwise. is a system dependent description of the file. -*/ - - -/**************************************************************************** -** -*f SyIsExecutableFile( ) . . . . . . . . . . . . . . . BSD/Mach/USG -*/ -#if SYS_BSD || SYS_MACH || SYS_USG - -Int SyIsExecutableFile ( Char * name ) +Char * SyWinCmd ( + Char * str, + UInt len ) { - if ( access( name, X_OK ) == 0 ) { - return 1; - } - else { - return 0; - } + return 0; } #endif @@ -4011,31 +2786,14 @@ Int SyIsExecutableFile ( Char * name ) /**************************************************************************** ** -*F SyFindGapRootFile( ) . . . . . . . . find file in system area -*/ -Char * SyFindGapRootFile ( Char * filename ) -{ - static Char result [256]; - Int k; - for ( k=0; k, , , ) load or link ** ** 'SyFindOrLinkGapRootFile' tries to find a GAP file in the root area and @@ -4198,162 +2956,6 @@ Int SyFindOrLinkGapRootFile ( /**************************************************************************** ** -*F SyExit( ) . . . . . . . . . . . . . exit GAP with return code -** -** 'SyExit' is the offical way to exit GAP, bus errors are the inoffical. -** The function 'SyExit' must perform all the neccessary cleanup operations. -** If ret is 0 'SyExit' should signal to a calling proccess that all is ok. -** If ret is 1 'SyExit' should signal a failure to the calling proccess. -*/ -#ifndef SYS_STDLIB_H /* ANSI standard functions */ -# if SYS_ANSI -# include -# endif -# define SYS_STDLIB_H -#endif - -#ifndef SYS_HAS_MISC_PROTO /* ANSI/TRAD decl. from H&S 19.3 */ -extern void exit ( int ); -#endif - -#if SYS_MAC_SYC -#ifndef SYS_CONSOLE_H /* console stuff */ -# include /* 'console_options' */ -# define SYS_CONSOLE_H -#endif -#endif - -void SyExit ( - UInt ret ) -{ -#if SYS_MAC_MPW -# ifndef SYS_HAS_TOOL - fputs("gap: please use

) . . . . . . for a nilpotent group and a prime +## +InstallMethod( SylowSubgroupOp, + "method for a nilpotent group, and a prime", + true, + [ IsGroup and IsNilpotentGroup, IsPosRat and IsInt ], 0, + function( G, p ) + local gens, g, ord; + + gens:= []; + for g in GeneratorsOfGroup( G ) do + ord:= Order( g ); + if ord mod p = 0 then + while ord mod p = 0 do + ord:= ord / p; + od; + Add( gens, g^ord ); + fi; + od; + + return SubgroupNC( G, gens ); + end ); + + ############################################################################# ## #M \=( , ) . . . . . . . . . . . . . . test if two groups are equal diff --git a/lib/grpffmat.gi b/lib/grpffmat.gi index 8662949379..ca9b1f73b9 100644 --- a/lib/grpffmat.gi +++ b/lib/grpffmat.gi @@ -21,7 +21,7 @@ IsGeneralLinearGroupWithFormRep := NewRepresentation ( "IsGeneralLinearGroupWithFormRep", IsMatrixGroup, [ "form" ] ); IsGeneralUnitaryGroupWithFormRep := NewRepresentation - ( "IsGeneralLinearGroupWithFormRep", IsMatrixGroup, [ "form" ] ); + ( "IsGeneralUnitaryGroupWithFormRep", IsMatrixGroup, [ "form" ] ); ############################################################################# ## @@ -43,6 +43,7 @@ InstallMethod( \in, IsElmsColls, row -> OnTuples( row, f ) ) = G!.form; end ); + ############################################################################# ## #M FieldOfMatrixGroup( ) @@ -121,8 +122,21 @@ function( grp ) Size( FieldOfMatrixGroup( Parent(grp) ) ) ) ); end ); -InstallMethod( IsomorphismPermGroup, "return Niceomorphism",true, - [IsFFEMatrixGroup],0,NiceMonomorphism); + +############################################################################# +## +#M IsomorphismPermGroup( ) . . . . . . . . . operation on vector space +## +InstallMethod( IsomorphismPermGroup, "ffe matrix group", true, + [ IsFFEMatrixGroup ], 0, + function( grp ) + local nice; + + nice := NicomorphismOfFFEMatrixGroup( grp ); + SetRange( nice, Image( nice ) ); + SetIsBijective( nice, true ); + return nice; +end ); ############################################################################# ## diff --git a/lib/grpmat.gi b/lib/grpmat.gi index 3290ad3fb8..8e33a2d95a 100644 --- a/lib/grpmat.gi +++ b/lib/grpmat.gi @@ -11,6 +11,8 @@ Revision.grpmat_gi := "@(#)$Id$"; +InstallMethod( KnowsHowToDecompose, "matrix groups", true, + [ IsMatrixGroup, IsList ], 0, ReturnFalse ); ############################################################################# ## @@ -42,6 +44,11 @@ InstallMethod( DefaultFieldOfMatrixGroup, "from one in char 0", true, else TryNextMethod(); fi; end ); +InstallOtherMethod( DefaultFieldOfMatrixGroup, + "from source of nice monomorphism", true, + [ IsMatrixGroup and HasNiceMonomorphism ], 0, + grp -> DefaultFieldOfMatrixGroup( Source( NiceMonomorphism( grp ) ) ) ); + ############################################################################# ## @@ -61,6 +68,11 @@ InstallMethod( DimensionOfMatrixGroup, "from one", true, [ IsMatrixGroup and HasOne ], 1, grp -> Length( One( grp ) ) ); +InstallOtherMethod( DimensionOfMatrixGroup, + "from source of nice monomorphism", true, + [ IsMatrixGroup and HasNiceMonomorphism ], 0, + grp -> DimensionOfMatrixGroup( Source( NiceMonomorphism( grp ) ) ) ); + ############################################################################# ## @@ -70,20 +82,45 @@ InstallOtherMethod( One, true, [ IsMatrixGroup ], 0, grp -> IdentityMat( DimensionOfMatrixGroup( grp ), DefaultFieldOfMatrixGroup( grp ) ) ); +InstallOtherMethod( One, "from source of nice monomorphism", true, + [ IsMatrixGroup and HasNiceMonomorphism ], 0, + grp -> One( Source( NiceMonomorphism( grp ) ) ) ); + ############################################################################# ## -#M NiceMonomorphism( ) +#M IsomorphismPermGroup( ) ## -InstallMethod( NiceMonomorphism, true, [ IsMatrixGroup and IsFinite ], 0, +InstallMethod( IsomorphismPermGroup, true, [ IsMatrixGroup and IsFinite ], 0, function( grp ) local nice; nice := SparseOperationHomomorphism( grp, One( grp ) ); - SetIsInjective( nice, true ); + SetRange( nice, Image( nice ) ); + SetIsBijective( nice, true ); + SetBase( nice!.externalSet, One( grp ) ); + SetFilterObj( nice, IsOperationHomomorphismByBase ); return nice; end ); +############################################################################# +## +#M NiceMonomorphism( ) +## +InstallMethod( NiceMonomorphism, true, [ IsMatrixGroup and IsFinite ], 0, + IsomorphismPermGroup ); +# function( grp ) +# local nice; +# +# nice := IsomorphismPermGroup( grp ); +# SetNiceMonomorphism( grp, nice ); +# if IsSolvableGroup( Image( nice ) ) then +# nice := nice * IsomorphismPcGroup( Image( nice ) ); +# SetNiceMonomorphism( grp, nice ); +# fi; +# return nice; +#end ); + ############################################################################# ## diff --git a/lib/grpnice.gi b/lib/grpnice.gi index fee450ad0c..79f98a3be8 100644 --- a/lib/grpnice.gi +++ b/lib/grpnice.gi @@ -72,7 +72,19 @@ InstallMethod( NiceObject, 0, function( G ) - return ImagesSet( NiceMonomorphism(G), G ); + local nice, img, D; + + nice := NiceMonomorphism( G ); + img := ImagesSet( nice, G ); + if IsOperationHomomorphism( nice ) and HasBase( nice!.externalSet ) then + if not IsBound( nice!.externalSet!.basePermImage ) then + D := HomeEnumerator( nice!.externalSet ); + nice!.externalSet!.basePermImage := List + ( Base( nice!.externalSet ), b -> PositionCanonical( D, b ) ); + fi; + SetBase( img, nice!.externalSet!.basePermImage ); + fi; + return img; end ); diff --git a/lib/grppc.gi b/lib/grppc.gi index 32de4c9836..a04ddbb0d4 100644 --- a/lib/grppc.gi +++ b/lib/grppc.gi @@ -1227,9 +1227,9 @@ end); ############################################################################# ## -#F ChiefSeriesPcGroup(G) +#F ChiefSeriesUnderActionPcGroup( , ) ## -ChiefSeriesPcGroup := function(G) +ChiefSeriesUnderActionPcGroup := function( U, G ) local e,ser,i,j,k,pcgs,mpcgs,op,m,cs,n; e:=ElementaryAbelianSeries(G); ser:=[G]; @@ -1240,7 +1240,7 @@ local e,ser,i,j,k,pcgs,mpcgs,op,m,cs,n; else pcgs:=InducedPcgsWrtHomePcgs(e[i-1]); mpcgs:=pcgs mod InducedPcgsWrtHomePcgs(e[i]); - op:=LinearOperationLayer(GeneratorsOfGroup(G),mpcgs); + op:=LinearOperationLayer(GeneratorsOfGroup(U),mpcgs); m:=GModuleByMats(op,GF(RelativeOrderOfPcElement(pcgs,pcgs[1]))); cs:=MTX.BasesCompositionSeries(m); Sort(cs,function(a,b) return Length(a)>Length(b);end); @@ -1257,9 +1257,17 @@ local e,ser,i,j,k,pcgs,mpcgs,op,m,cs,n; od; return ser; end; +#T why not installed directly as method? + +ChiefSeriesPcGroup := G -> ChiefSeriesUnderActionPcGroup( G, G ); +#T necessary at all? + +InstallMethod( ChiefSeriesUnderAction, + "method for a pcgs computable group", + IsIdentical, + [ IsGroup, IsGroup and IsPcgsComputable ], 0, + ChiefSeriesUnderActionPcGroup ); -InstallMethod(ChiefSeries,"pc group",true,[IsPcGroup],0, - ChiefSeriesPcGroup); ############################################################################# ## diff --git a/lib/help.g b/lib/help.g new file mode 100644 index 0000000000..3e4a073751 --- /dev/null +++ b/lib/help.g @@ -0,0 +1,620 @@ +############################################################################# +## +#W help.g GAP Library Frank Celler +## +#H @(#)$Id$ +## +#Y Copyright (C) 1996, Lehrstuhl D fuer Mathematik, RWTH Aachen, Germany +## +## This file contains the help system. +## +Revision.help_g := + "@(#)$Id$"; + + +############################################################################# +## + +#F MATCH_BEGIN_LOWER( , ) +## +MATCH_BEGIN_LOWER := function( a, b ) + local l, u, i, p, aa, bb; + + l := "abcdefghijklmnopqrstuvwxyz"; + u := "ABCDEFGHIJKLMNOPQRSTUVWXYZ"; + + if 0 = Length(b) or Length(a) < Length(b) then + return false; + fi; + + for i in [ 1 .. Length(b) ] do + p := Position( u, a[i] ); + if p = fail then aa := a[i]; else aa := l[p]; fi; + p := Position( u, b[i] ); + if p = fail then bb := b[i]; else bb := l[p]; fi; + if aa <> bb then + return false; + fi; + od; + return true; + +end; + + +############################################################################# +## +#F MATCH_BEGIN( , ) +## +MATCH_BEGIN := function( a, b ) + + if 0 = Length(b) or Length(a) < Length(b) then + return false; + fi; + return a{[1..Length(b)]} = b; + +end; + + +############################################################################# +## +#F FILLED_LINE( , , ) +## +FILLED_LINE := function( l, r, f ) + local w, n; + + w := SizeScreen()[1] - 8; + w := w - Length(l) - Length(r); + n := ShallowCopy(l); + Add( n, ' ' ); + if 0 < w then + while 0 < w do + Add( n, f ); + w := w - 1; + od; + fi; + Add( n, ' ' ); + Append( n, r ); + + return n; + +end; + + +############################################################################# +## +#F HELP_PRINT_LINES( ) +## +HELP_PRINT_LINES := function( lines ) + local size, stream, count, halt, line, i, char; + + size := SizeScreen(); + stream := InputTextFile("*errin*"); + count := 0; + halt := " -- for more, to quit --"; + for line in lines do + if count = size[2]-1 then + Print( halt, "\c" ); + for i in halt do Print( "\b" ); od; + Print( "\c" ); + char := ReadByte(stream); + for i in halt do Print( " " ); od; + for i in halt do Print( "\b" ); od; + Print( "\c" ); + if char = 113 or char = 81 then + Print( "\n" ); + return; + elif char = 13 then + count := size[2]-2; + else + count := 1; + fi; + fi; + Print( " ", line, "\n" ); + count := count+1; + od; + CloseStream(stream); + +end; + + +############################################################################# +## +#V HELP_BOOKS_INFO +## +HELP_BOOKS_INFO := rec(); + + +############################################################################# +## +#V HELP_MAIN_BOOKS +## +HELP_MAIN_BOOKS := Immutable( [ + "tutorial", "tut", "GAP 4 Tutorial", + "reference", "tut", "GAP 4 Reference Manual" +] ); + + +############################################################################# +## + +#F HELP_BOOK_INFO( ) +## +HELP_BOOK_INFO := function( book ) + local nums, readNumber, path, i, bnam, six, stream, c, + s, f, line, c1, c2, pos, name, num, x, s1, sec, + dirs; + + if 0 = Length(book) then + return fail; + fi; + + # numbers + nums := "0123456789"; + readNumber := function( str ) + local n; + + while str[pos] = ' ' do + pos := pos+1; + od; + n := 0; + while str[pos] <> '.' do + n := n * 10 + (Position(nums,str[pos])-1); + pos := pos+1; + od; + pos := pos+1; + return n; + end; + + # check if this is a book from the main library + path := false; + for i in [ 1, 4 .. Length(HELP_MAIN_BOOKS)-2 ] do + if MATCH_BEGIN_LOWER( HELP_MAIN_BOOKS[i], book ) then + path := HELP_MAIN_BOOKS[i+1]; + break; + fi; + od; + + # otherwise it is a share package + if path = false then + path := Concatenation( "pkg/", book, "/doc" ); + bnam := Concatenation( "Share Package '", book, "'" ); + else + path := Concatenation( "doc/", path ); + bnam := HELP_MAIN_BOOKS[i+2]; + fi; + + # get the filename of the "manual.six" file + dirs := DirectoriesLibrary( path ); + six := Filename( dirs, "manual.six" ); + if six = fail then + return fail; + fi; + + # read the file if we haven't see it yet + if not IsBound(HELP_BOOKS_INFO.(bnam)) then + + # read the "manual.six" line by line + stream := InputTextFile(six); + c := []; s := []; x := []; f := []; + repeat + line := ReadLine(stream); + if line <> fail then + if line[1] = 'C' then + if line{[1..10]} <> "C appendix" then + Add( c, line{[3..Length(line)-1]} ); + fi; + elif line[1] = 'S' then + Add( s, line{[3..Length(line)-1]} ); + elif line[1] = 'I' then + Add( x, line ); + elif line[1] = 'F' then + Add( f, line ); + else + Print( "#W corrupted 'manual.six': ", line ); + fi; + fi; + until IsEndOfStream(stream); + CloseStream(stream); + + # parse the chapters information + c1 := []; + c2 := []; + for i in c do + + # first the filename + pos := Position( i, ' ' ); + name := i{[1..pos-1]}; + + # then the chapter number + num := readNumber(i); + + # then the chapter name + while i[pos] = ' ' do pos := pos+1; od; + + # store that information in and + c1[num] := name; + c2[num] := i{[pos..Length(i)]}; + od; + + # parse the sections information + s1 := List( c1, x -> [] ); + for i in s do + + # chapter and section number + pos := 1; + num := readNumber(i); + sec := readNumber(i); + + # then the section name + while i[pos] = ' ' do pos := pos+1; od; + + # store the information in + s1[num][sec] := i{[pos..Length(i)]}; + od; + + + + HELP_BOOKS_INFO.(bnam) := rec( + bookname := Immutable(bnam), + directories := dirs, + filenames := Immutable(c1), + chapters := Immutable(c2), + sections := Immutable(s1), + secposs := [], + chappos := [], + index := x, + functions := f + ); + fi; + + return HELP_BOOKS_INFO.(bnam); + +end; + + +############################################################################# +## +#F HELP_CHAPTER_INFO( , ) +## +HELP_CHAPTER_BEGIN := Immutable("\\Chapter"); +HELP_SECTION_BEGIN := Immutable("\\Section"); + +HELP_CHAPTER_INFO := function( book, chapter ) + local info, filename, stream, poss, secnum, pos, line; + + # get the book info + info := HELP_BOOK_INFO(book); + + # read in a chapter + if not IsBound(info.secposs[chapter]) then + + filename := Filename( info.directories, info.filenames[chapter] ); + if filename = fail then + return fail; + fi; + stream := InputTextFile(filename); + poss := []; + secnum := 0; + repeat + pos := PositionStream(stream); + line := ReadLine(stream); + if line <> fail then + if MATCH_BEGIN( line, HELP_SECTION_BEGIN ) then + secnum := secnum + 1; + poss[secnum] := pos; + elif MATCH_BEGIN( line, HELP_CHAPTER_BEGIN ) then + info.chappos[chapter] := pos; + fi; + fi; + until IsEndOfStream(stream); + CloseStream(stream); + info.secposs[chapter] := Immutable(poss); + fi; + + # return the info + return [ info.chappos[chapter], info.secposs[chapter] ]; + +end; + + +############################################################################# +## +#F HELP_PRINT_SECTION( , ,