- Files:
-
- 5 added
- 3 removed
- 7 modified
-
lang/elisp/twittering-mode/trunk/twittering-mode.el (modified) (2 diffs)
-
lang/elisp/twittering-mode/branches/RB-0.3/twittering-mode.el (modified) (9 diffs)
-
lang/elisp/twittering-mode/branches/RB-0.3/ChangeLog (modified) (1 diff)
-
lang/elisp/twittering-mode/branches/gan2 (deleted)
-
hh2008/hayamiz/trunk/hascheme/parser.scm (modified) (9 diffs)
-
hh2008/hayamiz/sandbox (deleted)
-
hh2008/naoya_t/20080301_GOODDAY (added)
-
hh2008/naoya_t/20080301_GOODDAY/test.hs (added)
-
hh2008/naoya_t/20080301_GOODDAY/test.sh (added)
-
hh2008/naoya_t/20080301_GOODDAY/peg.scm (added)
-
hh2008/naoya_t/20080301_GOODDAY/ihci.scm (added)
-
hh2008/naoya_t/trunk/test.hs (modified) (2 diffs)
-
hh2008/naoya_t/trunk/test.sh (modified) (1 diff)
-
hh2008/naoya_t/trunk/ihci.scm (modified) (15 diffs)
-
pic (deleted)
Legend:
- Unmodified
- Added
- Removed
-
/lang/elisp/twittering-mode/trunk/twittering-mode.el
r24 r11 589 589 590 590 (defun twittering-get-response-header (&optional buffer) 591 "Ex tract HTTP response header from HTTP response.591 "Exract HTTP response header from HTTP response. 592 592 `buffer' may be a buffer or the name of an existing buffer. 593 593 If `buffer' is omitted, the value of `twittering-http-buffer' is used as `buffer'." … … 600 600 601 601 (defun twittering-get-response-body (&optional buffer) 602 "Ex tract HTTP response body from HTTP response, parse it as XML, and return a XML tree as list.602 "Exract HTTP response body from HTTP response, parse it as XML, and return a XML tree as list. 603 603 `buffer' may be a buffer or the name of an existing buffer. 604 604 If `buffer' is omitted, the value of `twittering-http-buffer' is used as `buffer'." -
/lang/elisp/twittering-mode/branches/RB-0.3/twittering-mode.el
r25 r11 7 7 ;; Tsuyoshi CHO <Tsuyoshi.CHO+develop@Gmail.com> 8 8 ;; Created: Sep 4, 2007 9 ;; Version: 0.39 ;; Version: SVN-HEAD 10 10 ;; Keywords: twitter web 11 11 ;; URL: http://lambdarepos.svnrepository.com/share/trac.cgi/browser/lang/elisp/twittering-mode … … 50 50 (defvar twittering-mode-map (make-sparse-keymap)) 51 51 52 (defvar twittering-timer nil "Timer object for timeline refreshing will be stored here. DO NOT SET VALUE MANUALLY.")52 (defvar twittering-timer nil) 53 53 54 54 (defvar twittering-idle-time 20) … … 107 107 (defun assocref (item alist) 108 108 (cdr (assoc item alist))) 109 (defmacro list-push (value listvar)110 `(setq ,listvar (cons ,value ,listvar)))111 109 112 110 ;;; Proxy … … 434 432 (setq c (string-to-char (match-string-no-properties 1 format-str))) 435 433 (if (> found-at cursor) 436 ( list-push (substring format-str cursor found-at) result)434 (push (substring format-str cursor found-at) result) 437 435 "|") 438 436 (setq cursor (match-end 1)) … … 440 438 (case c 441 439 ((?s) ; %s - screen_name 442 ( list-push (attr 'user-screen-name) result))440 (push (attr 'user-screen-name) result)) 443 441 ((?S) ; %S - name 444 ( list-push (attr 'user-name) result))442 (push (attr 'user-name) result)) 445 443 ((?i) ; %i - profile_image 446 ( list-push (profile-image) result))444 (push (profile-image) result)) 447 445 ((?d) ; %d - description 448 ( list-push (attr 'user-description) result))446 (push (attr 'user-description) result)) 449 447 ((?l) ; %l - location 450 ( list-push (attr 'user-location) result))448 (push (attr 'user-location) result)) 451 449 ((?L) ; %L - " [location]" 452 450 (let ((location (attr 'user-location))) 453 451 (unless (or (null location) (string= "" location)) 454 ( list-push (concat " [" location "]") result)) ))452 (push (concat " [" location "]") result)) )) 455 453 ((?u) ; %u - url 456 ( list-push (attr 'user-url) result))454 (push (attr 'user-url) result)) 457 455 ((?j) ; %j - user.id 458 ( list-push (attr 'user-id) result))456 (push (attr 'user-id) result)) 459 457 ((?p) ; %p - protected? 460 458 (let ((protected (attr 'user-protected))) 461 459 (when (string= "true" protected) 462 ( list-push "[x]" result))))460 (push "[x]" result)))) 463 461 ((?c) ; %c - created_at (raw UTC string) 464 ( list-push (attr 'created-at) result))462 (push (attr 'created-at) result)) 465 463 ((?C) ; %C{time-format-str} - created_at (formatted with time-format-str) 466 ( list-push (twittering-local-strftime464 (push (twittering-local-strftime 467 465 (or (match-string-no-properties 2 format-str) "%H:%M:%S") 468 466 (attr 'created-at)) … … 476 474 (let ((secs (+ (* (- (car now) (car created-at)) 65536) 477 475 (- (cadr now) (cadr created-at))))) 478 ( list-push (cond ((< secs 5) "less than 5 seconds ago")476 (push (cond ((< secs 5) "less than 5 seconds ago") 479 477 ((< secs 10) "less than 10 seconds ago") 480 478 ((< secs 20) "less than 20 seconds ago") … … 490 488 result)))) 491 489 ((?t) ; %t - text 492 ( list-push ;(clickable-text)490 (push ;(clickable-text) 493 491 (attr 'text) 494 492 result)) … … 496 494 (let ((truncated (attr 'truncated))) 497 495 (when (string= "true" truncated) 498 ( list-push "..." result))))496 (push "..." result)))) 499 497 ((?f) ; %f - source 500 ( list-push (attr 'source) result))498 (push (attr 'source) result)) 501 499 ((?#) ; %# - id 502 ( list-push (attr 'id) result))500 (push (attr 'id) result)) 503 501 (t 504 ( list-push (char-to-string c) result)))502 (push (char-to-string c) result))) 505 503 ) 506 ( list-push (substring format-str cursor) result)504 (push (substring format-str cursor) result) 507 505 (apply 'concat (nreverse result)) 508 506 ))) … … 781 779 encoded-str cursor)) 782 780 (when (> found-at cursor) 783 ( list-push (substring encoded-str cursor found-at) result))781 (push (substring encoded-str cursor found-at) result)) 784 782 (let ((number-entity (match-string-no-properties 2 encoded-str)) 785 783 (letter-entity (match-string-no-properties 3 encoded-str))) 786 784 (cond (number-entity 787 ( list-push785 (push 788 786 (char-to-string 789 787 (twittering-ucs-to-char 790 788 (string-to-number number-entity))) result)) 791 789 (letter-entity 792 (cond ((string= "gt" letter-entity) ( list-push ">" result))793 ((string= "lt" letter-entity) ( list-push "<" result))794 (t (list-push "?" result))))795 (t ( list-push "?" result)))790 (cond ((string= "gt" letter-entity) (push ">" result)) 791 ((string= "lt" letter-entity) (push "<" result)) 792 (t push "?" result))) 793 (t (push "?" result))) 796 794 (setq cursor (match-end 0)))) 797 ( list-push (substring encoded-str cursor) result)795 (push (substring encoded-str cursor) result) 798 796 (apply 'concat (nreverse result))) 799 797 "")) -
/lang/elisp/twittering-mode/branches/RB-0.3/ChangeLog
r25 r11 1 2008-03-15 Y. Hayamizu <haya@haya-laptop-ubuntu>2 3 * twittering-mode.el : pushをfree variableと誤認識されるバグ(再現できていない)のため,clのpushをlist-pushで置きかえ.4 (list-push): clのpushの代替として定義.5 6 1 2008-02-08 Tsuyoshi CHO <Tsuyoshi.CHO+develop@Gmail.com> 7 2 -
/hh2008/hayamiz/trunk/hascheme/parser.scm
r23 r15 6 6 (define-class <ast> () ()) 7 7 (define-class <ast-decl> (<ast>) ()) 8 (define-class <ast-decls> (<ast>)9 ((delcs :init-keyword :decls :getter decls)))10 8 (define-class <ast-type-decl> (<ast-decl>) 11 9 ((left :init-keyword :left :getter type-decl-left) … … 16 14 (define-class <ast-single-type> (<ast-type>) 17 15 ((type-name :init-keyword :name :getter type-name) 18 (type-arity :init-keyword :arity :accessor type-arity :init-value #f)16 (type-arity :init-keyword :arity :accessor type-arity) 19 17 (type-vars :init-keyword :vars :accessor type-vars :init-value #f) 20 18 (type-module :init-keyword :module :getter type-module :init-value #f))) 21 19 (define-class <ast-multi-type> (<ast-type>) 22 20 ((types :init-keyword :name :accessor types))) 23 (define-class <ast-simple-type> (<ast>) 24 ((type-name :init-keyword :name :getter type-name) 25 (type-vars :init-keyword :vars :getter type-vars))) 26 21 (define-class <ast-simple-type> (<ast>) ()) 27 22 (define-method make-type-decl ((left <ast-simple-type>) (right <ast-type>)) 28 (make <ast-type-decl> :left left :right right)) 23 ; (make <type-decl> :left left :right right) 24 `(:type-decl ,left ,right)) 29 25 30 26 (define (hascheme:parse str) … … 36 32 (Body <- "{" (:decls TopDecls) "}" :return decls) 37 33 (TopDecls <- Spaces* (:decl TopDecl) (:rest-decls TopDecls%) Spaces* 38 :return (make <ast-decls> :decls (cons decl rest-decls))34 :return `(:decls ,decl ,@rest-decls) 39 35 / Spaces* :return ()) 40 36 (TopDecls% <- Spaces* ";" Spaces* TopDecl TopDecls% … … 79 75 ) 80 76 81 (FuncApplyExpression 82 <- (:atom AtomExpression) 83 (:rest-atoms ((Spaces (:inatm AtomExpression) :return inatm) *)) 84 Spaces* :return `(:funapply ,atom ,@rest-atoms)) 77 (FuncApplyExpression <- AtomExpression +) 85 78 (AtomExpression 86 79 <- QVar … … 116 109 / "~" Spaces* AtomPattern) 117 110 118 (QVar <- LexQVarId 119 / "(" Spaces* (:sym LexQVarSym) Spaces* ")" :return sym) 111 (QVar <- LexQVarId / "(" Spaces* LexQVarSym Spaces* ")") 120 112 (GCon <- "(" Spaces* ")" 121 113 / "[" Spaces* "]" … … 130 122 / LexQtyCls "(" LexTyVar AType + ")") 131 123 (SimpleType <- (:con LexTyCon) (:vars SimpleTypeVars) 132 :return (make <ast-simple-type> :name con :varsvars))124 :return `(:type-name ,con :vars ,vars)) 133 125 (SimpleTypeVars <- Spaces (:var LexTyVar) (:vars SimpleTypeVars) 134 126 :return (cons var vars) 135 127 / :return ()) 136 128 (Type <- (:type BType) Spaces* (:rest-types Type%) 137 :return 138 (if (null? rest-types) 139 type 140 (make <ast-multi-type> :types (cons type rest-types)))) 129 :return `(:type ,type ,@rest-types)) 141 130 (Type% <- "->" Spaces* (:type Type) (:rest-types Type%) 142 131 :return (cons type rest-types) 143 132 / :return ()) 144 133 (BType <- (:type AType) (:rest-types BType%) 145 :return (cond 146 ((is-a? type <ast-single-type>) 147 (begin (set! (type-vars type) rest-types) 148 type)) 149 ((and (is-a? #?=type <ast-multi-type>) 150 (null? #?=rest-types)) 151 type) 152 (else (error "Type error")))) 134 :return (cons type rest-types)) 153 135 (BType% <- Spaces (:type AType) (:rest-types BType%) 154 136 :return (cons type rest-types) … … 158 140 / "(" Spaces* (:t1 Type) Spaces* "," 159 141 Spaces* (:t2 Type) Spaces* (:rest AType%) ")" 160 :return (make <ast-si ngle-type> :name '$Tuple142 :return (make <ast-simple-type> :name '$Tuple 161 143 :arity (+ 2 (length rest)) 162 144 :vars `(,t1 ,t2 ,@rest)) 163 145 / "[" Spaces* Type Spaces* "]" 164 / "(" Spaces* (:t Type) Spaces* ")" :return t)146 / "(" Spaces* Type Spaces* ")") 165 147 (AType% <- "," Spaces* (:t Type) Spaces* (:rest AType%) 166 148 :return (cons t rest) 167 149 / :return ()) 168 (GtyCon <- (:tycon LexQtyCon) 169 :return (make <ast-single-type> :name (cadr tycon) 170 :module (car tycon)) 150 (GtyCon <- LexQtyCon 171 151 / "(" Spaces* ")" 172 :return (make <ast-single-type> :name '$Unit :arity 0 )152 :return (make <ast-single-type> :name '$Unit :arity 0 :vars ()) 173 153 / "[" Spaces* "]" 174 154 :return '(make <ast-single-type> :name '$Unit :arity 0) … … 224 204 (LexQConSym <- (LexModId ".") ? LexConSym) 225 205 (LexQtyCon <- (:mod ((LexModId ".") ?)) (:tycon LexTyCon) 226 :return (if mod `( ,(car mod) ,tycon)227 `( #f ,tycon)))206 :return (if mod `(:module ,(car mod) ,@tycon) 207 `(:module #f ,@tycon))) 228 208 (LexQtyCls <- (LexModId ".") ? LexTyCls) 229 209 (LexGConSym <- ":" / LexQConSym ) … … 249 229 250 230 251 (define-method hascheme:ast-print ((ast <ast-decls>))252 (let1 ast-decls (decls ast)253 (unless (null? ast-decls)254 (hascheme:ast-print (car ast-decls))255 (unless (null? (cdr ast-decls))256 (display "; ")257 (for-each hascheme:ast-print (cdr ast-decls))))))258 259 (define-method hascheme:ast-print ((ast <ast-type-decl>))260 (hascheme:ast-print (type-decl-left ast))261 (display " = ")262 (hascheme:ast-print (type-decl-right ast)))263 264 (define-method hascheme:ast-print ((ast <ast-simple-type>))265 (let1 vars (type-vars ast)266 (cond267 ((null? vars) (display (type-name ast)))268 (else269 (display (type-name ast))270 (for-each (lambda (sym) (format #t " ~a" sym))271 vars)))))272 273 (define-method hascheme:ast-print ((ast <ast-single-type>))274 (let1 vars (type-vars ast)275 (cond276 ((null? vars) (display (type-name ast)))277 (else278 (display (type-name ast))279 (for-each (lambda (var)280 (cond281 ((symbol? var) (format #t " ~a" var))282 ((is-a? var <ast-type-var>)283 (display " ")284 (hascheme:ast-print var))285 ((is-a? var <ast>)286 (display " (")287 (hascheme:ast-print var)288 (display ")"))289 (error "Invalid type")))290 vars)))))291 292 (define-method hascheme:ast-print ((ast <ast-type-var>))293 (display (type-var ast)))294 295 231 (define (hascheme:parser-test) 296 232 (test* "Simplest body" '(()) -
/hh2008/naoya_t/trunk/test.hs
r22 r18 1 "Hello, World!" 2 putStrLn "Hello, World!" 3 5 * 6 - 7 4 print $ 5 * 6 - 7 5 \x -> x * x $ 5 * 6 - 7 6 print $ \x -> x * x $ 5 * 6 - 7 7 [1,2,3,4] 8 print [1,2,3,4] 9 tail [1,2,3] 10 print $ tail [1,2,3] 1 main = putStrLn "Hello, World!" 11 2 12 print if 1 then '@' else '*' 13 -- if c == '\t' then '@' else c 14 \num -> num * num 15 \x -> x 16 3 + 4 17 4 * 5 - 1 3 -- main = do { cs <- getContents ; print $ length $ lines cs } 18 4 19 5 firstNLines n cs = unlines $ take n $ lines cs 20 6 21 f1 = do { cs <- getContents ; print $ length $ lines cs } 22 f2 = print $ 5 + 2 * 5 23 f3 = print $ tail [1,2,3] 24 f4 = tail [1,2,3] 7 -- main = print $ 5 + 2 * 5 8 rmain = print $ tail [1,2,3] 9 -- main = tail [1,2,3] 10 11 tail [1,2,3] 12 print [1,2,3,4] 25 13 26 14 fib 0 = 0 … … 28 16 fib n = fib (n-1) + fib (n-2) 29 17 30 square n = n * n31 triple a = a + a + a32 33 main = putStrLn "Hello, World!"34 35 main = print $ 5 * 6 - 736 -- main = print $ \x -> x * x $ 5 * 6 - 7 -
/hh2008/naoya_t/trunk/test.sh
r22 r18 1 1 #!/bin/sh 2 #sed '/^$/d; /^--/d' test.hs | gosh -I. ihci.scm3 gosh -I. ihci.scm < test.hs 2 sed '/^$/d; /^--/d' test.hs | gosh -I. ihci.scm 3 -
/hh2008/naoya_t/trunk/ihci.scm
r22 r18 1 ;;2 ;; IHC - Ikoma Haskell Compiler3 ;;4 1 (use srfi-1) 5 2 … … 26 23 [%body-char ($or %unescaped)] 27 24 [%string-body ($do (chars ($many %body-char)) 28 ; ($return (tag :string (list->string chars))))] 29 ($return (list->string chars)))] 25 ($return (tag :string (list->string chars))))] 30 26 ) 31 27 ($between %dquote %string-body %dquote))) 32 33 (define %char34 ($do (($char #\'))35 (($optional ($char #\\)))36 (ch anychar)37 (($char #\'))38 ; ($return (tag :char ch))39 ($return ch)40 ))41 28 42 29 (define %ident ;; scheme-symbolで代用 … … 45 32 ($do (head %ident-head-char) 46 33 (rest ($many %ident-rest-char)) 47 ; ($return (tag :ident (string->symbol (list->string (cons head rest))))))))48 34 ($return (string->symbol (list->string (cons head rest))))))) 49 35 50 36 (define %digits 51 37 ($do (d ($many digit 1)) 52 ; ($return (tag :number (string->number (list->string d)))))) 53 ($return (string->number (list->string d))))) 38 ($return (tag :number (string->number (list->string d)))))) 54 39 55 40 (define %list 56 (let* ([%begin-list ($ char #\[)]57 [%end-list ($ char #\])]41 (let* ([%begin-list ($seq %ws ($char #\[) %ws)] 42 [%end-list ($seq %ws ($char #\]) %ws)] 58 43 [%item ($or %digits %string %ident)] 59 44 [%item-separator ($seq %ws ($char #\,) %ws)] … … 66 51 67 52 (define %tuple 68 (let* ([%begin-list ($ char #\()]69 [%end-list ($ char #\))]53 (let* ([%begin-list ($seq %ws ($char #\() %ws)] 54 [%end-list ($seq %ws ($char #\)) %ws)] 70 55 [%item ($or %digits %string %ident)] 71 56 [%item-separator ($seq %ws ($char #\,) %ws)] … … 77 62 )) 78 63 79 (define %atomic80 ($or %string %char %digits %ident %list %tuple))81 82 (define (char->symbol ch)83 (string->symbol (x->string ch)))84 85 (define %infixed86 (let1 %infix ($or ($one-of #[-+*/<>])87 ($string "==") ($string "<=") ($string ">="))88 ($do (item1 %atomic);($or %application %atomic)) ;%atomic)89 ; (seq ($do %ws90 ; (infix %infix)91 ; %ws92 ; (rest ($or %infixed %atomic))93 ; ($return (cons infix rest))))94 %ws95 (infix %infix)96 %ws97 (item2 %atomic);($or %application %atomic)) ;%atomic)98 (rest ($many ($do %ws99 (infix %infix)100 %ws101 (item %atomic);($or %application %atomic)) ;%atomic)102 ($return (list (char->symbol infix) item)))))103 ($return (let1 expr (append (list item1 (char->symbol infix) item2)104 (apply append rest))105 (case (length expr)106 ((3)107 (list ':apply (second expr) (first expr) (third expr)))108 ((5) ; 優先度まだ109 (list ':apply (fourth expr)110 (list ':apply (second expr) (first expr) (third expr))111 (fifth expr)))112 )))113 ;(tag :infixed (append (list item1 (char->symbol infix) item2)114 ;(apply append rest))))115 )))116 ; (seq ($or ($do %ws117 ; (infix %infix)118 ; %ws119 ; (rest %infixed)120 ; ($return (cons infix rest)))121 ; ($do %ws122 ; (infix %infix)123 ; %ws124 ; (rest %atomic)125 ; ($return (list infix rest))) ))126 ; ($return (tag :infixed (cons elem1 seq))))))127 128 64 (define %expr 129 ($or %infixed 130 ; ($between ($char #\() %expr ($char #\))) 131 %if %atomic)) 132 133 (define %comment 134 ($or 135 ($seq ($string "-- ") ($none-of #[\n]) ($char #\n)) 136 ($seq ($string "{-") ($many anychar) ($string "-}")) 137 )) 138 139 (define %if 140 ($do (($string "if")) 141 %ws 142 (cond %expr) 143 %ws 144 (($string "then")) 145 %ws 146 (conseq %expr) 147 (alt ($optional ($do %ws (($string "else")) %ws 148 (alt %expr) 149 ($return alt)))) 150 ($return (tag :if (list cond conseq alt))))) 65 ($or %string %digits %ident %list %tuple)) 151 66 152 67 (define %application … … 154 69 ($do (fn %ident) 155 70 %ws 156 (arg1 ($or %expr157 ($between ($char #\() %expr ($char #\)))))158 %ws159 71 (args ($my-sep-by %expr %ws)) 160 ($return `(:apply ,fn , arg1 ,@args)))161 ($do (app1 ($or %infixed %an-application %lambda %ident))72 ($return `(:apply ,fn ,@args))) 73 ($do (app1 %an-application) 162 74 (apps ($many ($do %ws 163 (($char #\$)) ; " $ "75 (($char #\$)) 164 76 %ws 165 (app ($or %infixed %an-application %lambda %ident))77 (app %an-application) 166 78 ($return app)))) 167 79 ($return (if (= 0 (length apps)) app1 `(:$ ,app1 ,@apps)))))) 168 80 169 (define %lambda170 ($do (($char #\\))171 (vars ($my-sep-by %ident %ws))172 %ws173 (($string "->"))174 %ws175 (body ($or %do %infixed %application %expr))176 ($return (tag ':lambda (list vars body)))))177 178 (define %assignment179 ($do (id %ident)180 %ws181 (($string "<-"))182 %ws183 (value ($or %infixed %application %expr))184 ($return `(:assign ,id ,value))185 ))186 187 (define %do188 (let1 %do-line-separator ($seq %ws ($or ($seq newline ($string " ")) ($char #\;)) %ws)189 ($do (($string "do"))190 %ws191 (exprs ($or ($between ($seq ($char #\{) %ws)192 ($my-sep-by ($or %assignment %infixed %application %expr)193 ($seq %ws ($char #\;) ($optional ($seq newline ($string " "))) %ws))194 ($seq %ws ($char #\})))195 ($my-sep-by ($or %assignment %infixed %application %expr)196 ($seq newline ($string " ") %ws)) ))197 ($return `(:do ,@exprs)))))198 199 (define %defun200 ($do (id %ident)201 %ws202 (args ($my-sep-by %ident %ws))203 %ws204 (($char #\=))205 %ws206 (rightside ($or %do %infixed %application %expr))207 ($return `(:defun (,id ,@args) ,rightside))208 ))209 210 (define %pattern211 ($do (id %ident)212 %ws213 (args ($my-sep-by ($or %ident %digits) %ws))214 %ws215 (($char #\=))216 %ws217 (rightside ($or %do %infixed %application %expr))218 ($return `(:pattern (,id ,@args) ,rightside))219 ))220 221 81 (define %haskell 222 82 (let* ([%unknown ($my-sep-by %expr %ws)] 223 ) 224 ($or %comment %lambda %defun %pattern %assignment %infixed %if %application %expr 225 %unknown 226 newline) 83 84 [%assignment ($do (id %ident) 85 %ws 86 (($string "<-")) 87 %ws 88 (value %application) 89 ($return `(:assign ,id ,value)) 90 )] 91 [%do-line-separator ($seq %ws ($or ($seq newline ($string " ")) ($char #\;)) %ws)] 92 [%do ($do (($string "do")) 93 %ws 94 (exprs ($or ($between ($seq ($char #\{) %ws) 95 ($my-sep-by ($or %assignment %application) 96 ($seq %ws ($char #\;) ($optional ($seq newline ($string " "))) %ws)) 97 ($seq %ws ($char #\}))) 98 ($my-sep-by ($or %assignment %application) 99 ($seq newline ($string " ") %ws)) )) 100 ($return `(:do ,@exprs)))] 101 102 [%defun ($do (id %ident) 103 %ws 104 (args ($my-sep-by %ident %ws)) 105 %ws 106 (($char #\=)) 107 %ws 108 (rightside ($or %do %application)) 109 ($return `(:defun (,id ,@args) ,rightside)) 110 )] 111 [%pattern ($do (id %ident) 112 %ws 113 (args ($my-sep-by ($or %ident %digits) %ws)) 114 %ws 115 (($char #\=)) 116 %ws 117 (rightside ($or %do %application)) 118 ($return `(:pattern (,id ,@args) ,rightside)) 119 )] 120 121 ) 122 ($or %defun %pattern %assignment %application %expr 123 %unknown) 227 124 )) 228 125 … … 237 134 ;(define ident-body untag) 238 135 239 (define lambda? (tagged?$ :lambda))240 241 136 (define (indent w lines) 242 137 (string-join (map (lambda (line) (string-append (make-string w #\space) (x->string line))) … … 248 143 (hash-table-put! *namespace* id val) 249 144 id) 250 251 (define (lookup id env)252 (let1 val (lookup-variable-value id env) 253 (if val val (hash-table-get *namespace* id))))145 (define (lookup id) 146 (let1 val (hash-table-get *namespace* id) 147 ; 148 val)) 254 149 255 150 ;; … … 260 155 (define (heval-map exps env) (map (cut heval <> env) exps)) 261 156 (define (heval exp env) 262 ; (print "HEVAL " exp) 263 (cond [(null? exp) *undefined*] 264 [(number? exp) exp] 265 [(string? exp) exp] 266 [(char? exp) exp] 267 [(symbol? exp) (let1 val (lookup exp env) 268 (if val (heval val env) *undefined*))] 269 [else (match exp 270 [(':$ . _) 271 (let loop ([apps (map (lambda (e) (if (or (ident? e) (lambda? e)) 272 (list ':apply e) e)) 273 (cdr exp))]) 274 (if (null? (cdr apps)) 275 (heval (car apps) env) 276 (heval (append (car apps) 277 (list (loop (cdr apps)))) 278 env) 279 )) 280 ] 281 282 [(':apply f . _) 283 (let ([f (cadr exp)] 284 [args (cddr exp)]) 285 (happly 286 (if (symbol? f) f (heval (second exp) env)) 287 (heval-map args env)) 288 )] 289 290 [(':assign x y) ; id <- action 291 (assign (ident-body x) (heval y env))] 292 293 [(':if cond then) 294 (if cond then *undefined*)] 295 [(':if cond then else) 296 (if cond then else)] 297 298 [(':do . _) ; do { ... ; ... ; ... } 299 `(seq ,@(heval-map (cdr exp) env))] 300 301 [(':lambda args . lambda-body) 302 (make-procedure (map ident-body args) ;lambda-parameters 303 lambda-body 304 env)] 305 306 [(':defun id definition) ; id x y z = app x $ app y $ app z 307 (let ([ident (car id)] 308 [args (cdr id)]) 309 (assign (ident-body ident) 310 (make-procedure (map ident-body args) ;lambda-parameters 311 (if (eq? 'seq (car definition)) ; lambda-body 312 ;(heval definition env) 313 ;(list (heval definition env)) ) 314 definition 315 (list definition)) 316 env)))] 317 318 [(':pattern id definition) ; id x y z = app x $ app y $ app z 319 (let ([ident (car id)] 320 [args (cdr id)]) 321 )] 322 323 [(':string . str) str] 324 [(':list . l) l];(heval-map l env)] 325 [(':tuple . t) t] 326 [(':ident . id) id] 327 328 [_ (if (pair? exp) exp ;(happly (car exp) (cdr exp)) 329 (format "unknown: ~a" exp))] 330 331 )])) 157 (if (or (null? exp) (not (pair? exp))) *undefined* 158 (match exp 159 [(':$ . _) 160 ; (delay-it 161 (let loop ([rest (cdr exp)]) 162 (if (null? (cdr rest)) 163 (heval (car rest) env) 164 (heval (append (car rest) (list (loop (cdr rest)))) env) 165 )) 166 ; env) 167 ] 168 [(':apply f . _) 169 (if (null? (cddr exp)) 170 ; (delay-it (list (ident-body f)) env) 171 (list (ident-body f)) 172 `(,(ident-body f) ,@(cddr exp)); ,@(map (cut heval <> env) (cdr exp))) 173 ; (delay-it `(,(ident-body f) 174 ; ,@(map (cut heval <> env) (cdr exp))) 175 ; env) 176 )] 177 [(':assign x y) ; id <- action 178 (assign (ident-body x) (heval y env))] 179 [(':do . _) ; do { ... ; ... ; ... } 180 `(seq ,@(heval-map (cdr exp) env))] 181 [(':defun id definition) ; id x y z = app x $ app y $ app z 182 (let ([ident (car id)] 183 [args (cdr id)]) 184 (assign (ident-body ident) 185 (make-procedure (map ident-body args) ;lambda-parameters 186 (if (eq? 'seq (car definition)) ; lambda-body 187 (heval definition env) 188 (list (heval definition env)) ) 189 env)))] 190 [(':pattern id definition) ; id x y z = app x $ app y $ app z 191 (let ([ident (car id)] 192 [args (cdr id)]) 193 (assign (ident-body ident) 194 (make-procedure (map ident-body args) ;lambda-parameters 195 (if (eq? 'seq (car definition)) ; lambda-body 196 (heval definition env) 197 (list (heval definition env)) ) 198 env)))] 199 200 [(':string . str) str] 201 [(':list . l) l] 202 [(':tuple . t) t] 203 [(':ident . id) id] 204 205 [_ (if (pair? exp) (happly (car exp) (cdr exp)) 206 (format "unknown: ~a" exp))] ))) 332 207 333 208 (define (primitive-procedure? proc) … … 335 210 putStrLn 336 211 lines length print 337 tail 338 * + - /))) 212 tail))) 339 213 340 214 (define (prim-print exp) … … 349 223 (list->haskell-string (untag obj))] 350 224 [(pair? obj) (haskell-description-of-list obj)] 351 [(number? obj) (number->string obj)]352 [(string? obj) obj]353 225 [else (x->string obj)])) 226 354 227 (print (haskell-description exp))) 355 228 … … 363 236 (let1 args* (heval-map args '()) 364 237 (case proc 365 [(putStr) (display (x->string (car args*)))]366 [(putStrLn) (apply prim-print args*)]367 [(print) (apply prim-print args*)]368 [(lines) (length args*)]369 [(length) (if (tagged? :string (car args*))238 ((putStr) (display (x->string (car args*)))) 239 ((putStrLn) (apply prim-print args*)) 240 ((print) (apply prim-print args*)) 241 ((lines) (length args*)) 242 ((length) (if (tagged? :string (car args*)) 370 243 (string-length (car args*)) 371 (length (car args*)))] 372 [(tail) (prim-tail (car args*))] 373 374 [(*) (apply * args*)] 375 [(+) (apply + args*)] 376 [(/) (apply / args*)] 377 [(-) (apply - args*)] 378 ; [else (error "unknown primitive: " proc)] 244 (length (car args*)))) 245 ((tail) (prim-tail (car args*))) 379 246 ))) 380 247 … … 385 252 (define (procedure-environment proc) (fourth proc)) 386 253 387 ; SICP pp225-226388 (define (enclosing-environment env) (cdr env))389 (define (first-frame env) (car env))390 (define the-empty-environment '())391 392 254 (define (make-frame vars vals) (cons vars vals)) 393 (define (frame-variables frame) (car frame))394 (define (frame-values frame) (cdr frame))395 255 396 256 (define (extend-environment vars vals base-env) 397 257 ;; assert-equal (length vars) (length vals) 398 258 (cons (make-frame vars vals) base-env)) 399 400 (define (lookup-variable-value var env)401 (define (env-loop env)402 (define (scan vars vals)403 (cond [(null? vars)404 (env-loop (enclosing-environment env))]405 [(eq? var (car vars))406 (car vals)]407 [else (scan (cdr vars) (cdr vals))]))408 (if (eq? env the-empty-environment)409 #f ; (error "unbound variable" var)410 (let1 frame (first-frame env)411 (scan (frame-variables frame)412 (frame-values frame)))))413 (env-loop env))414 415 (define (last-exp? seq) (null? (cdr seq)))416 (define (heval-sequence exps env)417 (cond [(last-exp? exps) (heval (car exps) env)]418 [else (heval (car exps) env)419 (heval-sequence (cdr exps) env)]))420 259 421 260 (define (happly proc args) … … 426 265 args 427 266 (procedure-environment proc)) 428 (heval- sequence(procedure-body proc) env))]267 (heval-map (procedure-body proc) env))] 429 268 [else 430 269 ; … … 435 274 (let1 input (read-line) 436 275 (if (eof-object? input) 'eof 437 ( begin438 ( when (and (string? input) (< 0 (string-length input)))276 (let1 parsed (parse-haskell input); (haskell->scheme input) 277 (let1 evaled (heval parsed '()) 439 278 (print "> " input) 440 (let1 parsed (parse-haskell input); (haskell->scheme input) 441 (print "=> " parsed) 442 (let1 evaled (heval parsed '()) 443 (print "=> " evaled) 444 ; (if evaled (print ": " (heval evaled '()))) 445 )) 446 (print "")) 279 (print "=> " parsed) 280 (print "" evaled)) 447 281 (repl))))) 448 282 449 ;(define (actual-value exp); env) 450 ; (if (and (pair? exp) (tagged? ':apply exp)) 451 ; ( 452 ; (force-it (heval exp '()))) 453 454 (let1 main (lookup 'main '()) 455 (print "====") 456 (happly main '()) 457 ) 283 (define (actual-value exp); env) 284 (force-it (heval exp '()))) 285 286 (let1 main (lookup 'main) 287 (print "----") 288 (happly main '()) 289 )
