Файловый менеджер - Редактировать - /var/www/html/ecmascript.zip
Ðазад
PK ! �!AO[D [D tokenize.scmnu �[��� ;;; ECMAScript for Guile ;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc. ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either ;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;;; Lesser General Public License for more details. ;;;; ;;;; You should have received a copy of the GNU Lesser General Public ;;;; License along with this library; if not, write to the Free Software ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Code: (define-module (language ecmascript tokenize) #:use-module (ice-9 rdelim) #:use-module ((srfi srfi-1) #:select (unfold-right)) #:use-module (system base lalr) #:export (next-token make-tokenizer make-tokenizer/1 tokenize tokenize/1)) (define (syntax-error what loc form . args) (throw 'syntax-error #f what (and=> loc source-location->source-properties) form #f args)) (define (port-source-location port) (make-source-location (port-filename port) (port-line port) (port-column port) (false-if-exception (ftell port)) #f)) ;; taken from SSAX, sorta (define (read-until delims port loc) (if (eof-object? (peek-char port)) (syntax-error "EOF while reading a token" loc #f) (let ((token (read-delimited delims port 'peek))) (if (eof-object? (peek-char port)) (syntax-error "EOF while reading a token" loc token) token)))) (define (char-hex? c) (and (not (eof-object? c)) (or (char-numeric? c) (memv c '(#\a #\b #\c #\d #\e #\f)) (memv c '(#\A #\B #\C #\D #\E #\F))))) (define (digit->number c) (- (char->integer c) (char->integer #\0))) (define (hex->number c) (if (char-numeric? c) (digit->number c) (+ 10 (- (char->integer (char-downcase c)) (char->integer #\a))))) (define (read-slash port loc div?) (let ((c1 (begin (read-char port) (peek-char port)))) (cond ((eof-object? c1) ;; hmm. error if we're not looking for a div? ? (make-lexical-token '/ loc #f)) ((char=? c1 #\/) (read-line port) (next-token port div?)) ((char=? c1 #\*) (read-char port) (let lp ((c (read-char port))) (cond ((eof-object? c) (syntax-error "EOF while in multi-line comment" loc #f)) ((char=? c #\*) (if (eqv? (peek-char port) #\/) (begin (read-char port) (next-token port div?)) (lp (read-char port)))) (else (lp (read-char port)))))) (div? (case c1 ((#\=) (read-char port) (make-lexical-token '/= loc #f)) (else (make-lexical-token '/ loc #f)))) (else (read-regexp port loc))))) (define (read-regexp port loc) ;; first slash already read (let ((terms (string #\/ #\\ #\nl #\cr))) (let lp ((str (read-until terms port loc)) (head "")) (let ((terminator (peek-char port))) (cond ((char=? terminator #\/) (read-char port) ;; flags (let lp ((c (peek-char port)) (flags '())) (if (or (eof-object? c) (not (or (char-alphabetic? c) (char-numeric? c) (char=? c #\$) (char=? c #\_)))) (make-lexical-token 'RegexpLiteral loc (cons (string-append head str) (reverse flags))) (begin (read-char port) (lp (peek-char port) (cons c flags)))))) ((char=? terminator #\\) (read-char port) (let ((echar (read-char port))) (lp (read-until terms port loc) (string-append head str (string #\\ echar))))) (else (syntax-error "regexp literals may not contain newlines" loc str))))))) (define (read-string port loc) (let ((c (read-char port))) (let ((terms (string c #\\ #\nl #\cr))) (define (read-escape port) (let ((c (read-char port))) (case c ((#\' #\" #\\) c) ((#\b) #\bs) ((#\f) #\np) ((#\n) #\nl) ((#\r) #\cr) ((#\t) #\tab) ((#\v) #\vt) ((#\0) (let ((next (peek-char port))) (cond ((eof-object? next) #\nul) ((char-numeric? next) (syntax-error "octal escape sequences are not supported" loc #f)) (else #\nul)))) ((#\x) (let* ((a (read-char port)) (b (read-char port))) (cond ((and (char-hex? a) (char-hex? b)) (integer->char (+ (* 16 (hex->number a)) (hex->number b)))) (else (syntax-error "bad hex character escape" loc (string a b)))))) ((#\u) (let* ((a (read-char port)) (b (read-char port)) (c (read-char port)) (d (read-char port))) (integer->char (string->number (string a b c d) 16)))) (else c)))) (let lp ((str (read-until terms port loc))) (let ((terminator (peek-char port))) (cond ((char=? terminator c) (read-char port) (make-lexical-token 'StringLiteral loc str)) ((char=? terminator #\\) (read-char port) (let ((echar (read-escape port))) (lp (string-append str (string echar) (read-until terms port loc))))) (else (syntax-error "string literals may not contain newlines" loc str)))))))) (define *keywords* '(("break" . break) ("else" . else) ("new" . new) ("var" . var) ("case" . case) ("finally" . finally) ("return" . return) ("void" . void) ("catch" . catch) ("for" . for) ("switch" . switch) ("while" . while) ("continue" . continue) ("function" . function) ("this" . this) ("with" . with) ("default" . default) ("if" . if) ("throw" . throw) ("delete" . delete) ("in" . in) ("try" . try) ("do" . do) ("instanceof" . instanceof) ("typeof" . typeof) ;; these aren't exactly keywords, but hey ("null" . null) ("true" . true) ("false" . false))) (define *future-reserved-words* '(("abstract" . abstract) ("enum" . enum) ("int" . int) ("short" . short) ("boolean" . boolean) ("export" . export) ("interface" . interface) ("static" . static) ("byte" . byte) ("extends" . extends) ("long" . long) ("super" . super) ("char" . char) ("final" . final) ("native" . native) ("synchronized" . synchronized) ("class" . class) ("float" . float) ("package" . package) ("throws" . throws) ("const" . const) ("goto" . goto) ("private" . private) ("transient" . transient) ("debugger" . debugger) ("implements" . implements) ("protected" . protected) ("volatile" . volatile) ("double" . double) ("import" . import) ("public" . public))) (define (read-identifier port loc) (let lp ((c (peek-char port)) (chars '())) (if (or (eof-object? c) (not (or (char-alphabetic? c) (char-numeric? c) (char=? c #\$) (char=? c #\_)))) (let ((word (list->string (reverse chars)))) (cond ((assoc-ref *keywords* word) => (lambda (x) (make-lexical-token x loc #f))) ((assoc-ref *future-reserved-words* word) (syntax-error "word is reserved for the future, dude." loc word)) (else (make-lexical-token 'Identifier loc (string->symbol word))))) (begin (read-char port) (lp (peek-char port) (cons c chars)))))) (define (read-numeric port loc) (let* ((c0 (if (char=? (peek-char port) #\.) #\0 (read-char port))) (c1 (peek-char port))) (cond ((eof-object? c1) (digit->number c0)) ((and (char=? c0 #\0) (or (char=? c1 #\x) (char=? c1 #\X))) (read-char port) (let ((c (peek-char port))) (if (not (char-hex? c)) (syntax-error "bad digit reading hexadecimal number" loc c)) (let lp ((c c) (acc 0)) (cond ((char-hex? c) (read-char port) (lp (peek-char port) (+ (* 16 acc) (hex->number c)))) (else acc))))) ((and (char=? c0 #\0) (char-numeric? c1)) (let lp ((c c1) (acc 0)) (cond ((eof-object? c) acc) ((char-numeric? c) (if (or (char=? c #\8) (char=? c #\9)) (syntax-error "invalid digit in octal sequence" loc c)) (read-char port) (lp (peek-char port) (+ (* 8 acc) (digit->number c)))) (else acc)))) (else (let lp ((c1 c1) (acc (digit->number c0))) (cond ((eof-object? c1) acc) ((char-numeric? c1) (read-char port) (lp (peek-char port) (+ (* 10 acc) (digit->number c1)))) ((or (char=? c1 #\e) (char=? c1 #\E)) (read-char port) (let ((add (let ((c (peek-char port))) (cond ((eof-object? c) (syntax-error "error reading exponent: EOF" loc #f)) ((char=? c #\+) (read-char port) +) ((char=? c #\-) (read-char port) -) ((char-numeric? c) +) (else (syntax-error "error reading exponent: non-digit" loc c)))))) (let lp ((c (peek-char port)) (e 0)) (cond ((and (not (eof-object? c)) (char-numeric? c)) (read-char port) (lp (peek-char port) (add (* 10 e) (digit->number c)))) (else (* (if (negative? e) (* acc 1.0) acc) (expt 10 e))))))) ((char=? c1 #\.) (read-char port) (let lp2 ((c (peek-char port)) (dec 0.0) (n -1)) (cond ((and (not (eof-object? c)) (char-numeric? c)) (read-char port) (lp2 (peek-char port) (+ dec (* (digit->number c) (expt 10 n))) (1- n))) (else ;; loop back to catch an exponential part (lp c (+ acc dec)))))) (else acc))))))) (define *punctuation* '(("{" . lbrace) ("}" . rbrace) ("(" . lparen) (")" . rparen) ("[" . lbracket) ("]" . rbracket) ("." . dot) (";" . semicolon) ("," . comma) ("<" . <) (">" . >) ("<=" . <=) (">=" . >=) ("==" . ==) ("!=" . !=) ("===" . ===) ("!==" . !==) ("+" . +) ("-" . -) ("*" . *) ("%" . %) ("++" . ++) ("--" . --) ("<<" . <<) (">>" . >>) (">>>" . >>>) ("&" . &) ("|" . bor) ("^" . ^) ("!" . !) ("~" . ~) ("&&" . &&) ("||" . or) ("?" . ?) (":" . colon) ("=" . =) ("+=" . +=) ("-=" . -=) ("*=" . *=) ("%=" . %=) ("<<=" . <<=) (">>=" . >>=) (">>>=" . >>>=) ("&=" . &=) ("|=" . bor=) ("^=" . ^=))) (define *div-punctuation* '(("/" . /) ("/=" . /=))) ;; node ::= (char (symbol | #f) node*) (define read-punctuation (let ((punc-tree (let lp ((nodes '()) (puncs *punctuation*)) (cond ((null? puncs) nodes) ((assv-ref nodes (string-ref (caar puncs) 0)) => (lambda (node-tail) (if (= (string-length (caar puncs)) 1) (set-car! node-tail (cdar puncs)) (set-cdr! node-tail (lp (cdr node-tail) `((,(substring (caar puncs) 1) . ,(cdar puncs)))))) (lp nodes (cdr puncs)))) (else (lp (cons (list (string-ref (caar puncs) 0) #f) nodes) puncs)))))) (lambda (port loc) (let lp ((c (peek-char port)) (tree punc-tree) (candidate #f)) (cond ((assv-ref tree c) => (lambda (node-tail) (read-char port) (lp (peek-char port) (cdr node-tail) (car node-tail)))) (candidate (make-lexical-token candidate loc #f)) (else (syntax-error "bad syntax: character not allowed" loc c))))))) (define (next-token port div?) (let ((c (peek-char port)) (loc (port-source-location port))) (case c ((#\ht #\vt #\np #\space #\x00A0) ; whitespace (read-char port) (next-token port div?)) ((#\newline #\cr) ; line break (read-char port) (next-token port div?)) ((#\/) ;; division, single comment, double comment, or regexp (read-slash port loc div?)) ((#\" #\') ; string literal (read-string port loc)) (else (cond ((eof-object? c) '*eoi*) ((or (char-alphabetic? c) (char=? c #\$) (char=? c #\_)) ;; reserved word or identifier (read-identifier port loc)) ((char-numeric? c) ;; numeric -- also accept . FIXME, requires lookahead (make-lexical-token 'NumericLiteral loc (read-numeric port loc))) (else ;; punctuation (read-punctuation port loc))))))) (define (make-tokenizer port) (let ((div? #f)) (lambda () (let ((tok (next-token port div?))) (set! div? (and (lexical-token? tok) (let ((cat (lexical-token-category tok))) (or (eq? cat 'Identifier) (eq? cat 'NumericLiteral) (eq? cat 'StringLiteral))))) tok)))) (define (make-tokenizer/1 port) (let ((div? #f) (eoi? #f) (stack '())) (lambda () (if eoi? '*eoi* (let ((tok (next-token port div?))) (case (if (lexical-token? tok) (lexical-token-category tok) tok) ((lparen) (set! stack (cons tok stack))) ((rparen) (if (and (pair? stack) (eq? (lexical-token-category (car stack)) 'lparen)) (set! stack (cdr stack)) (syntax-error "unexpected right parenthesis" (lexical-token-source tok) #f))) ((lbracket) (set! stack (cons tok stack))) ((rbracket) (if (and (pair? stack) (eq? (lexical-token-category (car stack)) 'lbracket)) (set! stack (cdr stack)) (syntax-error "unexpected right bracket" (lexical-token-source tok) #f))) ((lbrace) (set! stack (cons tok stack))) ((rbrace) (if (and (pair? stack) (eq? (lexical-token-category (car stack)) 'lbrace)) (set! stack (cdr stack)) (syntax-error "unexpected right brace" (lexical-token-source tok) #f))) ((semicolon) (set! eoi? (null? stack)))) (set! div? (and (lexical-token? tok) (let ((cat (lexical-token-category tok))) (or (eq? cat 'Identifier) (eq? cat 'NumericLiteral) (eq? cat 'StringLiteral))))) tok))))) (define (tokenize port) (let ((next (make-tokenizer port))) (let lp ((out '())) (let ((tok (next))) (if (eq? tok '*eoi*) (reverse! out) (lp (cons tok out))))))) (define (tokenize/1 port) (let ((next (make-tokenizer/1 port))) (let lp ((out '())) (let ((tok (next))) (if (eq? tok '*eoi*) (reverse! out) (lp (cons tok out))))))) PK ! ��VaH aH parse.scmnu �[��� ;;; ECMAScript for Guile ;; Copyright (C) 2009, 2010 Free Software Foundation, Inc. ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either ;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;;; Lesser General Public License for more details. ;;;; ;;;; You should have received a copy of the GNU Lesser General Public ;;;; License along with this library; if not, write to the Free Software ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Code: (define-module (language ecmascript parse) #:use-module (system base lalr) #:use-module (language ecmascript tokenize) #:export (read-ecmascript read-ecmascript/1 make-parser)) (define* (syntax-error message #:optional token) (if (lexical-token? token) (throw 'syntax-error #f message (and=> (lexical-token-source token) source-location->source-properties) (or (lexical-token-value token) (lexical-token-category token)) #f) (throw 'syntax-error #f message #f token #f))) (define (read-ecmascript port) (let ((parse (make-parser))) (parse (make-tokenizer port) syntax-error))) (define (read-ecmascript/1 port) (let ((parse (make-parser))) (parse (make-tokenizer/1 port) syntax-error))) (define *eof-object* (call-with-input-string "" read-char)) (define (make-parser) ;; Return a fresh ECMAScript parser. Parsers produced by `lalr-scm' are now ;; stateful (e.g., they won't invoke the tokenizer any more once it has ;; returned `*eoi*'), hence the need to instantiate new parsers. (lalr-parser ;; terminal (i.e. input) token types (lbrace rbrace lparen rparen lbracket rbracket dot semicolon comma < > <= >= == != === !== + - * % ++ -- << >> >>> & bor ^ ! ~ && or ? colon = += -= *= %= <<= >>= >>>= &= bor= ^= / /= break else new var case finally return void catch for switch while continue function this with default if throw delete in try do instanceof typeof null true false Identifier StringLiteral NumericLiteral RegexpLiteral) (Program (SourceElements) : $1 (*eoi*) : *eof-object*) ;; ;; Verily, here we define statements. Expressions are defined ;; afterwards. ;; (SourceElement (Statement) : $1 (FunctionDeclaration) : $1) (FunctionDeclaration (function Identifier lparen rparen lbrace FunctionBody rbrace) : `(var (,$2 (lambda () ,$6))) (function Identifier lparen FormalParameterList rparen lbrace FunctionBody rbrace) : `(var (,$2 (lambda ,$4 ,$7)))) (FunctionExpression (function lparen rparen lbrace FunctionBody rbrace) : `(lambda () ,$5) (function Identifier lparen rparen lbrace FunctionBody rbrace) : `(lambda () ,$6) (function lparen FormalParameterList rparen lbrace FunctionBody rbrace) : `(lambda ,$3 ,$6) (function Identifier lparen FormalParameterList rparen lbrace FunctionBody rbrace) : `(lambda ,$4 ,$7)) (FormalParameterList (Identifier) : `(,$1) (FormalParameterList comma Identifier) : `(,@$1 ,$3)) (SourceElements (SourceElement) : $1 (SourceElements SourceElement) : (if (and (pair? $1) (eq? (car $1) 'begin)) `(begin ,@(cdr $1) ,$2) `(begin ,$1 ,$2))) (FunctionBody (SourceElements) : $1 () : '(begin)) (Statement (Block) : $1 (VariableStatement) : $1 (EmptyStatement) : $1 (ExpressionStatement) : $1 (IfStatement) : $1 (IterationStatement) : $1 (ContinueStatement) : $1 (BreakStatement) : $1 (ReturnStatement) : $1 (WithStatement) : $1 (LabelledStatement) : $1 (SwitchStatement) : $1 (ThrowStatement) : $1 (TryStatement) : $1) (Block (lbrace StatementList rbrace) : `(block ,$2)) (StatementList (Statement) : $1 (StatementList Statement) : (if (and (pair? $1) (eq? (car $1) 'begin)) `(begin ,@(cdr $1) ,$2) `(begin ,$1 ,$2))) (VariableStatement (var VariableDeclarationList) : `(var ,@$2)) (VariableDeclarationList (VariableDeclaration) : `(,$1) (VariableDeclarationList comma VariableDeclaration) : `(,@$1 ,$2)) (VariableDeclarationListNoIn (VariableDeclarationNoIn) : `(,$1) (VariableDeclarationListNoIn comma VariableDeclarationNoIn) : `(,@$1 ,$2)) (VariableDeclaration (Identifier) : `(,$1) (Identifier Initialiser) : `(,$1 ,$2)) (VariableDeclarationNoIn (Identifier) : `(,$1) (Identifier Initialiser) : `(,$1 ,$2)) (Initialiser (= AssignmentExpression) : $2) (InitialiserNoIn (= AssignmentExpressionNoIn) : $2) (EmptyStatement (semicolon) : '(begin)) (ExpressionStatement (Expression semicolon) : $1) (IfStatement (if lparen Expression rparen Statement else Statement) : `(if ,$3 ,$5 ,$7) (if lparen Expression rparen Statement) : `(if ,$3 ,$5)) (IterationStatement (do Statement while lparen Expression rparen semicolon) : `(do ,$2 ,$5) (while lparen Expression rparen Statement) : `(while ,$3 ,$5) (for lparen semicolon semicolon rparen Statement) : `(for #f #f #f ,$6) (for lparen semicolon semicolon Expression rparen Statement) : `(for #f #f ,$5 ,$7) (for lparen semicolon Expression semicolon rparen Statement) : `(for #f ,$4 #f ,$7) (for lparen semicolon Expression semicolon Expression rparen Statement) : `(for #f ,$4 ,$6 ,$8) (for lparen ExpressionNoIn semicolon semicolon rparen Statement) : `(for ,$3 #f #f ,$7) (for lparen ExpressionNoIn semicolon semicolon Expression rparen Statement) : `(for ,$3 #f ,$6 ,$8) (for lparen ExpressionNoIn semicolon Expression semicolon rparen Statement) : `(for ,$3 ,$5 #f ,$8) (for lparen ExpressionNoIn semicolon Expression semicolon Expression rparen Statement) : `(for ,$3 ,$5 ,$7 ,$9) (for lparen var VariableDeclarationListNoIn semicolon semicolon rparen Statement) : `(for (var ,@$4) #f #f ,$8) (for lparen var VariableDeclarationListNoIn semicolon semicolon Expression rparen Statement) : `(for (var ,@$4) #f ,$7 ,$9) (for lparen var VariableDeclarationListNoIn semicolon Expression semicolon rparen Statement) : `(for (var ,@$4) ,$6 #f ,$9) (for lparen var VariableDeclarationListNoIn semicolon Expression semicolon Expression rparen Statement) : `(for (var ,@$4) ,$6 ,$8 ,$10) (for lparen LeftHandSideExpression in Expression rparen Statement) : `(for-in ,$3 ,$5 ,$7) (for lparen var VariableDeclarationNoIn in Expression rparen Statement) : `(begin (var ,$4) (for-in (ref ,@$4) ,$6 ,$8))) (ContinueStatement (continue Identifier semicolon) : `(continue ,$2) (continue semicolon) : `(continue)) (BreakStatement (break Identifier semicolon) : `(break ,$2) (break semicolon) : `(break)) (ReturnStatement (return Expression semicolon) : `(return ,$2) (return semicolon) : `(return)) (WithStatement (with lparen Expression rparen Statement) : `(with ,$3 ,$5)) (SwitchStatement (switch lparen Expression rparen CaseBlock) : `(switch ,$3 ,@$5)) (CaseBlock (lbrace rbrace) : '() (lbrace CaseClauses rbrace) : $2 (lbrace CaseClauses DefaultClause rbrace) : `(,@$2 ,@$3) (lbrace DefaultClause rbrace) : `(,$2) (lbrace DefaultClause CaseClauses rbrace) : `(,@$2 ,@$3)) (CaseClauses (CaseClause) : `(,$1) (CaseClauses CaseClause) : `(,@$1 ,$2)) (CaseClause (case Expression colon) : `(case ,$2) (case Expression colon StatementList) : `(case ,$2 ,$4)) (DefaultClause (default colon) : `(default) (default colon StatementList) : `(default ,$3)) (LabelledStatement (Identifier colon Statement) : `(label ,$1 ,$3)) (ThrowStatement (throw Expression semicolon) : `(throw ,$2)) (TryStatement (try Block Catch) : `(try ,$2 ,$3 #f) (try Block Finally) : `(try ,$2 #f ,$3) (try Block Catch Finally) : `(try ,$2 ,$3 ,$4)) (Catch (catch lparen Identifier rparen Block) : `(catch ,$3 ,$5)) (Finally (finally Block) : `(finally ,$2)) ;; ;; As promised, expressions. We build up to Expression bottom-up, so ;; as to get operator precedence right. ;; (PrimaryExpression (this) : 'this (null) : 'null (true) : 'true (false) : 'false (Identifier) : `(ref ,$1) (StringLiteral) : `(string ,$1) (RegexpLiteral) : `(regexp ,$1) (NumericLiteral) : `(number ,$1) (dot NumericLiteral) : `(number ,(string->number (string-append "." (number->string $2)))) (ArrayLiteral) : $1 (ObjectLiteral) : $1 (lparen Expression rparen) : $2) (ArrayLiteral (lbracket rbracket) : '(array) (lbracket Elision rbracket) : '(array ,@$2) (lbracket ElementList rbracket) : `(array ,@$2) (lbracket ElementList comma rbracket) : `(array ,@$2) (lbracket ElementList comma Elision rbracket) : `(array ,@$2)) (ElementList (AssignmentExpression) : `(,$1) (Elision AssignmentExpression) : `(,@$1 ,$2) (ElementList comma AssignmentExpression) : `(,@$1 ,$3) (ElementList comma Elision AssignmentExpression) : `(,@$1 ,@$3 ,$4)) (Elision (comma) : '((number 0)) (Elision comma) : `(,@$1 (number 0))) (ObjectLiteral (lbrace rbrace) : `(object) (lbrace PropertyNameAndValueList rbrace) : `(object ,@$2)) (PropertyNameAndValueList (PropertyName colon AssignmentExpression) : `((,$1 ,$3)) (PropertyNameAndValueList comma PropertyName colon AssignmentExpression) : `(,@$1 (,$3 ,$5))) (PropertyName (Identifier) : $1 (StringLiteral) : (string->symbol $1) (NumericLiteral) : $1) (MemberExpression (PrimaryExpression) : $1 (FunctionExpression) : $1 (MemberExpression lbracket Expression rbracket) : `(aref ,$1 ,$3) (MemberExpression dot Identifier) : `(pref ,$1 ,$3) (new MemberExpression Arguments) : `(new ,$2 ,$3)) (NewExpression (MemberExpression) : $1 (new NewExpression) : `(new ,$2 ())) (CallExpression (MemberExpression Arguments) : `(call ,$1 ,$2) (CallExpression Arguments) : `(call ,$1 ,$2) (CallExpression lbracket Expression rbracket) : `(aref ,$1 ,$3) (CallExpression dot Identifier) : `(pref ,$1 ,$3)) (Arguments (lparen rparen) : '() (lparen ArgumentList rparen) : $2) (ArgumentList (AssignmentExpression) : `(,$1) (ArgumentList comma AssignmentExpression) : `(,@$1 ,$3)) (LeftHandSideExpression (NewExpression) : $1 (CallExpression) : $1) (PostfixExpression (LeftHandSideExpression) : $1 (LeftHandSideExpression ++) : `(postinc ,$1) (LeftHandSideExpression --) : `(postdec ,$1)) (UnaryExpression (PostfixExpression) : $1 (delete UnaryExpression) : `(delete ,$2) (void UnaryExpression) : `(void ,$2) (typeof UnaryExpression) : `(typeof ,$2) (++ UnaryExpression) : `(preinc ,$2) (-- UnaryExpression) : `(predec ,$2) (+ UnaryExpression) : `(+ ,$2) (- UnaryExpression) : `(- ,$2) (~ UnaryExpression) : `(~ ,$2) (! UnaryExpression) : `(! ,$2)) (MultiplicativeExpression (UnaryExpression) : $1 (MultiplicativeExpression * UnaryExpression) : `(* ,$1 ,$3) (MultiplicativeExpression / UnaryExpression) : `(/ ,$1 ,$3) (MultiplicativeExpression % UnaryExpression) : `(% ,$1 ,$3)) (AdditiveExpression (MultiplicativeExpression) : $1 (AdditiveExpression + MultiplicativeExpression) : `(+ ,$1 ,$3) (AdditiveExpression - MultiplicativeExpression) : `(- ,$1 ,$3)) (ShiftExpression (AdditiveExpression) : $1 (ShiftExpression << MultiplicativeExpression) : `(<< ,$1 ,$3) (ShiftExpression >> MultiplicativeExpression) : `(>> ,$1 ,$3) (ShiftExpression >>> MultiplicativeExpression) : `(>>> ,$1 ,$3)) (RelationalExpression (ShiftExpression) : $1 (RelationalExpression < ShiftExpression) : `(< ,$1 ,$3) (RelationalExpression > ShiftExpression) : `(> ,$1 ,$3) (RelationalExpression <= ShiftExpression) : `(<= ,$1 ,$3) (RelationalExpression >= ShiftExpression) : `(>= ,$1 ,$3) (RelationalExpression instanceof ShiftExpression) : `(instanceof ,$1 ,$3) (RelationalExpression in ShiftExpression) : `(in ,$1 ,$3)) (RelationalExpressionNoIn (ShiftExpression) : $1 (RelationalExpressionNoIn < ShiftExpression) : `(< ,$1 ,$3) (RelationalExpressionNoIn > ShiftExpression) : `(> ,$1 ,$3) (RelationalExpressionNoIn <= ShiftExpression) : `(<= ,$1 ,$3) (RelationalExpressionNoIn >= ShiftExpression) : `(>= ,$1 ,$3) (RelationalExpressionNoIn instanceof ShiftExpression) : `(instanceof ,$1 ,$3)) (EqualityExpression (RelationalExpression) : $1 (EqualityExpression == RelationalExpression) : `(== ,$1 ,$3) (EqualityExpression != RelationalExpression) : `(!= ,$1 ,$3) (EqualityExpression === RelationalExpression) : `(=== ,$1 ,$3) (EqualityExpression !== RelationalExpression) : `(!== ,$1 ,$3)) (EqualityExpressionNoIn (RelationalExpressionNoIn) : $1 (EqualityExpressionNoIn == RelationalExpressionNoIn) : `(== ,$1 ,$3) (EqualityExpressionNoIn != RelationalExpressionNoIn) : `(!= ,$1 ,$3) (EqualityExpressionNoIn === RelationalExpressionNoIn) : `(=== ,$1 ,$3) (EqualityExpressionNoIn !== RelationalExpressionNoIn) : `(!== ,$1 ,$3)) (BitwiseANDExpression (EqualityExpression) : $1 (BitwiseANDExpression & EqualityExpression) : `(& ,$1 ,$3)) (BitwiseANDExpressionNoIn (EqualityExpressionNoIn) : $1 (BitwiseANDExpressionNoIn & EqualityExpressionNoIn) : `(& ,$1 ,$3)) (BitwiseXORExpression (BitwiseANDExpression) : $1 (BitwiseXORExpression ^ BitwiseANDExpression) : `(^ ,$1 ,$3)) (BitwiseXORExpressionNoIn (BitwiseANDExpressionNoIn) : $1 (BitwiseXORExpressionNoIn ^ BitwiseANDExpressionNoIn) : `(^ ,$1 ,$3)) (BitwiseORExpression (BitwiseXORExpression) : $1 (BitwiseORExpression bor BitwiseXORExpression) : `(bor ,$1 ,$3)) (BitwiseORExpressionNoIn (BitwiseXORExpressionNoIn) : $1 (BitwiseORExpressionNoIn bor BitwiseXORExpressionNoIn) : `(bor ,$1 ,$3)) (LogicalANDExpression (BitwiseORExpression) : $1 (LogicalANDExpression && BitwiseORExpression) : `(and ,$1 ,$3)) (LogicalANDExpressionNoIn (BitwiseORExpressionNoIn) : $1 (LogicalANDExpressionNoIn && BitwiseORExpressionNoIn) : `(and ,$1 ,$3)) (LogicalORExpression (LogicalANDExpression) : $1 (LogicalORExpression or LogicalANDExpression) : `(or ,$1 ,$3)) (LogicalORExpressionNoIn (LogicalANDExpressionNoIn) : $1 (LogicalORExpressionNoIn or LogicalANDExpressionNoIn) : `(or ,$1 ,$3)) (ConditionalExpression (LogicalORExpression) : $1 (LogicalORExpression ? AssignmentExpression colon AssignmentExpression) : `(if ,$1 ,$3 ,$5)) (ConditionalExpressionNoIn (LogicalORExpressionNoIn) : $1 (LogicalORExpressionNoIn ? AssignmentExpressionNoIn colon AssignmentExpressionNoIn) : `(if ,$1 ,$3 ,$5)) (AssignmentExpression (ConditionalExpression) : $1 (LeftHandSideExpression AssignmentOperator AssignmentExpression) : `(,$2 ,$1 ,$3)) (AssignmentExpressionNoIn (ConditionalExpressionNoIn) : $1 (LeftHandSideExpression AssignmentOperator AssignmentExpressionNoIn) : `(,$2 ,$1 ,$3)) (AssignmentOperator (=) : '= (*=) : '*= (/=) : '/= (%=) : '%= (+=) : '+= (-=) : '-= (<<=) : '<<= (>>=) : '>>= (>>>=) : '>>>= (&=) : '&= (^=) : '^= (bor=) : 'bor=) (Expression (AssignmentExpression) : $1 (Expression comma AssignmentExpression) : `(begin ,$1 ,$3)) (ExpressionNoIn (AssignmentExpressionNoIn) : $1 (ExpressionNoIn comma AssignmentExpressionNoIn) : `(begin ,$1 ,$3)))) PK ! 1� �� � array.scmnu �[��� ;;; ECMAScript for Guile ;; Copyright (C) 2009, 2010 Free Software Foundation, Inc. ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either ;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;;; Lesser General Public License for more details. ;;;; ;;;; You should have received a copy of the GNU Lesser General Public ;;;; License along with this library; if not, write to the Free Software ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Code: (define-module (language ecmascript array) #:use-module (oop goops) #:use-module (language ecmascript base) #:use-module (language ecmascript function) #:export (*array-prototype* new-array)) (define-class <js-array-object> (<js-object>) (vector #:init-value #() #:accessor js-array-vector #:init-keyword #:vector)) (define (new-array . vals) (let ((o (make <js-array-object> #:class "Array" #:prototype *array-prototype*))) (pput o 'length (length vals)) (let ((vect (js-array-vector o))) (let lp ((i 0) (vals vals)) (cond ((not (null? vals)) (vector-set! vect i (car vals)) (lp (1+ i) (cdr vals))) (else o)))))) (define *array-prototype* (make <js-object> #:class "Array" #:value new-array #:constructor new-array)) (hashq-set! *program-wrappers* new-array *array-prototype*) (pput *array-prototype* 'prototype *array-prototype*) (pput *array-prototype* 'constructor new-array) (define-method (pget (o <js-array-object>) p) (cond ((and (integer? p) (exact? p) (>= p 0)) (let ((v (js-array-vector o))) (if (< p (vector-length v)) (vector-ref v p) (next-method)))) ((or (and (symbol? p) (eq? p 'length)) (and (string? p) (string=? p "length"))) (vector-length (js-array-vector o))) (else (next-method)))) (define-method (pput (o <js-array-object>) p v) (cond ((and (integer? p) (exact? p) (>= 0 p)) (let ((vect (js-array-vector o))) (if (< p (vector-length vect)) (vector-set! vect p v) ;; Fixme: round up to powers of 2? (let ((new (make-vector (1+ p) 0))) (vector-move-left! vect 0 (vector-length vect) new 0) (set! (js-array-vector o) new) (vector-set! new p v))))) ((or (and (symbol? p) (eq? p 'length)) (and (string? p) (string=? p "length"))) (let ((vect (js-array-vector o))) (let ((new (make-vector (->uint32 v) 0))) (vector-move-left! vect 0 (min (vector-length vect) (->uint32 v)) new 0) (set! (js-array-vector o) new)))) (else (next-method)))) (define-js-method *array-prototype* (toString) (format #f "~A" (js-array-vector this))) (define-js-method *array-prototype* (concat . rest) (let* ((len (apply + (->uint32 (pget this 'length)) (map (lambda (x) (->uint32 (pget x 'length))) rest))) (rv (make-vector len 0))) (let lp ((objs (cons this rest)) (i 0)) (cond ((null? objs) (make <js-array-object> #:class "Array" #:prototype *array-prototype* #:vector rv)) ((is-a? (car objs) <js-array-object>) (let ((v (js-array-vector (car objs)))) (vector-move-left! v 0 (vector-length v) rv i) (lp (cdr objs) (+ i (vector-length v))))) (else (error "generic array concats not yet implemented")))))) (define-js-method *array-prototype* (join . separator) (let lp ((i (1- (->uint32 (pget this 'length)))) (l '())) (if (< i 0) (string-join l (if separator (->string (car separator)) ",")) (lp (1+ i) (cons (->string (pget this i)) l))))) (define-js-method *array-prototype* (pop) (let ((len (->uint32 (pget this 'length)))) (if (zero? len) *undefined* (let ((ret (pget this (1- len)))) (pput this 'length (1- len)) ret)))) (define-js-method *array-prototype* (push . args) (let lp ((args args)) (if (null? args) (->uint32 (pget this 'length)) (begin (pput this (->uint32 (pget this 'length)) (car args)) (lp (cdr args)))))) PK ! �� function.scmnu �[��� ;;; ECMAScript for Guile ;; Copyright (C) 2009 Free Software Foundation, Inc. ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either ;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;;; Lesser General Public License for more details. ;;;; ;;;; You should have received a copy of the GNU Lesser General Public ;;;; License along with this library; if not, write to the Free Software ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Code: (define-module (language ecmascript function) #:use-module (oop goops) #:use-module (language ecmascript base) #:export (*function-prototype* *program-wrappers*)) (define-class <js-program-wrapper> (<js-object>)) (define *program-wrappers* (make-doubly-weak-hash-table)) (define *function-prototype* (make <js-object> #:class "Function" #:value (lambda args *undefined*))) (define-js-method *function-prototype* (toString) (format #f "~A" (js-value this))) (define-js-method *function-prototype* (apply this-arg array) (cond ((or (null? array) (eq? array *undefined*)) (call/this this-arg (js-value this))) ((is-a? array <js-array-object>) (call/this this-arg (lambda () (apply (js-value this) (vector->list (js-array-vector array)))))) (else (throw 'TypeError 'apply array)))) (define-js-method *function-prototype* (call this-arg . args) (call/this this-arg (lambda () (apply (js-value this) args)))) (define-method (pget (o <applicable>) p) (let ((wrapper (hashq-ref *program-wrappers* o))) (if wrapper (pget wrapper p) (pget *function-prototype* p)))) (define-method (pput (o <applicable>) p v) (let ((wrapper (hashq-ref *program-wrappers* o))) (if wrapper (pput wrapper p v) (let ((wrapper (make <js-program-wrapper> #:value o #:class "Function" #:prototype *function-prototype*))) (hashq-set! *program-wrappers* o wrapper) (pput wrapper p v))))) (define-method (js-prototype (o <applicable>)) (let ((wrapper (hashq-ref *program-wrappers* o))) (if wrapper (js-prototype wrapper) #f))) (define-method (js-constructor (o <applicable>)) (let ((wrapper (hashq-ref *program-wrappers* o))) (if wrapper (js-constructor wrapper) #f))) PK ! �iɉ: : base.scmnu �[��� ;;; ECMAScript for Guile ;; Copyright (C) 2009, 2013, 2015 Free Software Foundation, Inc. ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either ;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;;; Lesser General Public License for more details. ;;;; ;;;; You should have received a copy of the GNU Lesser General Public ;;;; License along with this library; if not, write to the Free Software ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Code: (define-module (language ecmascript base) #:use-module (oop goops) #:export (*undefined* *this* <js-object> *object-prototype* js-prototype js-props js-prop-attrs js-value js-constructor js-class pget prop-keys prop-attrs prop-has-attr? pput has-property? pdel object->string object->number object->value/string object->value/number object->value ->primitive ->boolean ->number ->integer ->int32 ->uint32 ->uint16 ->string ->object call/this* call/this lambda/this define-js-method new-object new)) (define-class <undefined> ()) (define *undefined* (make <undefined>)) (define *this* (make-fluid)) (define-class <js-object> () (prototype #:getter js-prototype #:init-keyword #:prototype #:init-thunk (lambda () *object-prototype*)) (props #:getter js-props #:init-form (make-hash-table 7)) (prop-attrs #:getter js-prop-attrs #:init-value #f) (value #:getter js-value #:init-value #f #:init-keyword #:value) (constructor #:getter js-constructor #:init-value #f #:init-keyword #:constructor) (class #:getter js-class #:init-value "Object" #:init-keyword #:class)) (define-method (prop-keys (o <js-object>)) (hash-map->list (lambda (k v) k) (js-props o))) (define-method (pget (o <js-object>) (p <string>)) (pget o (string->symbol p))) (define-method (pget (o <js-object>) p) (let ((h (hashq-get-handle (js-props o) p))) (if h (cdr h) (let ((proto (js-prototype o))) (if proto (pget proto p) *undefined*))))) (define-method (prop-attrs (o <js-object>) p) (or (let ((attrs (js-prop-attrs o))) (and attrs (hashq-ref (js-prop-attrs o) p))) (let ((proto (js-prototype o))) (if proto (prop-attrs proto p) '())))) (define-method (prop-has-attr? (o <js-object>) p attr) (memq attr (prop-attrs o p))) (define-method (pput (o <js-object>) p v) (if (prop-has-attr? o p 'ReadOnly) (throw 'ReferenceError o p) (hashq-set! (js-props o) p v))) (define-method (pput (o <js-object>) (p <string>) v) (pput o (string->symbol p) v)) (define-method (pdel (o <js-object>) p) (if (prop-has-attr? o p 'DontDelete) #f (begin (pput o p *undefined*) #t))) (define-method (pdel (o <js-object>) (p <string>) v) (pdel o (string->symbol p))) (define-method (has-property? (o <js-object>) p) (if (hashq-get-handle (js-props o) p) #t (let ((proto (js-prototype o))) (if proto (has-property? proto p) #f)))) (define (call/this* this f) (with-fluid* *this* this f)) (define-macro (call/this this f . args) `(with-fluid* *this* ,this (lambda () (,f . ,args)))) (define-macro (lambda/this formals . body) `(lambda ,formals (let ((this (fluid-ref *this*))) . ,body))) (define-macro (define-js-method object name-and-args . body) `(pput ,object ',(car name-and-args) (lambda/this ,(cdr name-and-args) . ,body))) (define *object-prototype* #f) (set! *object-prototype* (make <js-object>)) (define-js-method *object-prototype* (toString) (format #f "[object ~A]" (js-class this))) (define-js-method *object-prototype* (toLocaleString . args) ((pget *object-prototype* 'toString))) (define-js-method *object-prototype* (valueOf) this) (define-js-method *object-prototype* (hasOwnProperty p) (and (hashq-get-handle (js-props this) p) #t)) (define-js-method *object-prototype* (isPrototypeOf v) (eq? this (js-prototype v))) (define-js-method *object-prototype* (propertyIsEnumerable p) (and (hashq-get-handle (js-props this) p) (not (prop-has-attr? this p 'DontEnum)))) (define (object->string o error?) (let ((toString (pget o 'toString))) (if (procedure? toString) (let ((x (call/this o toString))) (if (and error? (is-a? x <js-object>)) (throw 'TypeError o 'default-value) x)) (if error? (throw 'TypeError o 'default-value) o)))) (define (object->number o error?) (let ((valueOf (pget o 'valueOf))) (if (procedure? valueOf) (let ((x (call/this o valueOf))) (if (and error? (is-a? x <js-object>)) (throw 'TypeError o 'default-value) x)) (if error? (throw 'TypeError o 'default-value) o)))) (define (object->value/string o) (if (is-a? o <js-object>) (object->number o #t) o)) (define (object->value/number o) (if (is-a? o <js-object>) (object->string o #t) o)) (define (object->value o) ;; FIXME: if it's a date, we should try numbers first (object->value/string o)) (define (->primitive x) (if (is-a? x <js-object>) (object->value x) x)) (define (->boolean x) (not (or (not x) (null? x) (eq? x *undefined*) (and (number? x) (or (zero? x) (nan? x))) (and (string? x) (= (string-length x) 0))))) (define (->number x) (cond ((number? x) x) ((boolean? x) (if x 1 0)) ((null? x) 0) ((eq? x *undefined*) +nan.0) ((is-a? x <js-object>) (object->number x #t)) ((string? x) (string->number x)) (else (throw 'TypeError x '->number)))) (define (->integer x) (let ((n (->number x))) (cond ((nan? n) 0) ((zero? n) n) ((inf? n) n) (else (inexact->exact (round n)))))) (define (->int32 x) (let ((n (->number x))) (if (or (nan? n) (zero? n) (inf? n)) 0 (let ((m (logand (1- (ash 1 32)) (inexact->exact (round n))))) (if (negative? n) (- m (ash 1 32)) m))))) (define (->uint32 x) (let ((n (->number x))) (if (or (nan? n) (zero? n) (inf? n)) 0 (logand (1- (ash 1 32)) (inexact->exact (round n)))))) (define (->uint16 x) (let ((n (->number x))) (if (or (nan? n) (zero? n) (inf? n)) 0 (logand (1- (ash 1 16)) (inexact->exact (round n)))))) (define (->string x) (cond ((eq? x *undefined*) "undefined") ((null? x) "null") ((boolean? x) (if x "true" "false")) ((string? x) x) ((number? x) (cond ((nan? x) "NaN") ((zero? x) "0") ((inf? x) "Infinity") (else (number->string x)))) (else (->string (object->value/string x))))) (define (->object x) (cond ((eq? x *undefined*) (throw 'TypeError x '->object)) ((null? x) (throw 'TypeError x '->object)) ((boolean? x) (make <js-object> #:prototype Boolean #:value x)) ((number? x) (make <js-object> #:prototype String #:value x)) ((string? x) (make <js-object> #:prototype Number #:value x)) (else x))) (define (new-object . pairs) (let ((o (make <js-object>))) (map (lambda (pair) (pput o (car pair) (cdr pair))) pairs) o)) (slot-set! *object-prototype* 'constructor new-object) (define-method (new o . initargs) (let ((ctor (js-constructor o))) (if (not ctor) (throw 'TypeError 'new o) (let ((o (make <js-object> #:prototype (or (js-prototype o) *object-prototype*)))) (let ((new-o (call/this o apply ctor initargs))) (if (is-a? new-o <js-object>) new-o o)))))) PK ! ��_k[ [ compile-tree-il.scmnu �[��� ;;; ECMAScript for Guile ;; Copyright (C) 2009, 2011, 2016 Free Software Foundation, Inc. ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either ;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;;; Lesser General Public License for more details. ;;;; ;;;; You should have received a copy of the GNU Lesser General Public ;;;; License along with this library; if not, write to the Free Software ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Code: (define-module (language ecmascript compile-tree-il) #:use-module (language tree-il) #:use-module (ice-9 receive) #:use-module (system base pmatch) #:use-module (srfi srfi-1) #:export (compile-tree-il)) (define-syntax-rule (-> (type arg ...)) `(type ,arg ...)) (define-syntax-rule (@implv sym) (-> (@ '(language ecmascript impl) 'sym))) (define-syntax-rule (@impl sym arg ...) (-> (call (@implv sym) arg ...))) (define (empty-lexical-environment) '()) (define (econs name gensym env) (acons name (-> (lexical name gensym)) env)) (define (lookup name env) (or (assq-ref env name) (-> (toplevel name)))) (define (compile-tree-il exp env opts) (values (parse-tree-il (-> (begin (@impl js-init) (comp exp (empty-lexical-environment))))) env env)) (define (location x) (and (pair? x) (let ((props (source-properties x))) (and (not (null? props)) props)))) ;; for emacs: ;; (put 'pmatch/source 'scheme-indent-function 1) (define-syntax-rule (pmatch/source x clause ...) (let ((x x)) (let ((res (pmatch x clause ...))) (let ((loc (location x))) (if loc (set-source-properties! res (location x)))) res))) (define current-return-tag (make-parameter #f)) (define (return expr) (-> (abort (or (current-return-tag) (error "return outside function")) (list expr) (-> (const '()))))) (define (with-return-prompt body-thunk) (let ((tag (gensym "return"))) (parameterize ((current-return-tag (-> (lexical 'return tag)))) (-> (let '(return) (list tag) (list (-> (primcall 'make-prompt-tag))) (-> (prompt #t (current-return-tag) (body-thunk) (let ((val (gensym "val"))) (-> (lambda '() (-> (lambda-case `(((k val) #f #f #f () (,(gensym) ,val)) ,(-> (lexical 'val val))))))))))))))) (define (comp x e) (let ((l (location x))) (define (let1 what proc) (let ((sym (gensym))) (-> (let (list sym) (list sym) (list what) (proc sym))))) (define (begin1 what proc) (let1 what (lambda (v) (-> (begin (proc v) (-> (lexical v v))))))) (pmatch/source x (null ;; FIXME, null doesn't have much relation to EOL... (-> (const '()))) (true (-> (const #t))) (false (-> (const #f))) ((number ,num) (-> (const num))) ((string ,str) (-> (const str))) (this (@impl get-this)) ((+ ,a) (-> (call (-> (primitive '+)) (@impl ->number (comp a e)) (-> (const 0))))) ((- ,a) (-> (call (-> (primitive '-)) (-> (const 0)) (comp a e)))) ((~ ,a) (@impl bitwise-not (comp a e))) ((! ,a) (@impl logical-not (comp a e))) ((+ ,a ,b) (-> (call (-> (primitive '+)) (comp a e) (comp b e)))) ((- ,a ,b) (-> (call (-> (primitive '-)) (comp a e) (comp b e)))) ((/ ,a ,b) (-> (call (-> (primitive '/)) (comp a e) (comp b e)))) ((* ,a ,b) (-> (call (-> (primitive '*)) (comp a e) (comp b e)))) ((% ,a ,b) (@impl mod (comp a e) (comp b e))) ((<< ,a ,b) (@impl shift (comp a e) (comp b e))) ((>> ,a ,b) (@impl shift (comp a e) (comp `(- ,b) e))) ((< ,a ,b) (-> (call (-> (primitive '<)) (comp a e) (comp b e)))) ((<= ,a ,b) (-> (call (-> (primitive '<=)) (comp a e) (comp b e)))) ((> ,a ,b) (-> (call (-> (primitive '>)) (comp a e) (comp b e)))) ((>= ,a ,b) (-> (call (-> (primitive '>=)) (comp a e) (comp b e)))) ((in ,a ,b) (@impl has-property? (comp a e) (comp b e))) ((== ,a ,b) (-> (call (-> (primitive 'equal?)) (comp a e) (comp b e)))) ((!= ,a ,b) (-> (call (-> (primitive 'not)) (-> (call (-> (primitive 'equal?)) (comp a e) (comp b e)))))) ((=== ,a ,b) (-> (call (-> (primitive 'eqv?)) (comp a e) (comp b e)))) ((!== ,a ,b) (-> (call (-> (primitive 'not)) (-> (call (-> (primitive 'eqv?)) (comp a e) (comp b e)))))) ((& ,a ,b) (@impl band (comp a e) (comp b e))) ((^ ,a ,b) (@impl bxor (comp a e) (comp b e))) ((bor ,a ,b) (@impl bior (comp a e) (comp b e))) ((and ,a ,b) (-> (if (@impl ->boolean (comp a e)) (comp b e) (-> (const #f))))) ((or ,a ,b) (let1 (comp a e) (lambda (v) (-> (if (@impl ->boolean (-> (lexical v v))) (-> (lexical v v)) (comp b e)))))) ((if ,test ,then ,else) (-> (if (@impl ->boolean (comp test e)) (comp then e) (comp else e)))) ((if ,test ,then) (-> (if (@impl ->boolean (comp test e)) (comp then e) (@implv *undefined*)))) ((postinc (ref ,foo)) (begin1 (comp `(ref ,foo) e) (lambda (var) (-> (set! (lookup foo e) (-> (call (-> (primitive '+)) (-> (lexical var var)) (-> (const 1))))))))) ((postinc (pref ,obj ,prop)) (let1 (comp obj e) (lambda (objvar) (begin1 (@impl pget (-> (lexical objvar objvar)) (-> (const prop))) (lambda (tmpvar) (@impl pput (-> (lexical objvar objvar)) (-> (const prop)) (-> (call (-> (primitive '+)) (-> (lexical tmpvar tmpvar)) (-> (const 1)))))))))) ((postinc (aref ,obj ,prop)) (let1 (comp obj e) (lambda (objvar) (let1 (comp prop e) (lambda (propvar) (begin1 (@impl pget (-> (lexical objvar objvar)) (-> (lexical propvar propvar))) (lambda (tmpvar) (@impl pput (-> (lexical objvar objvar)) (-> (lexical propvar propvar)) (-> (call (-> (primitive '+)) (-> (lexical tmpvar tmpvar)) (-> (const 1)))))))))))) ((postdec (ref ,foo)) (begin1 (comp `(ref ,foo) e) (lambda (var) (-> (set (lookup foo e) (-> (call (-> (primitive '-)) (-> (lexical var var)) (-> (const 1))))))))) ((postdec (pref ,obj ,prop)) (let1 (comp obj e) (lambda (objvar) (begin1 (@impl pget (-> (lexical objvar objvar)) (-> (const prop))) (lambda (tmpvar) (@impl pput (-> (lexical objvar objvar)) (-> (const prop)) (-> (call (-> (primitive '-)) (-> (lexical tmpvar tmpvar)) (-> (const 1)))))))))) ((postdec (aref ,obj ,prop)) (let1 (comp obj e) (lambda (objvar) (let1 (comp prop e) (lambda (propvar) (begin1 (@impl pget (-> (lexical objvar objvar)) (-> (lexical propvar propvar))) (lambda (tmpvar) (@impl pput (-> (lexical objvar objvar)) (-> (lexical propvar propvar)) (-> (inline '- (-> (lexical tmpvar tmpvar)) (-> (const 1)))))))))))) ((preinc (ref ,foo)) (let ((v (lookup foo e))) (-> (begin (-> (set! v (-> (call (-> (primitive '+)) v (-> (const 1)))))) v)))) ((preinc (pref ,obj ,prop)) (let1 (comp obj e) (lambda (objvar) (begin1 (-> (call (-> (primitive '+)) (@impl pget (-> (lexical objvar objvar)) (-> (const prop))) (-> (const 1)))) (lambda (tmpvar) (@impl pput (-> (lexical objvar objvar)) (-> (const prop)) (-> (lexical tmpvar tmpvar)))))))) ((preinc (aref ,obj ,prop)) (let1 (comp obj e) (lambda (objvar) (let1 (comp prop e) (lambda (propvar) (begin1 (-> (call (-> (primitive '+)) (@impl pget (-> (lexical objvar objvar)) (-> (lexical propvar propvar))) (-> (const 1)))) (lambda (tmpvar) (@impl pput (-> (lexical objvar objvar)) (-> (lexical propvar propvar)) (-> (lexical tmpvar tmpvar)))))))))) ((predec (ref ,foo)) (let ((v (lookup foo e))) (-> (begin (-> (set! v (-> (call (-> (primitive '-)) v (-> (const 1)))))) v)))) ((predec (pref ,obj ,prop)) (let1 (comp obj e) (lambda (objvar) (begin1 (-> (call (-> (primitive '-)) (@impl pget (-> (lexical objvar objvar)) (-> (const prop))) (-> (const 1)))) (lambda (tmpvar) (@impl pput (-> (lexical objvar objvar)) (-> (const prop)) (-> (lexical tmpvar tmpvar)))))))) ((predec (aref ,obj ,prop)) (let1 (comp obj e) (lambda (objvar) (let1 (comp prop e) (lambda (propvar) (begin1 (-> (call (-> (primitive '-)) (@impl pget (-> (lexical objvar objvar)) (-> (lexical propvar propvar))) (-> (const 1)))) (lambda (tmpvar) (@impl pput (-> (lexical objvar objvar)) (-> (lexical propvar propvar)) (-> (lexical tmpvar tmpvar)))))))))) ((ref ,id) (lookup id e)) ((var . ,forms) `(begin ,@(map (lambda (form) (pmatch form ((,x ,y) (-> (define x (comp y e)))) ((,x) (-> (define x (@implv *undefined*)))) (else (error "bad var form" form)))) forms))) ((begin) (-> (void))) ((begin ,form) (comp form e)) ((begin . ,forms) `(begin ,@(map (lambda (x) (comp x e)) forms))) ((lambda ,formals ,body) (let ((syms (map (lambda (x) (gensym (string-append (symbol->string x) " "))) formals))) `(lambda () (lambda-case ((() ,formals #f #f ,(map (lambda (x) (@implv *undefined*)) formals) ,syms) ,(with-return-prompt (lambda () (comp-body e body formals syms)))))))) ((call/this ,obj ,prop . ,args) (@impl call/this* obj (-> (lambda '() `(lambda-case ((() #f #f #f () ()) (call ,(@impl pget obj prop) ,@args))))))) ((call (pref ,obj ,prop) ,args) (comp `(call/this ,(comp obj e) ,(-> (const prop)) ,@(map (lambda (x) (comp x e)) args)) e)) ((call (aref ,obj ,prop) ,args) (comp `(call/this ,(comp obj e) ,(comp prop e) ,@(map (lambda (x) (comp x e)) args)) e)) ((call ,proc ,args) `(call ,(comp proc e) ,@(map (lambda (x) (comp x e)) args))) ((return ,expr) (return (comp expr e))) ((array . ,args) `(call ,(@implv new-array) ,@(map (lambda (x) (comp x e)) args))) ((object . ,args) `(call ,(@implv new-object) ,@(map (lambda (x) (pmatch x ((,prop ,val) (-> (call (-> (primitive 'cons)) (-> (const prop)) (comp val e)))) (else (error "bad prop-val pair" x)))) args))) ((pref ,obj ,prop) (@impl pget (comp obj e) (-> (const prop)))) ((aref ,obj ,index) (@impl pget (comp obj e) (comp index e))) ((= (ref ,name) ,val) (let ((v (lookup name e))) (-> (begin (-> (set! v (comp val e))) v)))) ((= (pref ,obj ,prop) ,val) (@impl pput (comp obj e) (-> (const prop)) (comp val e))) ((= (aref ,obj ,prop) ,val) (@impl pput (comp obj e) (comp prop e) (comp val e))) ((+= ,what ,val) (comp `(= ,what (+ ,what ,val)) e)) ((-= ,what ,val) (comp `(= ,what (- ,what ,val)) e)) ((/= ,what ,val) (comp `(= ,what (/ ,what ,val)) e)) ((*= ,what ,val) (comp `(= ,what (* ,what ,val)) e)) ((%= ,what ,val) (comp `(= ,what (% ,what ,val)) e)) ((>>= ,what ,val) (comp `(= ,what (>> ,what ,val)) e)) ((<<= ,what ,val) (comp `(= ,what (<< ,what ,val)) e)) ((>>>= ,what ,val) (comp `(= ,what (>>> ,what ,val)) e)) ((&= ,what ,val) (comp `(= ,what (& ,what ,val)) e)) ((bor= ,what ,val) (comp `(= ,what (bor ,what ,val)) e)) ((^= ,what ,val) (comp `(= ,what (^ ,what ,val)) e)) ((new ,what ,args) `(call ,(@implv new) ,(comp what e) ,@(map (lambda (x) (comp x e)) args))) ((delete (pref ,obj ,prop)) (@impl pdel (comp obj e) (-> (const prop)))) ((delete (aref ,obj ,prop)) (@impl pdel (comp obj e) (comp prop e))) ((void ,expr) (-> (begin (comp expr e) (@implv *undefined*)))) ((typeof ,expr) (@impl typeof (comp expr e))) ((do ,statement ,test) (let ((%loop (gensym "%loop ")) (%continue (gensym "%continue "))) (let ((e (econs '%loop %loop (econs '%continue %continue e)))) (-> (letrec '(%loop %continue) (list %loop %continue) (list (-> (lambda '() (-> (lambda-case `((() #f #f #f () ()) ,(-> (begin (comp statement e) (-> (call (-> (lexical '%continue %continue))))))))))) (-> (lambda '() (-> (lambda-case `((() #f #f #f () ()) ,(-> (if (@impl ->boolean (comp test e)) (-> (call (-> (lexical '%loop %loop)))) (@implv *undefined*))))))))) (-> (call (-> (lexical '%loop %loop))))))))) ((while ,test ,statement) (let ((%continue (gensym "%continue "))) (let ((e (econs '%continue %continue e))) (-> (letrec '(%continue) (list %continue) (list (-> (lambda '() (-> (lambda-case `((() #f #f #f () ()) ,(-> (if (@impl ->boolean (comp test e)) (-> (begin (comp statement e) (-> (call (-> (lexical '%continue %continue)))))) (@implv *undefined*))))))))) (-> (call (-> (lexical '%continue %continue))))))))) ((for ,init ,test ,inc ,statement) (let ((%continue (gensym "%continue "))) (let ((e (econs '%continue %continue e))) (-> (letrec '(%continue) (list %continue) (list (-> (lambda '() (-> (lambda-case `((() #f #f #f () ()) ,(-> (if (if test (@impl ->boolean (comp test e)) (comp 'true e)) (-> (begin (comp statement e) (comp (or inc '(begin)) e) (-> (call (-> (lexical '%continue %continue)))))) (@implv *undefined*))))))))) (-> (begin (comp (or init '(begin)) e) (-> (call (-> (lexical '%continue %continue))))))))))) ((for-in ,var ,object ,statement) (let ((%enum (gensym "%enum ")) (%continue (gensym "%continue "))) (let ((e (econs '%enum %enum (econs '%continue %continue e)))) (-> (letrec '(%enum %continue) (list %enum %continue) (list (@impl make-enumerator (comp object e)) (-> (lambda '() (-> (lambda-case `((() #f #f #f () ()) (-> (if (@impl ->boolean (@impl pget (-> (lexical '%enum %enum)) (-> (const 'length)))) (-> (begin (comp `(= ,var (call/this ,(-> (lexical '%enum %enum)) ,(-> (const 'pop)))) e) (comp statement e) (-> (call (-> (lexical '%continue %continue)))))) (@implv *undefined*))))))))) (-> (call (-> (lexical '%continue %continue))))))))) ((block ,x) (comp x e)) (else (error "compilation not yet implemented:" x))))) (define (comp-body e body formals formal-syms) (define (process) (let lp ((in body) (out '()) (rvars '())) (pmatch in (((var (,x) . ,morevars) . ,rest) (lp `((var . ,morevars) . ,rest) out (if (or (memq x rvars) (memq x formals)) rvars (cons x rvars)))) (((var (,x ,y) . ,morevars) . ,rest) (lp `((var . ,morevars) . ,rest) `((= (ref ,x) ,y) . ,out) (if (or (memq x rvars) (memq x formals)) rvars (cons x rvars)))) (((var) . ,rest) (lp rest out rvars)) ((,x . ,rest) (guard (and (pair? x) (eq? (car x) 'lambda))) (lp rest (cons x out) rvars)) ((,x . ,rest) (guard (pair? x)) (receive (sub-out rvars) (lp x '() rvars) (lp rest (cons sub-out out) rvars))) ((,x . ,rest) (lp rest (cons x out) rvars)) (() (values (reverse! out) rvars))))) (receive (out rvars) (process) (let* ((names (reverse rvars)) (syms (map (lambda (x) (gensym (string-append (symbol->string x) " "))) names)) (e (fold econs (fold econs e formals formal-syms) names syms))) (-> (let names syms (map (lambda (x) (@implv *undefined*)) names) (comp out e)))))) PK ! ��t�s s impl.scmnu �[��� ;;; ECMAScript for Guile ;; Copyright (C) 2009 Free Software Foundation, Inc. ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either ;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;;; Lesser General Public License for more details. ;;;; ;;;; You should have received a copy of the GNU Lesser General Public ;;;; License along with this library; if not, write to the Free Software ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Code: (define-module (language ecmascript impl) #:use-module (oop goops) #:use-module (language ecmascript base) #:use-module (language ecmascript function) #:use-module (language ecmascript array) #:re-export (*undefined* *this* call/this* pget pput pdel has-property? ->boolean ->number new-object new new-array) #:export (js-init get-this typeof bitwise-not logical-not shift mod band bxor bior make-enumerator)) (define-class <js-module-object> (<js-object>) (module #:init-form (current-module) #:init-keyword #:module #:getter js-module)) (define-method (pget (o <js-module-object>) (p <string>)) (pget o (string->symbol p))) (define-method (pget (o <js-module-object>) (p <symbol>)) (let ((v (module-variable (js-module o) p))) (if v (variable-ref v) (next-method)))) (define-method (pput (o <js-module-object>) (p <string>) v) (pput o (string->symbol p) v)) (define-method (pput (o <js-module-object>) (p <symbol>) v) (module-define! (js-module o) p v)) (define-method (prop-attrs (o <js-module-object>) (p <symbol>)) (cond ((module-local-variable (js-module o) p) '()) ((module-variable (js-module o) p) '(DontDelete ReadOnly)) (else (next-method)))) (define-method (prop-attrs (o <js-module-object>) (p <string>)) (prop-attrs o (string->symbol p))) (define-method (prop-keys (o <js-module-object>)) (append (hash-map->list (lambda (k v) k) (module-obarray (js-module o))) (next-method))) ;; we could make a renamer, but having obj['foo-bar'] should be enough (define (js-require modstr) (make <js-module-object> #:module (resolve-interface (map string->symbol (string-split modstr #\.))))) (define-class <js-global-object> (<js-module-object>)) (define-method (js-module (o <js-global-object>)) (current-module)) (define (init-js-bindings! mod) (module-define! mod 'NaN +nan.0) (module-define! mod 'Infinity +inf.0) (module-define! mod 'undefined *undefined*) (module-define! mod 'require js-require) ;; isNAN, isFinite, parseFloat, parseInt, eval ;; decodeURI, decodeURIComponent, encodeURI, encodeURIComponent ;; Object Function Array String Boolean Number Date RegExp Error EvalError ;; RangeError ReferenceError SyntaxError TypeError URIError (module-define! mod 'Object *object-prototype*) (module-define! mod 'Array *array-prototype*)) (define (js-init) (cond ((get-this)) (else (fluid-set! *this* (make <js-global-object>)) (init-js-bindings! (current-module))))) (define (get-this) (fluid-ref *this*)) (define (typeof x) (cond ((eq? x *undefined*) "undefined") ((null? x) "object") ((boolean? x) "boolean") ((number? x) "number") ((string? x) "string") ((procedure? x) "function") ((is-a? x <js-object>) "object") (else "scm"))) (define bitwise-not lognot) (define (logical-not x) (not (->boolean (->primitive x)))) (define shift ash) (define band logand) (define bxor logxor) (define bior logior) (define mod modulo) (define-method (+ (a <string>) (b <string>)) (string-append a b)) (define-method (+ (a <string>) b) (string-append a (->string b))) (define-method (+ a (b <string>)) (string-append (->string a) b)) (define-method (+ a b) (+ (->number a) (->number b))) (define-method (- a b) (- (->number a) (->number b))) (define-method (* a b) (* (->number a) (->number b))) (define-method (/ a b) (/ (->number a) (->number b))) (define-method (< a b) (< (->number a) (->number b))) (define-method (< (a <string>) (b <string>)) (string< a b)) (define-method (<= a b) (<= (->number a) (->number b))) (define-method (<= (a <string>) (b <string>)) (string<= a b)) (define-method (>= a b) (>= (->number a) (->number b))) (define-method (>= (a <string>) (b <string>)) (string>= a b)) (define-method (> a b) (> (->number a) (->number b))) (define-method (> (a <string>) (b <string>)) (string> a b)) (define (obj-and-prototypes o) (if o (cons o (obj-and-prototypes (js-prototype o))) '())) (define (make-enumerator obj) (let ((props (make-hash-table 23))) (for-each (lambda (o) (for-each (lambda (k) (hashq-set! props k #t)) (prop-keys o))) (obj-and-prototypes obj)) (apply new-array (filter (lambda (p) (not (prop-has-attr? obj p 'DontEnum))) (hash-map->list (lambda (k v) k) props))))) PK ! r�vJ5 5 spec.scmnu �[��� ;;; ECMAScript specification for Guile ;; Copyright (C) 2009, 2010 Free Software Foundation, Inc. ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either ;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;;; Lesser General Public License for more details. ;;;; ;;;; You should have received a copy of the GNU Lesser General Public ;;;; License along with this library; if not, write to the Free Software ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Code: (define-module (language ecmascript spec) #:use-module (system base language) #:use-module (language ecmascript parse) #:use-module (language ecmascript compile-tree-il) #:export (ecmascript)) ;;; ;;; Language definition ;;; (define-language ecmascript #:title "ECMAScript" #:reader (lambda (port env) (read-ecmascript/1 port)) #:compilers `((tree-il . ,compile-tree-il)) ;; a pretty-printer would be interesting. #:printer write ) PK ! �!AO[D [D tokenize.scmnu �[��� PK ! ��VaH aH �D parse.scmnu �[��� PK ! 1� �� � 1� array.scmnu �[��� PK ! �� L� function.scmnu �[��� PK ! �iɉ: : �� base.scmnu �[��� PK ! ��_k[ [ � compile-tree-il.scmnu �[��� PK ! ��t�s s Z' impl.scmnu �[��� PK ! r�vJ5 5 = spec.scmnu �[��� PK U rB
| ver. 1.1 | |
.
| PHP 8.4.18 | Ð“ÐµÐ½ÐµÑ€Ð°Ñ†Ð¸Ñ Ñтраницы: 0.01 |
proxy
|
phpinfo
|
ÐаÑтройка