: call-syntax-rewrite # ( fnameToken -- handled ) dup token-lexeme identifier? 0 == if drop 0 exit then peek-token dup nil? if drop drop 0 exit then dup token-lexeme "(" string= 0 == if drop drop 0 exit then swap >r # stash fnameTok drop # discard peeked '(' next-token drop # consume '(' list-new # out list-new # out cur begin next-token dup nil? if "unterminated call expression" parse-error then dup token-lexeme ")" string= if drop # flush current arg list-extend # out' r> list-append # out'' inject-tokens 1 exit then dup token-lexeme "," string= if drop list-extend # out' list-new # out' cur continue then # default: append tok to cur list-append again ; immediate compile-only : extend-syntax "call-syntax-rewrite" set-token-hook ; immediate compile-only : fn-op-prec dup "+" string= if drop 1 exit then dup "-" string= if drop 1 exit then dup "*" string= if drop 2 exit then dup "/" string= if drop 2 exit then dup "%" string= if drop 2 exit then drop 0 ; compile-only : fn-operator? fn-op-prec 0 > ; compile-only : fn-check-dup >r # params (r: name) 0 # params idx begin over list-length swap >= if # params flag r> exit then dup >r # params idx (r: idx name) over swap list-get # params elem 1 rpick string= if "duplicate parameter names in fn definition" parse-error then drop # drop comparison flag when no error r> 1 + # params idx+1 again ; compile-only : fn-params list-new # lexer params swap # params lexer >r # params (r: lexer) begin 0 rpick lexer-pop token-lexeme # params lex swap drop # params lex (drop returned lexer) dup ")" string= if drop r> exit then dup "int" string= 0 == if "only 'int' parameters are supported in fn definitions" parse-error then drop # params 0 rpick lexer-pop token-lexeme # params lexer pname swap drop # params pname dup identifier? 0 == if "invalid parameter name in fn definition" parse-error then fn-check-dup # params pname list-append # params 0 rpick lexer-pop token-lexeme # params lexer sep swap drop # params sep dup "," string= if drop continue then dup ")" string= if drop r> exit then "expected ',' or ')' in parameter list" parse-error again ; compile-only : fn-collect-body "{" lexer-expect drop # consume opening brace, keep lexer lexer-collect-brace # lexer bodyTokens swap drop # bodyTokens ; compile-only : fn-lexemes-from-tokens >r # (r: tokens) list-new # acc begin 0 rpick list-empty? if rdrop exit then 0 rpick list-pop-front # acc tokens' first rdrop # acc tokens' swap # acc first tokens' >r # acc first (r: tokens') token-lexeme # acc lex list-append # acc' again ; compile-only : fn-validate-body dup list-length 0 == if "empty function body" parse-error then dup 0 list-get token-lexeme "return" string= 0 == if "function body must start with 'return'" parse-error then dup list-last ";" string= 0 == if "function body must terminate with ';'" parse-error then list-clone # body body' list-pop drop # body expr' (trim trailing ';') list-pop-front drop # body expr (trim leading 'return') dup list-length 0 == if "missing return expression" parse-error then ; compile-only : fn-emit-prologue # params out -- params out over list-length # params out n begin dup 0 > if 1 - # params out n-1 >r # params out (r: n-1) ">r" list-append # params out' r> # params out' n-1 continue then drop # params out exit again ; compile-only : fn-emit-epilogue # params out -- out over list-length >r # params out (r: n) begin r> dup 0 > if 1 - >r "rdrop" list-append continue then drop # drop counter swap drop # out exit again ; compile-only : fn-translate-prologue-loop # count -- dup 0 > if 1 - 0 rpick ">r" list-append drop fn-translate-prologue-loop then drop ; compile-only : fn-translate-epilogue-loop # count -- dup 0 > if 1 - 0 rpick "rdrop" list-append drop fn-translate-epilogue-loop then drop ; compile-only : fn-param-index # params name -- params idx flag >r # params (r: name) 0 # params idx begin over list-length over swap >= if # params idx flag (idx >= len?) drop # params r> drop # drop name -1 0 exit # params -1 0 then # params idx over over list-get # params idx elem 0 rpick string= # params idx flag if r> drop # drop name 1 exit # params idx 1 then drop # params idx 1 + # params idx+1 again ; compile-only : fn-build-param-map # params -- params map map-new # params map 0 # params map idx begin 2 pick list-length # params map idx len over swap >= if # params map idx flag drop # params map exit then # params map idx 2 pick over list-get # params map idx name swap # params map name idx dup >r # params map name idx (r: idx) map-set # params map' r> 1 + # params map' idx' continue again ; compile-only : fn-translate-token # out map tok -- out map # number? dup string>number # out map tok num ok if # drop tok, append num swap drop # out map num swap >r # out num (r: map) list-append # out' r> # out' map exit then drop # out map tok # param? dup >r # out map tok (r: tok) map-get # out map idx|nil ok if # append idx swap >r # out idx (r: map tok) list-append # out' r> # out' map # append "rpick" "rpick" # out' map "rpick" swap >r # out' "rpick" (r: map tok) list-append # out'' r> # out'' map # drop saved tok r> drop # out'' map exit then # not a param: drop idx|nil, append original tok drop # out map r> # out map tok swap >r # out tok (r: map) list-append # out' r> # out' map ; compile-only : fn-translate-postfix-loop # map out postfix -- map out begin dup list-empty? if drop exit then list-pop-front # map out postfix' tok swap >r # map out tok (r: postfix') >r swap r> # out map tok (r: postfix') fn-translate-token # out map swap # map out r> # map out postfix' continue again ; compile-only : fn-translate-postfix # postfix params -- out swap # params postfix list-new # params postfix out # prologue: stash args on return stack (emit ">r") swap >r # params out (r: postfix) fn-emit-prologue # params out r> swap # params postfix out # build param map (name -> index) 2 pick fn-build-param-map # params postfix out params map >r drop r> # params postfix out map # reorder to: params map out postfix swap >r swap r> swap # params map out postfix # translate tokens fn-translate-postfix-loop # params map out # drop map, emit epilogue swap drop # params out fn-emit-epilogue # out ; compile-only : fn-build-body fn-translate-postfix # words ; compile-only : fn "(),{};+-*/%," lexer-new # lexer dup lexer-pop # lexer nameTok dup >r # save nameTok token-lexeme # lexer name dup identifier? 0 == if "invalid function name for 'fn'" parse-error then >r # save name string drop # leave lexer only for params "(" lexer-expect drop # consume '(' keep lexer fn-params # params lexer fn-collect-body # params bodyTokens swap >r # bodyTokens (r: params) fn-lexemes-from-tokens # lexemes fn-validate-body # expr shunt # postfix r> # postfix params fn-build-body # body r> drop # drop name string r> # name token swap emit-definition ; immediate compile-only