Thread: [Win32forth-cvs] win32forth-stc/src/kernel gMeta.f, NONE, 1.1 gkernel.f, NONE, 1.1 gkernext.f, NONE

SourceForge Headquarters 225 Broadway Suite 1600 San Diego, CA 92101 +1 (858) 422-6466

Update of /cvsroot/win32forth/win32forth-stc/src/kernel
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv2950/src/kernel

Added Files:
	gMeta.f gkernel.f gkernext.f gmeta-compiler.f gmeta-fkernel.f 
	gmetadlg.f gversion.f 
Log Message:
win32forth-stc base comit

--- NEW FILE: gmeta-compiler.f ---
\ $Id: gmeta-compiler.f,v 1.1 2006/09/21 16:26:33 dbu_de Exp $

0 [IF]

                   WIN32FORTH EXPERIMENTAL KERNEL

GMETA-COMPILER.F
Version 0.1 Started    15/08/2005 23:09:35
            Completed  29/09/2005 20:29:10

--------------------------- Change Block -------------------------------

arm 15/08/2005 22:56:45
    First version 0.1 STC based kernel

------------------------- End Change Block -----------------------------

[...1441 lines suppressed...]
t: 1-    ( n -- n-1 )
            macro[
                dec     eax
            ]macro ;

t: 1+    ( n -- n-1 )
            macro[
                inc     eax
            ]macro ;

t: c@    ( n -- n-1 )
            macro[
                movzx   eax, byte [eax]
            ]macro ;

((
*** NOTE From this point on, everything is meta compiled!                                                                            
))

--- NEW FILE: gkernext.f ---
\ $Id: gkernext.f,v 1.1 2006/09/21 16:26:33 dbu_de Exp $

0 [IF]

                   WIN32FORTH EXPERIMENTAL KERNEL

GKERNEXT.F
Version 0.1 15/08/2005 23:09:35

--------------------------- Change Block -------------------------------

arm 15/08/2005 22:56:45
    First version 0.1 STC based kernel

------------------------- End Change Block -----------------------------

Experimental: a fully optimising, STC based, ANS Forth compliant kernel

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.

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.

------------------------------------------------------------------------

[THEN]

cr .( Loading NEXT ASM Support)

get-current also forth definitions

variable stk-i -1 stk-i !               \ # of input cells, -ve is unknown
variable stk-o -1 stk-o !               \ # of output cells, -ve is unknown

: stk-reset     ( -- )                  \ reset stack effects
                -1 stk-i ! -1 stk-o ! ;

: stk-adjust    ( -- )                  \ generate adjustment offset
                stk-i @ stk-o @
                2dup or 0< not -rot - cells and \ zero if either -ve
                dup if >r
                  macro[
                  lea   ebp, r@ [ebp]   \ !! use lea not add/sub to preserve cc
                  ]macro r>
                then drop stk-reset     \ reset
                ;

: stk-calc      ( in out -- )           \ calculate stack effects
                2dup or stk-i @ or stk-o @ or 0< \ if any -ve
                if
                   2drop stk-i on stk-o on \ set both -ve
                else
                   over stk-o @ - dup 0>   \ get in stk value
                   if
                     dup stk-i +! stk-o +! \ adjust
                   else
                     drop
                   then
                   swap - stk-o +!
                then
                ;

previous set-current

macro: next     ( -- )                  \ assemble the code to do a next
                a;
                ofa-calc                \ resolve the optimizer field address
                ret ret                 \ double ret to stop decompiler
                ;macro

macro: next;    ( -- )                  \ terminate code word
                stk-adjust              \ adjust stack
                next c;                 \ and return
                stk-reset
                ;macro

--- NEW FILE: gkernel.f ---
\ $Id: gkernel.f,v 1.1 2006/09/21 16:26:33 dbu_de Exp $

0 [IF]

                     WIN32FORTH EXPERIMENTAL KERNEL

  SKERNEL.F
  Version 0.1 15/08/2005 23:09:35

  --------------------------- Change Block -------------------------------

  arm 15/08/2005 22:56:45
      First version 0.1 STC based kernel

  ------------------------- End Change Block -----------------------------

  Experimental: a fully optimising, STC based, ANS Forth compliant kernel
[...5890 lines suppressed...]
\
\ ---------------------------------------------------------------------
\ ---------------------------------------------------------------------

\ ------------------- The End -----------------------------------------

\ Forward reference resolutions

' header        resolves header
' res-loadproc  resolves res-loadproc
' defined       resolves defined
' move-code     resolves move-code
' throw         resolves throw
' ?throw        resolves ?throw
' start/stop    resolves start/stop
' load-dll      resolves load-dll
' nabort!       resolves nabort!
' warnmsg       resolves warnmsg
' find          resolves find

