File:  [gforth] / gforth / arch / 4stack / prim-new.fs
Revision 1.1: download - view: text, annotated - select for diffs
Thu May 29 19:42:44 1997 UTC (25 years, 4 months ago) by pazsan
Branches: MAIN
CVS tags: v0-4-0, HEAD
Added port of gforth to 4stack to CVS archive

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

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