File:  [gforth] / gforth / arch / 4stack / prim.fs
Revision 1.17: download - view: text, annotated - select for diffs
Sat Nov 1 22:19:30 2008 UTC (14 years ago) by anton
Branches: MAIN
CVS tags: v0-7-0, HEAD
updated copyright years

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

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