--- NEW FILE: gmeta-fkernel.f ---
\ $Id: gmeta-fkernel.f,v 1.1 2006/09/21 16:26:33 dbu_de Exp $

0 [IF]

                   WIN32FORTH EXPERIMENTAL KERNEL

GMETA-FKERNEL.F

--------------------------- Change Block -------------------------------

arm 15/08/2005 22:56:45
    First version 0.1 STC based kernel

------------------------- End Change Block -----------------------------

Experimental: a fully optimising, STC based, ANS Forth compliant kernel

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.

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.

------------------------------------------------------------------------

[THEN]

cr .( Loading META GKERNEL Wrapper)

\ SYS-WARNING-OFF         \ don't warn about use of system words

ONLY FORTH ALSO DEFINITIONS ALSO VIMAGE

WARNING OFF
SYS-WARNING-OFF

: SETSIZE ;      \ must be findable, but doesn't do anything

KERN-VER $FLOAD      \ GET KERNEL VERSION

512000 0x1000 naligned constant MINAPPMEM  \ minimum size of kernel application dictionary
512000 0x1000 naligned constant MINCODEMEM \ minimum size of kernel code dictionary
512000 0x1000 naligned constant MINSYSMEM  \ minimum size of kernel system dictionary
  1024 0x1000 naligned constant MINKODEMEM \ minimum size of kernel kode dictionary

512000 0x1000 naligned  TO IMAGE-ASIZE  \ size of kernel application dictionary
512000 0x1000 naligned  TO IMAGE-CSIZE  \ size of kernel data dictionary
512000 0x1000 naligned  TO IMAGE-SSIZE  \ size of kernel system dictionary
  1024 0x1000 naligned  TO IMAGE-KSIZE  \ size of kernel kode dictionary

0                                       STD-HEADLEN + TO IMAGE-CSEP \ separations
IMAGE-CSIZE                             STD-HEADLEN + TO IMAGE-ASEP
IMAGE-ASIZE IMAGE-CSIZE +               STD-HEADLEN + TO IMAGE-SSEP
IMAGE-SSIZE IMAGE-ASIZE IMAGE-CSIZE + + STD-HEADLEN + TO IMAGE-KSEP

0x10000 DUP MALLOC TO IMAGE-CODEPTR IMAGE-CODEPTR SWAP 0x90 FILL \ where code IMAGE-APPPTR is built
0x10000 DUP MALLOC TO IMAGE-APPPTR  IMAGE-APPPTR  SWAP ERASE \ where target IMAGE-APPPTR is built
0x10000 DUP MALLOC TO IMAGE-SYSPTR  IMAGE-SYSPTR  SWAP ERASE \ where target heads are built
0x10000 DUP MALLOC TO IMAGE-KODEPTR IMAGE-KODEPTR SWAP 0x90 FILL \ where kode IMAGE-APPPTR is built

331 constant #threads                        \ # of threads in forth-wordlist
 17 constant #ithreads                       \ # of threads in procs lexicon
  7 constant #ethreads                       \ # of threads in exports lexicon
  7 constant #fthreads                       \ # of threads in files lexicon
 31 constant #hthreads                       \ # of threads in hidden lexicon
  1 constant #rthreads                       \ # of threads in root lexicon

CR
CR .( Build information ) \ .month,day,year .(  ) .time
CR .(   Directory:    ) CURRENT-DIR$ COUNT TYPE
CR .(   Source:       ) KERN-SRC  COUNT TYPE
CR .(   NEXT macros:  ) KERN-NEXT COUNT TYPE
CR .(   Version from: ) KERN-VER  COUNT TYPE
CR .(   Version:      ) #version# ((version)) type
   .(  Build: ) #build# .
CR .(   Build Image:  ) KERN-NAME COUNT TYPE
   .(  Type: ) Z" GUI CUI DLL " EXETYPE 1- CELLS+ 4 TYPE

[debug]     [if] cr .( [DEBUG]     generating basic debug) [then]
[tail-call] [if] cr .( [TAIL-CALL] optimising tail calls)  [then]

CR CR .( Compiling... ) \ time-reset

\ ===================================================================

\ ** NOTE From this point on, everything is meta compilation

\ ======================= LOAD COMPILER =============================

defer ofa-calc

KERN-NEXT $FLOAD              \ load kernel extension for NEXT, EXEC code
KERN-CMP  $FLOAD              \ load the compiler

\ ======================= COMPILED CODE =============================

