Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

initial commit

  • Loading branch information...
commit 50e47961a8bb1c9a6e1796f1d75e9385581cb4be 0 parents
Tomohiro Matsuyama authored
5 .gitignore
@@ -0,0 +1,5 @@
+*.fasl
+*.dx64fsl
+*.dx32fsl
+*.lx64fsl
+*.x86f
22 ruby-parser.asd
@@ -0,0 +1,22 @@
+(asdf:defsystem :ruby-parser
+ :description "Ruby Parser"
+ :author "Tomohiro Matsuyama"
+ :depends-on (:alexandria
+ :iterate
+ :anaphora
+ :optima
+ :yacc
+ :cl-ppcre
+ :closer-mop
+ :parse-number)
+ :components ((:module "src"
+ :serial t
+ :components ((:file "packages")
+ (:file "util")
+ (:file "specials")
+ (:file "types")
+ (:file "ast")
+ (:file "source")
+ (:file "env")
+ (:file "lexer")
+ (:file "parser")))))
198 src/ast.lisp
@@ -0,0 +1,198 @@
+(in-package :ruby-parser)
+
+(defstruct node loc)
+
+;;; Literals
+
+(defvariant (literal (:include node))
+ (string-lit (value (proper-list string-content)))
+ (xstring-lit (value (proper-list string-content)))
+ (symbol-lit (value (proper-list string-content)))
+ (integer-lit (value integer))
+ (float-lit (value float))
+ (regexp-lit (value (proper-list string-content))
+ (flag regexp-flag :init-form nil)))
+
+(deftype string-content ()
+ '(or string expr))
+
+(deftype regexp-flag ()
+ '(member nil :once))
+
+;;; Identifiers
+
+(defvariant (identifier (:include node))
+ (lvar (name string))
+ (dvar (name string))
+ (ivar (name string))
+ (cvar (name string))
+ (gvar (name string))
+ (const (cpath cpath))
+ (pvar (name pseudo-variable)))
+
+(defvariant (cpath (:include node))
+ (cpath-name (string string))
+ (cpath-rel (base expr)
+ (string string))
+ (cpath-glob (cpath cpath)))
+
+(deftype pseudo-variable ()
+ '(member :nil :true :false :self :__FILE__ :__LINE__))
+
+;;; Parameters
+
+(defvariant (parameter (:include node))
+ (param (name string))
+ (opt-param (name string)
+ (init expr))
+ (rest-param (name string))
+ (star-param)
+ (block-param (name string)))
+
+;;; Arguments
+
+(defvariant (argument (:include node))
+ (arg-value (expr expr))
+ (arg-splat (expr expr))
+ (arg-block (expr expr))
+ (arg-hash (list (proper-list expr))))
+
+;;; LHS
+
+(defvariant (lhs (:include node))
+ (lhs-id (id identifier))
+ (lhs-decl (id identifier))
+ (lhs-dest (list (proper-list lhs)))
+ (lhs-rest (lhs lhs))
+ (lhs-star)
+ (lhs-attr (self expr)
+ (meth string))
+ (lhs-aref (self expr)
+ (args (proper-list argument)))
+ (lhs-op (lhs lhs)
+ (op string))
+ (lhs-or (lhs lhs))
+ (lhs-and (lhs lhs)))
+
+;;; Misc
+
+(defstruct (blk (:include node))
+ (vars (required-argument) :type (proper-list lhs))
+ (body (required-argument) :type (proper-list stmt)))
+
+(deftype assign-kind ()
+ '(member :single :svalue :multi))
+
+;;; Statements
+
+(defvariant (stmt (:include node))
+ (alias-stmt (new string)
+ (old string))
+ (undef-stmt (list (proper-list string)))
+ (if-mod-stmt (stmt stmt)
+ (test expr))
+ (unless-mod-stmt (stmt stmt)
+ (test expr))
+ (while-mod-stmt (stmt stmt)
+ (test expr))
+ (until-mod-stmt (stmt stmt)
+ (test expr))
+ (rescue-mod-stmt (stmt stmt)
+ (else stmt))
+ (pre-exec-stmt (body (proper-list stmt)))
+ (post-exec-stmt (body (proper-list stmt)))
+ (expr-stmt (expr expr)))
+
+;;; Expressions
+
+(defvariant (expr (:include node))
+ (lit-expr (lit literal))
+ (id-expr (id identifier))
+ (nth-ref-expr (n fixnum))
+ (back-ref-expr (c character))
+ (array-expr (args (proper-list argument)))
+ (hash-expr (args (proper-list expr)))
+ (dot2-expr (lhs expr)
+ (rhs expr))
+ (dot3-expr (lhs expr)
+ (rhs expr))
+ (not-expr (expr expr))
+ (and-expr (lhs expr)
+ (rhs expr))
+ (or-expr (lhs expr)
+ (rhs expr))
+ (defined-expr (expr expr))
+ (tern-expr (test expr)
+ (then expr)
+ (else expr))
+ (if-expr (test expr)
+ (then (proper-list stmt))
+ (else (proper-list stmt)))
+ (unless-expr (test expr)
+ (then (proper-list stmt))
+ (else (proper-list stmt)))
+ (while-expr (test expr)
+ (body (proper-list stmt)))
+ (until-expr (test expr)
+ (body (proper-list stmt)))
+ (for-expr (lhs lhs)
+ (gen expr)
+ (body (proper-list stmt)))
+ (case-expr (test (or null expr) :init-form nil)
+ (whens (proper-list (cons (proper-list argument)
+ (proper-list stmt))))
+ (else (proper-list stmt)))
+ (break-expr (args (proper-list argument) :init-form '()))
+ (next-expr (args (proper-list argument) :init-form '()))
+ (redo-expr)
+ (retry-expr)
+ (call-expr (recv (or null expr) :init-form nil)
+ (meth string)
+ (args (proper-list argument) :init-form '())
+ (block (or null blk) :init-form nil))
+ (return-expr (args (proper-list argument) :init-form '()))
+ (yield-expr (args (proper-list argument) :init-form '()))
+ (super-expr (args (proper-list argument) :init-form '())
+ (block (or null blk) :init-form nil))
+ (zsuper-expr (block (or null blk) :init-form nil))
+ (assign-expr (lhs lhs)
+ (rhs expr)
+ (kind assign-kind))
+ (body-stmt (body (proper-list stmt))
+ (rescues (proper-list (cons (proper-list argument)
+ (proper-list stmt))))
+ (else (proper-list stmt))
+ (ensure (proper-list stmt)))
+ (class-expr (cpath cpath)
+ (super (or null expr) :init-form nil)
+ (body body-stmt))
+ (sclass-expr (expr expr)
+ (body body-stmt))
+ (module-expr (cpath cpath)
+ (body body-stmt))
+ (defn-expr (name string)
+ (params (proper-list parameter))
+ (body body-stmt))
+ (defs-expr (expr expr)
+ (name string)
+ (params (proper-list parameter))
+ (body body-stmt))
+ (begin-expr (body body-stmt))
+ (block-expr (body (proper-list stmt))))
+
+;;; Export
+
+(labels ((subclasses (class)
+ (let ((direct-subclasses (closer-mop:class-direct-subclasses class)))
+ (remove-duplicates (apply #'append direct-subclasses (mapcar #'subclasses direct-subclasses))))))
+ (iter (for class in (subclasses (find-class 'node)))
+ (for class-name = (class-name class))
+ (for predicate = (symbolicate class-name :-p))
+ (export class-name :ruby-parser)
+ (export predicate :ruby-parser)
+ (iter (for slot in (closer-mop:class-direct-slots class))
+ (for slot-name = (closer-mop:slot-definition-name slot))
+ (for accessor = (symbolicate class-name :- slot-name))
+ (export accessor :ruby-parser)
+ (import slot-name :ruby-parser.slots)
+ (export slot-name :ruby-parser.slots))))
17 src/env.lisp
@@ -0,0 +1,17 @@
+(in-package :ruby-parser)
+
+(defun make-env ())
+
+(defun env-find (env name))
+
+(defun env-find-in-current (env name))
+
+(defun env-use (env name))
+
+(defun env-add (env name kind))
+
+(defun env-extend (env &optional dynamic))
+
+(defun env-unextend (env))
+
+
1,234 src/lexer.lisp
@@ -0,0 +1,1234 @@
+(in-package :ruby-parser)
+
+;;; Lex State
+
+(deftype lex-state ()
+ '(member
+ :expr-beg
+ :expr-end
+ :expr-arg
+ :expr-cmdarg
+ :expr-endarg
+ :expr-mid
+ :expr-fname
+ :expr-dot
+ :expr-class))
+
+;;; Lex Stack State
+
+(defstruct stack-state
+ (list '(nil)))
+
+(defun stack-state-top (state)
+ (first (stack-state-list state)))
+
+(defun stack-state-push (state value)
+ (push value (stack-state-list state)))
+
+(defun stack-state-pop (state)
+ (smatch state
+ ((stack-state (list nil)) nil)
+ ((stack-state (list list (cons a rest)))
+ (setf list rest)
+ a)))
+
+(defun stack-state-lexpop (state)
+ (smatch state
+ ((stack-state (list list (list* a b rest)))
+ (setf list (cons (or a b) rest)))))
+
+;;; Lex Keyword Info
+
+(defstruct (keyword-info (:constructor make-keyword-info (id0 id1 state)))
+ (id0 () :read-only t)
+ (id1 () :read-only t)
+ (state () :type lex-state :read-only t))
+
+(defun keyword-info (name &optional (errorp t))
+ (declare #.standard-optimize-settings)
+ (match name
+ ("end" (make-keyword-info :kEND :kEND :expr-end))
+ ("else" (make-keyword-info :kELSE :kELSE :expr-beg))
+ ("case" (make-keyword-info :kCASE :kCASE :expr-beg))
+ ("ensure" (make-keyword-info :kENSURE :kENSURE :expr-beg))
+ ("module" (make-keyword-info :kMODULE :kMODULE :expr-beg))
+ ("elsif" (make-keyword-info :kELSIF :kELSIF :expr-beg))
+ ("def" (make-keyword-info :kDEF :kDEF :expr-fname))
+ ("rescue" (make-keyword-info :kRESCUE :kRESCUE-MOD :expr-mid))
+ ("not" (make-keyword-info :kNOT :kNOT :expr-beg))
+ ("then" (make-keyword-info :kTHEN :kTHEN :expr-beg))
+ ("yield" (make-keyword-info :kYIELD :kYIELD :expr-arg))
+ ("for" (make-keyword-info :kFOR :kFOR :expr-beg))
+ ("self" (make-keyword-info :kSELF :kSELF :expr-end))
+ ("false" (make-keyword-info :kFALSE :kFALSE :expr-end))
+ ("retry" (make-keyword-info :kRETRY :kRETRY :expr-end))
+ ("return" (make-keyword-info :kRETURN :kRETURN :expr-mid))
+ ("true" (make-keyword-info :kTRUE :kTRUE :expr-end))
+ ("if" (make-keyword-info :kIF :kIF-MOD :expr-beg))
+ ("defined?" (make-keyword-info :kDEFINED :kDEFINED :expr-arg))
+ ("super" (make-keyword-info :kSUPER :kSUPER :expr-arg))
+ ("undef" (make-keyword-info :kUNDEF :kUNDEF :expr-fname))
+ ("break" (make-keyword-info :kBREAK :kBREAK :expr-mid))
+ ("in" (make-keyword-info :kIN :kIN :expr-beg))
+ ("do" (make-keyword-info :kDO :kDO :expr-beg))
+ ("nil" (make-keyword-info :kNIL :kNIL :expr-end))
+ ("until" (make-keyword-info :kUNTIL :kUNTIL-MOD :expr-beg))
+ ("unless" (make-keyword-info :kUNLESS :kUNLESS-MOD :expr-beg))
+ ("or" (make-keyword-info :kOR :kOR :expr-beg))
+ ("next" (make-keyword-info :kNEXT :kNEXT :expr-mid))
+ ("when" (make-keyword-info :kWHEN :kWHEN :expr-beg))
+ ("redo" (make-keyword-info :kREDO :kREDO :expr-end))
+ ("and" (make-keyword-info :kAND :kAND :expr-beg))
+ ("begin" (make-keyword-info :kBEGIN :kBEGIN :expr-beg))
+ ("__LINE__" (make-keyword-info :k__LINE__ :k__LINE__ :expr-end))
+ ("class" (make-keyword-info :kCLASS :kCLASS :expr-class))
+ ("__FILE__" (make-keyword-info :k__FILE__ :k__FILE__ :expr-end))
+ ("END" (make-keyword-info :klEND :klEND :expr-end))
+ ("BEGIN" (make-keyword-info :klBEGIN :klBEGIN :expr-end))
+ ("while" (make-keyword-info :kWHILE :kWHILE-MOD :expr-beg))
+ ("alias" (make-keyword-info :kALIAS :kALIAS :expr-fname))
+ (otherwise (when errorp (error "There is no ruby keyword named ~A" name)))))
+
+;;; Lexer Constants
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defvar +ESC-RE+ "\\\\([0-7]{1,3}|x[0-9a-fA-F]{1,2}|M-[^\\\\]|(C-|c)[^\\\\]|[^0-7xMCc])")
+
+ (defconstant +STR-FUNC-BORING+ #x00)
+ (defconstant +STR-FUNC-ESCAPE+ #x01)
+ (defconstant +STR-FUNC-EXPAND+ #x02)
+ (defconstant +STR-FUNC-REGEXP+ #x04)
+ (defconstant +STR-FUNC-AWORDS+ #x08)
+ (defconstant +STR-FUNC-SYMBOL+ #x10)
+ (defconstant +STR-FUNC-INDENT+ #x20)
+
+ (defconstant +STR-SQUOTE+ +STR-FUNC-BORING+)
+ (defconstant +STR-DQUOTE+ (logior +STR-FUNC-BORING+ +STR-FUNC-EXPAND+))
+ (defconstant +STR-XQUOTE+ (logior +STR-FUNC-BORING+ +STR-FUNC-EXPAND+))
+ (defconstant +STR-REGEXP+ (logior +STR-FUNC-REGEXP+ +STR-FUNC-ESCAPE+ +STR-FUNC-EXPAND+))
+ (defconstant +STR-SSYM+ +STR-FUNC-SYMBOL+)
+ (defconstant +STR-DSYM+ (logior +STR-FUNC-SYMBOL+ +STR-FUNC-EXPAND+)))
+
+;;; Lexer
+
+(defparameter *lexer* nil)
+
+(defclass lexer ()
+ ((command-start :initform t)
+ (cmdarg :type stack-state
+ :initform (make-stack-state))
+ (cond :type stack-state
+ :initform (make-stack-state))
+ (tern :type stack-state
+ :initform (make-stack-state))
+ (nest :initform 0)
+ (version :initarg :version
+ :initform 19)
+ (lex-state :type lex-state
+ :initform :expr-beg)
+ (lex-strterm :initform nil)
+ (env :initarg :env
+ :initform (make-env))
+ (in-def :type fixnum
+ :initform 0)
+ (in-single :type fixnum
+ :initform 0)
+ (src :initarg :src
+ :reader lexer-src)
+ (string-buffer :initform '())
+ (lineno :initform nil)
+ (comments :initform '()))
+ (:metaclass closer-mop:funcallable-standard-class))
+
+(defun heredoc (lexer)
+ (declare #.standard-optimize-settings)
+ (block nil
+ (with-slots (lex-strterm src string-buffer) lexer
+ (with-source-shorthand src
+ (with-match (simple-vector _ eos func last-line) lex-strterm
+ (let* ((indent (plusp (logand func +STR-FUNC-INDENT+)))
+ (expand (plusp (logand func +STR-FUNC-EXPAND+)))
+ (eos-re (format nil (if indent
+ "[ \\t]*~A(\\r?\\n|\\z)"
+ "~A(\\r?\\n|\\z)")
+ eos)))
+ (flet ((fail () (rb-compile-error "failed to parse heredoc")))
+ (when (source-eos-p src)
+ (fail))
+ (when (and (source-bol-p src) (scan eos-re))
+ (source-unread src last-line)
+ (return (values :tSTRING-END eos)))
+ (setf string-buffer '())
+ (if expand
+ (progn
+ (cond ((scan "#[$@]")
+ (decf (source-position src))
+ (return (values :tSTRING-DVAR (matched))))
+ ((scan "#[{]")
+ (return (values :tSTRING-DBEG (matched))))
+ ((scan "#")
+ (push "#" string-buffer)))
+ (iter (until (peek eos-re))
+ (for c = (tokadd-string lexer func (string #\Newline) nil))
+ (when (eq c nil)
+ (fail))
+ (if (equal c (string #\Newline))
+ (progn
+ (push (string #\Newline) string-buffer)
+ (scan "\\n"))
+ (return-from heredoc
+ (values :tSTRING-CONTENT
+ (format nil "~{~A~}" (reverse string-buffer)))))
+ (when (source-eos-p src)
+ (fail))))
+ (iter (until (peek eos-re))
+ (scan ".*(\\n|\\z)")
+ (push (matched) string-buffer)
+ (when (source-eos-p src)
+ (fail))))
+ (setf lex-strterm (vector :heredoc eos func last-line))
+ (return
+ (values :tSTRING-CONTENT
+ (format nil "~{~A~}" (reverse string-buffer)))))))))))
+
+(defun heredoc-identifier (lexer)
+ (declare #.standard-optimize-settings)
+ (block nil
+ (with-slots (lex-strterm src string-buffer) lexer
+ (with-source-shorthand src
+ (let ((line nil)
+ (term nil)
+ (func +STR-FUNC-BORING+))
+ (setf string-buffer '())
+
+ (cond ((scan "(-?)(['\"`])(.*?)\\2")
+ (setq term (matched 2))
+ (unless (equal (matched 1) "")
+ (setq func (logior func +STR-FUNC-INDENT+)))
+ (setq func (logior func
+ (match term
+ ("'" +STR-SQUOTE+)
+ ("\"" +STR-DQUOTE+)
+ (_ +STR-XQUOTE+))))
+ (push (matched 3) string-buffer))
+
+ ((scan "-?(['\"`])(?!\\1*\\Z)")
+ (rb-compile-error "unterminated here document identifier"))
+
+ ((scan "(-?)(\\w+)")
+ (setq term "\"")
+ (setq func (logior func +STR-DQUOTE+))
+ (unless (equal (matched 1) "")
+ (setq func (logior func +STR-FUNC-INDENT+)))
+ (push (matched 2) string-buffer))
+
+ (t (return)))
+
+ (when (scan ".*\\n")
+ (setq line (matched))
+ ; TODO src.extra_lines_added += 1
+ )
+
+ (setf lex-strterm (vector :heredoc (format nil "~{~A~}" (reverse string-buffer)) func line))
+
+ (if (equal term "`")
+ (return (values :tXSTRING-BEG "`"))
+ (return (values :tSTRING-BEG "\""))))))))
+
+(defun parse-number-1 (string &key (token :tINTEGER) (start 0) (radix 10))
+ (declare #.standard-optimize-settings)
+ (let ((sign 1))
+ (case (char string start)
+ (#\+ (incf start))
+ (#\- (setq sign -1) (incf start)))
+ (setq string (delete #\_ string))
+ (values token
+ (* (if (equal string "")
+ 0
+ (parse-number:parse-number string :start start :radix radix))
+ sign))))
+
+(defun parse-number (lexer)
+ (declare #.standard-optimize-settings)
+ (with-slots (src lex-state) lexer
+ (with-source-shorthand src
+ (setf lex-state :expr-end)
+ (cond ((scan "\\+") (parse-number lexer))
+ ((scan "\\-")
+ (multiple-value-bind (token value)
+ (parse-number lexer)
+ (values token (- value))))
+ ((scan "0[xbd]\\b")
+ (rb-compile-error "Invalid numeric format"))
+ ((scan "0x([a-fA-F0-9_]+)")
+ (parse-number-1 (matched 1) :radix 16))
+ ((scan "0b([01_]+)")
+ (parse-number-1 (matched 1) :radix 2))
+ ((scan "0d([0-9_]+)")
+ (parse-number-1 (matched 1)))
+ ((scan "0[Oo]?[0-7_]*[89]")
+ (rb-compile-error "Illegal octal digit."))
+ ((scan "0[Oo]?([0-7_]+)|0[Oo]")
+ (parse-number-1 (matched 1) :radix 8))
+ ((scan "[\\d_]+_([eE]|\\.)")
+ (rb-compile-error "Trailing '_' in number."))
+ ((scan "[\\d_]+\\.[\\d_]+([eE][+-]?[\\d_]+)?\\b|[+-]?[\\d_]+[eE][+-]?[\\d_]+\\b")
+ (parse-number-1 (matched) :token :tFLOAT))
+ ((scan "0\\b")
+ (parse-number-1 (matched)))
+ ((scan "[\\d_]+\\b")
+ (parse-number-1 (matched)))
+ (t (rb-compile-error "Bad number format"))))))
+
+(defun parse-quote (lexer)
+ (declare #.standard-optimize-settings)
+ (with-slots (src lex-state lex-strterm) lexer
+ (with-source-shorthand src
+ (let (beg nnd short-hand c)
+ (if (scan "[a-zA-Z0-9]{1,2}")
+ (progn
+ (when (= (length (matched)) 2)
+ (rb-compile-error "unknown type of %string"))
+ (setq c (matched)
+ beg (string (source-read-char src))))
+ (setq c "Q"
+ beg (string (source-read-char src))
+ short-hand t))
+
+ (when (or (source-eos-p src)
+ (eq c nil)
+ (eq beg nil))
+ (rb-compile-error "unterminated quoted string meets end of file"))
+
+ (match beg
+ ("(" (setq nnd ")"))
+ ("[" (setq nnd "]"))
+ ("{" (setq nnd "}"))
+ ("<" (setq nnd ">"))
+ (_ (setq nnd beg
+ beg (string #\Null))))
+
+ (let (token
+ string
+ (value (format nil "%~A~A" c beg)))
+ (match c
+ ("Q"
+ (setq token :tSTRING-BEG
+ string +STR-DQUOTE+
+ value (if short-hand
+ (format nil "%~A" nnd)
+ (format nil "%~A~A" c beg))))
+ ("q"
+ (setq token :tSTRING-BEG
+ string +STR-SQUOTE+))
+ ("W"
+ (scan "\\s*")
+ (setq token :tWORDS-BEG
+ string (logior +STR-DQUOTE+ +STR-FUNC-AWORDS+)))
+ ("w"
+ (scan "\\s*")
+ (setq token :tAWORDS-BEG
+ string (logior +STR-SQUOTE+ +STR-FUNC-AWORDS+)))
+ ("x"
+ (setq token :tXSTRING-BEG
+ string +STR-XQUOTE+))
+ ("r"
+ (setq token :tREGEXP-BEG
+ string +STR-REGEXP+))
+ ("s"
+ (setf lex-state :expr-fname)
+ (setq token :tSYMBEG
+ string +STR-SSYM+)))
+
+ (unless token
+ (rb-compile-error "Bad %string type. Expected [Qqwxr\W], found '~A'." c))
+
+ (setf lex-strterm (vector :strterm string nnd beg))
+
+ (values token value))))))
+
+(defun parse-string (lexer)
+ (declare #.standard-optimize-settings)
+ (block nil
+ (with-slots (nest lex-strterm src string-buffer lineno) lexer
+ (with-source-shorthand src
+ (with-match (simple-vector _ func term paren) lex-strterm
+ (let ((space nil)
+ (term-re (ppcre:quote-meta-chars term))
+ (awords (and func (plusp (logand func +STR-FUNC-AWORDS+))))
+ (regexp (and func (plusp (logand func +STR-FUNC-REGEXP+))))
+ (expand (and func (plusp (logand func +STR-FUNC-EXPAND+)))))
+ (unless func
+ (setf lineno nil)
+ (return :tSTRING-END))
+ (setq space (and awords (scan "\\s+")))
+ (when (and (zerop nest) (scan term-re))
+ (cond (awords
+ (setf (svref lex-strterm 1) nil)
+ (return :tSPACE))
+ (regexp
+ (setf lineno nil)
+ (return (values :tREGEXP-END (parse-regx-options lexer))))
+ (t
+ (setf lineno nil)
+ (return (values :tSTRING-END term)))))
+ (when space
+ (return :tSPACE))
+ (setf string-buffer '())
+ (when expand
+ (cond ((scan "#(?=[$@])")
+ (return :tSTRING-DVAR))
+ ((scan "#[{]")
+ (return :tSTRING-DBEG))
+ ((scan "#")
+ (push "#" string-buffer))))
+ (when (eq (tokadd-string lexer func term paren) nil)
+ (rb-compile-error "unterminated string meets end of file"))
+ (return
+ (values :tSTRING-CONTENT
+ (format nil "~{~A~}" (reverse string-buffer))))))))))
+
+(defun read-escape (lexer)
+ (declare #.standard-optimize-settings)
+ (with-slots (src) lexer
+ (with-source-shorthand src
+ (cond ((scan "\\") "\\")
+ ((scan "n") (string #\Newline))
+ ((scan "t") (string #\Tab))
+ ((scan "r") (string #\Return))
+ ((scan "f") (string #\Linefeed))
+ ((scan "v") (string #\Vt))
+ ((scan "a") (string #\Bel))
+ ((scan "e") (string #\Esc))
+ ((scan "b") (string #\Backspace))
+ ((scan "s") " ")
+ ((scan "[0-7]{1,3}")
+ (string (code-char (parse-integer (matched) :radix 8))))
+ ((scan "x([0-9a-fA-F]{1,2})")
+ (string (code-char (parse-integer (matched 1) :radix 16))))
+ ((scan "M-\\\\[\\\\MCc]")
+ (scan "M-\\\\")
+ (aprog1 (read-escape lexer)
+ (setf (char it 0) (code-char (logior (char-code (char it 0)) #x80)))))
+ ((scan "M-(.)")
+ (aprog1 (matched 1)
+ (setf (char it 0) (code-char (logior (char-code (char it 0)) #x80)))))
+ ((scan "(C-|c)\\\\[\\\\MCc]")
+ (scan "(C-|c)\\\\")
+ (aprog1 (read-escape lexer)
+ (setf (char it 0) (code-char (logand (char-code (char it 0)) #x9f)))))
+ ((scan "C-\\?|c\\?")
+ (code-char 127))
+ ((scan "(?:C-|c)(.)")
+ (aprog1 (matched 1)
+ (setf (char it 0) (code-char (logand (char-code (char it 0)) #x9f)))))
+ ((or (scan "[McCx0-9]")
+ (source-eos-p src))
+ (rb-compile-error "Invalid escape character syntax"))
+ (t (source-read-char src))))))
+
+(defun parse-regx-options (lexer)
+ (declare #.standard-optimize-settings)
+ (with-slots (src) lexer
+ (with-source-shorthand src
+ (scan "[a-z]*")
+ (loop for c across (matched)
+ if (find c "ixmonesu")
+ collect c into good
+ else
+ collect c into bad
+ finally
+ (if bad
+ (rb-compile-error "unknown regexp option~P - ~A"
+ (length bad) bad)
+ (format nil "~{~A~}" good))))))
+
+(defun tokadd-escape (lexer term)
+ (declare #.standard-optimize-settings)
+ (with-slots (src string-buffer) lexer
+ (with-source-shorthand src
+ (cond ((scan "\\\\\\n"))
+ ((scan "\\\\([0-7]{1,3}|x[0-9a-fA-F]{1,2})")
+ (push (matched) string-buffer))
+ ((scan "\\\\([MC]-|c)(?=\\\\)")
+ (push (matched) string-buffer)
+ (tokadd-escape lexer term))
+ ((scan "\\\\([MC]-|c)(.)")
+ (push (matched) string-buffer))
+ ((scan "\\\\[McCx]")
+ (rb-compile-error "Invalid escape character syntax"))
+ ((scan "\\\\(.)")
+ (push (matched) string-buffer))
+ (t
+ (rb-compile-error "Invalid escape character syntax"))))))
+
+(defun tokadd-string (lexer func term paren)
+ (declare #.standard-optimize-settings)
+ (with-slots (nest src string-buffer) lexer
+ (with-source-shorthand src
+ (let ((awords (plusp (logand func +STR-FUNC-AWORDS+)))
+ (escape (plusp (logand func +STR-FUNC-ESCAPE+)))
+ (expand (plusp (logand func +STR-FUNC-EXPAND+)))
+ (regexp (plusp (logand func +STR-FUNC-REGEXP+)))
+ (symbol (plusp (logand func +STR-FUNC-SYMBOL+))))
+ (let ((paren-re (and paren (ppcre:quote-meta-chars paren)))
+ (term-re (ppcre:quote-meta-chars term))
+ c)
+ (iter (until (source-eos-p src))
+ (for handled = t)
+ (setq c nil)
+ (cond ((and (zerop nest) (scan term-re))
+ (decf (source-position src))
+ (finish))
+ ((and paren-re (scan paren-re))
+ (incf nest))
+ ((scan term-re)
+ (decf nest))
+ ((and awords (scan "\\s"))
+ (decf (source-position src))
+ (finish))
+ ((and expand (scan "#(?=[\\$\\@\\{])"))
+ (decf (source-position src))
+ (finish))
+ ((and expand (scan "#(?!\\n)")))
+ ((peek "\\")
+ (cond ((and awords (scan "\\\\\\n"))
+ (push (string #\Newline) string-buffer)
+ (next-iteration))
+ ((and awords (scan "\\\\\\s"))
+ (setq c " "))
+ ((and expand (scan "\\\\\\n"))
+ (next-iteration))
+ ((and regexp (peek "\\\\"))
+ (tokadd-escape lexer term)
+ (next-iteration))
+ ((and expand (scan "\\\\"))
+ (setq c (read-escape lexer)))
+ ((scan "\\\\\\n"))
+ ((scan "\\\\\\\\")
+ (when escape
+ (push "\\" string-buffer))
+ (setq c "\\"))
+ ((scan "\\\\")
+ (unless (or (scan term-re)
+ (null paren)
+ (scan paren-re))
+ (push "\\" string-buffer)))
+ (t (setq handled nil))))
+ (t (setq handled nil)))
+ (unless handled
+ (scan (format nil (if awords
+ "[^~A~A\\#\\0\\\\\\n\\ ]+|."
+ "[^~A~A\\#\\0\\\\]+|.")
+ term-re paren-re))
+ (setq c (matched))
+ (when (and symbol (ppcre:scan #\Null c))
+ (rb-compile-error "symbol cannot contain '\\0'")))
+ (setq c (or c (matched)))
+ (push c string-buffer))
+ (setq c (or c (matched)))
+ (when (source-eos-p src)
+ (setq c nil))
+ c)))))
+
+(defun unescape (s)
+ (declare #.standard-optimize-settings)
+ (match s
+ ("a" (string #\Bel))
+ ("b" (string #\Backspace))
+ ("e" (string #\Escape))
+ ("f" (string #\Linefeed))
+ ("n" (string #\Newline))
+ ("r" (string #\Return))
+ ("s" " ")
+ ("t" (string #\Tab))
+ ("v" (string #\Vt))
+ ("\\" "\\")
+ (#.(string #\Newline) (string ""))
+ ("C-?" (string (code-char 127)))
+ ("c?" (string (code-char 127)))
+ (otherwise
+ (cond ((ppcre:scan "^[0-7]{1,3}" s)
+ (string (code-char (parse-integer s :radix 8 :junk-allowed t))))
+ ((ppcre:scan "^x([0-9a-fA-F]{1,2})" s)
+ (string (code-char (parse-integer s :start 1 :radix 16 :junk-allowed t))))
+ ((ppcre:scan "^M-(.)" s)
+ (string (code-char (logior (char-code (char s 2)) #x80))))
+ ((ppcre:scan "^C-(.)" s)
+ (string (code-char (logand (char-code (char s 2)) #x9f))))
+ ((ppcre:scan "^c(.)" s)
+ (string (code-char (logand (char-code (char s 1)) #x9f))))
+ ((ppcre:scan "^[McCx0-9]" s)
+ (rb-compile-error "Invalid escape character syntax"))
+ (t s)))))
+
+(defun lex (&optional (lexer *lexer*))
+ (declare #.standard-optimize-settings)
+ (with-slots (lex-state lex-strterm
+ cmdarg cond tern command-start
+ lineno comments version)
+ lexer
+ (with-source-shorthand (lexer-src lexer)
+ (flet ((arg-ambiguous ()
+ (rb-warning "Ambiguous first argument. make sure."))
+ (expr-beg-push ()
+ (stack-state-push cond nil)
+ (stack-state-push cmdarg nil)
+ (setf lex-state :expr-beg))
+ (argument-state-p (state)
+ (or (eq state :expr-arg)
+ (eq state :expr-cmdarg)))
+ (fix-arg-lex-state ()
+ (setf lex-state (if (or (eq lex-state :expr-fname)
+ (eq lex-state :expr-dot))
+ :expr-arg
+ :expr-beg))))
+ (when lex-strterm
+ (return-from lex (lex-string lexer)))
+
+ (iter (with space-seen = nil)
+ (with command-state = command-start)
+ (with src = (lexer-src lexer))
+ (with last-state = lex-state)
+ (setf command-start nil)
+
+ (when (scan '(:alternation #\Space #\Tab #\Return #\Page #\Vt))
+ (setq space-seen t)
+ (next-iteration))
+
+ (when (peek "[^a-zA-Z]")
+ (cond
+ ((scan "\\n|#")
+ (setf lineno nil)
+ (when (equal (matched) "#")
+ (decf (source-position src))
+
+ (loop while (scan "\\s*#.*(\\n+|\\z)")
+ do (push (matched) comments))
+
+ (when (source-eos-p src)
+ (return)))
+
+ (scan "\\n+")
+
+ (when (member lex-state '(:expr-beg :expr-fname
+ :expr-dot :expr-class))
+ (next-iteration))
+
+ (setf command-start t)
+ (setf lex-state :expr-beg)
+ (return :tNL))
+
+ ((scan "[\\]\\)\\}]")
+ (stack-state-lexpop cond)
+ (stack-state-lexpop cmdarg)
+ (setf lex-state :expr-end)
+ (let ((result (ematch (matched)
+ (")" :tRPAREN)
+ ("]" :tRBRACK)
+ ("}" :tRCURLY))))
+ (when (member result '(tRBACK tRCURLY))
+ (stack-state-lexpop tern))
+ (return (values result (matched)))))
+
+ ((scan "\\.\\.\\.?|,|![=~]?")
+ (setf lex-state :expr-beg)
+ (return
+ (ematch (matched)
+ (".." :tDOT2)
+ ("..." :tDOT3)
+ ("," :tCOMMA)
+ ("!" :tBANG)
+ ("!=" :tNEQ)
+ ("!~" :tNMATCH))))
+
+ ((peek "\\.")
+ (cond ((scan "\\.\\d")
+ (rb-compile-error "no .<digit> floating literal anymore put 0 before dot"))
+ ((scan "\\.")
+ (setf lex-state :expr-dot)
+ (return (values :tDOT ".")))))
+
+ ((scan "\\(")
+ (let ((result :tLPAREN2))
+ (cond ((or (eq lex-state :expr-beg)
+ (eq lex-state :expr-mid))
+ (setq result :tLPAREN))
+ ((and space-seen
+ (eq lex-state :expr-cmdarg))
+ (setq result :tLPAREN-ARG))
+ ((and space-seen
+ (eq lex-state :expr-arg))
+ (stack-state-push tern nil)
+ (rb-warning "don:t put space before argument parentheses")
+ (setq result :tLPAREN2))
+ ((not space-seen)
+ (stack-state-push tern nil)))
+
+ (expr-beg-push)
+
+ (return (values result "("))))
+
+ ((peek "\\=")
+ (cond ((scan "\\=\\=\\=|\\=\\=|\\=~|\\=>|\\=(?!begin\\b)")
+ (fix-arg-lex-state)
+ (return
+ (values
+ (ematch (matched)
+ ("=" :tEQL)
+ ("==" :tEQ)
+ ("===" :tEQQ)
+ ("=>" :tASSOC)
+ ("=~" :tMATCH)
+ ("->" :tLAMBDA))
+ (matched))))
+
+ ((scan "\\=begin(?=\\s)")
+ (push (matched) comments)
+
+ (unless (scan "(?m).*?\\n=end( |\\t|\\f)*[^\\n]*(\\n|\\z)")
+ (setf comments '())
+ (rb-compile-error "embedded document meets end of file"))
+
+ (push (matched) comments)
+
+ (next-iteration))
+ (t (error "you shouldn't be able to get here"))))
+
+ ((scan #.(format nil "\\\"(~A|#(~A|[^\\{\\#\\@\\$\\\"\\\\])|[^\\\"\\\\\\#])*\\\"" +ESC-RE+ +ESC-RE+))
+ (setf lex-state :expr-end)
+ (let ((string (subseq (matched) 1 (1- (length (matched))))))
+ (return (values :tSTRING
+ (ppcre:regex-replace-all +ESC-RE+
+ string
+ (lambda (s &rest args)
+ (declare (ignore args))
+ (unescape s)))))))
+
+ ((scan "\\\"")
+ (setf lex-strterm (vector :strterm +STR-DQUOTE+ "\"" (string #\Nul)))
+ (return (values :tSTRING-BEG "\"")))
+
+ ((scan "\\@\\@?\\w*")
+ (when (ppcre:scan (matched) "\\@\\d")
+ (rb-compile-error (format nil "`~A` is not allowed as a variable name" (matched))))
+
+ (return (process-token lexer (matched) command-state)))
+
+ ((scan "\\:\\:")
+ (when (or (member lex-state '(:expr-beg :expr-mid :expr-class))
+ (and (argument-state-p lex-state) space-seen))
+ (setf lex-state :expr-beg)
+ (return (values :tCOLON3 "::")))
+
+ (setf lex-state :expr-dot)
+ (return (values :tCOLON2 "::")))
+
+ ((and (not (eq lex-state :expr-end))
+ (not (eq lex-state :expr-endarg))
+ (scan ":([a-zA-Z_]\\w*(?:[?!]|=(?!>))?)"))
+ (setf lex-state :expr-end)
+ (return (values :tSYMBOL (matched 1))))
+
+ ((scan "\\:")
+ (when (or (eq lex-state :expr-end)
+ (eq lex-state :expr-endarg)
+ (peek "\\s")
+ (stack-state-top tern))
+ (setf lex-state :expr-beg)
+ (return (values :tCOLON ":")))
+
+ (cond ((scan "\\'")
+ (setf lex-strterm (vector :strterm +STR-SSYM+ (matched) (string #\Nul))))
+ ((scan "\\\"")
+ (setf lex-strterm (vector :strterm +STR-DSYM+ (matched) (string #\Nul)))))
+
+ (setf lex-state :expr-fname)
+ (return (values :tSYMBEG ":")))
+
+ ((peek "[0-9]")
+ (return (parse-number lexer)))
+
+ ((scan "\\[")
+ (let ((result (matched)))
+ (cond ((or (eq lex-state :expr-fname)
+ (eq lex-state :expr-dot))
+ (setf lex-state :expr-arg)
+ (cond ((scan "\\]\\=")
+ (return (values :tASET "[]=")))
+ ((scan "\\]")
+ (return (values :tAREF "[]")))
+ (t
+ (rb-compile-error "unexpected '['"))))
+ ((or (eq lex-state :expr-beg)
+ (eq lex-state :expr-mid))
+ (stack-state-push tern nil)
+ (setq result :tLBRACK))
+ ((and (argument-state-p lex-state) space-seen)
+ (stack-state-push tern nil)
+ (setq result :tLBRACK))
+ (t
+ (setq result '|[|)))
+
+ (expr-beg-push)
+
+ (return (values result "["))))
+
+ ((scan "\\'(\\\\.|[^\\'])*\\'")
+ (setf lex-state :expr-end)
+ (return (values :tSTRING (matched))))
+
+ ((peek "\\|")
+ (cond ((scan "\\|\\|\\=")
+ (setf lex-state :expr-beg)
+ (return (values :tOP-ASGN "||")))
+ ((scan "\\|\\|")
+ (setf lex-state :expr-beg)
+ (return (values :tOROP "||")))
+ ((scan "\\|\\=")
+ (setf lex-state :expr-beg)
+ (return (values :tOP-ASGN "|")))
+ ((scan "\\|")
+ (fix-arg-lex-state)
+ (return (values :tPIPE "|")))))
+
+ ((scan "\\{")
+ #| FIXME
+ if defined?(@hack_expects_lambda) && @hack_expects_lambda
+ @hack_expects_lambda = false
+ self.lex_state = :expr_beg
+ return :tLAMBEG
+ end
+ |#
+ (let ((result (cond ((or (argument-state-p lex-state)
+ (eq lex-state :expr-end))
+ :tLCURLY)
+ ((eq lex-state :expr-endarg)
+ :tLBRACE-ARG)
+ (t
+ (stack-state-push tern t)
+ :tLBRACE))))
+ (expr-beg-push)
+ (unless (eq result :tLBRACE)
+ (setf command-start t))
+
+ (return (values result "{"))))
+
+ ((scan "->")
+ #|
+ FIXME
+ @hack_expects_lambda = true
+ |#
+ (setf lex-state :expr-arg)
+ (return :tLAMBDA))
+
+ ((scan "[+-]")
+ (let* ((sign (matched))
+ (utype (if (equal sign "+") :tUPLUS :tUMINUS))
+ (type (if (equal sign "+") :tPLUS :tMINUS)))
+ (when (or (eq lex-state :expr-fname)
+ (eq lex-state :expr-dot))
+ (setf lex-state :expr-arg)
+ (if (scan "@")
+ (return (values utype (format nil "~A@" sign)))
+ (return (values type sign))))
+
+ (when (scan "=")
+ (setf lex-state :expr-beg)
+ (return (values :tOP-ASGN sign)))
+
+ (when (or (eq lex-state :expr-beg)
+ (eq lex-state :expr-mid)
+ (and (argument-state-p lex-state)
+ space-seen
+ (not (peek "\\s"))))
+ (when (argument-state-p lex-state)
+ (arg-ambiguous))
+
+ (setf lex-state :expr-beg)
+ (return
+ (values (if (peek "\\d")
+ (if (eq utype :tUPLUS)
+ (parse-number lexer)
+ :tUMINUS-NUM)
+ utype)
+ sign)))
+
+ (setf lex-state :expr-beg)
+ (return (values type sign))))
+
+ ((peek "\\*")
+ (cond ((scan "\\*\\*=")
+ (setf lex-state :expr-beg)
+ (return (values :tOP-ASGN "**")))
+ ((scan "\\*\\*")
+ (fix-arg-lex-state)
+ (return (values :tPOW "**")))
+ ((scan "\\*=")
+ (setf lex-state :expr-beg)
+ (return (values :tOP-ASGN "*")))
+ ((scan "\\*")
+ (let ((result (cond ((and (argument-state-p lex-state)
+ space-seen
+ (peek "\\S"))
+ (rb-warning "`*' interpreted as argument prefix")
+ :tSTAR)
+ ((or (eq lex-state :expr-beg)
+ (eq lex-state :expr-mid))
+ :tSTAR)
+ (t
+ :tSTAR2))))
+ (fix-arg-lex-state)
+ (return (values result "*"))))))
+
+ ((peek "\\<")
+ (cond ((scan "\\<=\\>")
+ (fix-arg-lex-state)
+ (return (values :tCMP "<=>")))
+ ((scan "\\<=")
+ (fix-arg-lex-state)
+ (return (values :tLEQ "<=")))
+ ((scan "\\<\\<=")
+ (fix-arg-lex-state)
+ (setf lex-state :expr-beg)
+ (return (values :tOP-ASGN "<<")))
+ ((scan "\\<\\<")
+ (when (and (not (member lex-state '(:expr-end :expr-dot
+ :expr-endarg :expr-class)))
+ (or (not (argument-state-p lex-state))
+ space-seen))
+ (awhen (heredoc-identifier lexer)
+ (return it)))
+
+ (fix-arg-lex-state)
+ (return (values :tLSHFT "<<")))
+ ((scan "\\<")
+ (fix-arg-lex-state)
+ (return (values :tLT "<")))))
+
+ ((peek "\\>")
+ (cond ((scan "\\>=")
+ (fix-arg-lex-state)
+ (return (values :tGEQ ">=")))
+ ((scan "\\>\\>=")
+ (fix-arg-lex-state)
+ (setf lex-state :expr-beg)
+ (return (values :tOP-ASGN ">>")))
+ ((scan "\\>\\>")
+ (fix-arg-lex-state)
+ (return (values :tRSHFT ">>")))
+ ((scan "\\>")
+ (fix-arg-lex-state)
+ (return (values :tGT ">")))))
+
+ ((scan "\\`")
+ (case lex-state
+ (:expr-fname
+ (setf lex-state :expr-end)
+ (return (values :tBACK-REF2 "`")))
+ (:expr-dot
+ (setf lex-state (if command-state :expr-cmdarg :expr-arg))
+ (return (values :tBACK-REF2 "`")))
+ (otherwise
+ (setf lex-strterm (vector :strterm +STR-XQUOTE+ "`" (string #\Nul)))
+ (return (values :tXSTRING-BEG "`")))))
+
+ ((scan "\\?")
+ (when (or (eq lex-state :expr-end)
+ (eq lex-state :expr-endarg))
+ (setf lex-state :expr-beg)
+ (stack-state-push tern t)
+ (return (values :tEH "?")))
+ (when (source-eos-p src)
+ (rb-compile-error "incomplete character syntax"))
+ (cond ((peek '(:alternation :whitespace-char-class #\Vt))
+ (unless (argument-state-p lex-state)
+ (awhen (match (char (matched) 0)
+ (#\Space #\s)
+ (#\Newline #\n)
+ (#\Tab #\t)
+ (#\Vt #\v)
+ (#\Return #\r)
+ (#\Page #\f))
+ (rb-warning "invalid character syntax; use ?\\~C" it)))
+ (setf lex-state :expr-beg)
+ (stack-state-push tern t)
+ (return (values :tEH "?")))
+ ((peek "\\w(?=\\w)")
+ (setf lex-state :expr-beg)
+ (stack-state-push tern t)
+ (return (values :tEH "?"))))
+ (let ((c (if (scan "\\")
+ (read-escape lexer)
+ (string (source-read-char src)))))
+ (setf lex-state :expr-end)
+ (if (= version 18)
+ (return (values :tINTEGER
+ (logand (char-int (char c 0)) #xff)))
+ (return (values :tSTRING c)))))
+
+ ((peek "\\&")
+ (cond ((scan "\\&\\&\\=")
+ (setf lex-state :expr-beg)
+ (return (values :tOP-ASGN "&&")))
+ ((scan "\\&\\&")
+ (setf lex-state :expr-beg)
+ (return (values :tANDOP "&&")))
+ ((scan "\\&\\=")
+ (setf lex-state :expr-beg)
+ (return (values :tOP-ASGN "&")))
+ ((scan "\\&")
+ (let ((result (cond ((and (argument-state-p lex-state)
+ space-seen
+ (not (peek "\\s")))
+ (rb-warning "`&' interpreted as argument prefix")
+ :tAMPER)
+ ((or (eq lex-state :expr-beg)
+ (eq lex-state :expr-mid))
+ :tAMPER)
+ (t :tAMPER2))))
+ (fix-arg-lex-state)
+ (return (values result "&"))))))
+
+ ((scan "\\/")
+ (when (or (eq lex-state :expr-beg)
+ (eq lex-state :expr-mid))
+ (setf lex-strterm (vector :strterm +STR-REGEXP+ "/" (string #\Nul)))
+ (return (values :tREGEXP-BEG "/")))
+
+ (when (scan "\\=")
+ (setf lex-state :expr-beg)
+ (return (values :tOP-ASGN "/")))
+
+ (when (and (argument-state-p lex-state)
+ space-seen
+ (not (scan "\\s")))
+ (arg-ambiguous)
+ (setf lex-strterm (vector :strterm +STR-REGEXP+ "/" (string #\Nul)))
+ (return (values :tREGEXP-BEG "/")))
+
+ (fix-arg-lex-state)
+ (return (values :tDIVIDE "/")))
+
+ ((scan "\\^=")
+ (setf lex-state :expr-beg)
+ (return (values :tOP-ASGN "^")))
+
+ ((scan "\\^")
+ (fix-arg-lex-state)
+ (return (values :tCARET "^")))
+
+ ((scan "\\;")
+ (setf command-start t)
+ (setf lex-state :expr-beg)
+ (return (values :tSEMI ";")))
+
+ ((scan "\\~")
+ (when (or (eq lex-state :expr-fname)
+ (eq lex-state :expr-dot))
+ (scan "@"))
+
+ (fix-arg-lex-state)
+ (return (values :tTILDE "~")))
+
+ ((scan "\\\\")
+ (when (scan "\\n")
+ (setf lineno nil)
+ (setf space-seen t)
+ (next-iteration))
+ (rb-compile-error "bare backslash only allowed before newline"))
+
+ ((scan "\\%")
+ (when (or (eq lex-state :expr-beg)
+ (eq lex-state :expr-mid))
+ (return (parse-quote lexer)))
+
+ (when (scan "\\=")
+ (setf lex-state :expr-beg)
+ (return (values :tOP-ASGN "%")))
+
+ (when (and (argument-state-p lex-state)
+ (not (peek "\\s")))
+ (return (parse-quote lexer)))
+
+ (fix-arg-lex-state)
+ (return (values :tPERCENT "%")))
+
+ ((peek "\\$")
+ (cond ((scan "(\\$_)(\\w+)")
+ (setf lex-state :expr-end)
+ (return (process-token lexer (matched) command-state)))
+ ((scan "\\$_")
+ (setf lex-state :expr-end)
+ (return (values :tGVAR (matched))))
+ ((scan "\\$[~*$?!@\\/\\\\;,.=:<>\"]|\\$-\\w?")
+ (setf lex-state :expr-end)
+ (return (values :tGVAR (matched))))
+ ((scan "\\$([\\&\\`\\'\\+])")
+ (setf lex-state :expr-end)
+ (if (eq last-state :expr-fname)
+ (return (values :tGVAR (matched)))
+ (return (values :tBACK-REF
+ (char (matched) 0)))))
+ ((scan "\\$([1-9]\\d*)")
+ (setf lex-state :expr-end)
+ (if (eq last-state :expr-fname)
+ (return (values :tGVAR (matched)))
+ (return (values :tNTH-REF
+ (parse-integer (subseq (matched) 1 2))))))
+ ((scan "\\$0")
+ (setf lex-state :expr-end)
+ (return (process-token lexer (matched) command-state)))
+ ((scan "\\$\\W|\\$\\z")
+ (setf lex-state :expr-end)
+ (return (values "$" "$")))
+ ((scan "\\S\\w+")
+ (setf lex-state :expr-end)
+ (return (process-token lexer (matched) command-state)))))
+
+ ((peek "\\_")
+ (cond ((and (source-bol-p src)
+ (scan "__END__(\n|\Z)"))
+ (setf lineno nil)
+ (return))
+ ((scan "\\_\\w*")
+ (return (process-token lexer (matched) command-state)))))))
+
+ (cond ((or (scan '(:alternation #\Eot #\Sub #\Nul))
+ (source-eos-p src))
+ (return))
+ ((scan "\\W")
+ (rb-compile-error "Invalid char ~A in expression" (matched))))
+
+ (scan "\\w+")
+ (return (process-token lexer (matched) command-state)))))))
+
+(defun process-token (lexer token command-state)
+ (declare #.standard-optimize-settings)
+ (block nil
+ (with-slots (lex-state command-start cmdarg cond tern env) lexer
+ (with-source-shorthand (lexer-src lexer)
+ (when (and (ppcre:scan "^\\w" token)
+ (scan "[\\!\\?](?!=)"))
+ (setq token (concatenate 'string token (matched))))
+ (let ((src (lexer-src lexer))
+ (last-state lex-state)
+ result)
+ (cond ((ppcre:scan "^\\$" token)
+ (setf lex-state :expr-end
+ result :tGVAR))
+ ((ppcre:scan "^@@" token)
+ (setf lex-state :expr-end
+ result :tCVAR))
+ ((ppcre:scan "^@" token)
+ (setf lex-state :expr-end
+ result :tIVAR))
+ (t
+ (if (ppcre:scan "[!?]$" token)
+ (setq result :tFID)
+ (progn
+ (when (and (eq lex-state :expr-fname)
+ (scan "=(?:(?![~>=])|(?==>))"))
+ (setq result :tIDENTIFIER
+ token (concatenate 'string token (matched))))
+ (unless result
+ (setq result (if (ppcre:scan "^[A-Z]" token)
+ :tCONSTANT
+ :tIDENTIFIER)))))
+ (when (and (not (stack-state-top tern))
+ (or (and (eq lex-state :expr-beg)
+ (not command-state))
+ (eq lex-state :expr-arg)
+ (eq lex-state :expr-cmdarg)))
+ #|
+ FIXME
+ if (lex_state == :expr_beg && !command_state) || lex_state == :expr_arg || lex_state == :expr_cmdarg
+ colon = src.scan(/:/)
+
+ if colon && src.peek(1) != ":"
+ src.unscan
+ self.lex_state = :expr_beg
+ src.scan(/:/)
+ self.yacc_value = [token, src.lineno]
+ return :tLABEL
+ end
+
+ src.unscan if colon
+ end
+ |#
+ )
+ (unless (eq lex-state :expr-dot)
+ (optima:when-match (keyword-info id0 id1 state)
+ (keyword-info token nil)
+ (let ((old-state lex-state)
+ (value (vector token (source-lineno src))))
+ (declare (ignore value))
+ (setf lex-state state)
+ (when (eq old-state :expr-fname)
+ (return id0))
+ (when (eq id0 :kDO)
+ (setf command-start t)
+ (cond ((stack-state-top cond)
+ (return :kDO-COND))
+ ((and (stack-state-top cmdarg)
+ (not (eq old-state :expr-cmdarg)))
+ (return :kDO-BLOCK))
+ ((eq old-state :expr-endarg)
+ (return :kDO-BLOCK))
+ ; FIXME defined?(@hack_expects_lambda) && @hack_expects_lambda
+ (t
+ (return :kDO))))
+ (when (or (eq old-state :expr-beg)
+ (eq old-state :expr-value))
+ (return id0))
+ (unless (eq id0 id1)
+ (setf lex-state :expr-beg))
+ (return id1))))
+ (if (member lex-state '(:expr-beg :expr-mid
+ :expr-dot :expr-arg
+ :expr-cmdarg))
+ (setf lex-state (if command-state :expr-cmdarg :expr-arg))
+ (setf lex-state :expr-end))))
+ (when (and (not (eq last-state :expr-dot))
+ (eq (env-find env token) :lvar))
+ (setf lex-state :expr-end))
+ (return (values result token)))))))
+
+(defun lex-string (lexer)
+ (declare #.standard-optimize-settings)
+ (with-slots (lex-state lex-strterm lineno) lexer
+ (multiple-value-bind (token value)
+ (if (and lex-strterm
+ (eq (svref lex-strterm 0) :heredoc))
+ (heredoc lexer)
+ (parse-string lexer))
+ (when (or (eq token :tSTRING-END)
+ (eq token :tREGEXP-END))
+ (setf lineno nil
+ lex-strterm nil
+ lex-state :expr-end))
+ (values token value))))
+
+(defun make-lexer (src &key (version 18))
+ (declare #.standard-optimize-settings)
+ (let ((lexer (make-instance 'lexer :src src :version version)))
+ (flet ((lex ()
+ (multiple-value-bind (token value) (lex lexer)
+ ;(format t "LEX ~A ~A~%" token value)
+ (values token value))))
+ (closer-mop:set-funcallable-instance-function lexer #'lex)
+ lexer)))
+
+(defun lex-from-stream (stream)
+ (let ((lexer (make-lexer (make-source-from-stream stream))))
+ (iter (for (values token value) = (funcall lexer))
+ (while token)
+ (collect (list token value)))))
+
+(defun lex-from-string (string)
+ (with-input-from-string (stream string)
+ (lex-from-stream stream)))
+
+(defun lex-from-file (filename)
+ (with-open-file (stream filename)
+ (lex-from-stream stream)))
10 src/packages.lisp
@@ -0,0 +1,10 @@
+(defpackage :ruby-parser
+ (:use :cl :anaphora :iterate :optima)
+ (:import-from :alexandria
+ #:once-only
+ #:required-argument
+ #:ensure-list
+ #:symbolicate))
+
+(defpackage :ruby-parser.slots
+ (:use :cl))
1,263 src/parser.lisp
@@ -0,0 +1,1263 @@
+(in-package :ruby-parser)
+
+(defmacro defparser (name &body body)
+ (let ((options
+ (iter (while (and (consp (car body))
+ (keywordp (caar body))))
+ (collect (pop body)))))
+ `(yacc:define-parser ,name
+ ,@options
+ ,@(iter (for (name . rhss) in body)
+ (for new-rhss =
+ (iter (for i from 1)
+ (for rhs in rhss)
+ (if (and (consp rhs)
+ (listp (car rhs)))
+ (let* ((body (cdr rhs))
+ (args (iter (for i from 1 to (length (car rhs)))
+ (collect (intern (format nil "$~D" i)))))
+ (action-name (alexandria:symbolicate name (format nil "-~D" i)))
+ (action `(alexandria:named-lambda ,action-name ,args
+ (declare (ignorable ,@args))
+ ,@body)))
+ (collect `(,@(car rhs) ,action)))
+ (collect rhs))))
+ (collect (cons name new-rhss))))))
+
+(defun const-name-p (name)
+ (and (stringp name)
+ (plusp (length name))
+ (upper-case-p (char name 0))))
+
+(defun cvar-name-p (name)
+ (and (stringp name)
+ (>= (length name) 2)
+ (char= (char name 0) #\@)
+ (char= (char name 1) #\@)))
+
+(defun ivar-name-p (name)
+ (and (stringp name)
+ (not (const-name-p name))
+ (plusp (length name))
+ (char= (char name 0) #\@)))
+
+(defun gvar-name-p (name)
+ (and (stringp name)
+ (plusp (length name))
+ (char= (char name 0) #\$)))
+
+(defun yyerror (control-string &rest args)
+ (apply #'error control-string args))
+
+(defun backref-assign-error (backref)
+ (declare (ignore backref)))
+
+(defun new-logop (lhs op rhs)
+ (multiple-value-ematch (values op lhs)
+ ((:and (and-expr (lhs l) (rhs r) loc))
+ (make-and-expr :lhs l :rhs (new-logop r op rhs) :loc loc))
+ ((:and _)
+ (make-and-expr :lhs lhs :rhs rhs))
+ ((:or (or-expr (lhs l) (rhs r) loc))
+ (make-or-expr :lhs l :rhs (new-logop r op rhs) :loc loc))
+ ((:or _)
+ (make-or-expr :lhs lhs :rhs rhs))))
+
+(defun literal-concat (head tail)
+ (multiple-value-ematch (values head tail)
+ (((lit-expr (lit (string-lit (value head-value))) loc)
+ (lit-expr (lit (string-lit (value tail-value)))))
+ (make-lit-expr :lit (make-string-lit :value (append head-value tail-value)) :loc loc))))
+
+(defun gettable (name &key loc)
+ (match name
+ ("nil" (make-id-expr :id (make-pvar :name :nil) :loc loc))
+ ("true" (make-id-expr :id (make-pvar :name :true) :loc loc))
+ ("false" (make-id-expr :id (make-pvar :name :false) :loc loc))
+ ("self" (make-id-expr :id (make-pvar :name :self) :loc loc))
+ ("__FILE__" (make-id-expr :id (make-pvar :name :__FILE__) :loc loc))
+ ("__LINE__" (make-id-expr :id (make-pvar :name :__LINE__) :loc loc))
+ (otherwise
+ (cond ((cvar-name-p name)
+ (make-id-expr :id (make-cvar :name (subseq name 2)) :loc loc))
+ ((ivar-name-p name)
+ (make-id-expr :id (make-ivar :name (subseq name 1)) :loc loc))
+ ((ivar-name-p name)
+ (make-id-expr :id (make-gvar :name (subseq name 1)) :loc loc))
+ ((const-name-p name)
+ (make-id-expr :id (make-const :cpath (make-cpath-name :string name))
+ :loc loc))
+ (t
+ (with-slots (env) *state*
+ (case (env-find env name)
+ (:lvar (make-id-expr :id (make-lvar :name name) :loc loc))
+ (:dvar (make-id-expr :id (make-dvar :name name) :loc loc))
+ (otherwise (make-call-expr :meth name :loc loc)))))))))
+
+(defun new-assignable (name &key loc)
+ (declare (ignore loc))
+ (match name
+ ((or "nil" "self" "true" "false"
+ "__FILE__" "__LINE__")
+ (error "Can't change the value of ~A" name))
+ (otherwise
+ (with-slots (env in-def in-single) *state*
+ (unless (env-find env name)
+ (env-add env name :lvar))
+ (cond ((cvar-name-p name)
+ (if (or (plusp in-def) (plusp in-single))
+ (make-lhs-id :id (make-cvar :name name))
+ (make-lhs-decl :id (make-cvar :name name))))
+ ((ivar-name-p name)
+ (make-lhs-id :id (make-ivar :name name)))
+ ((gvar-name-p name)
+ (make-lhs-id :id (make-gvar :name name)))
+ ((const-name-p name)
+ (make-lhs-id :id (make-const :cpath (make-cpath-name :string name))))
+ (t
+ (case (env-find env name)
+ (:lvar (make-lhs-id :id (make-lvar :name name)))
+ (:dvar
+ (unless (eq (env-find-in-current env name) :dvar)
+ (env-use env name))
+ (make-lhs-id :id (make-lvar :name name)))
+ (otherwise
+ (make-lhs-id :id (make-lvar :name name))))))))))
+
+(defun get-match-node (lhs rhs &key loc)
+ (multiple-value-match (values lhs rhs)
+ (((lit-expr (lit (regexp-lit))) _)
+ (make-call-expr :recv lhs :meth "=~" :args (list (make-arg-value :expr rhs)) :loc loc))
+ ((_ (lit-expr (lit (regexp-lit))))
+ (make-call-expr :recv rhs :meth "=~" :args (list (make-arg-value :expr lhs)) :loc loc))
+ ((_ _)
+ (make-call-expr :recv lhs :meth "=~" :args (list (make-arg-value :expr rhs)) :loc loc))))
+
+(defun new-aref (ary args &key loc)
+ (match ary
+ ((id-expr (id (pvar (name :self))))
+ (make-call-expr :meth "[]" :args args :loc loc))
+ (otherwise
+ (make-call-expr :recv ary :meth "[]" :args args :loc loc))))
+
+(defun new-op-asgn (lhs op arg &key loc)
+ (let ((lhs (match op
+ ("||" (make-lhs-or :lhs lhs))
+ ("&&" (make-lhs-and :lhs lhs))
+ (_ (make-lhs-op :lhs lhs :op op)))))
+ (make-assign-expr :lhs lhs :rhs arg :kind :single :loc loc)))
+
+;;; Parser
+
+(defvar *state* nil)
+
+(locally (declare #.standard-optimize-settings)
+ (defparser *parser*
+ (:start-symbol program)
+ (:terminals #.*terminals*)
+ (:precedence
+ ((:right :tBANG :tTILDE :tUPLUS)
+ (:right :tPOW)
+ (:right :tUMINUS-NUM :tUMINUS)
+ (:left :tSTAR2 :tDIVIDE :tPERCENT)
+ (:left :tPLUS :tMINUS)
+ (:left :tLSHFT :tRSHFT)
+ (:left :tAMPER2)
+ (:left :tPIPE :tCARET)
+ (:left :tGT :tGEQ :tLT :tLEQ)
+ (:nonassoc :tCMP :tEQ :tEQQ :tNEQ :tMATCH :tNMATCH)
+ (:left :tANDOP)
+ (:left :tOROP)
+ (:nonassoc :tDOT2 :tDOT3)
+ (:right :tEH :tCOLON)
+ (:left :kRESCUE-MOD)
+ (:right :tEQL :tOP-ASGN)
+ (:nonassoc :kDEFINED)
+ (:right :kNOT)
+ (:left :kOR :kAND)
+ (:nonassoc :kIF-MOD :kUNLESS-MOD :kWHILE-MOD :kUNTIL-MOD)
+ (:nonassoc :tLBRACE-ARG)
+ (:nonassoc :tLOWEST)))
+
+ (program ((program-e1 compstmt) $2))
+
+ (program-e1 (() (setf (slot-value *state* 'lex-state) :expr-beg)))
+
+ (bodystmt ((compstmt opt-rescue opt-else opt-ensure)
+ (make-body-stmt :body $1
+ :rescues $2
+ :else $3
+ :ensure $4)))
+
+ (compstmt ((stmts opt-terms) $1))
+
+ (stmts (() ())
+ ((stmt) (list $1))
+ ((stmts terms stmt) (append $1 (list $3)))
+ ((error stmt) $2))
+
+ (stmt ((:kALIAS fitem stmt-e1 fitem)
+ (make-alias-stmt :new $2 :old $4 :loc $1))
+ ((:kALIAS :tGVAR :tGVAR)
+ (make-alias-stmt :new $2 :old $3 :loc $1))
+ ((:kALIAS :tGVAR :tBACK-REF)
+ (make-alias-stmt :new $2 :old $3 :loc $1))
+ ((:kALIAS :tGVAR :tNTH-REF)
+ (yyerror "can't make alias for the number variables"))
+ ((:kUNDEF undef-list)
+ (make-undef-stmt :list $2 :loc $1))
+ ((stmt :kIF-MOD expr-value)
+ (make-if-mod-stmt :stmt $1 :test $3 :loc $2))
+ ((stmt :kUNLESS-MOD expr-value)
+ (make-unless-mod-stmt :stmt $1 :test $3 :loc $2))
+ ((stmt :kWHILE-MOD expr-value)
+ (make-while-mod-stmt :stmt $1 :test $3 :loc $2))
+ ((stmt :kUNTIL-MOD expr-value)
+ (make-until-mod-stmt :stmt $1 :test $3 :loc $2))
+ ((stmt :kRESCUE-MOD stmt)
+ (make-rescue-mod-stmt :stmt $1 :else $3 :loc $2))
+ ((:klBEGIN stmt-e2 :tLCURLY compstmt :tRCURLY)
+ (make-pre-exec-stmt :body $4 :loc $1))
+ ((:klEND :tLCURLY compstmt :tRCURLY)
+ (if (or (plusp (slot-value *state* 'in-def))
+ (plusp (slot-value *state* 'in-single)))
+ (yyerror "END in method; use at-exit")
+ (make-post-exec-stmt :body $3 :loc $1)))
+ ((lhs :tEQL command-call)
+ (make-expr-stmt :expr (make-assign-expr :lhs $1 :rhs $3 :kind :single)))
+ ((mlhs :tEQL command-call)
+ (make-expr-stmt :expr (make-assign-expr :lhs (make-lhs-dest :list $1)
+ :rhs $3
+ :kind :multi
+ :loc $2)))
+ ((var-lhs :tOP-ASGN command-call)
+ (make-expr-stmt :expr (new-op-asgn $1 $2 $3)))
+ ((primary-value |[| aref-args :tRBRACK :tOP-ASGN command-call)
+ (make-expr-stmt :expr (new-op-asgn (make-lhs-aref :self $1 :args $3) $5 $6)))
+ ((primary-value :tDOT :tIDENTIFIER :tOP-ASGN command-call)
+ (make-expr-stmt :expr (new-op-asgn (make-lhs-attr :self $1 :meth (car $3)) $4 $5)))
+ ((primary-value :tDOT :tCONSTANT :tOP-ASGN command-call)
+ (make-expr-stmt :expr (new-op-asgn (make-lhs-attr :self $1 :meth (car $3)) $4 $5)))
+ ((primary-value :tCOLON2 :tIDENTIFIER :tOP-ASGN command-call)
+ (make-expr-stmt :expr (new-op-asgn (make-lhs-attr :self $1 :meth (car $3)) $4 $5)))
+ ((backref :tOP-ASGN command-call)
+ (backref-assign-error $1))
+ ((lhs :tEQL mrhs)
+ (make-expr-stmt :expr (make-assign-expr :lhs $1
+ :rhs (make-array-expr :args $3)
+ :kind :svalue)))
+ ((mlhs :tEQL arg-value)
+ (make-expr-stmt :expr (make-assign-expr :lhs (make-lhs-dest :list $1)
+ :rhs $3
+ :kind :multi)))
+ ((mlhs :tEQL mrhs)
+ (make-expr-stmt :expr (make-assign-expr :lhs (make-lhs-dest :list $1)
+ :rhs (make-array-expr :args $3)
+ :kind :multi)))
+ ((expr) (make-expr-stmt :expr $1)))
+
+ (stmt-e1 (() (setf (slot-value *state* 'lex-state) :expr-fname)))
+
+ (stmt-e2 (() (if (or (plusp (slot-value *state* 'in-def))
+ (plusp (slot-value *state* 'in-single)))
+ (yyerror "BEGIN in method")
+ (env-extend (slot-value *state* 'env)))))
+
+ (expr ((command-call) $1)
+ ((expr :kAND expr)
+ (new-logop $1 :and $3))
+ ((expr :kOR expr)
+ (new-logop $1 :or $3))
+ ((:kNOT expr)
+ (make-not-expr :expr $2 :loc $1))
+ ((:tBANG command-call)
+ (make-not-expr :expr $2 :loc $1))
+ ((arg) $1))
+
+ (expr-value ((expr) $1))
+
+ (command-call ((command) $1)
+ ((block-command) $1)
+ ((:kRETURN call-args)
+ (make-return-expr :args $2 :loc $1))
+ ((:kBREAK call-args)
+ (make-break-expr :args $2 :loc $1))
+ ((:kNEXT call-args)
+ (make-next-expr :args $2 :loc $1)))
+
+ (block-command ((block-call) $1)
+ ((block-call :tDOT operation2 command-args)
+ (make-call-expr :recv $1 :meth $3 :args $4))
+ ((block-call :tCOLON2 operation2 command-args)
+ (make-call-expr :recv $1 :meth $3 :args $4)))
+
+ (cmd-brace-block ((:tLBRACE-ARG cmd-brace-block-e1 opt-block-var compstmt :tRCURLY)
+ (let ((block (make-blk :vars $3 :body $4)))
+ (env-unextend (slot-value *state* 'env))
+ block)))
+
+ (cmd-brace-block-e1 (()
+ (env-extend (slot-value *state* 'env) t)
+ ()))
+
+ (command ((operation command-args #|%prec LOWEST|#)
+ (make-call-expr :meth $1 :args $2))
+ ((operation command-args cmd-brace-block)
+ (make-call-expr :meth $1 :args $2 :block $3))
+ ((primary-value :tDOT operation2 command-args #|%prec LOWEST|#)
+ (make-call-expr :recv $1 :meth $3 :args $4))
+ ((primary-value :tDOT operation2 command-args cmd-brace-block)
+ (make-call-expr :recv $1 :meth $3 :args $4 :block $5))
+ ((primary-value :tCOLON2 operation2 command-args #|%prec LOWEST|#)
+ (make-call-expr :recv $1 :meth $3 :args $4))
+ ((primary-value :tCOLON2 operation2 command-args cmd-brace-block)
+ (make-call-expr :recv $1 :meth $3 :args $4 :block $5))
+ ((:kSUPER command-args)
+ (make-super-expr :args $2 :loc $1))
+ ((:kYIELD command-args)
+ (make-yield-expr :args $2 :loc $1)))
+
+ (mlhs ((mlhs-basic) $1)
+ ((:tLPAREN mlhs-entry :tRPAREN) $2))
+
+ (mlhs-entry ((mlhs-basic) $1)
+ ((:tLPAREN mlhs-entry :tRPAREN)
+ (list (make-lhs-dest :list $2))))
+
+ (mlhs-basic ((mlhs-head) $1)
+ ((mlhs-head mlhs-item)
+ (append $1 (list $2)))
+ ((mlhs-head :tSTAR mlhs-node)
+ (append $1 (list (make-lhs-rest :lhs $3))))
+ ((mlhs-head :tSTAR)
+ (append $1 (list (make-lhs-star))))
+ ((:tSTAR mlhs-node)
+ (list (make-lhs-rest :lhs $2)))
+ ((:tSTAR)
+ (list (make-lhs-star))))
+
+ (mlhs-item ((mlhs-node) $1)
+ ((:tLPAREN mlhs-entry :tRPAREN)
+ (make-lhs-dest :list $2)))
+
+ (mlhs-head ((mlhs-item :tCOMMA) (list $1))
+ ((mlhs-head mlhs-item :tCOMMA)
+ (append $1 (list $2))))
+
+ (mlhs-node ((variable)
+ (new-assignable $1))
+ ((primary-value |[| aref-args :tRBRACK)
+ (make-lhs-aref :self $1 :args $3))
+ ((primary-value :tDOT :tIDENTIFIER)
+ (make-lhs-attr :self $1 :meth $3))
+ ((primary-value :tCOLON2 :tIDENTIFIER)
+ (make-lhs-attr :self $1 :meth $3))
+ ((primary-value :tDOT :tCONSTANT)
+ (make-lhs-attr :self $1 :meth $3))
+ ((primary-value :tCOLON2 :tCONSTANT)
+ (if (or (plusp (slot-value *state* 'in-def))
+ (plusp (slot-value *state* 'in-single)))
+ (yyerror "dynamic constant assignment")
+ (make-lhs-id :id (make-const :cpath (make-cpath-rel :base $1 :string $3)))))
+ ((:tCOLON3 :tCONSTANT)
+ (if (or (plusp (slot-value *state* 'in-def))
+ (plusp (slot-value *state* 'in-single)))
+ (yyerror "dynamic constant assignment")
+ (make-lhs-id :id (make-const :cpath (make-cpath-glob :cpath (make-cpath-name :string $2))))))
+ ((backref)
+ (backref-assign-error $1)))
+
+ (lhs ((variable)
+ (new-assignable $1))
+ ((primary-value |[| aref-args :tRBRACK)
+ (make-lhs-aref :self $1 :args $3))
+ ((primary-value :tDOT :tIDENTIFIER)
+ (make-lhs-attr :self $1 :meth $3))
+ ((primary-value :tCOLON2 :tIDENTIFIER)
+ (make-lhs-attr :self $1 :meth $3))
+ ((primary-value :tDOT :tCONSTANT)
+ (make-lhs-attr :self $1 :meth $3))
+ ((primary-value :tCOLON2 :tCONSTANT)
+ (if (or (plusp (slot-value *state* 'in-def))
+ (plusp (slot-value *state* 'in-single)))
+ (yyerror "dynamic constant assignment")
+ (make-lhs-id :id (make-const :cpath (make-cpath-rel :base $1 :string $3)))))
+ ((:tCOLON3 :tCONSTANT)
+ (if (or (plusp (slot-value *state* 'in-def))
+ (plusp (slot-value *state* 'in-single)))
+ (yyerror "dynamic constant assignment")
+ (make-lhs-id :id (make-const :cpath (make-cpath-glob :cpath (make-cpath-name :string $2)))))))
+
+ (cname ((:tIDENTIFIER) (yyerror "class/module name must be :tCONSTANT"))
+ ((:tCONSTANT) $1))
+
+ (cpath ((:tCOLON3 cname)
+ (make-cpath-glob :cpath (make-cpath-name :string $2))) }
+ ((cname)
+ (make-cpath-name :string $1))
+ ((primary-value :tCOLON2 cname)
+ (make-cpath-rel :base $1 :string $3)))
+
+ (fname ((:tIDENTIFIER) $1)
+ ((:tCONSTANT) $1)
+ ((:tFID) $1)
+ ((op)
+ (setf (slot-value *state* 'lex-state) :expr-end)
+ $1)
+ ((reswords)
+ (setf (slot-value *state* 'lex-state) :expr-end)
+ $1))
+
+ (fitem ((fname) $1)
+ ((symbol) $1))
+
+ (undef-list ((fitem) (list $1))
+ ((undef-list :tCOMMA undef-list-e1 fitem)
+ (append $1 (list $4))))
+
+ (undef-list-e1 (() (setf (slot-value *state* 'lex-state) :expr-fname)))
+
+ (op ((:tPIPE) "|")
+ ((:tCARET) "^")
+ ((:tAMPER2) "&")
+ ((:tCMP) "<=>")
+ ((:tEQ) "==")
+ ((:tEQQ) "===")
+ ((:tMATCH) "=~")
+ ((:tGT) ">")
+ ((:tGEQ) ">=")
+ ((:tLT) "<")
+ ((:tLEQ) "<=")
+ ((:tLSHFT) "<<")
+ ((:tRSHFT) ">>")
+ ((:tPLUS) "+")
+ ((:tMINUS) "-")
+ ((:tSTAR2) "*")
+ ((:tSTAR) "*")
+ ((:tDIVIDE) "/")
+ ((:tPERCENT) "%")
+ ((:tPOW) "**")
+ ((:tTILDE) "~")
+ ((:tUPLUS) "+@")
+ ((:tUMINUS) "-@")
+ ((:tAREF) "[]")
+ ((:tASET) "[]=")
+ ((:tBACK-REF2) "`"))
+
+ (reswords ((:k__LINE__) "-__LINE__")
+ ((:k__FILE__) "-__FILE__")
+ ((:klBEGIN) "BEGIN")
+ ((:klEND) "END")
+ ((:kALIAS) "alias")
+ ((:kAND) "and")
+ ((:kBEGIN) "begin")
+ ((:kBREAK) "break")
+ ((:kCASE) "case")
+ ((:kCLASS) "class")
+ ((:kDEF) "def")
+ ((:kDEFINED) "defined")
+ ((:kDO) "do")
+ ((:kELSE) "else")
+ ((:kELSIF) "elsif")
+ ((:kEND) "end")
+ ((:kENSURE) "ensure")
+ ((:kFALSE) "false")
+ ((:kFOR) "for")
+ ((:kIN) "in")
+ ((:kMODULE) "module")
+ ((:kNEXT) "next")
+ ((:kNIL) "nil")
+ ((:kNOT) "not")
+ ((:kOR) "or")
+ ((:kREDO) "redo")
+ ((:kRESCUE) "rescue")
+ ((:kRETRY) "retry")
+ ((:kRETURN) "return")
+ ((:kSELF) "self")
+ ((:kSUPER) "super")
+ ((:kTHEN) "then")
+ ((:kTRUE) "true")
+ ((:kUNDEF) "undef")
+ ((:kWHEN) "when")
+ ((:kYIELD) "yield")
+ ((:kIF-MOD) "if")
+ ((:kUNLESS-MOD) "unless")
+ ((:kWHILE-MOD) "while")
+ ((:kUNTIL-MOD) "until")
+ ((:kRESCUE-MOD) "rescue"))
+
+ (arg ((lhs :tEQL arg)
+ (make-assign-expr :lhs $1 :rhs $3 :kind :single))
+ ((lhs :tEQL arg :kRESCUE-MOD arg)
+ (make-assign-expr :lhs $1
+ :rhs (make-begin-expr
+ :body (make-body-stmt
+ :body (list (make-expr-stmt :expr $3))
+ :rescues (list (cons nil (list (make-expr-stmt :expr $5))))))
+ :kind :single))
+ ((var-lhs :tOP-ASGN arg)
+ (new-op-asgn $1 $2 $3))
+ ((primary-value |[| aref-args :tRBRACK :tOP-ASGN arg)
+ (new-op-asgn (make-lhs-aref :self $1 :args $3) $5 $6))
+ ((primary-value :tDOT :tIDENTIFIER :tOP-ASGN arg)
+ (new-op-asgn (make-lhs-attr :self $1 :meth $3) $4 $5))
+ ((primary-value :tDOT :tCONSTANT :tOP-ASGN arg)
+ (new-op-asgn (make-lhs-attr :self $1 :meth $3) $4 $5))
+ ((primary-value :tCOLON2 :tIDENTIFIER :tOP-ASGN arg)
+ (new-op-asgn (make-lhs-attr :self $1 :meth $3) $4 $5))
+ ((primary-value :tCOLON2 :tCONSTANT :tOP-ASGN arg)
+ (yyerror "constant re-assignment"))
+ ((:tCOLON3 :tCONSTANT :tOP-ASGN arg)
+ (yyerror "constant re-assignment"))
+ ((backref :tOP-ASGN arg)
+ (backref-assign-error $1))
+ ((arg :tDOT2 arg)
+ #| TODO
+ v1, v2 = val[0], val[2]
+ if v1.node-type == :lit and v2.node-type == :lit and Fixnum === v1.last and Fixnum === v2.last then
+ result = s(:lit, (v1.last)..(v2.last))
+ else
+ result = s(:dot2, v1, v2)
+ end
+ |#
+ (make-dot2-expr :lhs $1 :rhs $3 :loc $2))
+ ((arg :tDOT3 arg)
+ #| TODO
+ v1, v2 = val[0], val[2]
+ if v1.node-type == :lit and v2.node-type == :lit and Fixnum === v1.last and Fixnum === v2.last then
+ result = s(:lit, (v1.last)...(v2.last))
+ else
+ result = s(:dot3, v1, v2)
+ end
+ |#
+ (make-dot3-expr :lhs $1 :rhs $3 :loc $2))
+ ((arg :tPLUS arg)
+ (make-call-expr :recv $1 :meth "+" :args (list (make-arg-value :expr $3)) :loc $2))
+ ((arg :tMINUS arg)
+ (make-call-expr :recv $1 :meth "-" :args (list (make-arg-value :expr $3)) :loc $2))
+ ((arg :tSTAR2 arg)
+ (make-call-expr :recv $1 :meth "*" :args (list (make-arg-value :expr $3)) :loc $2))
+ ((arg :tDIVIDE arg)
+ (make-call-expr :recv $1 :meth "/" :args (list (make-arg-value :expr $3)) :loc $2))
+ ((arg :tPERCENT arg)
+ (make-call-expr :recv $1 :meth "%" :args (list (make-arg-value :expr $3)) :loc $2))
+ ((arg :tPOW arg)
+ (make-call-expr :recv $1 :meth "**" :args (list (make-arg-value :expr $3)) :loc $2))
+ ((:tUMINUS-NUM :tINTEGER :tPOW arg)
+ (make-call-expr :recv (make-call-expr :recv (make-lit-expr :lit (make-integer-lit :value $2))
+ :meth "**"
+ :args (list (make-arg-value :expr $4))
+ :loc $3)
+ :meth "-@"
+ :loc $1))
+ ((:tUMINUS-NUM :tFLOAT :tPOW arg)
+ (make-call-expr :recv (make-call-expr :recv (make-lit-expr :lit (make-float-lit :value $2))
+ :meth "**"
+ :args (list (make-arg-value :expr $4))
+ :loc $3)
+ :meth "-@"
+ :loc $1))
+ ((:tUPLUS arg)
+ (match $2
+ ((literal) $2)
+ (otherwise
+ (make-call-expr :recv $2 :meth "+@" :loc $1))))
+ ((:tUMINUS arg)
+ (make-call-expr :recv $2 :meth "-@" :loc $1))
+ ((arg :tPIPE arg)
+ (make-call-expr :recv $1 :meth "|" :args (list (make-arg-value :expr $3)) :loc $2))
+ ((arg :tCARET arg)
+ (make-call-expr :recv $1 :meth "^" :args (list (make-arg-value :expr $3)) :loc $2))
+ ((arg :tAMPER2 arg)
+ (make-call-expr :recv $1 :meth "&" :args (list (make-arg-value :expr $3)) :loc $2))
+ ((arg :tCMP arg)
+ (make-call-expr :recv $1 :meth "<=>" :args (list (make-arg-value :expr $3)) :loc $2))
+ ((arg :tGT arg)
+ (make-call-expr :recv $1 :meth ">" :args (list (make-arg-value :expr $3)) :loc $2))
+ ((arg :tGEQ arg)
+ (make-call-expr :recv $1 :meth ">=" :args (list (make-arg-value :expr $3)) :loc $2))
+ ((arg :tLT arg)
+ (make-call-expr :recv $1 :meth "<" :args (list (make-arg-value :expr $3)) :loc $2))
+ ((arg :tLEQ arg)
+ (make-call-expr :recv $1 :meth "<=" :args (list (make-arg-value :expr $3)) :loc $2))
+ ((arg :tEQ arg)
+ (make-call-expr :recv $1 :meth "==" :args (list (make-arg-value :expr $3)) :loc $2))
+ ((arg :tEQQ arg)
+ (make-call-expr :recv $1 :meth "===" :args (list (make-arg-value :expr $3)) :loc $2))
+ ((arg :tNEQ arg)
+ (make-not-expr :expr (make-call-expr :recv $1
+ :meth "=="
+ :args (list (make-arg-value :expr $3)))))
+ ((arg :tMATCH arg)
+ (get-match-node $1 $3 :loc $2))
+ ((arg :tNMATCH arg)
+ (make-not-expr :expr (get-match-node $1 $3 :loc $2)))
+ ((:tBANG arg)
+ (make-not-expr :expr $2 :loc $1))
+ ((:tTILDE arg)
+ (make-call-expr :recv $2 :meth "~" :loc $1))
+ ((arg :tLSHFT arg)
+ (make-call-expr :recv $1 :meth "<<" :args (list (make-arg-value :expr $3)) :loc $2))
+ ((arg :tRSHFT arg)
+ (make-call-expr :recv $1 :meth ">>" :args (list (make-arg-value :expr $3)) :loc $2))
+ ((arg :tANDOP arg)
+ (new-logop $1 :and $3))
+ ((arg :tOROP arg)
+ (new-logop $1 :or $3))
+ ((:kDEFINED opt-nl arg)
+ (make-defined-expr :expr $3))
+ ((arg :tEH arg :tCOLON arg)
+ (make-tern-expr :test $1 :then $3 :else $5 :loc (node-loc $1)))
+ ((primary)
+ $1))
+
+ (arg-value ((arg) $1))
+
+ (aref-args (() ())
+ ((command opt-nl)
+ (rb-warning "parenthesize argument(s) for future version")
+ (list (make-arg-value :expr $1)))
+ ((args trailer) $1)
+ ((args :tCOMMA :tSTAR arg opt-nl)
+ (append $1 (list (make-arg-value :expr $4))))
+ ((assocs trailer)
+ (list (make-arg-hash :list $1)))
+ ((:tSTAR arg opt-nl)
+ (list (make-arg-splat :expr $2))))
+
+ (paren-args ((:tLPAREN2 none :tRPAREN) ())
+ ((:tLPAREN2 call-args opt-nl :tRPAREN) $2)
+ ((:tLPAREN2 block-call opt-nl :tRPAREN)
+ (rb-warning "parenthesize argument(s) for future version")
+ (list (make-arg-value :expr $2)))
+ ((:tLPAREN2 args :tCOMMA block-call opt-nl :tRPAREN)
+ (rb-warning "parenthesize argument(s) for future version")
+ (append $2 (list (make-arg-value :expr $4)))))
+
+ (opt-paren-args (() ())
+ ((paren-args) $1))
+
+ (call-args ((command)
+ (rb-warning "parenthesize argument(s) for future version")
+ ())
+ ((args opt-block-arg)
+ (append $1 $2))
+ ((args :tCOMMA :tSTAR arg-value opt-block-arg)
+ (append $1 (cons (make-arg-splat :expr $4) $5)))
+ ((assocs opt-block-arg)
+ (make-arg-hash :list (cons $1 $2)))
+ ((assocs :tCOMMA :tSTAR arg-value opt-block-arg)
+ (make-arg-hash :list (list* $1 (make-arg-splat :expr $4) $5)))
+ ((args :tCOMMA assocs opt-block-arg)
+ (append $1 (make-arg-hash :list (cons $3 $4))))
+ ((args :tCOMMA assocs :tCOMMA :tSTAR arg opt-block-arg)
+ (append $1 (make-arg-hash :list (list* $3 (make-arg-splat :expr $6) $7))))
+ ((:tSTAR arg-value opt-block-arg)
+ (cons (make-arg-splat :expr $2) $3))
+ ((block-arg) (list $1)))
+
+ (call-args2 ((arg-value :tCOMMA args opt-block-arg)
+ (append (cons (make-arg-value :expr $1) $3) $4))
+ ((arg-value :tCOMMA block-arg)
+ (list (make-arg-value :expr $1) $3))
+ ((arg-value :tCOMMA :tSTAR arg-value opt-block-arg)
+ (list* (make-arg-value :expr $1) (make-arg-splat :expr $4) $5))
+ ((arg-value :tCOMMA args :tCOMMA :tSTAR arg-value opt-block-arg)
+ (append (cons (make-arg-value :expr $1) $3)
+ (cons (make-arg-splat :expr $6) $7)))
+ ((assocs opt-block-arg)
+ (cons (make-arg-hash :list $1) $2))
+ ((assocs :tCOMMA :tSTAR arg-value opt-block-arg)
+ (list* (make-arg-hash :list $1) (make-arg-splat :expr $4) $5))
+ ((arg-value :tCOMMA assocs opt-block-arg)
+ (list* (make-arg-value :expr $1) (make-arg-hash :list $3) $4))
+ ((arg-value :tCOMMA args :tCOMMA assocs opt-block-arg)
+ (append (cons (make-arg-value :expr $1) $3)
+ (cons (make-arg-hash :list $5) $6)))
+ ((arg-value :tCOMMA assocs :tCOMMA :tSTAR arg-value opt-block-arg)
+ (list* (make-arg-value :expr $1)
+ (make-arg-hash :list $3)
+ (make-arg-splat :expr $6)
+ $7))
+ ((arg-value :tCOMMA args :tCOMMA assocs :tCOMMA :tSTAR arg-value opt-block-arg)
+ (append (cons (make-arg-value :expr $1) $3)
+ (list* (make-arg-hash :list $5)
+ (make-arg-splat :expr $8)
+ $9)))
+ ((:tSTAR arg-value opt-block-arg)
+ (cons (make-arg-splat :expr $2) $3))
+ ((block-arg) (list $1)))
+
+ (command-args ((command-args-e1 open-args)
+ (setf (slot-value *state* 'cmdarg) (make-stack-state :list $1))
+ $2))
+
+ (command-args-e1 (()
+ (let ((list (stack-state-list (slot-value *state* 'cmdarg))))
+ (stack-state-push (slot-value *state* 'cmdarg) t)
+ list)))
+
+ (open-args ((call-args) $1)
+ ((:tLPAREN-ARG open-args-e1 :tRPAREN)
+ (rb-warning "don't put space before argument parentheses")
+ ())
+ ((:tLPAREN-ARG call-args2 open-args-e1 :tRPAREN)
+ (rb-warning "don't put space before argument parentheses")
+ $2))
+
+ (open-args-e1 (() (setf (slot-value *state* 'lex-state) :expr-endarg)))
+
+ (block-arg ((:tAMPER arg-value) (make-arg-block :expr $2)))
+
+ (opt-block-arg ((:tCOMMA block-arg) (list $2))
+ (() ()))
+
+ (args ((arg-value)
+ (list (make-arg-value :expr $1)))
+ ((args :tCOMMA arg-value)
+ (append $1 (list (make-arg-value :expr $3)))))
+
+ (mrhs ((args :tCOMMA arg-value)
+ (append $1 (list (make-arg-value :expr $3))))
+ ((args :tCOMMA :tSTAR arg-value)
+ (append $1 (list (make-arg-splat :expr $4))))
+ ((:tSTAR arg-value)
+ (list (make-arg-splat :expr $2))))
+
+ (primary ((literal) $1)
+ ((strings) $1)
+ ((xstring) $1)
+ ((regexp) $1)
+ ((words) $1)
+ ((awords) $1)
+ ((var-ref) $1)
+ ((backref) $1)
+ ((:tFID)
+ (make-call-expr :meth $1))
+ ((:kBEGIN bodystmt :kEND)
+ (make-begin-expr :body $2 :loc $1))
+ ((:tLPAREN-ARG expr primary-e1 opt-nl :tRPAREN)
+ (rb-warning "(...) interpreted as grouped expression")
+ $2)
+ ((:tLPAREN compstmt :tRPAREN)
+ (match $2
+ (() (make-id-expr :id (make-pvar :name :nil) :loc $1))
+ (_ (make-block-expr :body $2 :loc $1))))
+ ((primary-value :tCOLON2 :tCONSTANT)
+ (make-id-expr :id (make-const :cpath (make-cpath-rel :base $1 :string $3))))
+ ((:tCOLON3 :tCONSTANT)
+ (make-id-expr :id (make-const :cpath (make-cpath-glob :cpath (make-cpath-name :string $2)))))
+ ((primary-value |[| aref-args :tRBRACK)
+ (new-aref $1 $3 :loc $2))
+ ((:tLBRACK aref-args :tRBRACK)
+ (make-array-expr :args $2 :loc $1))
+ ((:tLBRACE assoc-list :tRCURLY)
+ (make-hash-expr :args $2 :loc $1))
+ ((:kRETURN)
+ (make-return-expr :loc $1))
+ ((:kYIELD :tLPAREN2 call-args :tRPAREN)
+ (make-yield-expr :args $3 :loc $1))
+ ((:kYIELD :tLPAREN2 :tRPAREN)
+ (make-yield-expr :loc $1))
+ ((:kYIELD)
+ (make-yield-expr :loc $1))
+ ((:kDEFINED opt-nl :tLPAREN2 expr :tRPAREN)
+ (make-defined-expr :expr $4 :loc $1))
+ ((operation brace-block)
+ (make-call-expr :meth $1 :block $2))
+ ((method-call)
+ $1)
+ ((method-call brace-block)
+ (match $1
+ ((call-expr recv meth args loc)
+ (make-call-expr :recv recv :meth meth :args args :block $2 :loc loc))
+ (_ (error "invalid method-call"))))
+ ((:kIF expr-value then compstmt if-tail :kEND)
+ (make-if-expr :test $2 :then $4 :else $5 :loc $1))
+ ((:kUNLESS expr-value then compstmt opt-else :kEND)
+ (make-unless-expr :test $2 :then $4 :else $5 :loc $1))
+ ((:kWHILE
+ primary-e2
+ expr-value do
+ primary-e3
+ compstmt :kEND)
+ (make-while-expr :test $3 :body $6 :loc $1))
+ ((:kUNTIL
+ primary-e2
+ expr-value do
+ primary-e3
+ compstmt :kEND)
+ (make-until-expr :test $3 :body $6 :loc $1))
+ ((:kCASE expr-value opt-terms case-body opt-else :kEND)
+ (make-case-expr :test $2 :whens $4 :else $5 :loc $1))
+ ((:kCASE opt-terms case-body opt-else :kEND)
+ (make-case-expr :whens $3 :else $4 :loc $1))
+ ((:kCASE opt-terms :kELSE compstmt :kEND)
+ (make-case-expr :else $4 :loc $1))
+ ((:kFOR
+ block-var :kIN
+ primary-e2
+ expr-value do
+ primary-e3
+ compstmt :kEND)
+ (make-for-expr :lhs $2 :gen $5 :body $8 :loc $1))
+ ((:kCLASS
+ cpath superclass
+ primary-e4
+ bodystmt :kEND)
+ (prog1 (make-class-expr :cpath $2 :super $3 :body $5 :loc $1)
+ (env-unextend (slot-value *state* 'env))))
+ ((:kCLASS
+ :tLSHFT
+ expr
+ primary-e5
+ term
+ primary-e6
+ bodystmt :kEND)
+ (prog1 (make-sclass-expr :expr $3 :body $7 :loc $1)
+ (setf (slot-value *state* 'in-def) $4)
+ (setf (slot-value *state* 'in-single) $6)
+ (env-unextend (slot-value *state* 'env))))
+ ((:kMODULE
+ cpath
+ primary-e7
+ bodystmt :kEND)
+ (prog1 (make-module-expr :cpath $2 :body $4)
+ (env-unextend (slot-value *state* 'env))))
+ ((:kDEF
+ fname
+ primary-e8
+ f-arglist bodystmt :kEND)
+ (prog1 (make-defn-expr :name $2 :params $4 :body $5)
+ (env-unextend (slot-value *state* 'env))
+ (decf (slot-value *state* 'in-def))))
+ ((:kDEF
+ singleton dot-or-colon
+ primary-e9
+ fname
+ primary-e10
+ f-arglist bodystmt :kEND)
+ (prog1 (make-defs-expr :expr $2 :name $5 :params $7 :body $8 :loc $1)
+ (env-unextend (slot-value *state* 'env))
+ (decf (slot-value *state* 'in-single))))
+ ((:kBREAK)
+ (make-break-expr :loc $1))
+ ((:kNEXT)
+ (make-next-expr :loc $1))
+ ((:kREDO)
+ (make-redo-expr :loc $1))
+ ((:kRETRY)
+ (make-retry-expr :loc $1)))
+
+ (primary-e1 (() (setf (slot-value *state* 'lex-state) :expr-endarg)))
+ (primary-e2 (() (stack-state-push (slot-value *state* 'cond) t)))
+ (primary-e3 (() (stack-state-pop (slot-value *state* 'cond))))
+ (primary-e4 (()
+ (if (or (plusp (slot-value *state* 'in-def))
+ (plusp (slot-value *state* 'in-single)))
+ (yyerror "class definition in method body")
+ (env-extend (slot-value *state* 'env)))))
+ (primary-e5 (()
+ (let ((in-def (slot-value *state* 'in-def)))
+ (setf (slot-value *state* 'in-def) 0)
+ in-def)))
+ (primary-e6 (()
+ (let ((in-single (slot-value *state* 'in-single)))
+ (setf (slot-value *state* 'in-single) 0)
+ (env-extend (slot-value *state* 'env))
+ in-single)))
+ (primary-e7 (()
+ (if (or (plusp (slot-value *state* 'in-def))
+ (plusp (slot-value *state* 'in-single)))
+ (yyerror "module definition in method body")
+ (env-extend (slot-value *state* 'env)))))
+ (primary-e8 (()
+ (incf (slot-value *state* 'in-def))
+ (env-extend (slot-value *state* 'env))))
+ (primary-e9 (()
+ (setf (slot-value *state* 'lex-state) :expr-fname)))
+ (primary-e10 (()
+ (incf (slot-value *state* 'in-single))
+ (env-extend (slot-value *state* 'env))
+ (setf (slot-value *state* 'lex-state) :expr-end)))
+
+ (primary-value ((primary) $1))
+
+ (then ((term) ())
+ ((:tCOLON) ())
+ ((:kTHEN) ())
+ ((term :kTHEN) ()))
+
+ (do ((term) ())
+ ((:tCOLON) ())
+ ((:kDO-COND) ()))
+
+ (if-tail ((opt-else) $1)
+ ((:kELSIF expr-value then compstmt if-tail)
+ (list (make-expr-stmt :expr (make-if-expr :test $2 :then $4 :else $5 :loc $1)))))
+
+ (opt-else (() ())
+ ((:kELSE compstmt) $2))
+
+ (block-var ((lhs) $1)
+ ((mlhs) (make-lhs-dest :list $1)))
+
+ (opt-block-var (() ())
+ ((:tPIPE :tPIPE) ())
+ ((:tOROP) ())
+ ((:tPIPE lhs :tPIPE) (list $2))
+ ((:tPIPE mlhs :tPIPE) $2))
+
+ (do-block ((:kDO-BLOCK
+ do-block-e1
+ opt-block-var
+ compstmt :kEND)
+ (prog1 (make-blk :vars $3 :body $3)
+ (env-unextend (slot-value *state* 'env)))))
+ (do-block-e1 (() (env-extend (slot-value *state* 'env) t)))
+
+ (block-call ((command do-block)
+ (match $1
+ ((call-expr recv meth args loc)
+ (make-call-expr :recv recv :meth meth :args args :block $2 :loc loc))
+ ((super-expr args loc)
+ (make-super-expr :args args :block $2 :loc loc))
+ ((yield-expr)
+ $1)
+ (otherwise
+ (error "invalid block-call"))))
+ ((block-call :tDOT operation2 opt-paren-args)
+ (make-call-expr :recv $1 :meth $3 :args $4))
+ ((block-call :tCOLON2 operation2 opt-paren-args)
+ (make-call-expr :recv $1 :meth $3 :args $4)))
+
+ (method-call ((operation paren-args)
+ (make-call-expr :meth $1 :args $2))
+ ((primary-value :tDOT operation2 opt-paren-args)
+ (make-call-expr :recv $1 :meth $3 :args $4))
+ ((primary-value :tCOLON2 operation2 paren-args)
+ (make-call-expr :recv $1 :meth $3 :args $4))
+ ((primary-value :tCOLON2 operation3)
+ (make-call-expr :recv $1 :meth $3))
+ ((:kSUPER paren-args)
+ (make-super-expr :args $2 :loc $1))
+ ((:kSUPER)
+ (make-zsuper-expr :loc $1)))
+
+ (brace-block ((:tLCURLY
+ brace-block-e1
+ opt-block-var
+ compstmt :tRCURLY)
+ (prog1 (make-blk :vars $3 :body $4)
+ (env-unextend (slot-value *state* 'env))))
+ ((:kDO
+ brace-block-e1
+ opt-block-var
+ compstmt :kEND)
+ (prog1 (make-blk :vars $3 :body $4)
+ (env-unextend (slot-value *state* 'env)))))
+ (brace-block-e1 (() (env-extend (slot-value *state* 'env) t)))
+
+ (case-body ((:kWHEN
+ when-args then compstmt cases)
+ (cons (cons $2 $4) $5)))
+
+ (when-args ((args) $1)
+ ((args :tCOMMA :tSTAR arg-value)
+ (append $1 (list (make-arg-splat :expr $4))))
+ ((:tSTAR arg-value)
+ (list (make-arg-splat :expr $2))))
+
+ (cases ((case-body) $1)
+ (() ()))
+
+ (opt-rescue ((:kRESCUE exc-list exc-var then compstmt opt-rescue)
+ (let ((body
+ (if $3
+ (let ((asgn
+ (make-assign-expr :lhs $3
+ :rhs (make-id-expr :id (make-gvar :name "!"))
+ :kind :single)))
+ (cons (make-expr-stmt :expr asgn) $5))
+ $5)))
+ (cons (cons $2 body) $6)))
+ (() ()))
+
+ (exc-list ((arg-value) (list (make-arg-value :expr $1)))
+ ((mrhs) $1)
+ (() ()))
+
+ (exc-var ((:tASSOC lhs) $2)
+ (() nil))
+
+ (opt-ensure ((:kENSURE compstmt) $2)
+ (() ()))
+
+ (literal ((numeric)
+ (make-lit-expr :lit (etypecase $1
+ (integer (make-integer-lit :value $1))
+ (float (make-float-lit :value $1)))))
+ ((symbol)
+ (make-lit-expr :lit (make-string-lit :value (list $1))))
+ ((dsym) $1))
+
+ (strings ((string) $1))
+
+ (string ((string1) $1)
+ ((string string1)
+ (literal-concat $1 $2)))
+
+ (string1 ((:tSTRING-BEG string-contents :tSTRING-END)
+ (make-lit-expr :lit (make-string-lit :value $2)))
+ ((:tSTRING)
+ (make-lit-expr :lit (make-string-lit :value (list $1)))))
+
+ (xstring ((:tXSTRING-BEG xstring-contents :tSTRING-END)
+ (make-lit-expr :lit (make-xstring-lit :value $2))))
+
+ (regexp ((:tREGEXP-BEG xstring-contents :tREGEXP-END)
+ (make-lit-expr :lit (make-regexp-lit :value $2))))
+
+ (words ((:tWORDS-BEG :tSPACE :tSTRING-END)
+ (make-array-expr :loc $1))
+ ((:tWORDS-BEG word-list :tSTRING-END)
+ (make-array-expr :args $2 :loc $1)))
+
+ (word-list (() ())
+ ((word-list word :tSPACE)
+ (append $1 (list (make-arg-value :expr $2)))))
+
+ (word ((string-content)
+ (make-lit-expr :lit (make-string-lit :value (list $1))))
+ ((word string-content)
+ (literal-concat $1 (make-lit-expr :lit (make-string-lit :value (list $2))))))
+
+ (awords ((:tAWORDS-BEG :tSPACE :tSTRING-END)
+ (make-array-expr :loc $1))
+ ((:tAWORDS-BEG qword-list :tSTRING-END)
+ (make-array-expr :args $2 :loc $1)))
+
+ (qword-list (() ())
+ ((qword-list :tSTRING-CONTENT :tSPACE)
+ (append $1 (list (make-arg-value :expr (make-lit-expr :lit (make-string-lit :value (list $2))))))))
+
+ (string-contents (() ())
+ ((string-contents string-content)
+ (append $1 (list $2))))
+
+ (xstring-contents (() ())
+ ((xstring-contents string-content)
+ (append $1 (list $2))))
+
+ (string-content ((:tSTRING-CONTENT) $1)
+ ((:tSTRING-DVAR
+ string-content-e1
+ string-dvar)
+ (setf (slot-value *state* 'lex-strterm) $2)
+ (cons $3 $1))
+ ((:tSTRING-DBEG
+ string-content-e2
+ compstmt :tRCURLY)
+ (setf (slot-value *state* 'lex-strterm) $2)
+ (stack-state-lexpop (slot-value *state* 'cond))
+ (stack-state-lexpop (slot-value *state* 'cmdarg))
+ (cons (make-block-expr :body $3) $1)))
+
+ (string-content-e1 (()
+ (prog1 (slot-value *state* 'lex-strterm)
+ (setf (slot-value *state* 'lex-strterm) nil)
+ (setf (slot-value *state* 'lex-state) :expr-beg))))
+ (string-content-e2 (()
+ (prog1 (slot-value *state* 'lex-strterm)
+ (setf (slot-value *state* 'lex-strterm) nil)
+ (setf (slot-value *state* 'lex-state) :expr-beg)
+ (stack-state-push (slot-value *state* 'cond) nil)
+ (stack-state-push (slot-value *state* 'cmdarg) nil))))
+
+ (string-dvar ((:tGVAR) (make-id-expr :id (make-gvar :name $1)))
+ ((:tIVAR) (make-id-expr :id (make-ivar :name $1)))
+ ((:tCVAR) (make-id-expr :id (make-cvar :name $1)))
+ ((backref) $1))
+
+ (symbol ((:tSYMBEG sym)
+ (setf (slot-value *state* 'lex-state) :expr-end)
+ $2)
+ ((:tSYMBOL)
+ $1))
+
+ (sym ((fname) $1)
+ ((:tIVAR) $1)
+ ((:tGVAR) $1)
+ ((:tCVAR) $1))
+
+ (dsym ((:tSYMBEG xstring-contents :tSTRING-END)
+ (make-lit-expr :lit (make-symbol-lit :value $2) :loc $1)))
+
+ (numeric ((:tINTEGER) $1)
+ ((:tFLOAT) $1)
+ ((:tUMINUS-NUM :tINTEGER #|%prec LOWEST|#)
+ (- $2))
+ ((:tUMINUS-NUM :tFLOAT #|%prec LOWEST|#)
+ (- $2)))
+
+ (variable ((:tIDENTIFIER) $1)
+ ((:tIVAR) $1)
+ ((:tGVAR) $1)
+ ((:tCONSTANT) $1)
+ ((:tCVAR) $1)
+ ((:kNIL) "nil")
+ ((:kSELF) "self")
+ ((:kTRUE) "true")
+ ((:kFALSE) "false")
+ ((:k__FILE__) "-__FILE__")
+ ((:k__LINE__) "-__LINE__"))
+
+ (var-ref ((variable)
+ (gettable $1)))
+
+ (var-lhs ((variable)
+ (new-assignable $1)))
+
+ (backref ((:tNTH-REF) (make-nth-ref-expr :n $1))
+ ((:tBACK-REF) (make-back-ref-expr :c $1)))
+
+ (superclass ((term) nil)
+ ((:tLT
+ superclass-e1
+ expr-value term)
+ $3)
+ ((error term) nil))
+ (superclass-e1 (()
+ (setf (slot-value *state* 'lex-state) :expr-beg)))
+
+ (f-arglist ((:tLPAREN2 f-args opt-nl :tRPAREN)
+ (setf (slot-value *state* 'lex-state) :expr-beg)
+ $2)
+ ((f-args term) $1))
+
+ (f-args ((f-arg :tCOMMA f-optarg :tCOMMA f-rest-arg opt-f-block-arg)
+ (append $1 $3 $5 $6))
+ ((f-arg :tCOMMA f-optarg opt-f-block-arg)
+ (append $1 $3 () $4))
+ ((f-arg :tCOMMA f-rest-arg opt-f-block-arg)
+ (append $1 () $3 $4))
+ ((f-arg opt-f-block-arg)
+ (append $1 () () $2))
+ ((f-optarg :tCOMMA f-rest-arg opt-f-block-arg)
+ (append () $1 $3 $4))
+ ((f-optarg opt-f-block-arg)
+ (append () $1 () $2))
+ ((f-rest-arg opt-f-block-arg)
+ (append () () $1 $2))
+ ((f-block-arg)
+ (append () () () $1))
+ (() ()))
+
+ (f-norm-arg ((:tCONSTANT)
+ (yyerror "formal argument cannot be a constant: ~A" $1))
+ ((:tIVAR)
+ (yyerror "formal argument cannot be an instance variable"))
+ ((:tCVAR)
+ (yyerror "formal argument cannot be a class variable"))
+ ((:tIDENTIFIER)
+ (env-add (slot-value *state* 'env) $1 :lvar)