ficl-developers Mailing List for Ficl - small systems scripting with OO
Brought to you by:
jsadler
You can subscribe to this list here.
2001 |
Jan
|
Feb
|
Mar
|
Apr
|
May
|
Jun
|
Jul
|
Aug
|
Sep
|
Oct
(3) |
Nov
(25) |
Dec
(6) |
---|---|---|---|---|---|---|---|---|---|---|---|---|
2002 |
Jan
|
Feb
|
Mar
(3) |
Apr
|
May
|
Jun
|
Jul
|
Aug
(2) |
Sep
|
Oct
|
Nov
|
Dec
|
2004 |
Jan
|
Feb
|
Mar
|
Apr
|
May
|
Jun
|
Jul
(13) |
Aug
|
Sep
|
Oct
|
Nov
|
Dec
|
2010 |
Jan
|
Feb
|
Mar
|
Apr
|
May
|
Jun
|
Jul
|
Aug
|
Sep
|
Oct
(1) |
Nov
(1) |
Dec
|
2016 |
Jan
|
Feb
|
Mar
|
Apr
|
May
|
Jun
|
Jul
(9) |
Aug
|
Sep
|
Oct
|
Nov
|
Dec
|
From: Alex M. <cal...@gm...> - 2016-07-26 01:56:58
|
Hi! I haven't used Ficl in a few years, but I did come across a couple of bugs I've wanted to bring to someone's attention, so I've compared the 4.1.0 Ficl copy I used to Toomas's and Marcin's versions. (1) PICK - John Sadler's Ficl treats the stack as "xu ... x1 u" (no x0), while the DPANS94 says it should be "xu ... x1 x0 u". Toomas appears to have fixed it in vm.c (ficlInstructionPick case); Marcin still has John's original code. I always figured PICK was a common instruction, so I was surprised that Johbn never noticed the bug. (2) FILE-POSITION and FILE-SIZE - should return a double-cell integer according to DPANS94. However, ficlPrimitiveFilePosition() and ficlPrimitiveFileSize() in fileaccess.c use ficlStackPushInteger() to push a single-cell result onto the stack. This is true in all three versions of Ficl (John, Toomas, and Marcin). Since sometime back in the 2000s, I've had odd results with Ficl on various platforms from the Nintendo DS to Windows (98!) to Linux. Turning off all compiler optimization helped in some cases. Since my work didn't depend on Ficl (and the only Forth program I've written is a web server using network extensions to Ficl), I didn't dig too deeply into the strange behavior I was seeing and, as a result, I've never quite trusted Ficl. I'm glad to see you two are actively working on it! - Alex |
From: Toomas S. <ts...@me...> - 2016-07-25 20:10:04
|
> On 25. juuli 2016, at 23:02, Marcin Cieslak <sa...@sa...> wrote: > > On Mon, 25 Jul 2016, Toomas Soome wrote: > >> >>> On 25. juuli 2016, at 22:47, Marcin Cieslak <sa...@sa...> wrote: >>> >>> On Mon, 25 Jul 2016, Toomas Soome wrote: >>> >>>> ok, I’ll try to find some time to review and compare in coming >>>> days… will see how my time will go. I assume you have also reviewed >>>> freebsd patches for 64bit build? They have done some just to make it >>>> build, but setjmp/pick issues are still there for them… >>> >>> Hm, now as I come to it: last time I checked FreeBSD boot loader >>> was based on ficl 3, and the current master is ficl 4, which >>> has switched to a switch-threaded model. >> >> >> yes, its still is based on v3, there have been few attempts to >> switch to 4, but not completed. And of course, in loader it is used >> single threaded still:) They do have ficl4 as userspace app tho, but >> unfortunately, pretty broken;) > > Shall we revive ficl3 branches in the repository then? > > Marcin I don’t think there is need for that;) for time being they can live, and since I already have working ficl4, I can eventually push it to fbsd as well - since they have [had] some people working about it, I did not want to spoil their efforts, just gave some hints what to look for:) rgds, toomas |
From: Marcin C. <sa...@sa...> - 2016-07-25 20:02:37
|
On Mon, 25 Jul 2016, Toomas Soome wrote: > > > On 25. juuli 2016, at 22:47, Marcin Cieslak <sa...@sa...> wrote: > > > > On Mon, 25 Jul 2016, Toomas Soome wrote: > > > >> ok, I’ll try to find some time to review and compare in coming > >> days… will see how my time will go. I assume you have also reviewed > >> freebsd patches for 64bit build? They have done some just to make it > >> build, but setjmp/pick issues are still there for them… > > > > Hm, now as I come to it: last time I checked FreeBSD boot loader > > was based on ficl 3, and the current master is ficl 4, which > > has switched to a switch-threaded model. > > > yes, its still is based on v3, there have been few attempts to > switch to 4, but not completed. And of course, in loader it is used > single threaded still:) They do have ficl4 as userspace app tho, but > unfortunately, pretty broken;) Shall we revive ficl3 branches in the repository then? Marcin |
From: Marcin C. <sa...@sa...> - 2016-07-25 19:47:22
|
On Mon, 25 Jul 2016, Toomas Soome wrote: > ok, I’ll try to find some time to review and compare in coming > days… will see how my time will go. I assume you have also reviewed > freebsd patches for 64bit build? They have done some just to make it > build, but setjmp/pick issues are still there for them… Hm, now as I come to it: last time I checked FreeBSD boot loader was based on ficl 3, and the current master is ficl 4, which has switched to a switch-threaded model. I have fixed lost 64 bit registers by rearranging macros with https://github.com/forthinspired/ficl/commit/f8c09048b6ec60f74932aac87d93cac527ec61fa > btw, I also did replace lzjb with lz4 for 2 reasons - one is that > lz4 does a bit better work, and for second, as zfs does have lz4, it > means I can share the same uncompress and save some pages of precious > memory;) well, the last bit wont really concern normal userspace > interpreter. I think that the pure ficl code does not contain anything to do with a compression, I believe it is a FreeBSD-related change. (By the way I am using FreeBSD every day) Marcin |
From: Marcin C. <sa...@sa...> - 2016-07-25 18:59:14
|
On Sat, 23 Jul 2016, Toomas Soome wrote: > > hi! > > This certainly is a bit of surprise to see my subscribe request being accepted after that much of time:) I already thought its all dead now, glad to see it certainly is not true:) > > Just want to note for starters, I have been working on port of freebsd > loader for illumos family of operating systems, and part of the work, > I have integrated ficl 4 to my port of loader. Of course this also did > mean some amount of work to make 4.1.0 actually working;) > > For time being the ficl bits in project can be browsed at https://github.com/tsoome/illumos-gate/tree/loader/usr/src/common/ficl, if there is any interest, I can put together patches for upstreaming, just at the moment my focus is on other issues related my project. This is great! I have fixed 4.1.0 breakage with Windows and also made more 64-bit changes. I have uploaded it here: https://github.com/forthinspired/ficl I hve sent you the invitation to join the team so we can integrate your changes. Good to see the work going on! Marcin |
From: Toomas S. <ts...@me...> - 2016-07-25 18:54:56
|
> On 25. juuli 2016, at 21:30, Marcin Cieslak <sa...@sa...> wrote: > > On Sat, 23 Jul 2016, Toomas Soome wrote: > >> >> hi! >> >> This certainly is a bit of surprise to see my subscribe request being accepted after that much of time:) I already thought its all dead now, glad to see it certainly is not true:) >> >> Just want to note for starters, I have been working on port of freebsd >> loader for illumos family of operating systems, and part of the work, >> I have integrated ficl 4 to my port of loader. Of course this also did >> mean some amount of work to make 4.1.0 actually working;) >> >> For time being the ficl bits in project can be browsed at https://github.com/tsoome/illumos-gate/tree/loader/usr/src/common/ficl, if there is any interest, I can put together patches for upstreaming, just at the moment my focus is on other issues related my project. > > This is great! I have fixed 4.1.0 breakage with Windows and > also made more 64-bit changes. > > I have uploaded it here: > > https://github.com/forthinspired/ficl > > I hve sent you the invitation to join the team so we can > integrate your changes. > > Good to see the work going on! > > Marcin ok, I’ll try to find some time to review and compare in coming days… will see how my time will go. I assume you have also reviewed freebsd patches for 64bit build? They have done some just to make it build, but setjmp/pick issues are still there for them… btw, I also did replace lzjb with lz4 for 2 reasons - one is that lz4 does a bit better work, and for second, as zfs does have lz4, it means I can share the same uncompress and save some pages of precious memory;) well, the last bit wont really concern normal userspace interpreter. rgds, toomas |
From: Toomas S. <ts...@me...> - 2016-07-23 11:38:48
|
hi! This certainly is a bit of surprise to see my subscribe request being accepted after that much of time:) I already thought its all dead now, glad to see it certainly is not true:) Just want to note for starters, I have been working on port of freebsd loader for illumos family of operating systems, and part of the work, I have integrated ficl 4 to my port of loader. Of course this also did mean some amount of work to make 4.1.0 actually working;) For time being the ficl bits in project can be browsed at https://github.com/tsoome/illumos-gate/tree/loader/usr/src/common/ficl, if there is any interest, I can put together patches for upstreaming, just at the moment my focus is on other issues related my project. rgds, toomas |
From: Marcin C. <sa...@sa...> - 2010-11-22 07:46:16
|
When testing ficl on amd64 I noticed that the virtual machine segfaults every so often (on most errors). Here's the fix for review: --- vm.c.orig 2003-06-18 19:14:06.000000000 +0200 +++ vm.c 2009-06-22 17:53:13.497065077 +0200 @@ -280,12 +280,12 @@ if (once) count = 1; - LOCAL_VARIABLE_REFILL; - oldExceptionHandler = vm->exceptionHandler; vm->exceptionHandler = &exceptionHandler; /* This has to come before the setjmp! */ except = setjmp(exceptionHandler); + LOCAL_VARIABLE_REFILL; + if (except) { LOCAL_VARIABLE_SPILL; |
From: Marcin C. <sa...@sa...> - 2010-10-21 08:59:33
|
Hello, I am happy to announce that we have a new version of ficl released, 4.1.0. New in this release: - support for 64-bit platforms; - improved support for BSD family systems. Contributed by Aleksej Saushev (as...@in...) Download at: http://sourceforge.net/projects/ficl/files/ficl-all/ficl4.1/ficl-4.1.0.tar.gz/download //Marcin |
From: john s. <joh...@al...> - 2004-07-28 17:06:16
|
David - I haven't had a chance to review the fix, but it is on the list. I hope to get time for a new revision in the next few weeks. - John At 7/27/2004 02:12 AM, David McNab wrote: >Hi, > >Some weeks ago I posted a bug report and fix, whereby 'alloc' distorts the >stack before calling --> init. > >Recapping - for classes whose init methods accept arguments, other than >'inst cls', the stack signature is different when the class is >instantiated via 'new', compared to instantiation via 'alloc' or 'allot'. > >IMHO, this is a critical bug. > >The fix, in the last line of ': alloc' in oo.fr, is to change: > class 2dup --> init >to: > class 2dup >r >r --> init r> r> > >Has this fix been accepted? > >-- >Cheers >David > > >------------------------------------------------------- >This SF.Net email is sponsored by BEA Weblogic Workshop >FREE Java Enterprise J2EE developer tools! >Get your free copy of BEA WebLogic Workshop 8.1 today. >http://ads.osdn.com/?ad_id=4721&alloc_id=10040&op=click >_______________________________________________ >Ficl-developers mailing list >Fic...@li... >https://lists.sourceforge.net/lists/listinfo/ficl-developers |
From: David M. <da...@re...> - 2004-07-27 09:12:40
|
Hi, Some weeks ago I posted a bug report and fix, whereby 'alloc' distorts the stack before calling --> init. Recapping - for classes whose init methods accept arguments, other than 'inst cls', the stack signature is different when the class is instantiated via 'new', compared to instantiation via 'alloc' or 'allot'. IMHO, this is a critical bug. The fix, in the last line of ': alloc' in oo.fr, is to change: class 2dup --> init to: class 2dup >r >r --> init r> r> Has this fix been accepted? -- Cheers David |
From: Chris D. <chr...@gm...> - 2004-07-19 21:59:55
|
> Better question - what *won't* I be using FICL for? Nice stuff! I used Ficl in the past to develop cellphone applications on the Symbian OS. I ported it to the Nokia 9210 and it enabled be to develop both on my desktop PC and on the phone itself, which was great for debugging. My plan is to port it to the newer cellphones now that my 9210 has died. Hopefully the more popular cellphones too since there weren't too many 9210 users in NZ. Memory usage on the phone was about 150Kb if I recall correctly which was pretty good. Symbian uses C++ API's everywhere and Ficl was great at embedding and interacting with the C++ code. Chris. -- http://radio.weblogs.com/0102385 |
From: David M. <da...@re...> - 2004-07-19 11:50:56
|
Chris Double wrote: >>Enjoy (if there's actually anyone reading this) > Nice, I'm reading and following it. What sort of things are you using Ficl for? Better question - what *won't* I be using FICL for? What I particularly like about FICL is: * it's Forth! (with an acceptable amount of ANS conformity) * blindingly easy to add C and C++ primitives * easy to embed whole turnkey apps into very small standalone Windows EXE files (I code on Linux, enjoy being able to debug on linux, then just build'n'run on *doze) * coherent code layout, easy to follow - no autocrap, no obfuscated make, zillions of files, just the source, plain and simple So far, I've only published one FICL-based app - PSST - at http://psst.sf.net - an encrypted peer-peer instant messenger, with anti-MITM features. I'm currently in the process of wrapping a bunch of third-party libs (eg FLTK GUI, OpenSSL Crypto, Speex...) into FICL Forth primitives. When I've got a good selection of stuff implemented, I'll formally publish the extensions framework (mentioned in a prior post). -- Cheers David |
From: Chris D. <chr...@gm...> - 2004-07-18 01:09:30
|
On Sun, 18 Jul 2004 10:42:40 +1200, David McNab <da...@re...> wrote: > > Enjoy (if there's actually anyone reading this) Nice, I'm reading and following it. What sort of things are you using Ficl for? |
From: David M. <da...@re...> - 2004-07-17 22:42:52
|
Hi, As someone who's written lots of Python, I've grown very fond of bound instance methods - ie, a single entity which, when executed, invokes a method of a class in respect of a specific class instance. For instance: class foo: ... def bar(self, *args): print "this is foo.bar" fooInst = foo() x = fooInst.bar # this saves a 'bound instance method' ... x() # equivalent to 'fooInst.bar()' I couldn't find anything similar in FICL's OO, so decided to implement it myself. Here's the code -------------------- also oop definitions \ helpers for -->bind-xt-for-method : (exec-instance-method) ( xt-thisword ) dup 2@ ( xt-thisword cls inst ) rot 2 cells + @ ( cls inst xt-clsMeth ) execute ; : (bind-instance-method) ( inst cls xt-clsMeth -- xt-instMeth ) \ create a word to hold the 'inst cls xt', and run the method s" create _im_" evaluate ( inst cls xt-clsMeth ) -rot ( xt-clsMeth inst cls ) , , , ( ) last-word ( xt-instMeth ) does> \ ." instance method runner started" cr (exec-instance-method) ; \ the beast itself \ binds an instance method to an xt, so whenever the \ xt is executed, the object signature ( inst cls ) is \ pushed onto the stack, and the method executed : -->bind-instance-method ( inst cls -- xt ) state @ if \ compiling parse-method ( inst cls addr u ) postpone lookup-method ( inst cls xt-clsMeth ) postpone (bind-instance-method) ( xt-instMeth ) else \ interpreting parse-word ( inst cls addr u ) lookup-method ( inst cls xt-clsMeth ) (bind-instance-method) ( xt-instMeth ) then ; immediate ----------------------------------- Now, for an example: -------------------- also oop definitions object subclass c-myclass cell: .somestuff : setstuff { x 2:this } ." setting somestuff to " x . cr x this --> .somestuff ! ; : showstuff { 2:this } ." somestuff = " this --> .somestuff @ cr ; end-class c-myclass --> new myinst 44 myinst --> setstuff myinst --> showstuff \ make 2 instance method bindings against instance 'myinst' myinst -->bind-instance-method showstuff constant showstuff-myinst myinst -->bind-instance-method setstuff constant setstuff-myinst showstuff-myinst execute 56 setstuff-myinst execute showstuff-myinst execute --------------------------------------- As you can see, we've created single xt's which each invoke a particular method of a particular instance of a particular class. This can be handy, especially when working in with other code that needs single xt's. There is a cost: * a new dictionary word gets created for each bound method of each instance. so if you're creating bindings for 3 methods of a class, and you have 20 instances of the class, that's 60 words! however, each word stores only 3 data cells and 2 instructions (including the semiParen) * on execution, there's an overhead of 11 (albeit quick) instructions per invocation Lastly - I've tested -->bind-instance-method in both compilation and interpretation states, and it seems to work fine in both. Enjoy (if there's actually anyone reading this) -- Cheers David |
From: David M. <da...@re...> - 2004-07-16 22:50:46
|
Hi, I tried to load gforth's 'oof.fs' package into ficl. Initially, it barfs for lack of the word '/string', so I prepended the definition: : /string ( addr u n -- addr' n' ) rot over + -rot - ; This seems to be a valid /string def. However, on loading oof.fs, ficl segfaults. I've had a look in oof.fs, but can't find anything obvious which might be causing it. IF anyone's more familiar with ficl, and has a couple of spare minutes to look into it, I've put a copy of oof.fs at: http://www.freenet.org.nz/oof.fs -- Cheers David |
From: David M. <da...@re...> - 2004-07-16 07:08:36
|
Hi, I notice that after creating a ficl oo class, as in object subclass myclass ... end-class the word 'myclass' is actually flagged as 'immediate', which means that if I want to use it in a colon def, I have to postpone it. Is this intentional? -- Cheers David |
From: David M. <da...@re...> - 2004-07-16 03:02:51
|
Hi, On looking through oo.fr, i noticed a few conditional compilations for 'vcall extensions'. However, there's no mention of vcall extensions in the FICL OO documentation. Am I right in assuming that 'vcall extensions' allow instances to be pushed on the stack by themselves, as opposed to ( inst cls )? There are notes in the FICL release history that 'vcall extensions are still broken'. Is this still the case? If the vcall extensions are indeed working, can someone please offer some usage info and examples? -- Cheers David |
From: David M. <da...@re...> - 2004-07-15 06:52:33
|
Hi, I noticed that 'bye' within a 'load'ed file was having no effect. This is fixed with the following patch (which is also attached to this message): --- extras.c 2003-06-19 05:14:06.000000000 +1200 +++ extras.c.new 2004-07-15 18:49:32.000000000 +1200 @@ -168,6 +168,9 @@ ficlVmThrowError(vm, "Error loading file <%s> line %d", FICL_COUNTED_STRING_GET_POINTER(*counted), line); break; } + /* Break all the way out on user exit -- da...@re... */ + if (result == FICL_VM_STATUS_USER_EXIT) + break; } /* ** Pass an empty line with SOURCE-ID == -1 to flush -- Cheers David |
From: Dean V. <Dea...@do...> - 2004-07-14 12:57:22
|
David, your comments pertaining to FICL, in general, and your framework offer, in particular, elicited a strong reaction on my part. I have been totally perplexed by the lack of response to FICL inside and outside of the Forth community in light of the release of FICL 4.x.x. FICL seems to me to have a "capability and balance" that could be an unrivaled complement to C/C++, in particular when one considers issues of rapid application development, oo extensions, small "footprint", "kiss" attributes etc.. Seems to me their is a huge "boat" that is being missed! Please receive my "vote" in favor of, and interest in, your framework and FICL proliferation. Dean Vieau |
From: David M. <da...@re...> - 2004-07-13 22:44:46
|
Hi, I'm returning to FICL after a 1-2 year break, and am wondering about the status of the FICL project overall. Is FICL still being developed, or has it gone static after the last stable 4.0.31 release? I'm writing because I've just written a framework which makes it easy and convenient to write and share extensions (sets of words in C/C++ and FICL-forth), and am wondering whether it's worth my while to document it and submit it. To me, FICL has a lot of advantages: * Ease of embedding into standalone binaries * Moderately fast * Easy to implement words in C++ (not just C) * Ease of customisation * Reasonably good ANS-compliance * Portability * Simplicity * Multiplicity of systems and vms Would be a shame to see FICL use dropping away. -- Cheers David |
From: john s. <jws...@at...> - 2002-08-06 04:04:47
|
Chris - That would be a side-effect of the way s" gets its scratch memory - it uses= =20 the uncommitted dictionary, which gets clobbered by the new definition... Inadvertent self-modifying= code. If you instead write : test s" : x 1 2 3 ;" execute ; test it works... - John At 8/5/2002 03:44 AM, Chris Double wrote: >Running ficl v3.02, executing the following gives an error: > >s" : x 1 2 3 ;" evaluate >ok> s" : x 1 2 3 ;" evaluate >2=EA not found > >Any ideas what the problem might be? > >Chris. >-- > Chris Double > chr...@do... > > >------------------------------------------------------- >This sf.net email is sponsored by:ThinkGeek >Welcome to geek heaven. >http://thinkgeek.com/sf >_______________________________________________ >Ficl-developers mailing list >Fic...@li... >https://lists.sourceforge.net/lists/listinfo/ficl-developers John Sadler - joh...@al... Voice 415-271-6795 Fax 802-609-9217 |
From: Chris D. <chr...@do...> - 2002-08-05 10:44:17
|
Running ficl v3.02, executing the following gives an error: s" : x 1 2 3 ;" evaluate ok> s" : x 1 2 3 ;" evaluate 2=EA not found Any ideas what the problem might be? Chris. --=20 Chris Double chr...@do... |
From: Chris D. <chr...@do...> - 2002-03-28 04:20:04
|
Here's some code I put together to query and display information from ODBC databases. It's a work in progress but I thought others might be interested in having a play with it. I'd appreciate comments on better ways of doing things. Most of the words return either a false value or a series of results followed by a true value. This seems to lead to quite nested code. Is there a better way of doing this? Should I use Catch and Throw for this sort of thing instead? Also I have problems with freeing allocated data. I have do a bit of swapping around of stack data to enable me to free things. I know I don't free everything in my code below. If I use catch and throw what's the best way of ensuring allocated data is freed? In lisp I'd use unwind-protect for example. Is there a forth equivalent? The useage of the code is as follows: : test odbcinit ( -- env b ) IF dup s" DSN=mydb" odbcconnect ( env -- env dbc b) IF dup s" select * from MYTABLE" odbcexecute ( env dbc -- env dbc stmt b ) IF dup odbcnextrow ( env dbc stmt -- env dbc stmt b ) IF odbcdescribecolumns ( env dbc stmt -- env dbc stmt ) begin odbcdescribecolumndata ( env dbc stmt -- env dbc stmt ) dup odbcnextrow ( env dbc stmt -- env dbc stmt b ) 0= until ( -- env dbc stmt ) THEN odbccloseexecute drop THEN dup odbcdisconnect drop odbcclosedatabase drop THEN odbcuninit THEN ; Note you can get column metadata as well as column results. Code pasted below. -----------------8<------------------ s" odbc32.dll" loadlibrary constant hodbc s" SQLAllocHandle" hodbc getprocaddress constant win32sqlallochandle s" SQLFreeHandle" hodbc getprocaddress constant win32sqlfreehandle s" SQLSetEnvAttr" hodbc getprocaddress constant win32sqlsetenvattr s" SQLDriverConnect" hodbc getprocaddress constant win32sqldriverconnect s" SQLDisconnect" hodbc getprocaddress constant win32sqldisconnect s" SQLGetDiagRec" hodbc getprocaddress constant win32sqlgetdiagrec s" SQLExecDirect" hodbc getprocaddress constant win32sqlexecdirect s" SQLFetch" hodbc getprocaddress constant win32sqlfetch s" SQLGetData" hodbc getprocaddress constant win32sqlgetdata s" SQLNumResultCols" hodbc getprocaddress constant win32sqlnumresultcols s" SQLDescribeCol" hodbc getprocaddress constant win32sqldescribecol 1024 constant temp_buffer_len \ SQL data type codes 0 constant SQL_UNKNOWN_TYPE 1 constant SQL_CHAR 2 constant SQL_NUMERIC 3 constant SQL_DECIMAL 4 constant SQL_INTEGER 5 constant SQL_SMALLINT 6 constant SQL_FLOAT 7 constant SQL_REAL 8 constant SQL_DOUBLE 9 constant SQL_DATETIME 12 constant SQL_VARCHAR 91 constant SQL_TYPE_DATE 92 constant SQL_TYPE_TIME 93 constant SQL_TYPE_TIMESTAMP -4 constant SQL_NO_TOTAL -1 constant SQL_NULL_DATA \ Values of NULLABLE field 0 constant SQL_NO_NULLS 1 constant SQL_NULLABLE 2 constant SQL_NULLABLE_UNKNOWN 99 constant SQL_C_DEFAULT : safealloc ( n -- addr ) allocate abort" allocation failed" ; : safefree ( addr -- ) free abort" free failed" ; \ Convert a long integer on the stack to a short : toshort ( n -- n ) 65535 and ; \ Did the SQL call succeed (SQL_SUCCESS or SQL_SUCCESS_WITH_INFO) : succeeded ( n -- b ) 1 invert and 0= ; \ Call a native SQL function, converting return value as required : callsqlfunction ( argcount func -- n ) 0 callnativefunction toshort ; : sqlallochandleaddr ( type n addr - f | handle t ) dup >r 3 win32sqlallochandle callsqlfunction succeeded IF r> @ true ELSE r> drop false THEN ; : sqlallochandle ( type n - f | handle t ) 4 safealloc dup >r sqlallochandleaddr r> safefree ; : sqlfreehandle ( type handle - b ) 2 win32sqlfreehandle callsqlfunction succeeded ; : sqlsetenvattr ( env n n len -- b ) 4 win32sqlsetenvattr callsqlfunction succeeded ; : sqldriverconnect ( dbc hwnd dsnstr len outstr len addr n -- b ) 8 win32sqldriverconnect callsqlfunction succeeded ; : sqldisconnect ( dbc -- b ) 1 win32sqldisconnect callsqlfunction succeeded ; : sqlgetdiagrec ( type handle n addr1 addr2 addr3 len3 addr4 -- b ) 8 win32sqlgetdiagrec callsqlfunction succeeded ; : sqlexecdirect ( stmt str len -- b ) 3 win32sqlexecdirect callsqlfunction succeeded ; : sqlfetch ( stmt -- b ) 1 win32sqlfetch callsqlfunction succeeded ; : sqlgetdata ( stmt column type addr len lenaddr -- b ) 6 win32sqlgetdata callsqlfunction succeeded ; : sqlnumresultcols ( stmt addr -- b ) 2 win32sqlnumresultcols callsqlfunction succeeded ; : sqldescribecol ( stmt col nameaddr namelen namelenaddr typeaddr sizeptr digitsptr nullptr -- b ) 9 win32sqldescribecol callsqlfunction succeeded ; 1 constant SQL_HANDLE_ENV 2 constant SQL_HANDLE_DBC 3 constant SQL_HANDLE_STMT 4 constant SQL_HANDLE_DESC 0 constant SQL_NULL_HANDLE 200 constant SQL_ATTR_ODBC_VERSION 2 constant SQL_OV_ODBC2 3 constant SQL_OV_ODBC3 : allocenvhandle ( -- f | handle t ) SQL_HANDLE_ENV SQL_NULL_HANDLE sqlallochandle ; : allocdbchandle ( env -- f | handle t ) SQL_HANDLE_DBC swap sqlallochandle ; : allocstmthandle ( dbc -- f | handle t ) SQL_HANDLE_STMT swap sqlallochandle ; : allocdeschandle ( dbc -- f | handle t ) SQL_HANDLE_DESC swap sqlallochandle ; : freeenvhandle ( handle -- b ) SQL_HANDLE_ENV swap sqlfreehandle ; : freedbchandle ( handle -- b ) SQL_HANDLE_DBC swap sqlfreehandle ; : freestmthandle ( handle -- b ) SQL_HANDLE_STMT swap sqlfreehandle ; : freedeschandle ( handle -- b ) SQL_HANDLE_DESC swap sqlfreehandle ; : setodbcversion3 ( env -- b ) SQL_ATTR_ODBC_VERSION SQL_OV_ODBC3 0 sqlsetenvattr ; : driverconnect ( dbc dsnstr len -- b) 0 -rot temp_buffer_len safealloc dup >r temp_buffer_len 4 safealloc dup >r 1 sqldriverconnect r> safefree r> safefree ; : getdiagrec ( type handle n -- f | msg msglen state statelen b ) 5 safealloc dup >r 4 safealloc dup >r temp_buffer_len safealloc dup >r temp_buffer_len 4 safealloc dup >r sqlgetdiagrec IF r> @ r> swap r> drop r> 5 true ELSE r> r> r> r> safefree safefree safefree safefree false THEN ; : displaydiagrec ( type handle n -- ) getdiagrec IF 2dup ." State: " type cr drop safefree 2dup ." Message: " type cr drop safefree THEN ; : execdirect ( stmt str len -- b ) sqlexecdirect ; : fetchrow ( stmt -- b ) sqlfetch ; : getintegerdata ( stmt column -- f | n null? t ) SQL_INTEGER 4 safealloc dup >r 4 4 safealloc dup >r sqlgetdata IF r> @ SQL_NULL_DATA = r> @ swap true ELSE r> safefree r> safefree false THEN ; : numresultcols ( stmt -- f | n t ) 4 safealloc dup >r sqlnumresultcols IF r> dup safefree @ toshort true ELSE r> safefree false THEN ; : describecol ( stmt col -- f | null digits size type name len t ) 128 safealloc dup >r 128 4 safealloc dup >r 4 safealloc dup >r 4 safealloc dup >r 4 safealloc dup >r 4 safealloc dup >r sqldescribecol IF r> dup @ toshort swap safefree r> dup @ toshort swap safefree r> dup @ swap safefree r> dup @ toshort swap safefree r> dup @ toshort swap safefree r> swap true ELSE r> r> r> r> r> r> safefree safefree safefree safefree safefree safefree false THEN ; \ Initialize ODBC returning env handle : odbcinit ( -- f | env t ) allocenvhandle IF dup setodbcversion3 ELSE false THEN ; \ Uninitialize ODBC : odbcuninit ( env -- b ) freeenvhandle ; \ Connect to a database returning the dbc handle : odbcconnect ( env dsn len -- f | dbc t ) rot allocdbchandle IF dup 2swap driverconnect ELSE drop drop false THEN ; \ Disconnect from a database : odbcdisconnect ( dbc | b ) sqldisconnect ; \ Execute a SQL statement : odbcexecute ( dbc str len -- f | stmt t ) rot allocstmthandle IF dup 2swap execdirect ELSE drop drop false THEN ; \ Get next row from a statement : odbcnextrow ( stmt -- b ) fetchrow ; \ Return the number of columns in the result set : odbcnumcols ( stmt -- f | n t ) numresultcols ; \ Get an integer field from the current row : odbcintegerfield ( stmt column -- f | n null>? t ) getintegerdata ; \ Display a description of the given type : displaytype ( n -- ) dup SQL_UNKNOWN_TYPE = IF ." SQL_UNKNOWN_TYPE" THEN dup SQL_CHAR = IF ." SQL_CHAR" THEN dup SQL_NUMERIC = IF ." SQL_NUMERIC" THEN dup SQL_DECIMAL = IF ." SQL_DECIMAL" THEN dup SQL_INTEGER = IF ." SQL_INTEGER" THEN dup SQL_SMALLINT = IF ." SQL_SMALLINT" THEN dup SQL_FLOAT = IF ." SQL_FLOAT" THEN dup SQL_REAL = IF ." SQL_REAL" THEN dup SQL_DOUBLE = IF ." SQL_DOUBLE" THEN dup SQL_DATETIME = IF ." SQL_DATETIME" THEN dup SQL_VARCHAR = IF ." SQL_VARCHAR" THEN dup SQL_TYPE_DATE = IF ." SQL_TYPE_DATE" THEN dup SQL_TYPE_TIME = IF ." SQL_TYPE_TIME" THEN dup SQL_TYPE_TIMESTAMP = IF ." SQL_TYPE_TIMESTAMP" THEN ." (" . ." )" cr ; \ Display a description of the column : odbcdescribecolumn ( stmt n -- ) describecol IF 2dup ." Name: " type cr drop safefree ." Type: " displaytype ." Size: " . cr ." Digits: " . cr ." Null: " dup SQL_NO_NULLS = IF ." No" THEN dup SQL_NULLABLE = IF ." Yes" THEN dup SQL_NULLABLE_UNKNOWN = IF ." Unknown" THEN ." (" . ." )" cr ELSE abort" Describe column failed" THEN ; \ Display descriptions for all columns : odbcdescribecolumns ( stmt -- ) dup odbcnumcols IF 1+ 1 do ." Column: " i . cr ." ============" cr dup i odbcdescribecolumn cr loop ELSE abort" odbcnumcols failed" THEN ; \ Get the type and length of a column : odbcgetcolumntypeandsize ( stmt column -- f | size n t ) describecol IF drop safefree >r >r drop drop r> r> true ELSE false THEN ; \ Return the c buffer size for the given type : odbcsizefortype ( size n -- size ) drop drop 1024 ; \ Get data from an ODBC field. addr must be freed by caller. : odbcgetdata ( stmt column -- f | null addr type t ) 2dup odbcgetcolumntypeandsize IF ( stmt column size type ) dup >r odbcsizefortype SQL_C_DEFAULT swap ( stmt col ctype size ) dup safealloc dup >r swap ( stmt col ctype addr len ) 4 safealloc dup >r ( stmt col ctype addr len addr2 ) sqlgetdata IF ( -- ) r> dup @ SQL_NULL_DATA = swap safefree ( null ) r> ( null addr ) r> ( null addr type ) true ELSE r> safefree r> safefree r> drop false THEN ELSE false THEN ; \ Get year month day hour minute second fraction from a timestamp addr : odbcdecodetimestamp ( addr -- y m d h m s f ) dup w@ swap dup 2 + w@ swap dup 4 + w@ swap dup 6 + w@ swap dup 8 + w@ swap dup 10 + w@ swap 12 + w@ ; \ Get year month day from a date addr : odbcdecodedate ( addr -- y m d ) dup w@ swap dup 2 + w@ swap dup 4 + w@ swap ; \ Get hour minute second from a time addr : odbcdecodetime ( addr -- h m s ) dup w@ swap dup 2 + w@ swap dup 4 + w@ swap ; \ Get float from a float addr : odbcdecodefloat ( addr -- f: n ) f@ ; \ Display ODBC data : odbcdisplaydata ( addr type -- ) dup SQL_UNKNOWN_TYPE = IF 2dup drop . THEN dup SQL_CHAR = IF 2dup drop c@ emit THEN dup SQL_NUMERIC = IF 2dup drop dup strlen type THEN dup SQL_DECIMAL = IF ." decimal?" THEN dup SQL_INTEGER = IF 2dup drop @ . THEN dup SQL_SMALLINT = IF 2dup drop w@ . THEN dup SQL_FLOAT = IF 2dup drop f@ f. THEN dup SQL_REAL = IF 2dup drop f@ f. THEN dup SQL_DOUBLE = IF 2dup drop f@ f. THEN dup SQL_DATETIME = IF 2dup drop odbcdecodetimestamp . . . . . . . THEN dup SQL_VARCHAR = IF 2dup drop dup strlen type THEN dup SQL_TYPE_DATE = IF 2dup drop odbcdecodedate . . . THEN dup SQL_TYPE_TIME = IF 2dup drop odbcdecodetime . . . THEN dup SQL_TYPE_TIMESTAMP = IF 2dup drop odbcdecodetimestamp . . . . . . . THEN 2drop ; \ Display data in all columns : odbcdescribecolumndata ( stmt -- ) dup odbcnumcols IF 1+ 1 do i . ." : " dup i odbcgetdata IF rot 0= IF odbcdisplaydata ELSE ." NULL" THEN ELSE ." Could not get data" THEN cr loop ELSE abort" odbcnumcols failed" THEN ; \ Close the execution and cleanup : odbccloseexecute ( stmt -- b ) freestmthandle ; \ Close the database : odbcclosedatabase ( dbc -- b ) freedbchandle ; -----------------8<------------------ Cheers, Chris. -- Chris Double chr...@do... |
From: Chris D. <chr...@do...> - 2002-03-27 03:00:26
|
Pasted below are some routines I use in ficlwin for getting data to and from the clipboard. Inspired by 'Line Filter' from the ugly forth page (http://home.earthlink.net/~neilbawd/lnfilt.html). Using these definitions you should be able to get linefilter things working. The main words are: : stringfromclipboard ( -- str len ) : stringtoclipboard { str len | hglobal lpvoid -- } : evalclipboard ( -- ) I'm often using the command line version of ficl compiled for windows and edit in my editor, copy definitions to the clipboard and then do an 'evalclipboard' in the command line window to get things across to ficl. Works quite well. Code thrown together without much checking so and comments appreciated. --------------8<---------------- s" kernel32" loadlibrary constant hkernel s" GlobalAlloc" hkernel getprocaddress constant win32globalalloc s" GlobalFree" hkernel getprocaddress constant win32globalfree s" GlobalLock" hkernel getprocaddress constant win32globallock s" GlobalUnlock" hkernel getprocaddress constant win32globalunlock 2 constant GMEM_MOVEABLE : globalalloc ( flags length -- hglobal ) 2 win32globalalloc 0 callnativefunction ; : globalfree ( hglobal -- result ) 1 win32globalfree 0 callnativefunction 0= ; : globallock ( hglobal -- lpvoid ) 1 win32globallock 0 callnativefunction ; : globalunlock ( lpvoid -- result ) 1 win32globalunlock 0 callnativefunction ; s" user32" loadlibrary constant huser s" OpenClipboard" huser getprocaddress constant win32openclipboard s" CloseClipboard" huser getprocaddress constant win32closeclipboard s" IsClipboardFormatAvailable" huser getprocaddress constant win32isclipboardformatavailable s" GetClipboardData" huser getprocaddress constant win32getclipboarddata s" SetClipboardData" huser getprocaddress constant win32setclipboarddata s" EmptyClipboard" huser getprocaddress constant win32emptyclipboard 1 constant CF_TEXT : openclipboard ( -- result ) 0 1 win32openclipboard 0 callnativefunction ; : closeclipboard ( -- result ) 0 win32closeclipboard 0 callnativefunction ; : isclipboardformatavailable ( type -- result ) 1 win32isclipboardformatavailable 0 callnativefunction ; : getclipboarddata ( type -- str len ) 1 win32getclipboarddata 0 callnativefunction ( addr -- ) dup strlen ( addr len -- ) strdup drop ( -- addr2 len2 ) ; : setclipboarddata ( type hglobal -- result ) 2 win32setclipboarddata 0 callnativefunction 0> ; : emptyclipboard ( -- result ) 0 win32emptyclipboard 0 callnativefunction ; : stringfromclipboard ( -- str len ) openclipboard drop 1 getclipboarddata closeclipboard drop ; : stringtoclipboard { str len | hglobal lpvoid -- } openclipboard drop GMEM_MOVEABLE len 1+ globalalloc to hglobal hglobal globallock to lpvoid lpvoid len str len strcpy ( -- str len ) 2dup 1+ + 0 swap ! hglobal globalunlock drop CF_TEXT hglobal setclipboarddata drop closeclipboard drop ; \ Evaluate whatever exists in the clipboard : evalclipboard ( -- ) stringfromclipboard evaluate ; \ Short version of evalclipboard to save typing... : ec ( -- ) evalclipboard ; --------------8<---------------- Chris. -- http://www.double.co.nz -- Chris Double chr...@do... |