KERN-SRC  $FLOAD              \ load & compile the kernel source

\ ===================== END COMPILED CODE ===========================

\ NOTE: We're still in compile mode, only runtime after this

ct-resolve                 \ resolve the compile tokens
na-resolve                 \ resolve the compile tokens

\ Initialize list head ptr variables

proc-list-t @ winproc-link t-!
libs-list-t @ winlib-link t-!
voc-link-t @ voc-link t-!

\ Copy over the threads in the vocabularies

voc-ptr exports                                 \ correct the vocabs
  exports-threads swap tsys-there #ethreads cells move \ move the threads
voc-ptr imports                                 \ correct the vocabs
  imports-threads swap tsys-there #ithreads cells move \ move the threads
voc-ptr files                                 \ correct the vocabs
  files-threads   swap tsys-there #fthreads cells move \ move the threads
voc-ptr hidden                                  \ correct the vocabs
  hidden-threads  swap tsys-there #hthreads cells move \ move the threads
voc-ptr root                                 \ correct the vocabs
  root-threads    swap tsys-there #rthreads cells move \ move the threads
voc-ptr forth                                  \ correct the vocabs
  forth-threads   swap tsys-there #threads cells move \ move the threads

\ Calculate lengths of sections to write

tapp-HERE  IMAGE-ORIGIN IMAGE-ASEP + - TO IMAGE-AACTUAL
tsys-HERE  IMAGE-ORIGIN IMAGE-SSEP + - TO IMAGE-SACTUAL
tcode-HERE IMAGE-ORIGIN IMAGE-CSEP + - TO IMAGE-CACTUAL
tkode-HERE IMAGE-ORIGIN IMAGE-KSEP + - TO IMAGE-KACTUAL

\ Initialise the data pointers

\  CELL OFFSET  FUNCTION
\  ---- ------  --------
\   0     0     Current pointer to area
\   1     4     Address of the area (origin)
\   2     8     Highest address of area (origin + length)

tapp-HERE   ADP t-!                                 \ init the data pointers
tsys-HERE   SDP t-!
tcode-HERE  CDP t-!
tkode-HERE  KDP t-!

IMAGE-ORIGIN IMAGE-CSEP + CDP CELL+ t-!
IMAGE-ORIGIN IMAGE-ASEP + ADP CELL+ t-!
IMAGE-ORIGIN IMAGE-KSEP + KDP CELL+ t-!
IMAGE-ORIGIN IMAGE-SSEP + SDP CELL+ t-!

IMAGE-ORIGIN IMAGE-CSEP + IMAGE-CSIZE + CDP 2 CELLS+ t-!
IMAGE-ORIGIN IMAGE-ASEP + IMAGE-ASIZE + ADP 2 CELLS+ t-!
IMAGE-ORIGIN IMAGE-SSEP + IMAGE-SSIZE + SDP 2 CELLS+ t-!
IMAGE-ORIGIN IMAGE-KSEP + IMAGE-KSIZE + KDP 2 CELLS+ t-!

' EXEM IMAGE-ORIGIN - TO IMAGE-ENTRY          \ entry point

\ Make sure words all resolved

.UNRESOLVED [IF] CR C" *** Errors in compile" ABORT!
            [ELSE]
              cr .( Compilation complete)
              cr IMAGE-STATS
              IMAGE-SAVE [IF]
                KERN-NAME COUNT STD-IMG2EXE
              [THEN]
            cr \ .elapsed cr
            [THEN]

--- NEW FILE: gMeta.f ---
\ $Id: gMeta.f,v 1.1 2006/09/21 16:26:33 dbu_de Exp $
0 [IF]

                   WIN32FORTH EXPERIMENTAL KERNEL

GMETA-FKERNEL.F
  Convenience loader for meta compiler.

--------------------------- Change Block -------------------------------

arm 15/08/2005 22:56:45
    First version 0.1 STC based kernel

------------------------- End Change Block -----------------------------

Experimental: a fully optimising, STC based, ANS Forth compliant kernel

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.

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.

------------------------------------------------------------------------

[THEN]

only forth also definitions also vimage

\ default files for meta-compile

create kern-name ," gkernel.exe"
create kern-src  ," stc\kernel\gkernel.f"
create kern-next ," stc\kernel\gkernext.f"
create kern-ver  ," stc\kernel\gversion.f"       
create kern-cmp  ," stc\kernel\gmeta-compiler.f"

true  value [debug]                     \ basic debug flag
true  value [tail-call]                 \ generate tail-calls

