File:  [gforth] / gforth / arch / 4stack / prim.fs
Revision 1.7: download - view: text, annotated - select for diffs
Sun Mar 9 15:16:58 2003 UTC (19 years, 8 months ago) by anton
Branches: MAIN
CVS tags: v0-6-1, v0-6-0, HEAD
updated copyright years

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

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