File:  [gforth] / gforth / arch / 4stack / prim-new.fs
Revision 1.6: download - view: text, annotated - select for diffs
Sun Oct 19 21:19:06 2008 UTC (13 years, 11 months ago) by pazsan
Branches: MAIN
CVS tags: HEAD
Minor fixes to make 4stack work again (build with 32 bit engine!)

    1: \ 4stack primitives
    2: 
    3: \ Copyright (C) 2000,2007 Free Software Foundation, Inc.
    4: 
    5: \ This file is part of Gforth.
    6: 
    7: \ Gforth is free software; you can redistribute it and/or
    8: \ modify it under the terms of the GNU General Public License
    9: \ as published by the Free Software Foundation, either version 3
   10: \ of the License, or (at your option) any later version.
   11: 
   12: \ This program is distributed in the hope that it will be useful,
   13: \ but WITHOUT ANY WARRANTY; without even the implied warranty of
   14: \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   15: \ GNU General Public License for more details.
   16: 
   17: \ You should have received a copy of the GNU General Public License
   18: \ along with this program. If not, see http://www.gnu.org/licenses/.
   19: 
   20: Label start  ;;
   21: nop          ;; first opcode must be a nop!
   22: $80000000 ## ;;
   23: #,           ;;
   24: sr!          jmpa $828 >IP ;;
   25: 
   26: $800 .org
   27: ip0:	.int 0
   28: 	.int 0
   29: conpat:	nop      nop       ip@      jmpa                              ;;
   30: varpat:	nop      nop       ip@      jmpa                              ;;
   31: jmppat:	nop      ip@       nop      jmpa                              ;;
   32: colpat:	nop      nop       ip@      jmpa                              ;;
   33: ;;      ds       cfa       fs       rs
   34: main:   ;;
   35: 	-$200 ## nop       nop      nop       -12 #       ld 1: ip    ;;
   36: 	#,       nop       nop      nop       set 0: R3               ;;
   37: 	nop      nop       nop      nop       0 #         set 1: R1   ;;
   38: 	nop      nop       nop      nop       0 #         ld 1: R1 N+ ;;
   39: 	nop      nop       nop      nop       0 #         ld 1: R1 N+ ;;
   40: 	nop      ip!       nop      nop       0 #         ld 1: R1 N+ ;;
   41: 	nop      ip!       ip@      nop       set 2: R1   ld 1: R1 N+ ;;
   42: 
   43: docol:  .endif ;;
   44: ;;	nop      nop       ip@      jmp docol                         ;;
   45: ;;      ds ca    cfa       fs       rs
   46:         nop      8 #       drop     -12 #     get 0: R1   get 3: R1   ;;
   47: 	drop     add 0s0   nop      add       0 #         set 1: R1   ;;
   48: 	nop      drop      nop      nop       0 #         ld 1: R1 N+ ;;
   49: 	nop      drop      nop      nop       0 #         ld 1: R1 N+ ;;
   50: 	nop      ip!       nop      nop       0 #         ld 1: R1 N+ ;;
   51: 	nop      ip!       ip@      nop       set 2: R1   ld 1: R1 N+ ;;
   52: dodoes: .endif ;;
   53: ;;      nop      nop       ip@      jmp doesjump
   54: ;;      nop      ip@       nop      jmp dodoes
   55: ;;      ds df ca cfa       fs       rs
   56: 	8 #      nop       drop     -12 #     get 0: R1   get 3: R1   ;;
   57: 	add      nop       nop      add       0 #         set 1: R1   ;;
   58: 	nop      drop      nop      nop       0 #         ld 1: R1 N+ ;;
   59: 	nop      drop      nop      nop       0 #         ld 1: R1 N+ ;;
   60: 	nop      ip!       nop      nop       0 #         ld 1: R1 N+ ;;
   61: 	nop      ip!       ip@      nop       set 2: R1   ld 1: R1 N+ ;;
   62: dovar:  .endif ;;
   63: ;;	nop      nop       ip@      jmp dovar                         ;;
   64: ;;      ds       cfa       fs       rs
   65: 	8 #      swap      ip!      nop       get 0: R1               ;;
   66: 	add      ip!       ip@      nop       set 2: R1   ld 1: R1 N+ ;;
   67: 
   68: docon:  .endif ;;
   69: ;;	nop      nop       ip@      jmp dovar                         ;;
   70: ;;      ds       cfa       fs       rs
   71: 	nop      swap      ip!      nop       ld 0: R1    2 #         ;;
   72: 	nop      ip!       ip@      nop       set 2: R1   ld 1: R1 N+ ;;
   73: end-code
   74: 
   75: -2 Doer: :docol
   76: -3 Doer: :docon
   77: -4 Doer: :dovar
   78: -8 Doer: :dodoes
   79: -9 Doer: :doesjump
   80: 
   81: Code execute ( xt -- )
   82: 	nop      nop       nop      ip@       br .endif
   83: 	ip!      drop      pick 0s0 nop       set 2: R1               ;;
   84: 	nop      nop       nop      ip!       -1 #        ld 1: R1    ;;
   85: end-code
   86: 
   87: Code ?branch
   88: 	nop      nop       nop      ip@       br .endif
   89: 	nop      swap      nop      nop       br 0 ?0<>
   90: 	nop      nop       nop      nop       -12 #       R1= R1 3: +s0 ;;
   91: 	nop      drop      nop      nop       0 #         ld 1: R1 N+ ;;
   92: 	nop      drop      nop      nop       0 #         ld 1: R1 N+ ;;
   93: .endif
   94: 	nop      ip!       nop      drop      0 #         ld 1: R1 N+ ;;
   95: 	nop      ip!       ip@      nop       set 2: R1   ld 1: R1 N+ ;;
   96: end-code
   97: 
   98: Code +
   99: 	add      ip!       ip@      nop       set 2: R1   ld 1: R1 N+ ;;
  100: end-code
  101: 
  102: Code and
  103: 	and      ip!       ip@      nop       set 2: R1   ld 1: R1 N+ ;;
  104: end-code
  105: 
  106: Code xor
  107: 	xor      ip!       ip@      nop       set 2: R1   ld 1: R1 N+ ;;
  108: end-code
  109: 
  110: Code sp@
  111: 	sp@      ip!       ip@      nop       set 2: R1   ld 1: R1 N+ ;;
  112: end-code
  113: 
  114: Code sp!
  115: 	sp!      ip!       ip@      nop       set 2: R1   ld 1: R1 N+ ;;
  116: end-code
  117: 
  118: Code rp@
  119: 	nop      nop       ip@      sp@       br .endif
  120: 	pick 3s0 swap      ip!      drop                              ;;
  121: 	nop      ip!       ip@      nop       set 2: R1   ld 1: R1 N+ ;;
  122: end-code
  123: 
  124: Code rp!
  125: 	drop     nop       ip@      pick 0s0  br .endif
  126: 	nop      swap      ip!      sp!                               ;;
  127: 	nop      ip!       ip@      nop       set 2: R1   ld 1: R1 N+ ;;
  128: end-code
  129: 
  130: Code ;s
  131: 	nop      nop       nop      nop       br .endif
  132: 	nop      drop      nop      nop       0 #         set 3: R1   ;;
  133: 	nop      drop      nop      nop       0 #         ld 1: R1 N+ ;;
  134: 	nop      nop       nop      nop       0 #         ld 1: R1 N+ ;;
  135: 	nop      ip!       nop      nop       0 #         ld 1: R1 N+ ;;
  136: 	nop      ip!       ip@      nop       set 2: R1   ld 1: R1 N+ ;;
  137: end-code
  138: 
  139: Code @
  140: 	nop      nop       ip@      nop       br .endif
  141: 	drop     swap      ip!      nop       ld 0: s0b   0 #         ;;
  142: 	nop      ip!       ip@      nop       set 2: R1   ld 1: R1 N+ ;;
  143: end-code
  144: 
  145: Code !
  146: 	nop      nop       ip@      nop       br .endif
  147: 	drop     swap      ip!      nop       st 0: s0b   0 #         ;;
  148: 	nop      ip!       ip@      nop       set 2: R1   ld 1: R1 N+ ;;
  149: end-code
  150: 
  151: \ obligatory IO
  152: 
  153: Code key?
  154: 	nop      nop       ip@      nop       br .endif
  155: 	nop      swap      nop      nop       inb R3      3 #         ;;
  156: 	nop      nop       ip!      nop                               ;;
  157: 	0<>      ip!       ip@      nop       set 2: R1   ld 1: R1 N+ ;;
  158: end-code
  159: 
  160: Code (key)
  161: 	nop      nop       ip@      nop       br .endif
  162: .begin					      inb R3	  3 #         ;;
  163: 	nop				      br 0 ?0= .until
  164: 					      inb R3	  2 #         ;;
  165: 	nop      swap      ip!      nop                               ;;
  166: 	nop      ip!       ip@      nop       set 2: R1   ld 1: R1 N+ ;;
  167: end-code
  168: 
  169: Code (emit)
  170: 	nop      nop       ip@      nop       br .endif
  171: ;; .begin					      inb R3	  1 #         ;;
  172: ;;	nop				      br 0 ?0= .until
  173: 					      outb 0: R3  0 #         ;;
  174: 	nop      swap      ip!      nop                               ;;
  175: 	nop      ip!       ip@      nop       set 2: R1   ld 1: R1 N+ ;;
  176: end-code
  177: 
  178: Code 2/
  179: 	asr      ip!       ip@      nop       set 2: R1   ld 1: R1 N+ ;;
  180: end-code
  181: 
  182: Code branch
  183: 	nop      nop       nop      ip@       br .endif
  184: 	nop      nop       nop      nop       -12 #       R1= R1 3: +s0 ;;
  185: 	nop      drop      nop      nop       0 #         ld 1: R1 N+ ;;
  186: 	nop      drop      nop      nop       0 #         ld 1: R1 N+ ;;
  187: 	nop      ip!       nop      drop      0 #         ld 1: R1 N+ ;;
  188: 	nop      ip!       ip@      nop       set 2: R1   ld 1: R1 N+ ;;
  189: end-code
  190: 
  191: Code (loop)
  192: 	pick 3s1 nop       nop      ip@       br .endif
  193: 	dec      nop       nop      nop                               ;;
  194: 	sub 3s1  swap      nop      nop       br 0 ?0=
  195: 	nop      nop       nop      nop       -12 #       R1= R1 3: +s0 ;;
  196: 	nop      drop      nop      nop       0 #         ld 1: R1 N+ ;;
  197: 	nop      drop      nop      nop       0 #         ld 1: R1 N+ ;;
  198: .endif
  199: 	nop      ip!       nop      drop      0 #         ld 1: R1 N+ ;;
  200: 	nop      ip!       ip@      inc       set 2: R1   ld 1: R1 N+ ;;
  201: end-code
  202: 
  203: Code (+loop)
  204: 	pick 3s1 nop       nop      ip@       br .endif
  205: 	subr 3s1 nop       nop      nop                               ;;
  206: 	xor #min nop       nop      nop                               ;;
  207: 	add s1   swap      nop      nop       br 0 ?ov
  208: 	nop      nop       nop      nop       -12 #       R1= R1 3: +s0 ;;
  209: 	nop      drop      nop      nop       0 #         ld 1: R1 N+ ;;
  210: 	nop      drop      nop      nop       0 #         ld 1: R1 N+ ;;
  211: .endif
  212: 	nop      ip!       nop      drop      0 #         ld 1: R1 N+ ;;
  213: 	drop     ip!       ip@      add 0s0   set 2: R1   ld 1: R1 N+ ;;
  214: end-code
  215: 
  216: Code (do)
  217: 	nop      nop       ip@      nop       br .endif
  218: 	nip      swap      ip!      pick 0s1                          ;;
  219: 	drop     ip!       ip@      pick 0s0  set 2: R1   ld 1: R1 N+ ;;
  220: end-code
  221: 
  222: Code -
  223: 	subr     ip!       ip@      nop       set 2: R1   ld 1: R1 N+ ;;
  224: end-code
  225: 
  226: Code or
  227: 	or       ip!       ip@      nop       set 2: R1   ld 1: R1 N+ ;;
  228: end-code
  229: 
  230: Code 1+
  231: 	inc      ip!       ip@      nop       set 2: R1   ld 1: R1 N+ ;;
  232: end-code
  233: 
  234: Code 2*
  235: 	asl      ip!       ip@      nop       set 2: R1   ld 1: R1 N+ ;;
  236: end-code
  237: 
  238: Code cell+
  239: 	add c2   ip!       ip@      nop       set 2: R1   ld 1: R1 N+ ;;
  240: end-code
  241: 
  242: Code cells
  243: 	nop      nop       ip@      nop       br .endif
  244: 	asl      swap      ip!      nop                               ;;
  245: 	asl      ip!       ip@      nop       set 2: R1   ld 1: R1 N+ ;;
  246: end-code
  247: 
  248: Code c@
  249: 	nop      nop       ip@      nop       br .endif
  250: 	drop     swap      ip!      nop       ldb 0: s0b   0 #         ;;
  251: 	nop      ip!       ip@      nop       set 2: R1   ld 1: R1 N+ ;;
  252: end-code
  253: 
  254: Code c!
  255: 	nop      nop       ip@      nop       br .endif
  256: 	drop     swap      ip!      nop       stb 0: s0b   0 #         ;;
  257: 	nop      ip!       ip@      nop       set 2: R1   ld 1: R1 N+ ;;
  258: end-code
  259: 
  260: Code um*
  261: 	nop      nop       ip@      nop       br .endif
  262: 	umul     swap      ip!      nop                               ;;
  263: 	mul@     ip!       ip@      nop       set 2: R1   ld 1: R1 N+ ;;
  264: end-code
  265: 
  266: Code m*
  267: 	nop      nop       ip@      nop       br .endif
  268: 	mul      swap      ip!      nop                               ;;
  269: 	mul@     ip!       ip@      nop       set 2: R1   ld 1: R1 N+ ;;
  270: end-code
  271: 
  272: Code d+
  273: 	nop      nop       ip@      nop       br .endif
  274: 	pass     swap      ip!      nop                               ;;
  275: 	mul@+    ip!       ip@      nop       set 2: R1   ld 1: R1 N+ ;;
  276: end-code
  277: 
  278: Code >r
  279: 	drop     ip!       ip@      pick 0s0  set 2: R1   ld 1: R1 N+ ;;
  280: end-code
  281: 
  282: Code r>
  283: 	pick 3s0 ip!       ip@      drop      set 2: R1   ld 1: R1 N+ ;;
  284: end-code
  285: 
  286: Code drop
  287: 	drop     ip!       ip@      nop       set 2: R1   ld 1: R1 N+ ;;
  288: end-code
  289: 
  290: Code swap
  291: 	swap     ip!       ip@      nop       set 2: R1   ld 1: R1 N+ ;;
  292: end-code
  293: 
  294: Code over
  295: 	over     ip!       ip@      nop       set 2: R1   ld 1: R1 N+ ;;
  296: end-code
  297: 
  298: Code 2dup
  299: 	nop      nop       ip@      nop       br .endif
  300: 	over     swap      ip!      nop                               ;;
  301: 	over     ip!       ip@      nop       set 2: R1   ld 1: R1 N+ ;;
  302: end-code
  303: 
  304: Code rot
  305: 	rot      ip!       ip@      nop       set 2: R1   ld 1: R1 N+ ;;
  306: end-code
  307: 
  308: Code -rot
  309: 	nop      nop       ip@      nop       br .endif
  310: 	rot      swap      ip!      nop                               ;;
  311: 	rot      ip!       ip@      nop       set 2: R1   ld 1: R1 N+ ;;
  312: end-code
  313: 
  314: Code i
  315: 	pick 3s0 ip!       ip@      nop       set 2: R1   ld 1: R1 N+ ;;
  316: end-code
  317: 
  318: Code i'
  319: 	pick 3s1 ip!       ip@      nop       set 2: R1   ld 1: R1 N+ ;;
  320: end-code
  321: 
  322: Code j
  323: 	pick 3s2 ip!       ip@      nop       set 2: R1   ld 1: R1 N+ ;;
  324: end-code
  325: 
  326: Code lit
  327: 	ip@      nop       pick 1s0 nop       br .endif                ;;
  328: 	nop      nip       ip!      nop       0 #         ld 1: R1 N+ ;;
  329: 	nop      ip!       ip@      nop       set 2: R1   ld 1: R1 N+ ;;
  330: end-code
  331: 
  332: Code 0=
  333: 	0=       ip!       ip@      nop       set 2: R1   ld 1: R1 N+ ;;
  334: end-code
  335: 
  336: Code 0<>
  337: 	0<>      ip!       ip@      nop       set 2: R1   ld 1: R1 N+ ;;
  338: end-code
  339: 
  340: Code u<
  341: 	nop      nop       ip@      nop       br .endif
  342: 	subr     swap      ip!      nop                               ;;
  343: 	u<       ip!       ip@      nop       set 2: R1   ld 1: R1 N+ ;;
  344: end-code
  345: 
  346: Code u>
  347: 	nop      nop       ip@      nop       br .endif
  348: 	subr     swap      ip!      nop                               ;;
  349: 	u>       ip!       ip@      nop       set 2: R1   ld 1: R1 N+ ;;
  350: end-code
  351: 
  352: Code u>=
  353: 	nop      nop       ip@      nop       br .endif
  354: 	subr     swap      ip!      nop                               ;;
  355: 	u>=      ip!       ip@      nop       set 2: R1   ld 1: R1 N+ ;;
  356: end-code
  357: 
  358: Code u<=
  359: 	nop      nop       ip@      nop       br .endif
  360: 	subr     swap      ip!      nop                               ;;
  361: 	u<=      ip!       ip@      nop       set 2: R1   ld 1: R1 N+ ;;
  362: end-code
  363: 
  364: Code >=
  365: 	nop      nop       ip@      nop       br .endif
  366: 	subr     swap      ip!      nop                               ;;
  367: 	>=       ip!       ip@      nop       set 2: R1   ld 1: R1 N+ ;;
  368: end-code
  369: 
  370: Code <=
  371: 	nop      nop       ip@      nop       br .endif
  372: 	subr     swap      ip!      nop                               ;;
  373: 	<=       ip!       ip@      nop       set 2: R1   ld 1: R1 N+ ;;
  374: end-code
  375: 
  376: Code =
  377: 	nop      nop       ip@      nop       br .endif
  378: 	subr     swap      ip!      nop                               ;;
  379: 	0=       ip!       ip@      nop       set 2: R1   ld 1: R1 N+ ;;
  380: end-code
  381: 
  382: Code <>
  383: 	nop      nop       ip@      nop       br .endif
  384: 	subr     swap      ip!      nop                               ;;
  385: 	0<>      ip!       ip@      nop       set 2: R1   ld 1: R1 N+ ;;
  386: end-code
  387: 
  388: \ : (find-samelen) ( u f83name1 -- u f83name2/0 )
  389: \     BEGIN  2dup cell+ c@ $1F and <> WHILE  @  dup 0= UNTIL  THEN ;
  390: Code (find-samelen)
  391: 	nop      nop       ip@      nop       br .endif
  392:         nop      0 #       0 #      nop                               ;;
  393: 	nop      nop       pick 0s0 nop                               ;;
  394: .begin
  395: 	drop     drop      nop      nop       ldb 0: s0b  4 #         ;;
  396:         nop      $1F #     nip      nop       ld 2: s0b   0 #         ;;
  397: 	drop     and 0s0   nop      nop                               ;;
  398: 	pick 2s0 sub 0s0   nop      nop       br 1&2 :0<> .until      ;;
  399: 	pick 2s1 nop       pass     nop       br 1 ?0=                ;;
  400: 	drop     swap      ip!      nop                               ;;
  401: 	nop      ip!       ip@      nop       set 2: R1   ld 1: R1 N+ ;;
  402: .endif
  403: 	nip      swap      ip!      nop                               ;;
  404: 	nop      ip!       ip@      nop       set 2: R1   ld 1: R1 N+ ;;
  405: end-code
  406: 
  407: \ obligatory code address manipulations
  408: 
  409: : >code-address ( xt -- addr )  cell+ @ -8 and ;
  410: : >does-code    ( xt -- addr )
  411:     cell+ @ -8 and \ dup 3 and 3 <> IF  drop 0  EXIT  THEN
  412:     8 + dup cell - @ 3 and 0<> and ;
  413: : code-address! ( addr xt -- )  >r 3 or $808 @ r> 2! ;
  414: : does-code!    ( a_addr xt -- )  >r 5 - $808 @ r> 2! ;
  415: : does-handler! ( a_addr -- )  $818 2@ rot 2! ;
  416: 
  417: \ this was obligatory, now some things to speed it up
  418: 
  419: : (type)
  420:     bounds ?DO  I c@ (emit)  LOOP ;
  421: \    BEGIN  dup  WHILE
  422: \	>r dup c@ (emit) 1+ r> 1-  REPEAT  2drop ;
  423: 
  424: \ division a/b
  425: \ x:=a, y:=b, r:=est; iterate(x:=x*r, y:=y*r, r:=2-y*r);
  426: \ result: x=a/b; y=1; r=1
  427: 
  428: \ Label idiv-table
  429: \ idiv-tab:
  430: \ .macro .idiv-table [F]
  431: \ 	$100 $80 DO  0 $100 I 2* 1+ um/mod  long, drop  LOOP
  432: \ .end-macro
  433: \ 	.idiv-table
  434: \ end-code
  435: \ 
  436: \ Code um/mod1 ( u -- 1/u )
  437: \ ;;	b        --        --       --        --          --          ;;
  438: \ 	ff1      -$1F #    nop      nop       br 0 :0= div0
  439: \ 	bfu      add 0s0   ip@      nop       set 2: R2               ;;
  440: \ ;;	b'       --        --       --        --          --          ;;
  441: \ 	lob      $0FF ##   pick 0s0 pick 0s0  0 #         -$108 ## ;;
  442: \ 	1 #      #,        sub #min 1 #       ld 0: R2 +s0 #,         ;;
  443: \ 	cm!      and       nop      cm!       br 2 ?0= by2
  444: \ ;;      est      --        --       b'        --          --          ;;
  445: \ 	umul 3s0 pick 0s0  nop      umul 0s0  0 #         0 #         ;;
  446: \ 	mulr<@   nop       nop      -mulr@                            ;;
  447: \ 	drop     umul 3s0  nop      umul 0s0                          ;;
  448: \ 	mulr<@   cm!       nop      -mulr@                            ;;
  449: \ 	umul 3s0 drop      pick 1s0 drop                              ;;
  450: \ 	drop     mulr<@    ip!      nop       0 #         ld 1: R1 N+ ;;
  451: \ 	pick 1s0 drop      nop      nop                               ;;
  452: \ by2:
  453: \ div0:
  454: \ 	-1 #     ip!       nop      nop       0 #         ld 1: R1 N+ ;;
  455: \ 	nop      nop       nop      nop                               ;;
  456: \ end-code

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>