level0/meta/meta-asm-commands.f

   1 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;; Native x86 GNU/Linux Forth System
   3 ;; metacompiler
   4 ;;
   5 ;; Copyright (C) 2020 Ketmar Dark // Invisible Vector
   6 ;;
   7 ;; This program is free software: you can redistribute it and/or modify
   8 ;; it under the terms of the GNU General Public License as published by
   9 ;; the Free Software Foundation, version 3 of the License ONLY.
  10 ;;
  11 ;; This program is distributed in the hope that it will be useful,
  12 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;; GNU General Public License for more details.
  15 ;;
  16 ;; You should have received a copy of the GNU General Public License
  17 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  18 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  19 ;; additional assembler commands
  20 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  21
  22 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  23 ;; app entry point
  24 : ENTRY  ( -- )
  25   Reset-Instruction
  26   4 to *OpSize
  27   Imm
  28   ;; label?
  29   *Imm elf-entry-point-addr !
  30   *OpRel if
  31     *ImSize 4 = ERRID_ASM_EXPECT_32BIT_OPERAND not-?asm-error
  32     *ImmName bcount *ImSize *ImmForthType
  33     ;; HACK!
  34     elf-current-pc >r
  35     elf-entry-point-addr real->tc to elf-current-pc
  36     asm-Label-Fixup
  37     r> to elf-current-pc
  38   endif
  39 ;
  40
  41
  42 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  43 : $INCLUDE  ( -- )
  44   tk-str? ERRID_ASM_STRING_EXPECTED not-?asm-error
  45   lexer:tkvalue count pad c4s-copy-a-c
  46   \ lexer:NextToken tk-eol? ERRID_ASM_SYNTAX_ERROR not-?asm-error
  47   pad count include-file
  48 ;
  49
  50
  51 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  52 : $HIDDEN  ( -- )  tc-hidden ;
  53 : $PUBLIC  ( -- )  tc-public ;
  54 : $NORETURN  ( -- )  tc-noreturn ;
  55 : $CODEBLOCK  ( -- )  tc-codeblock ;
  56 : IMMEDIATE  ( -- )  tc-immediate ;
  57
  58 : $ARG_NONE    ( -- )  tc-arg-none ;
  59 : $ARG_BRANCH  ( -- )  tc-arg-branch ;
  60 : $ARG_LIT     ( -- )  tc-arg-lit ;
  61 : $ARG_C4STRZ  ( -- )  tc-arg-c4strz ;
  62 : $ARG_CFA     ( -- )  tc-arg-cfa ;
  63 : $ARG_CBLOCK  ( -- )  tc-arg-cblock ;
  64 : $ARG_VOCID   ( -- )  tc-arg-vocid ;
  65
  66
  67 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  68 hidden:: ($VAR-ETC-CREATE)  ( tc-cfa -- )
  69   ;; get name
  70   tk-str? ERRID_ASM_STRING_EXPECTED not-?asm-error
  71   ;; create word header and CFA
  72   lexer:tkvalue count 2dup upcase-str rot execute
  73   lexer:NextToken
  74 ;
  75
  76 hidden:: ($VAR-COMPILE-VALUE)  ( -- )
  77   ;; parse word value
  78   Reset-Instruction
  79   4 to *OpSize
  80   Imm
  81   ;; label?
  82   *OpRel if
  83     ;; create label fixup
  84     *ImSize 4 = ERRID_ASM_EXPECT_32BIT_OPERAND not-?asm-error
  85     *ImmName bcount *ImSize *ImmForthType asm-Label-Fixup
  86   endif
  87   ;; put value
  88   *Imm tc-,
  89 ;
  90
  91 hidden:: ($VAR-ETC)  ( tc-cfa -- )
  92   ($VAR-ETC-CREATE)
  93   ($VAR-COMPILE-VALUE)
  94   tc-create;
  95 ;
  96
  97 : $VARIABLE     ( -- )  ['] tc-(variable-header-str) ($VAR-ETC) ;
  98 : $CONSTANT     ( -- )  ['] tc-(constant-header-str) ($VAR-ETC) ;
  99 : $VALUE        ( -- )  ['] tc-(value-header-str) ($VAR-ETC) ;
 100 : $DEFER        ( -- )  ['] tc-(defer-header-str) ($VAR-ETC) ;
 101
 102 : $VOCABHEADER  ( -- )
 103   ['] tc-(vocab-header-str) ($VAR-ETC)
 104   tc-create;
 105   ;; patch wordlist name pointer
 106   *OpRel if
 107     *ImmLabelDefined
 108   else
 109     true
 110   endif
 111   if
 112     ;; address is known, fix name pointer
 113     tc-latest-nfa
 114     \ tc-here cell- tc-@  ;; get wordlist address
 115     *Imm                  ;; our wordlist address lives here too ;-)
 116     tc-vocid->headnfa
 117     ;; sanity check
 118     dup tc-@ ?abort" trying to create two headers for one wordlist"
 119     tc-!
 120   else
 121     ;; address is unknown
 122     ?abort" cannot create vocabulary headers with forwards (yet)"
 123   endif
 124 ;
 125
 126 : $ARRAY     ( -- )  ['] tc-(variable-header-str) ($VAR-ETC-CREATE) ;
 127 : $ENDARRAY  ( -- )  tc-create; ;
 128
 129
 130 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 131 : $TABLEMSG  ( -- )
 132   ;; get name
 133   tk-str? ERRID_ASM_STRING_EXPECTED not-?asm-error
 134   \ TODO: check if it is a constant
 135   ;; find constant and put its value
 136   lexer:tkvalue count x-tc-xcfind-must tc-cfa->pfa tc-@ asm-,
 137   lexer:NextToken
 138   ;; message
 139   tk-str? ERRID_ASM_STRING_EXPECTED not-?asm-error
 140   lexer:tkvalue count over + swap ?do i c@ asm-c, loop
 141   0 asm-c,
 142   lexer:NextToken
 143 ;
 144
 145
 146 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 147 : $ALIAS  ( -- )
 148   tk-str? not-?abort" old word name expected"
 149   lexer:tkvalue count x-tc-xcfind not-?abort" old word not found"
 150   lexer:NextToken
 151
 152   tk-str? not-?abort" new word name expected"
 153   lexer:tkvalue count x-tc-xcfind ?abort" new word redefined found"
 154
 155   lexer:tkvalue count tc-(create-str) tc-smudge
 156   tc-(jmp,)
 157
 158   lexer:NextToken
 159 ;
 160
 161
 162 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 163 -1 value tc-has-debugger?  (hidden)
 164 0 value tc-urforth-next-ptr  (hidden)
 165
 166 hidden:: tc-NEXT  ( -- )
 167   tc-has-debugger? 0< if
 168     " URFORTH_DEBUG" asmx86:asm-Get-Constant if
 169       notnot to tc-has-debugger?
 170       tc-has-debugger? if
 171         " urforth_next_ptr" asmx86:asm-Get-Label 1 <> ?abort" \`urforth_next_ptr\` must be defined"
 172         to tc-urforth-next-ptr
 173       endif
 174     endif
 175   endif
 176
 177   \ " lodsd" asm-str
 178   $AD asm-c,
 179   \ either "jmp eax" of "jmp dword [nextref]"
 180   $FF asm-c, \ both has prefixes
 181   tc-has-debugger? 0> if
 182     $25 asm-c, tc-urforth-next-ptr asm-,
 183   else
 184     $E0 asm-c,
 185   endif
 186 ;
 187
 188 replace asmx86:macro-instrs:NEXT tc-NEXT