File:  [gforth] / gforth / arch / 4stack / prim-new.fs
Revision 1.5: download - view: text, annotated - select for diffs
Mon Dec 31 19:02:24 2007 UTC (14 years, 9 months ago) by anton
Branches: MAIN
CVS tags: HEAD
updated copyright year after changing license notice

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

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