0x400000 to image-origin   \ where target image will run
image-origin to std-exeload \ needed but needs checked in imageman why so
gui      to exetype        \ default is a gui
true value image-save      \ we want to save the image

\ fpath+ stc\kernel

fload stc\kernel\gmeta-fkernel         \ compile the kernel

--- NEW FILE: gmetadlg.f ---
\ $Id: gmetadlg.f,v 1.1 2006/09/21 16:26:33 dbu_de Exp $

cr .( Loading META FKERNEL Dialog)

load-dialog METADLG    \ load the dialogs for meta

\ -------------------- Meta Dialog --------------------

:Object META-DIALOG <SUPER dialog

IDD_META METADLG find-dialog-id constant template

int sysmem
int appmem
int codemem

int defsysmem
int defappmem
int defcodemem

:M GetRegistryValue: ( a1 n1 -- n2 flag ) \ read a value from registry
                s" MetaDlg" RegGetString dup
                if   number? >r d>s r>
                else 2drop 0 false then
                ;M

:M SetRegistryValue: ( n1 a1 n2 -- ) \ write a value to registry
                rot s>d (d.) 2swap s" MetaDlg" RegSetString
                ;M

:M ClassInit:   ( -- )
                ClassInit: super
                0 to appmem
                0 to sysmem
                0 to codemem
                0 to defappmem
                0 to defsysmem
                0 to defcodemem
                ;M

:M SetEdit:     ( -- )
                appmem 0 <# #s #>  IDC_EDTAPPMEM SetDlgItemText: self
                sysmem 0 <# #s #>  IDC_EDTSYSMEM SetDlgItemText: self
                codemem 0 <# #s #> IDC_EDTCODEMEM SetDlgItemText: self
                ;M

:M On_Init:     ( hWnd-focus -- f )
                SetEdit: self
                1 ;M

:M GetAppMem:   ( -- appmemory )
                appmem
                ;M

:M SetAppMem:   ( appmemory -- )
                TO appmem
                ;M

:M SetDefAppMem:   ( appmemory -- )
                TO defappmem
                ;M

:M GetSysMem:   ( -- sysmemory )
                sysmem
                ;M

:M SetSysMem:   ( sysmemory -- )
                TO sysmem
                ;M

:M SetDefSysMem:   ( sysmemory -- )
                TO defsysmem
                ;M

:M GetCodeMem:  ( -- codememory )
                codemem
                ;M

:M SetCodeMem:  ( codememory -- )
                TO codemem
                ;M

:M SetDefCodeMem:  ( codememory -- )
                TO defcodemem
                ;M

:M SetDefault:  ( -- ) \ restore default values
                defappmem SetAppMem: self
                defsysmem SetSysMem: self
                defcodemem SetCodeMem: self
                SetEdit: self
                ;M

:M Start:       ( -- n1 )       \ return size of image
                conhndl template run-dialog ;M

:M On_Command:  { hCtrl code ID \ memory$ flag -- f1 }
                64 localAlloc: memory$
                0 to flag

                ID
                case
                IDOK     of  memory$ 31 IDC_EDTAPPMEM GetDlgItemText: self
                             memory$ swap number? abs +to flag drop to appmem
                             memory$ 31 IDC_EDTSYSMEM GetDlgItemText: self
                             memory$ swap number? abs +to flag drop to sysmem
                             memory$ 31 IDC_EDTCODEMEM GetDlgItemText: self
                             memory$ swap number? abs +to flag drop to codemem

                             flag 3 = \ if all are ok, then we are done
                             if
                                  1 end-dialog
                             else beep
                             then             endof

                IDCANCEL of  0 end-dialog     endof
                3        of  SetDefault: self endof

                        false swap ( default result )
                endcase ;M

;Object

--- NEW FILE: gversion.f ---
\ $Id: gversion.f,v 1.1 2006/09/21 16:26:33 dbu_de Exp $

cr .( Loading META version info)

00203     VALUE #VERSION#

\ Change only the version number above; the build number is automatically assigned.
\ After changeing the version number you must rebuild your complete Win32Forth
\ system (including WinEd and SciEdit). Because this Version number is used in
\ wm_win32for-init to create a unique message name.

VERSION# #VERSION# = [IF]
  build# 1+ VALUE #BUILD#
[ELSE]
  1         VALUE #BUILD#
[THEN]

\s <--- remember, this is code -- needed to stop!

Version numbers: v.ww.rr

v   Major version
ww  Minor version
rr  Release

Thread: [Win32forth-cvs] win32forth-stc/src/kernel gMeta.f, NONE, 1.1 gkernel.f, NONE, 1.1 gkernext.f, NONE

win32forth-cvs