File:  [gforth] / gforth / arch / 4stack / prim-new.fs
Revision 1.3: download - view: text, annotated - select for diffs
Sat Sep 23 15:47:01 2000 UTC (22 years, 2 months ago) by anton
Branches: MAIN
CVS tags: v0-6-2, v0-6-1, v0-6-0, v0-5-0, HEAD
changed FSF address in copyright messages

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

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