From c1de180e137afa60ca2942a270d5259f55229753 Mon Sep 17 00:00:00 2001 From: Viktor Szakats Date: Thu, 2 Dec 1999 00:17:21 +0000 Subject: [PATCH] 19991202-00:54 GMT+1 Victor Szel --- harbour/ChangeLog | 53 ++++++++ harbour/doc/pragma.txt | 49 ++++--- harbour/makefile.b32 | 37 ++++-- harbour/rdd.b32 | 4 +- harbour/source/rdd/dbnubs.c | 46 +++---- harbour/source/rtl/Makefile | 152 +++++++++++---------- harbour/source/rtl/break.c | 76 +++++++++++ harbour/source/rtl/empty.c | 119 +++++++++++++++++ harbour/source/rtl/initexit.c | 75 +++++++++++ harbour/source/rtl/len.c | 103 ++++++++++++++ harbour/source/rtl/pcount.c | 80 +++++++++++ harbour/source/rtl/proc.c | 202 ++++++++++++++++++++++++++++ harbour/source/rtl/pvalue.c | 83 ++++++++++++ harbour/source/rtl/type.c | 69 ++++++++++ harbour/source/rtl/valtype.c | 119 +++++++++++++++++ harbour/source/rtl/word.c | 77 +++++++++++ harbour/source/rtl/xhelp.c | 80 +++++++++++ harbour/source/vm/hvm.c | 244 ---------------------------------- harbour/tests/multiarg.prg | 2 +- 19 files changed, 1300 insertions(+), 370 deletions(-) create mode 100644 harbour/source/rtl/break.c create mode 100644 harbour/source/rtl/empty.c create mode 100644 harbour/source/rtl/initexit.c create mode 100644 harbour/source/rtl/len.c create mode 100644 harbour/source/rtl/pcount.c create mode 100644 harbour/source/rtl/proc.c create mode 100644 harbour/source/rtl/pvalue.c create mode 100644 harbour/source/rtl/type.c create mode 100644 harbour/source/rtl/valtype.c create mode 100644 harbour/source/rtl/word.c create mode 100644 harbour/source/rtl/xhelp.c diff --git a/harbour/ChangeLog b/harbour/ChangeLog index 1fa7055d53..1f51ed7934 100644 --- a/harbour/ChangeLog +++ b/harbour/ChangeLog @@ -1,3 +1,56 @@ +19991202-00:54 GMT+1 Victor Szel + * source/rtl/Makefile + + New files added to the GNU make system. + * source/rtl/pvalue.c + tests/multiarg.prg + * HB_ prefix added to the PVALUE() function name. + +19991202-00:54 GMT+1 Jose Lalin + * source/rdd/dbnubs.c + ! Warnings fixed. + * source/vm/hvm.c + - Removed all of this functions. + + source/rtl/break.c + + HARBOUR HB_BREAK( void ) + + source/rtl/empty.c + + HARBOUR HB_EMPTY( void ) + % Added support for MEMO type. + + source/rtl/initexit.c + + HARBOUR HB___QUIT( void ) + + source/rtl/len.c + + HARBOUR HB_LEN( void ) + % Added support for MEMO type. + + source/rtl/pcount.c + + HARBOUR HB_PCOUNT( void ) + + source/rtl/proc.c + + HARBOUR HB_PROCNAME( void ) + + HARBOUR HB_PROCLINE( void ) + + HARBOUR HB_PROCFILE( void ) + + source/rtl/pvalue.c + + HARBOUR HB_PVALUE( void ) + + source/rtl/type.c + + HARBOUR HB_TYPE( void ) + + source/rtl/valtype.c + + HARBOUR HB_VALTYPE( void ) + % Added support for MEMO type. + + source/rtl/word.c + + HARBOUR HB_WORD( void ) + + source/rtl/xhelp.c (it should go to harbinit.prg) + + HARBOUR HB___XHELP( void ) + * All of them: + + Added License agreement. + + Added documentation. + + Formatting + * makefile.b32 + + Updated with this new modules. + ! WARNING ! Remember to update other makefiles. + * rdd.b32 + + Added dbeval.prg + * doc/pragma.txt + ! Some typos fixed. + ! Formatting. + (Uploaded by Victor Szel) + 19991130-04:30 EST Paul Tucker * source/pp/hbpp.c * added a cast on xgrab call. diff --git a/harbour/doc/pragma.txt b/harbour/doc/pragma.txt index 639afda94d..f1840f4a95 100644 --- a/harbour/doc/pragma.txt +++ b/harbour/doc/pragma.txt @@ -4,26 +4,32 @@ INTRODUCTION ============ -This file explains what is and how to use #pragma directive in Harbour. +This file explains what is and how to use the #pragma directive +with Harbour. + + +WHAT IS +======= +The #pragma is a directive used inside the source code in many compilers +to change the behaviour of the compiler at compile time. -PRAGMA -====== -The #pragma is a directive used in many compilers to change at compile -time some flags inside the compiler itself. USAGE ===== -Currently the #pragma directive can be used in two ways: switch mode and -command mode. +Currently the #pragma directive can be used in two ways: the switch mode +and the command mode. -The syntax is: #pragma [=On/Off] or - #pragma -CompilerFlag[+|-] +The syntax is: #pragma [=On/Off] or + #pragma -CompilerFlag[+|-] -Remember thar you can use both modes mixed in the same module and -upper/lower case without worry. +You can use both modes mixed in the same module and upper/lower case +without worry. -To enable/disable a command you simply do: =On/Off and -for switches you do: /+/- +To enable or disable a command or a switch you simply do: + + * Command mode Switch mode + -------------------------------------------------------------- + * #pragma =On/Off #pragma /+/- Example: #pragma AddDebugInfo=Off /* Suppress debug info */ #pragma /B+ /* Add debug info from here */ @@ -32,7 +38,7 @@ for switches you do: /+/- IMPLEMENTATION ============== -This is the list of the supported commands and switchs: +This is the list of the supported commands and switches: * Command Switch ----------------------------------------------- @@ -47,20 +53,22 @@ This is the list of the supported commands and switchs: * WARNINGLEVEL = /W * SHORTCUTTING = /Z<+/-> - The switchs have the same behaviour as the corresponding compiler ones - and the commands are sinonyms for the switchs. + The switches have the same behaviour as the corresponding compiler ones + and the commands are sinonyms for the switches. * TRACEPRAGMAS - This command shows pragma activity when enabled. + This command shows pragma activity at compile time when enabled. + + NOTE: You can use the abbreviated commands mode by typing only the + first eight chars. - NOTE: you can use the abbreviated commands mode by typing only the - first ten chars. NOTES ===== This directive is not supported in the standalone version of the Harbour preprocessor. + EXAMPLES ======== @@ -74,6 +82,7 @@ This is the same as calling Harbour with the -n switch in the command line, but with the great benefit that if you forgot to pass the switch if will be used anyway because it is included inside the source. -======= +=========== +Dec 1, 1999 Regards, Jose Lalin diff --git a/harbour/makefile.b32 b/harbour/makefile.b32 index c95d5e6d5b..0e8f1f8629 100644 --- a/harbour/makefile.b32 +++ b/harbour/makefile.b32 @@ -25,25 +25,29 @@ PROJECT: harbour.exe harbour.lib lib\b32\terminal.lib lib\b32\termwin.lib harbour.lib : achoice.obj adir.obj alert.obj arrays.obj \ asort.obj binnum.obj browdb.obj browse.obj \ - classes.obj cmdarg.obj codebloc.obj copyfile.obj \ - dates.obj dates2.obj datesx.obj dbedit.obj dbstrux.obj \ - debug.obj debugger.obj descend.obj devoutp.obj \ - dir.obj dircmd.obj do.obj dynsym.obj dummy.obj \ - environ.obj errorapi.obj errorsys.obj extend.obj \ + break.obj classes.obj cmdarg.obj codebloc.obj \ + copyfile.obj dates.obj dates2.obj datesx.obj \ + dbedit.obj dbstrux.obj debug.obj debugger.obj \ + descend.obj devoutp.obj dir.obj dircmd.obj do.obj \ + dynsym.obj dummy.obj empty.obj environ.obj \ + errorapi.obj errorsys.obj extend.obj \ fieldbl.obj fileread.obj filesys.obj fm.obj \ - harbinit.obj hardcr.obj hbfsapi.obj hbstr.obj hbtrace.obj hb_f.obj hvm.obj \ + harbinit.obj hardcr.obj hbfsapi.obj hbstr.obj \ + hbtrace.obj hb_f.obj hvm.obj initexit.obj \ initsymb.obj inkey.obj input.obj isprint.obj itemapi.obj \ - langapi.obj mainstd.obj mainwin.obj math.obj \ + langapi.obj len.obj mainstd.obj mainwin.obj math.obj \ mathx.obj memofile.obj memoline.obj memvars.obj \ memvarbl.obj menuto.obj mlcount.obj mtran.obj msgen.obj \ natmsg.obj net.obj objfunc.obj oldbox.obj oldclear.obj \ - readvar.obj readkey.obj \ + pcount.obj proc.obj pvalue.obj readvar.obj readkey.obj \ samples.obj set.obj setta.obj setcolor.obj \ setkey.obj setta.obj soundex.obj strfmt.obj \ strings.obj stringp.obj stringsx.obj symbols.obj \ tbcolumn.obj tbrowse.obj tbrwtext.obj tclass.obj \ terror.obj text.obj tget.obj tgetlist.obj tone.obj \ - transfrm.obj xsavescr.obj wait.obj + trace.obj transfrm.obj type.obj valtype.obj \ + wait.obj word.obj \ + xhelp.obj xsavescr.obj symbols.obj : symbols.asm @@ -53,6 +57,7 @@ alert.obj : alert.c extend.h hbdefs.h arrays.obj : arrays.c extend.h hbdefs.h asort.obj : asort.c extend.h hbdefs.h binnum.obj : binnum.c extend.h hbdefs.h +break.obj : break.c extend.h hbdefs.h browdb.obj : browdb.c extend.h hbdefs.h browse.obj : browse.c extend.h hbdefs.h classes.obj : classes.c extend.h hbdefs.h @@ -74,6 +79,7 @@ dircmd.obj : dircmd.c extend.h hbdefs.h do.obj : do.c extend.h hbdefs.h dynsym.obj : dynsym.c extend.h hbdefs.h dummy.obj : dummy.c extend.h hbdefs.h +empty.obj : empty.c extend.h hbdefs.h environ.obj : environ.c extend.h hbdefs.h errorapi.obj : errorapi.c extend.h hbdefs.h errorsys.obj : errorsys.c extend.h hbdefs.h @@ -89,12 +95,14 @@ hbstr.obj : hbstr.c extend.h hbdefs.h hbtrace.obj : hbtrace.c extend.h hbdefs.h hb_f.obj : hb_f.c extend.h hbdefs.h hvm.obj : hvm.c extend.h hbdefs.h +initexit.obj : initexit.c extend.h hbdefs.h initsymb.obj : initsymb.c extend.h hbdefs.h inkey.obj : inkey.c extend.h hbdefs.h input.obj : input.c extend.h hbdefs.h isprint.obj : isprint.c extend.h hbdefs.h itemapi.obj : itemapi.c extend.h hbdefs.h langapi.obj : langapi.c extend.h hbdefs.h +len.obj : len.c extend.h hbdefs.h mainstd.obj : mainstd.c extend.h hbdefs.h mainwin.obj : mainwin.c extend.h hbdefs.h math.obj : math.c extend.h hbdefs.h @@ -112,6 +120,9 @@ net.obj : net.c extend.h hbdefs.h objfunc.obj : objfunc.c extend.h hbdefs.h oldbox.obj : oldbox.c extend.h hbdefs.h oldclear.obj : oldclear.c extend.h hbdefs.h +pcount.obj : pcount.c extend.h hbdefs.h +proc.obj : proc.c extend.h hbdefs.h +pvalue.obj : pvalue.c extend.h hbdefs.h readkey.obj : readkey.c extend.h hbdefs.h readvar.obj : readvar.c extend.h hbdefs.h samples.obj : samples.c extend.h hbdefs.h @@ -133,9 +144,13 @@ text.obj : text.c extend.h hbdefs.h tget.obj : tget.c extend.h hbdefs.h tgetlist.obj : tgetlist.c extend.h hbdefs.h tone.obj : tone.c extend.h init.h inkey.h +trace.obj : trace.c extend.h init.h inkey.h transfrm.obj : transfrm.c extend.h hbdefs.h -xsavescr.obj : xsavescr.c extend.h hbdefs.h +type.obj : type.c extend.h hbdefs.h wait.obj : wait.c extend.h hbdefs.h +word.obj : word.c extend.h hbdefs.h +xhelp.obj : xhelp.c extend.h hbdefs.h +xsavescr.obj : xsavescr.c extend.h hbdefs.h achoice.c : achoice.prg harbour.exe adir.c : adir.prg harbour.exe @@ -168,8 +183,8 @@ terror.c : terror.prg harbour.exe text.c : text.prg harbour.exe tget.c : tget.prg harbour.exe tgetlist.c : tgetlist.prg harbour.exe -xsavescr.c : xsavescr.prg harbour.exe wait.c : wait.prg harbour.exe +xsavescr.c : xsavescr.prg harbour.exe .asm.obj: tasm32 $<, $@ diff --git a/harbour/rdd.b32 b/harbour/rdd.b32 index 4c2675c677..2fc20c7287 100644 --- a/harbour/rdd.b32 +++ b/harbour/rdd.b32 @@ -14,7 +14,7 @@ lib\b32\rdd.lib : rddsys.obj dbcmd.obj dbfntx1.obj dbfntx0.obj \ dbf0.obj dbf1.obj delim0.obj delim1.obj \ sdf0.obj sdf1.obj dbfcdx1.obj dbfcdx0.obj \ - dbnubs.obj rddord.obj + dbnubs.obj rddord.obj dbeval.obj dbf0.c : dbf0.prg dbfntx0.c : dbfntx0.prg @@ -23,6 +23,7 @@ sdf0.c : sdf0.prg delim0.c : delim0.prg dbfcdx0.c : dbfcdx0.prg rddord.c : rddord.prg +dbeval.c : dbeval.prg dbcmd.obj : dbcmd.c rddsys.obj : rddsys.c @@ -37,6 +38,7 @@ delim1.obj : delim1.c dbfcdx0.obj : dbfcdx0.c dbfcdx1.obj : dbfcdx1.c dbnubs.obj : dbnubs.c +dbeval.obj : dbeval.c .c.obj : bcc32 -c -O2 -Iinclude -o$@ -v $< diff --git a/harbour/source/rdd/dbnubs.c b/harbour/source/rdd/dbnubs.c index 1144013cc0..4bc469eb68 100644 --- a/harbour/source/rdd/dbnubs.c +++ b/harbour/source/rdd/dbnubs.c @@ -35,29 +35,29 @@ #include "hbdefs.h" -extern HARBOUR HB_DBSEEK(); -extern HARBOUR HB_DBSKIP(); -extern HARBOUR HB_DBGOTOP(); -extern HARBOUR HB_DBGOBOTTOM(); -extern HARBOUR HB_DBGOTO(); -extern HARBOUR HB_DBAPPEND(); -extern HARBOUR HB_DBDELETE(); -extern HARBOUR HB_DBRECALL(); -extern HARBOUR HB_DBCOMMITALL(); -extern HARBOUR HB_DBUNLOCK(); -extern HARBOUR HB_DBUNLOCKALL(); -extern HARBOUR HB_DBSETFILTER(); -extern HARBOUR HB_DBCLEARRELATION(); -extern HARBOUR HB_DBSETRELATION(); -extern HARBOUR HB_DBREINDEX(); -extern HARBOUR HB_DBCREATEINDEX(); -extern HARBOUR HB_DBCLEARINDEX(); -extern HARBOUR HB_DBSETINDEX(); -extern HARBOUR HB_DBSETORDER(); -extern HARBOUR HB_DBCLOSEALL(); -extern HARBOUR HB_DBCLOSEAREA(); -extern HARBOUR HB_DBUSEAREA(); -extern HARBOUR HB_DBSELECTAREA(); +extern HARBOUR HB_DBSEEK( void ); +extern HARBOUR HB_DBSKIP( void ); +extern HARBOUR HB_DBGOTOP( void ); +extern HARBOUR HB_DBGOBOTTOM( void ); +extern HARBOUR HB_DBGOTO( void ); +extern HARBOUR HB_DBAPPEND( void ); +extern HARBOUR HB_DBDELETE( void ); +extern HARBOUR HB_DBRECALL( void ); +extern HARBOUR HB_DBCOMMITALL( void ); +extern HARBOUR HB_DBUNLOCK( void ); +extern HARBOUR HB_DBUNLOCKALL( void ); +extern HARBOUR HB_DBSETFILTER( void ); +extern HARBOUR HB_DBCLEARRELATION( void ); +extern HARBOUR HB_DBSETRELATION( void ); +extern HARBOUR HB_DBREINDEX( void ); +extern HARBOUR HB_DBCREATEINDEX( void ); +extern HARBOUR HB_DBCLEARINDEX( void ); +extern HARBOUR HB_DBSETINDEX( void ); +extern HARBOUR HB_DBSETORDER( void ); +extern HARBOUR HB_DBCLOSEALL( void ); +extern HARBOUR HB_DBCLOSEAREA( void ); +extern HARBOUR HB_DBUSEAREA( void ); +extern HARBOUR HB_DBSELECTAREA( void ); HARBOUR HB___DBSEEK( void ) { diff --git a/harbour/source/rtl/Makefile b/harbour/source/rtl/Makefile index 5b53518e74..dcd6b7bb67 100644 --- a/harbour/source/rtl/Makefile +++ b/harbour/source/rtl/Makefile @@ -5,85 +5,97 @@ ROOT = ../../ C_SOURCES=\ - arrays.c \ - binnum.c \ - classes.c \ - codebloc.c \ - console.c \ - copyfile.c \ - dates.c \ - descend.c \ - dir.c \ - do.c \ - environ.c \ - errorapi.c \ - extend.c \ - filesys.c \ - fm.c \ - gtapi.c \ - hardcr.c \ - inkey.c \ - isprint.c \ - itemapi.c \ - langapi.c \ - math.c \ - memofile.c \ - memoline.c \ - memvars.c \ - mlcount.c \ - mouseapi.c \ - mtran.c \ - natmsg.c \ - net.c \ - oemansi.c \ - oldbox.c \ - oldclear.c \ - samples.c \ - set.c \ - setcolor.c \ - soundex.c \ - strings.c \ - tone.c \ - trace.c \ - transfrm.c \ + arrays.c \ + binnum.c \ + break.c \ + classes.c \ + codebloc.c \ + console.c \ + copyfile.c \ + dates.c \ + descend.c \ + dir.c \ + do.c \ + empty.c \ + environ.c \ + errorapi.c \ + extend.c \ + filesys.c \ + fm.c \ + gtapi.c \ + hardcr.c \ + initexit.c \ + inkey.c \ + isprint.c \ + itemapi.c \ + langapi.c \ + len.c \ + math.c \ + memofile.c \ + memoline.c \ + memvars.c \ + mlcount.c \ + mouseapi.c \ + mtran.c \ + natmsg.c \ + net.c \ + oemansi.c \ + oldbox.c \ + oldclear.c \ + pcount.c \ + proc.c \ + pvalue.c \ + samples.c \ + set.c \ + setcolor.c \ + soundex.c \ + strings.c \ + tone.c \ + trace.c \ + transfrm.c \ + type.c \ + valtype.c \ + word.c \ + xhelp.c \ \ - gtxxx.c \ - mousexxx.c \ - msgxxx.c \ + gtxxx.c \ + mousexxx.c \ + msgxxx.c \ PRG_SOURCES=\ - achoice.prg \ - adir.prg \ - alert.prg \ - asort.prg \ - browdb.prg \ - browse.prg \ - dbedit.prg \ - devoutp.prg \ - dircmd.prg \ - dummy.prg \ + achoice.prg \ + adir.prg \ + alert.prg \ + asort.prg \ + browdb.prg \ + browse.prg \ + dbedit.prg \ + devoutp.prg \ + dircmd.prg \ + dummy.prg \ errorsys.prg \ - fieldbl.prg \ + fieldbl.prg \ harbinit.prg \ - input.prg \ - memvarbl.prg \ - menuto.prg \ - objfunc.prg \ - readkey.prg \ - readvar.prg \ - setfunc.prg \ - setkey.prg \ - setta.prg \ - tclass.prg \ + input.prg \ + memvarbl.prg \ + menuto.prg \ + objfunc.prg \ + readkey.prg \ + readvar.prg \ + setfunc.prg \ + setkey.prg \ + setta.prg \ + tclass.prg \ tbcolumn.prg \ - tbrowse.prg \ - terror.prg \ - text.prg \ - tget.prg \ + tbrowse.prg \ + terror.prg \ + text.prg \ + tget.prg \ tgetlist.prg \ - wait.prg \ + wait.prg \ xsavescr.prg \ LIBNAME=rtl include $(TOP)$(ROOT)config/lib.cf + diff --git a/harbour/source/rtl/break.c b/harbour/source/rtl/break.c new file mode 100644 index 0000000000..1fef865a53 --- /dev/null +++ b/harbour/source/rtl/break.c @@ -0,0 +1,76 @@ +/* + * $Id$ + */ + +/* + * Harbour Project source code: + * BREAK() function + * + * Copyright 1999 {list of individual authors and e-mail addresses} + * www - http://www.harbour-project.org + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version, with one exception: + * + * The exception is that if you link the Harbour Runtime Library (HRL) + * and/or the Harbour Virtual Machine (HVM) with other files to produce + * an executable, this does not by itself cause the resulting executable + * to be covered by the GNU General Public License. Your use of that + * executable is in no way restricted on account of linking the HRL + * and/or HVM code into it. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA (or visit + * their web site at http://www.gnu.org/). + * + */ + +#include "extend.h" +#include "ctoharb.h" + +/* $DOC$ + * $FUNCNAME$ + * BREAK + * $CATEGORY$ + * + * $ONELINER$ + * Exits from a BEGIN SEQUENCE block + * $SYNTAX$ + * BREAK( ) --> NIL + * $ARGUMENTS$ + * is any valid expression. It is allways required. + * If do not want to pass any argument, just use NIL. + * $RETURNS$ + * NIL + * $DESCRIPTION$ + * This function pass the control to the RECOVER statement in a + * BEGIN SEQUENCE block. + * $EXAMPLES$ + * Break( NIL ) + * $TESTS$ + * $STATUS$ + * R + * $COMPLIANCE$ + * BREAK() is fully CA-Clipper compliant. + * $SEEALSO$ + * BEGIN SEQUENCE + * $END$ + */ + +/* NOTE: This function should normally have a parameter count check. But + since in Harbour we cannot distinguish between BREAK() function and + the BREAK statement, because both generate a BREAK() function + call on the pcode level, we should drop the checking. */ + +HARBOUR HB_BREAK( void ) +{ + hb_vmRequestBreak( hb_param( 1, IT_ANY ) ); +} diff --git a/harbour/source/rtl/empty.c b/harbour/source/rtl/empty.c new file mode 100644 index 0000000000..83009f1e92 --- /dev/null +++ b/harbour/source/rtl/empty.c @@ -0,0 +1,119 @@ +/* + * $Id$ + */ + +/* + * Harbour Project source code: + * EMPTY() function + * + * Copyright 1999 {list of individual authors and e-mail addresses} + * www - http://www.harbour-project.org + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version, with one exception: + * + * The exception is that if you link the Harbour Runtime Library (HRL) + * and/or the Harbour Virtual Machine (HVM) with other files to produce + * an executable, this does not by itself cause the resulting executable + * to be covered by the GNU General Public License. Your use of that + * executable is in no way restricted on account of linking the HRL + * and/or HVM code into it. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA (or visit + * their web site at http://www.gnu.org/). + * + */ + +#include "extend.h" +#include "itemapi.h" + +/* $DOC$ + * $FUNCNAME$ + * EMPTY + * $CATEGORY$ + * + * $ONELINER$ + * Checks if the passed argument is empty. + * $SYNTAX$ + * EMPTY( ) --> + * $ARGUMENTS$ + * is any valid expression. + * $RETURNS$ + * A logical value. It is true (.T.) if the passed argument is empty + * otherwise it is false (.F.). + * $DESCRIPTION$ + * This function checks if an expression has empty value and returns a + * logical indicating whether it the expression is empty or not. + * $EXAMPLES$ + * ? Empty( "I'm not empty" ) + * $TESTS$ + * function Test() + * ? Empty( 1 ) --> .f. + * ? Empty( Date() ) --> .f. + * ? Empty( .f. ) --> .t. + * return nil + * $STATUS$ + * R + * $COMPLIANCE$ + * EMPTY() is fully CA-Clipper compliant. + * $SEEALSO$ + * LEN + * $END$ + */ + +HARBOUR HB_EMPTY( void ) +{ + PHB_ITEM pItem = hb_param( 1, IT_ANY ); + + /* NOTE: pItem cannot be NULL here */ + + switch( pItem->type & ~IT_BYREF ) + { + case IT_ARRAY: + hb_retl( hb_arrayLen( pItem ) == 0 ); + break; + + case IT_STRING: + case IT_MEMO: + hb_retl( hb_strEmpty( hb_itemGetCPtr( pItem ), hb_itemGetCLen( pItem ) ) ); + break; + + case IT_INTEGER: + hb_retl( hb_itemGetNI( pItem ) == 0 ); + break; + + case IT_LONG: + hb_retl( hb_itemGetNL( pItem ) == 0 ); + break; + + case IT_DOUBLE: + hb_retl( hb_itemGetND( pItem ) == 0.0 ); + break; + + case IT_DATE: + /* NOTE: This is correct ! Get the date as long value. */ + hb_retl( hb_itemGetNL( pItem ) == 0 ); + break; + + case IT_LOGICAL: + hb_retl( ! hb_itemGetL( pItem ) ); + break; + + case IT_BLOCK: + hb_retl( FALSE ); + break; + + default: + hb_retl( TRUE ); + break; + } +} diff --git a/harbour/source/rtl/initexit.c b/harbour/source/rtl/initexit.c new file mode 100644 index 0000000000..238f06e2cf --- /dev/null +++ b/harbour/source/rtl/initexit.c @@ -0,0 +1,75 @@ +/* + * $Id$ + */ + +/* + * Harbour Project source code: + * __QUIT() function + * + * Copyright 1999 {list of individual authors and e-mail addresses} + * www - http://www.harbour-project.org + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version, with one exception: + * + * The exception is that if you link the Harbour Runtime Library (HRL) + * and/or the Harbour Virtual Machine (HVM) with other files to produce + * an executable, this does not by itself cause the resulting executable + * to be covered by the GNU General Public License. Your use of that + * executable is in no way restricted on account of linking the HRL + * and/or HVM code into it. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA (or visit + * their web site at http://www.gnu.org/). + * + */ + +#include "extend.h" +#include "ctoharb.h" + +/* $DOC$ + * $FUNCNAME$ + * __QUIT() + * $CATEGORY$ + * + * $ONELINER$ + * Terminates an application. + * $SYNTAX$ + * __QUIT() --> NIL + * $ARGUMENTS$ + * None + * $RETURNS$ + * NIL + * $DESCRIPTION$ + * This function terminates the current application and returns + * to the system. + * $EXAMPLES$ + * See Test + * $TESTS$ + * function EndApp( lYesNo ) + * if lYesNo + * __Quit() + * endif + * return nil + * $STATUS$ + * R + * $COMPLIANCE$ + * __QUIT() is fully CA-Clipper compliant. + * $SEEALSO$ + * QUIT command + * $END$ + */ + +HARBOUR HB___QUIT( void ) +{ + hb_vmRequestQuit(); +} diff --git a/harbour/source/rtl/len.c b/harbour/source/rtl/len.c new file mode 100644 index 0000000000..30f9f76f73 --- /dev/null +++ b/harbour/source/rtl/len.c @@ -0,0 +1,103 @@ +/* + * $Id$ + */ + +/* + * Harbour Project source code: + * LEN() function + * + * Copyright 1999 {list of individual authors and e-mail addresses} + * www - http://www.harbour-project.org + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version, with one exception: + * + * The exception is that if you link the Harbour Runtime Library (HRL) + * and/or the Harbour Virtual Machine (HVM) with other files to produce + * an executable, this does not by itself cause the resulting executable + * to be covered by the GNU General Public License. Your use of that + * executable is in no way restricted on account of linking the HRL + * and/or HVM code into it. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA (or visit + * their web site at http://www.gnu.org/). + * + */ + +#include "extend.h" +#include "errorapi.h" +#include "itemapi.h" + +/* $DOC$ + * $FUNCNAME$ + * LEN + * $CATEGORY$ + * + * $ONELINER$ + * Returns size of a string or size of an array. + * $SYNTAX$ + * LEN( ) --> + * $ARGUMENTS$ + * is a character string or the array to check. + * $RETURNS$ + * The length of the string or the number of elements that contains + * an array. + * $DESCRIPTION$ + * This function returns the string length or the size of an array. If + * it is used with a multidimensional array it returns the sizee of the + * first dimension. + * $EXAMPLES$ + * ? Len( "Harbour" ) --> 7 + * $TESTS$ + * function Test() + * LOCAL cName := "" + * ACCEPT "Enter your name: " TO cName + * ? Len( cName ) + * return nil + * $STATUS$ + * R + * $COMPLIANCE$ + * LEN() is fully CA-Clipper compliant. + * $SEEALSO$ + * EMPTY, RTRIM, LTRIM + * $END$ + */ + +HARBOUR HB_LEN( void ) +{ + PHB_ITEM pItem = hb_param( 1, IT_ANY ); + + /* NOTE: pItem cannot be NULL here */ + + switch( pItem->type ) + { + case IT_ARRAY: + hb_retnl( hb_arrayLen( pItem ) ); + break; + + case IT_STRING: + case IT_MEMO: + hb_retnl( hb_itemGetCLen( pItem ) ); + break; + + default: + { + PHB_ITEM pResult = hb_errRT_BASE_Subst( EG_ARG, 1111, NULL, "LEN" ); + + if( pResult ) + { + hb_itemReturn( pResult ); + hb_itemRelease( pResult ); + } + } + } +} diff --git a/harbour/source/rtl/pcount.c b/harbour/source/rtl/pcount.c new file mode 100644 index 0000000000..37ca6efca5 --- /dev/null +++ b/harbour/source/rtl/pcount.c @@ -0,0 +1,80 @@ +/* + * $Id$ + */ + +/* + * Harbour Project source code: + * PCOUNT() function + * + * Copyright 1999 {list of individual authors and e-mail addresses} + * www - http://www.harbour-project.org + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version, with one exception: + * + * The exception is that if you link the Harbour Runtime Library (HRL) + * and/or the Harbour Virtual Machine (HVM) with other files to produce + * an executable, this does not by itself cause the resulting executable + * to be covered by the GNU General Public License. Your use of that + * executable is in no way restricted on account of linking the HRL + * and/or HVM code into it. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA (or visit + * their web site at http://www.gnu.org/). + * + */ + +#include "extend.h" + +/* $DOC$ + * $FUNCNAME$ + * PCOUNT + * $CATEGORY$ + * + * $ONELINER$ + * Retrieves the number of arguments passed to a function. + * $SYNTAX$ + * PCOUNT() --> + * $ARGUMENTS$ + * None + * $RETURNS$ + * Returns a number that indicates the number of arguments + * passed to a function or procedure. + * $DESCRIPTION$ + * This function is useful to check if a function or procedure + * has received the required number of arguments. + * $EXAMPLES$ + * See Test + * $TESTS$ + * function Test( xExp ) + * if PCount() == 0 + * ? "This function needs a parameter" + * else + * ? xExp + * endif + * return nil + * $STATUS$ + * R + * $COMPLIANCE$ + * PCOUNT() is fully CA-Clipper compliant. + * $SEEALSO$ + * PVALUE + * $END$ + */ + +HARBOUR HB_PCOUNT( void ) +{ + /* Skip current function */ + PHB_ITEM pBase = hb_stack.pItems + hb_stack.pBase->item.asSymbol.stackbase; + + hb_retni( pBase->item.asSymbol.paramcnt ); +} diff --git a/harbour/source/rtl/proc.c b/harbour/source/rtl/proc.c new file mode 100644 index 0000000000..dc7b17670b --- /dev/null +++ b/harbour/source/rtl/proc.c @@ -0,0 +1,202 @@ +/* + * $Id$ + */ + +/* + * Harbour Project source code: + * PROCNAME(), PROCLINE() and PROCFILE() functions + * + * Copyright 1999 {list of individual authors and e-mail addresses} + * www - http://www.harbour-project.org + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version, with one exception: + * + * The exception is that if you link the Harbour Runtime Library (HRL) + * and/or the Harbour Virtual Machine (HVM) with other files to produce + * an executable, this does not by itself cause the resulting executable + * to be covered by the GNU General Public License. Your use of that + * executable is in no way restricted on account of linking the HRL + * and/or HVM code into it. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA (or visit + * their web site at http://www.gnu.org/). + * + */ + +/* + * The following parts are Copyright of the individual authors. + * www - http://www.harbour-project.org + * + * Copyright 1999 Victor Szel + * HB_PROCFILE() + * + * See doc/license.txt for licensing terms. + * + */ + +#include "extend.h" + +/* $DOC$ + * $FUNCNAME$ + * PROCNAME + * $CATEGORY$ + * + * $ONELINER$ + * Gets the name of the current function on the stack + * $SYNTAX$ + * PROCNAME( ) --> + * $ARGUMENTS$ + * is the function level required. + * $RETURNS$ + * Return the name of the function that it is being executed. + * $DESCRIPTION$ + * This function look at the top of the stack and gets the current + * executed function if no arguments are passed. Otherwise it returns + * the name of the function or procedure at . + * $EXAMPLES$ + * See Test + * $TESTS$ + * This test will show the functions and procedures in stack + * before executing it. + * function Test() + * LOCAL n := 1 + * while !Empty( ProcName( n ) ) + * ? ProcName( n++ ) + * end do + * return nil + * $STATUS$ + * R + * $COMPLIANCE$ + * PROCNAME() is fully CA-Clipper compliant. + * $SEEALSO$ + * PROCLINE, PROCFILE + * $END$ + */ + +HARBOUR HB_PROCNAME( void ) +{ + int iLevel = hb_parni( 1 ) + 1; /* we are already inside ProcName() */ + PHB_ITEM pBase = hb_stack.pBase; + + while( ( iLevel-- > 0 ) && pBase != hb_stack.pItems ) + pBase = hb_stack.pItems + pBase->item.asSymbol.stackbase; + + if( ( iLevel == -1 ) ) + { + if( ( pBase + 1 )->type == IT_ARRAY ) /* it is a method name */ + { + char * szProcName; + + szProcName = ( char * ) hb_xgrab( strlen( hb_objGetClsName( pBase + 1 ) ) + 1 + + strlen( pBase->item.asSymbol.value->szName ) + 1 ); + strcpy( szProcName, hb_objGetClsName( pBase + 1 ) ); + strcat( szProcName, ":" ); + strcat( szProcName, pBase->item.asSymbol.value->szName ); + hb_retc( szProcName ); + hb_xfree( ( void * ) szProcName ); + } + else + hb_retc( pBase->item.asSymbol.value->szName ); + } + else + hb_retc( "" ); +} + +/* $DOC$ + * $FUNCNAME$ + * PROCLINE + * $CATEGORY$ + * + * $ONELINER$ + * Gets the line number of the current function on the stack + * $SYNTAX$ + * PROCLINE( ) --> + * $ARGUMENTS$ + * is the function level required. + * $RETURNS$ + * Return the line number of the function that it is being executed. + * $DESCRIPTION$ + * This function look at the top of the stack and gets the current + * line number of executed function if no arguments are passed. + * Otherwise it returns the line number of the function or procedure + * at . + * $EXAMPLES$ + * See Test + * $TESTS$ + * function Test() + * ? ProcLine( 0 ) + * ? ProcName( 2 ) + * return nil + * $STATUS$ + * R + * $COMPLIANCE$ + * PROCLINE() is fully CA-Clipper compliant. + * $SEEALSO$ + * PROCNAME, PROCFILE + * $END$ + */ + +HARBOUR HB_PROCLINE( void ) +{ + int iLevel = hb_parni( 1 ) + 1; /* we are already inside ProcName() */ + PHB_ITEM pBase = hb_stack.pBase; + + while( ( iLevel-- > 0 ) && pBase != hb_stack.pItems ) + pBase = hb_stack.pItems + pBase->item.asSymbol.stackbase; + + if( iLevel == -1 ) + hb_retni( pBase->item.asSymbol.lineno ); + else + hb_retni( 0 ); +} + +/* $DOC$ + * $FUNCNAME$ + * PROCFILE + * $CATEGORY$ + * + * $ONELINER$ + * This function allways returns an empty string. + * $SYNTAX$ + * PROCFILE( ) --> + * $ARGUMENTS$ + * is any valid type. + * $RETURNS$ + * Return and empty string + * $DESCRIPTION$ + * This function is added to the RTL for full compatibility. It allways + * returns an empty string. + * $EXAMPLES$ + * ? ProcFile() + * $TESTS$ + * function Test() + * ? ProcFile() + * ? ProcFile( NIL ) + * ? ProcFile( 2 ) + * return nil + * $STATUS$ + * R + * $COMPLIANCE$ + * PROCFILE() is fully CA-Clipper compliant. + * $SEEALSO$ + * PROCNAME, PROCLINE + * $END$ + */ + +/* NOTE: Clipper undocumented function, which always returns an empty + string. */ + +HARBOUR HB_PROCFILE( void ) +{ + hb_retc( "" ); +} diff --git a/harbour/source/rtl/pvalue.c b/harbour/source/rtl/pvalue.c new file mode 100644 index 0000000000..4eb67bc734 --- /dev/null +++ b/harbour/source/rtl/pvalue.c @@ -0,0 +1,83 @@ +/* + * $Id$ + */ + +/* + * Harbour Project source code: + * HB_PVALUE() function + * + * Copyright 1999 Eddie Runia + * www - http://www.harbour-project.org + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version, with one exception: + * + * The exception is that if you link the Harbour Runtime Library (HRL) + * and/or the Harbour Virtual Machine (HVM) with other files to produce + * an executable, this does not by itself cause the resulting executable + * to be covered by the GNU General Public License. Your use of that + * executable is in no way restricted on account of linking the HRL + * and/or HVM code into it. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA (or visit + * their web site at http://www.gnu.org/). + * + */ + +#include "extend.h" +#include "errorapi.h" +#include "itemapi.h" + +/* $DOC$ + * $FUNCNAME$ + * HB_PVALUE + * $CATEGORY$ + * + * $ONELINER$ + * Retrieves the value of an argument. + * $SYNTAX$ + * HB_PVALUE( ) --> + * $ARGUMENTS$ + * A number that indicates the argument to check. + * $RETURNS$ + * Returns the value stored by an argument. + * $DESCRIPTION$ + * This function is useful to check the value stored in an argument. + * $EXAMPLES$ + * See Test + * $TESTS$ + * function Test( nValue, cString ) + * if PCount() == 2 + * ? hb_PValue( 1 ), nValue + * ? hb_PValue( 2 ), cString + * endif + * return nil + * $STATUS$ + * R + * $COMPLIANCE$ + * HB_PVALUE() is a new function and hence not CA-Clipper compliant. + * $SEEALSO$ + * PCOUNT + * $END$ + */ + +HARBOUR HB_HB_PVALUE( void ) +{ + USHORT uiParam = hb_parni( 1 ); + PHB_ITEM pBase = hb_stack.pItems + hb_stack.pBase->item.asSymbol.stackbase; /* Skip function + self */ + + if( uiParam && uiParam <= pBase->item.asSymbol.paramcnt ) /* Valid number */ + hb_itemReturn( pBase + 1 + uiParam ); + else + hb_errRT_BASE( EG_ARG, 3011, NULL, "HB_PVALUE" ); +} + diff --git a/harbour/source/rtl/type.c b/harbour/source/rtl/type.c new file mode 100644 index 0000000000..d7dbc50427 --- /dev/null +++ b/harbour/source/rtl/type.c @@ -0,0 +1,69 @@ +/* + * $Id$ + */ + +/* + * Harbour Project source code: + * TYPE() function + * + * Copyright 1999 {list of individual authors and e-mail addresses} + * www - http://www.harbour-project.org + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version, with one exception: + * + * The exception is that if you link the Harbour Runtime Library (HRL) + * and/or the Harbour Virtual Machine (HVM) with other files to produce + * an executable, this does not by itself cause the resulting executable + * to be covered by the GNU General Public License. Your use of that + * executable is in no way restricted on account of linking the HRL + * and/or HVM code into it. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA (or visit + * their web site at http://www.gnu.org/). + * + */ + +#include "extend.h" + +/* $DOC$ + * $FUNCNAME$ + * TYPE + * $CATEGORY$ + * + * $ONELINER$ + * Retrieves the type of an expression + * $SYNTAX$ + * TYPE( ) --> + * $ARGUMENTS$ + * is a character expression. + * $RETURNS$ + * Returns a character indicating the type of the passed expression. + * $DESCRIPTION$ + * This function returns one character which represents the date type + * of the argument. + * $EXAMPLES$ + * See Test + * $TESTS$ + * $STATUS$ + * S + * $COMPLIANCE$ + * TYPE() is + * $SEEALSO$ + * VALTYPE + * $END$ + */ + +HARBOUR HB_TYPE( void ) +{ + /* TODO: Implement this. */ +} diff --git a/harbour/source/rtl/valtype.c b/harbour/source/rtl/valtype.c new file mode 100644 index 0000000000..12bf1a0bb7 --- /dev/null +++ b/harbour/source/rtl/valtype.c @@ -0,0 +1,119 @@ +/* + * $Id$ + */ + +/* + * Harbour Project source code: + * VALTYPE() function + * + * Copyright 1999 {list of individual authors and e-mail addresses} + * www - http://www.harbour-project.org + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version, with one exception: + * + * The exception is that if you link the Harbour Runtime Library (HRL) + * and/or the Harbour Virtual Machine (HVM) with other files to produce + * an executable, this does not by itself cause the resulting executable + * to be covered by the GNU General Public License. Your use of that + * executable is in no way restricted on account of linking the HRL + * and/or HVM code into it. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA (or visit + * their web site at http://www.gnu.org/). + * + */ + +#include "extend.h" + +/* $DOC$ + * $FUNCNAME$ + * VALTYPE + * $CATEGORY$ + * + * $ONELINER$ + * Retrieves the data type of an expression + * $SYNTAX$ + * VALTYPE( ) --> + * $ARGUMENTS$ + * is any valid expression. + * $RETURNS$ + * Returns a character indicating the type of the passed expression. + * $DESCRIPTION$ + * This function returns one character which represents the date type + * of the argument. + * $EXAMPLES$ + * See Test + * $TESTS$ + * function Test() + * ? ValType( Array( 1 ) ) --> "A" + * ? ValType( {|| 1 + 1 } ) --> "B" + * ? ValType( "HARBOUR" ) --> "C" + * ? ValType( Date() ) --> "D" + * ? ValType( .T. ) --> "L" + * ? ValType( 1 ) --> "N" + * ? ValType( TBrowse() ) --> "O" + * ? ValType( NIL ) --> "U" + * return nil + * $STATUS$ + * R + * $COMPLIANCE$ + * VALTYPE() is fully CA-Clipper compliant. + * $SEEALSO$ + * TYPE + * $END$ + */ + +HARBOUR HB_VALTYPE( void ) +{ + PHB_ITEM pItem = hb_param( 1, IT_ANY ); + + /* NOTE: pItem cannot be NULL here */ + + switch( pItem->type & ~IT_BYREF ) + { + case IT_ARRAY: + hb_retc( hb_arrayIsObject( pItem ) ? "O" : "A" ); + break; + + case IT_BLOCK: + hb_retc( "B" ); + break; + + case IT_DATE: + hb_retc( "D" ); + break; + + case IT_LOGICAL: + hb_retc( "L" ); + break; + + case IT_INTEGER: + case IT_LONG: + case IT_DOUBLE: + hb_retc( "N" ); + break; + + case IT_STRING: + hb_retc( "C" ); + break; + + case IT_MEMOFLAG: + hb_retc( "M" ); + break; + + case IT_NIL: + default: + hb_retc( "U" ); + break; + } +} diff --git a/harbour/source/rtl/word.c b/harbour/source/rtl/word.c new file mode 100644 index 0000000000..ed078d75fd --- /dev/null +++ b/harbour/source/rtl/word.c @@ -0,0 +1,77 @@ +/* + * $Id$ + */ + +/* + * Harbour Project source code: + * WORD() function + * + * Copyright 1999 Victor Szel + * www - http://www.harbour-project.org + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version, with one exception: + * + * The exception is that if you link the Harbour Runtime Library (HRL) + * and/or the Harbour Virtual Machine (HVM) with other files to produce + * an executable, this does not by itself cause the resulting executable + * to be covered by the GNU General Public License. Your use of that + * executable is in no way restricted on account of linking the HRL + * and/or HVM code into it. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA (or visit + * their web site at http://www.gnu.org/). + * + */ + +#include "extend.h" +#include "errorapi.h" +#include "itemapi.h" + +/* $DOC$ + * $FUNCNAME$ + * WORD + * $CATEGORY$ + * + * $ONELINER$ + * Converts double to integer values. + * $SYNTAX$ + * WORD( ) --> + * $ARGUMENTS$ + * is a numeric double value. + * $RETURNS$ + * An integer in the range +-32767 + * $DESCRIPTION$ + * This function converts double values to integers to use + * within the CALL command + * $EXAMPLES$ + * $TESTS$ + * $STATUS$ + * R + * $COMPLIANCE$ + * WORD() is NOT fully CA-Clipper compliant. + * $SEEALSO$ + * CALL command + * $END$ + */ + +/* INCOMPATIBILITY: The Clipper NG states that WORD() will only work when used + in CALL commands parameter list, otherwise it will return + NIL, in Harbour it will work anywhere. */ + +HARBOUR HB_WORD( void ) +{ + if( ISNUM( 1 ) ) + hb_retni( hb_parni( 1 ) ); + else + hb_errRT_BASE( EG_ARG, 1091, NULL, "WORD" ); +} diff --git a/harbour/source/rtl/xhelp.c b/harbour/source/rtl/xhelp.c new file mode 100644 index 0000000000..761f13d941 --- /dev/null +++ b/harbour/source/rtl/xhelp.c @@ -0,0 +1,80 @@ +/* + * $Id$ + */ + +/* + * Harbour Project source code: + * __XHELP() function + * + * Copyright 1999 Victor Szel + * www - http://www.harbour-project.org + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version, with one exception: + * + * The exception is that if you link the Harbour Runtime Library (HRL) + * and/or the Harbour Virtual Machine (HVM) with other files to produce + * an executable, this does not by itself cause the resulting executable + * to be covered by the GNU General Public License. Your use of that + * executable is in no way restricted on account of linking the HRL + * and/or HVM code into it. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA (or visit + * their web site at http://www.gnu.org/). + * + */ + +#include "extend.h" +#include "ctoharb.h" + +/* $DOC$ + * $FUNCNAME$ + * __XHELP() + * $CATEGORY$ + * Internal + * $ONELINER$ + * Looks if a Help() user defined function exist. + * $SYNTAX$ + * __XHELP() --> + * $ARGUMENTS$ + * None + * $RETURNS$ + * This function returns aleatory values. + * $DESCRIPTION$ + * This is an internal undocumented Clipper function, which will + * try to call the user defined function HELP() if it's defined + * in the current application. This is the default SetKey() handler + * for the F1 key. + * $EXAMPLES$ + * $TESTS$ + * $STATUS$ + * R + * $COMPLIANCE$ + * __XHELP() is fully CA-Clipper compliant. + * $SEEALSO$ + * + * $END$ + */ + +HARBOUR HB___XHELP( void ) +{ + PHB_DYNS pDynSym = hb_dynsymFind( "HELP" ); + + if( pDynSym ) + { + hb_vmPushSymbol( pDynSym->pSymbol ); + hb_vmPushNil(); + hb_vmDo( 0 ); + + /* NOTE: Leave the return value as it is. */ + } +} diff --git a/harbour/source/vm/hvm.c b/harbour/source/vm/hvm.c index bbb500c21b..aa734b0912 100644 --- a/harbour/source/vm/hvm.c +++ b/harbour/source/vm/hvm.c @@ -37,11 +37,6 @@ * The following parts are Copyright of the individual authors. * www - http://www.harbour-project.org * - * Copyright 1999 Victor Szel - * HB_WORD() - * HB___XHELP() - * HB_PROCFILE() - * * Copyright 1999 Eddie Runia * HB___VMVARSGET() * HB___VMVARSLIST() @@ -3413,191 +3408,6 @@ void hb_vmForceLink( void ) /* ----------------------------- */ /* TODO: Put these to /source/rtl/?.c */ -HARBOUR HB_LEN( void ) -{ - PHB_ITEM pItem = hb_param( 1, IT_ANY ); - - /* NOTE: pItem cannot be NULL here */ - - switch( pItem->type ) - { - case IT_ARRAY: - hb_retnl( hb_arrayLen( pItem ) ); - break; - - case IT_STRING: - hb_retnl( hb_itemGetCLen( pItem ) ); - break; - - default: - { - PHB_ITEM pResult = hb_errRT_BASE_Subst( EG_ARG, 1111, NULL, "LEN" ); - - if( pResult ) - { - hb_itemReturn( pResult ); - hb_itemRelease( pResult ); - } - } - } -} - -HARBOUR HB_EMPTY( void ) -{ - PHB_ITEM pItem = hb_param( 1, IT_ANY ); - - /* NOTE: pItem cannot be NULL here */ - - switch( pItem->type & ~IT_BYREF ) - { - case IT_ARRAY: - hb_retl( hb_arrayLen( pItem ) == 0 ); - break; - - case IT_STRING: - hb_retl( hb_strEmpty( hb_itemGetCPtr( pItem ), hb_itemGetCLen( pItem ) ) ); - break; - - case IT_INTEGER: - hb_retl( hb_itemGetNI( pItem ) == 0 ); - break; - - case IT_LONG: - hb_retl( hb_itemGetNL( pItem ) == 0 ); - break; - - case IT_DOUBLE: - hb_retl( hb_itemGetND( pItem ) == 0.0 ); - break; - - case IT_DATE: - /* NOTE: This is correct ! Get the date as long value. */ - hb_retl( hb_itemGetNL( pItem ) == 0 ); - break; - - case IT_LOGICAL: - hb_retl( ! hb_itemGetL( pItem ) ); - break; - - case IT_BLOCK: - hb_retl( FALSE ); - break; - - default: - hb_retl( TRUE ); - break; - } -} - -HARBOUR HB_VALTYPE( void ) -{ - PHB_ITEM pItem = hb_param( 1, IT_ANY ); - - /* NOTE: pItem cannot be NULL here */ - - switch( pItem->type & ~IT_BYREF ) - { - case IT_ARRAY: - hb_retc( hb_arrayIsObject( pItem ) ? "O" : "A" ); - break; - - case IT_BLOCK: - hb_retc( "B" ); - break; - - case IT_DATE: - hb_retc( "D" ); - break; - - case IT_LOGICAL: - hb_retc( "L" ); - break; - - case IT_INTEGER: - case IT_LONG: - case IT_DOUBLE: - hb_retc( "N" ); - break; - - case IT_STRING: - hb_retc( "C" ); - break; - - case IT_NIL: - default: - hb_retc( "U" ); - break; - } -} - -HARBOUR HB_TYPE( void ) -{ - /* TODO: Implement this. */ -} - -/* INCOMPATIBILITY: The Clipper NG states that WORD() will only work when used - in CALL commands parameter list, otherwise it will return - NIL, in Harbour it will work anywhere. */ - -HARBOUR HB_WORD( void ) -{ - if( ISNUM( 1 ) ) - hb_retni( hb_parni( 1 ) ); - else - hb_errRT_BASE( EG_ARG, 1091, NULL, "WORD" ); -} - -HARBOUR HB_PROCNAME( void ) -{ - int iLevel = hb_parni( 1 ) + 1; /* we are already inside ProcName() */ - PHB_ITEM pBase = hb_stack.pBase; - - while( ( iLevel-- > 0 ) && pBase != hb_stack.pItems ) - pBase = hb_stack.pItems + pBase->item.asSymbol.stackbase; - - if( ( iLevel == -1 ) ) - { - if( ( pBase + 1 )->type == IT_ARRAY ) /* it is a method name */ - { - char * szProcName; - - szProcName = ( char * ) hb_xgrab( strlen( hb_objGetClsName( pBase + 1 ) ) + 1 + - strlen( pBase->item.asSymbol.value->szName ) + 1 ); - strcpy( szProcName, hb_objGetClsName( pBase + 1 ) ); - strcat( szProcName, ":" ); - strcat( szProcName, pBase->item.asSymbol.value->szName ); - hb_retc( szProcName ); - hb_xfree( ( void * ) szProcName ); - } - else - hb_retc( pBase->item.asSymbol.value->szName ); - } - else - hb_retc( "" ); -} - -HARBOUR HB_PROCLINE( void ) -{ - int iLevel = hb_parni( 1 ) + 1; /* we are already inside ProcName() */ - PHB_ITEM pBase = hb_stack.pBase; - - while( ( iLevel-- > 0 ) && pBase != hb_stack.pItems ) - pBase = hb_stack.pItems + pBase->item.asSymbol.stackbase; - - if( iLevel == -1 ) - hb_retni( pBase->item.asSymbol.lineno ); - else - hb_retni( 0 ); -} - -/* NOTE: Clipper undocumented function, which always returns an empty - string. */ - -HARBOUR HB_PROCFILE( void ) -{ - hb_retc( "" ); -} - HARBOUR HB_ERRORLEVEL( void ) { hb_retni( s_byErrorLevel ); @@ -3610,31 +3420,6 @@ HARBOUR HB_ERRORLEVEL( void ) s_byErrorLevel = hb_parni( 1 ); } -HARBOUR HB_PCOUNT( void ) -{ - /* Skip current function */ - PHB_ITEM pBase = hb_stack.pItems + hb_stack.pBase->item.asSymbol.stackbase; - - hb_retni( pBase->item.asSymbol.paramcnt ); -} - -HARBOUR HB_PVALUE( void ) /* PValue( ) */ -{ - USHORT uiParam = hb_parni( 1 ); /* Get parameter */ - PHB_ITEM pBase = hb_stack.pItems + hb_stack.pBase->item.asSymbol.stackbase; - /* Skip function + self */ - - if( uiParam && uiParam <= pBase->item.asSymbol.paramcnt ) /* Valid number */ - hb_itemReturn( pBase + 1 + uiParam ); - else - hb_errRT_BASE( EG_ARG, 3011, NULL, "PVALUE" ); -} - -HARBOUR HB___QUIT( void ) -{ - hb_vmRequestQuit(); -} - void hb_vmRequestQuit( void ) { HB_TRACE(HB_TR_DEBUG, ("hb_vmRequestQuit()")); @@ -3662,16 +3447,6 @@ USHORT hb_vmRequestQuery( void ) return s_uiActionRequest; } -/* NOTE: This function should normally have a parameter count check. But - since in Harbour we cannot distinguish between BREAK() function and - the BREAK statement, because both generate a BREAK() function - call on the pcode level, we should drop the checking. */ - -HARBOUR HB_BREAK( void ) -{ - hb_vmRequestBreak( hb_param( 1, IT_ANY ) ); -} - void hb_vmRequestCancel( void ) { HB_TRACE(HB_TR_DEBUG, ("hb_vmRequestCancel()")); @@ -3689,24 +3464,6 @@ void hb_vmRequestCancel( void ) } } -/* NOTE: This is an internal undocumented Clipper function, which will try - to call the function HELP() if it's defined. This is the default - SetKey() handler for the F1 key. */ - -HARBOUR HB___XHELP( void ) -{ - PHB_DYNS pDynSym = hb_dynsymFind( "HELP" ); - - if( pDynSym ) - { - hb_vmPushSymbol( pDynSym->pSymbol ); - hb_vmPushNil(); - hb_vmDo( 0 ); - - /* NOTE: Leave the return value as it is. */ - } -} - /* $Doc$ * $FuncName$ __vmVarSList() * $Description$ Return the statics array @@ -3730,4 +3487,3 @@ HARBOUR HB___VMVARSGET( void ) hb_itemReturn( s_aStatics.item.asArray.value->pItems + hb_stack.iStatics + hb_parni( 1 ) - 1 ); } - diff --git a/harbour/tests/multiarg.prg b/harbour/tests/multiarg.prg index 3f028e9944..996dbd31e1 100644 --- a/harbour/tests/multiarg.prg +++ b/harbour/tests/multiarg.prg @@ -26,5 +26,5 @@ return nil function ShoutArg( nArg, x1,x2,x3,x4,x5,x6,x7,x8,x9,x10 ) - QOut( nArg, "==", PValue( nArg ) ) + QOut( nArg, "==", hb_PValue( nArg ) ) return nil