rpn: new demo, simple RPN calculator that doesn't use Factor's evaluator reflectively
							parent
							
								
									bf57d78b09
								
							
						
					
					
						commit
						4fac281b1a
					
				| 
						 | 
				
			
			@ -39,19 +39,19 @@ TUPLE: A
 | 
			
		|||
    dup length T heap-size /mod 0 = [ drop T bad-byte-array-length ] unless
 | 
			
		||||
    swap A boa ; inline
 | 
			
		||||
 | 
			
		||||
M: A clone [ length>> ] [ underlying>> clone ] bi A boa ;
 | 
			
		||||
M: A clone [ length>> ] [ underlying>> clone ] bi A boa ; inline
 | 
			
		||||
 | 
			
		||||
M: A length length>> ;
 | 
			
		||||
M: A length length>> ; inline
 | 
			
		||||
 | 
			
		||||
M: A nth-unsafe underlying>> NTH call ;
 | 
			
		||||
M: A nth-unsafe underlying>> NTH call ; inline
 | 
			
		||||
 | 
			
		||||
M: A set-nth-unsafe underlying>> SET-NTH call ;
 | 
			
		||||
M: A set-nth-unsafe underlying>> SET-NTH call ; inline
 | 
			
		||||
 | 
			
		||||
: >A ( seq -- specialized-array ) A new clone-like ; inline
 | 
			
		||||
: >A ( seq -- specialized-array ) A new clone-like ;
 | 
			
		||||
 | 
			
		||||
M: A like drop dup A instance? [ >A ] unless ;
 | 
			
		||||
M: A like drop dup A instance? [ >A ] unless ; inline
 | 
			
		||||
 | 
			
		||||
M: A new-sequence drop (A) ;
 | 
			
		||||
M: A new-sequence drop (A) ; inline
 | 
			
		||||
 | 
			
		||||
M: A equal? over A instance? [ sequence= ] [ 2drop f ] if ;
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			@ -60,9 +60,9 @@ M: A resize
 | 
			
		|||
        [ T heap-size * ] [ underlying>> ] bi*
 | 
			
		||||
        resize-byte-array
 | 
			
		||||
    ] 2bi
 | 
			
		||||
    A boa ;
 | 
			
		||||
    A boa ; inline
 | 
			
		||||
 | 
			
		||||
M: A byte-length underlying>> length ;
 | 
			
		||||
M: A byte-length underlying>> length ; inline
 | 
			
		||||
 | 
			
		||||
M: A pprint-delims drop \ A{ \ } ;
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -0,0 +1 @@
 | 
			
		|||
Slava Pestov
 | 
			
		||||
| 
						 | 
				
			
			@ -0,0 +1,45 @@
 | 
			
		|||
! Copyright (C) 2009 Slava Pestov
 | 
			
		||||
! See http://factorcode.org/license.txt for BSD license.
 | 
			
		||||
USING: accessors combinators io kernel lists math math.parser
 | 
			
		||||
sequences splitting ;
 | 
			
		||||
IN: rpn
 | 
			
		||||
 | 
			
		||||
SINGLETONS: add-insn sub-insn mul-insn div-insn ;
 | 
			
		||||
TUPLE: push-insn value ;
 | 
			
		||||
 | 
			
		||||
GENERIC: eval-insn ( stack insn -- stack )
 | 
			
		||||
 | 
			
		||||
: binary-op ( stack quot: ( x y -- z ) -- stack )
 | 
			
		||||
    [ uncons uncons ] dip dip cons ; inline
 | 
			
		||||
 | 
			
		||||
M: add-insn eval-insn drop [ + ] binary-op ;
 | 
			
		||||
M: sub-insn eval-insn drop [ - ] binary-op ;
 | 
			
		||||
M: mul-insn eval-insn drop [ * ] binary-op ;
 | 
			
		||||
M: div-insn eval-insn drop [ / ] binary-op ;
 | 
			
		||||
M: push-insn eval-insn value>> swons ;
 | 
			
		||||
 | 
			
		||||
: rpn-tokenize ( string -- string' )
 | 
			
		||||
    " " split harvest sequence>list ;
 | 
			
		||||
 | 
			
		||||
: rpn-parse ( string -- tokens )
 | 
			
		||||
    rpn-tokenize [
 | 
			
		||||
        {
 | 
			
		||||
            { "+" [ add-insn ] }
 | 
			
		||||
            { "-" [ sub-insn ] }
 | 
			
		||||
            { "*" [ mul-insn ] }
 | 
			
		||||
            { "/" [ div-insn ] }
 | 
			
		||||
            [ string>number push-insn boa ]
 | 
			
		||||
        } case
 | 
			
		||||
    ] lmap ;
 | 
			
		||||
 | 
			
		||||
: print-stack ( list -- )
 | 
			
		||||
    [ number>string print ] leach ;
 | 
			
		||||
 | 
			
		||||
: rpn-eval ( tokens -- )
 | 
			
		||||
    nil [ eval-insn ] foldl print-stack ;
 | 
			
		||||
 | 
			
		||||
: rpn ( -- )
 | 
			
		||||
    "RPN> " write flush
 | 
			
		||||
    readln [ rpn-parse rpn-eval rpn ] when* ;
 | 
			
		||||
 | 
			
		||||
MAIN: rpn
 | 
			
		||||
| 
						 | 
				
			
			@ -0,0 +1 @@
 | 
			
		|||
Simple RPN calculator
 | 
			
		||||
| 
						 | 
				
			
			@ -0,0 +1 @@
 | 
			
		|||
demos
 | 
			
		||||
		Loading…
	
		Reference in New Issue