- Files:
-
- 16 added
- 1 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 (added)
-
lang/elisp/twittering-mode/branches/gan2/twittering-mode.el (added)
-
lang/elisp/twittering-mode/branches/gan2/ChangeLog (added)
-
lang/elisp/twittering-mode/branches/gan2/makefile (added)
-
lang/elisp/twittering-mode/branches/gan2/TAGS (added)
-
hh2008/hayamiz/trunk/hascheme/parser.scm (modified) (9 diffs)
-
hh2008/hayamiz/sandbox (added)
-
hh2008/hayamiz/sandbox/hoge.hs (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)
-
hh2008/naoya_t/20080301_GOODDAY (deleted)
-
pic (added)
-
pic/test (added)
-
pic/test/libusb (added)
-
pic/test/libusb/pickit2 (added)
-
pic/test/libusb/pickit2/pickit2.c (added)
-
pic/test/libusb/pickit2/Makefile (added)
-
pic/driver (added)
-
pic/driver/macosx (added)
-
pic/driver/macosx/pickit2 (added)
Legend:
- Unmodified
- Added
- Removed
-
/lang/elisp/twittering-mode/trunk/twittering-mode.el
r11 r24 589 589 590 590 (defun twittering-get-response-header (&optional buffer) 591 "Ex ract HTTP response header from HTTP response.591 "Extract 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 ract HTTP response body from HTTP response, parse it as XML, and return a XML tree as list.602 "Extract 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
r11 r25 7 7 ;; Tsuyoshi CHO <Tsuyoshi.CHO+develop@Gmail.com> 8 8 ;; Created: Sep 4, 2007 9 ;; Version: SVN-HEAD9 ;; Version: 0.3 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 )52 (defvar twittering-timer nil "Timer object for timeline refreshing will be stored here. DO NOT SET VALUE MANUALLY.") 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))) 109 111 110 112 ;;; Proxy … … 432 434 (setq c (string-to-char (match-string-no-properties 1 format-str))) 433 435 (if (> found-at cursor) 434 ( push (substring format-str cursor found-at) result)436 (list-push (substring format-str cursor found-at) result) 435 437 "|") 436 438 (setq cursor (match-end 1)) … … 438 440 (case c 439 441 ((?s) ; %s - screen_name 440 ( push (attr 'user-screen-name) result))442 (list-push (attr 'user-screen-name) result)) 441 443 ((?S) ; %S - name 442 ( push (attr 'user-name) result))444 (list-push (attr 'user-name) result)) 443 445 ((?i) ; %i - profile_image 444 ( push (profile-image) result))446 (list-push (profile-image) result)) 445 447 ((?d) ; %d - description 446 ( push (attr 'user-description) result))448 (list-push (attr 'user-description) result)) 447 449 ((?l) ; %l - location 448 ( push (attr 'user-location) result))450 (list-push (attr 'user-location) result)) 449 451 ((?L) ; %L - " [location]" 450 452 (let ((location (attr 'user-location))) 451 453 (unless (or (null location) (string= "" location)) 452 ( push (concat " [" location "]") result)) ))454 (list-push (concat " [" location "]") result)) )) 453 455 ((?u) ; %u - url 454 ( push (attr 'user-url) result))456 (list-push (attr 'user-url) result)) 455 457 ((?j) ; %j - user.id 456 ( push (attr 'user-id) result))458 (list-push (attr 'user-id) result)) 457 459 ((?p) ; %p - protected? 458 460 (let ((protected (attr 'user-protected))) 459 461 (when (string= "true" protected) 460 ( push "[x]" result))))462 (list-push "[x]" result)))) 461 463 ((?c) ; %c - created_at (raw UTC string) 462 ( push (attr 'created-at) result))464 (list-push (attr 'created-at) result)) 463 465 ((?C) ; %C{time-format-str} - created_at (formatted with time-format-str) 464 ( push (twittering-local-strftime466 (list-push (twittering-local-strftime 465 467 (or (match-string-no-properties 2 format-str) "%H:%M:%S") 466 468 (attr 'created-at)) … … 474 476 (let ((secs (+ (* (- (car now) (car created-at)) 65536) 475 477 (- (cadr now) (cadr created-at))))) 476 ( push (cond ((< secs 5) "less than 5 seconds ago")478 (list-push (cond ((< secs 5) "less than 5 seconds ago") 477 479 ((< secs 10) "less than 10 seconds ago") 478 480 ((< secs 20) "less than 20 seconds ago") … … 488 490 result)))) 489 491 ((?t) ; %t - text 490 ( push ;(clickable-text)492 (list-push ;(clickable-text) 491 493 (attr 'text) 492 494 result)) … … 494 496 (let ((truncated (attr 'truncated))) 495 497 (when (string= "true" truncated) 496 ( push "..." result))))498 (list-push "..." result)))) 497 499 ((?f) ; %f - source 498 ( push (attr 'source) result))500 (list-push (attr 'source) result)) 499 501 ((?#) ; %# - id 500 ( push (attr 'id) result))502 (list-push (attr 'id) result)) 501 503 (t 502 ( push (char-to-string c) result)))504 (list-push (char-to-string c) result))) 503 505 ) 504 ( push (substring format-str cursor) result)506 (list-push (substring format-str cursor) result) 505 507 (apply 'concat (nreverse result)) 506 508 ))) … … 779 781 encoded-str cursor)) 780 782 (when (> found-at cursor) 781 ( push (substring encoded-str cursor found-at) result))783 (list-push (substring encoded-str cursor found-at) result)) 782 784 (let ((number-entity (match-string-no-properties 2 encoded-str)) 783 785 (letter-entity (match-string-no-properties 3 encoded-str))) 784 786 (cond (number-entity 785 ( push787 (list-push 786 788 (char-to-string 787 789 (twittering-ucs-to-char 788 790 (string-to-number number-entity))) result)) 789 791 (letter-entity 790 (cond ((string= "gt" letter-entity) ( push ">" result))791 ((string= "lt" letter-entity) ( push "<" result))792 (t push "?" result)))793 (t ( push "?" result)))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))) 794 796 (setq cursor (match-end 0)))) 795 ( push (substring encoded-str cursor) result)797 (list-push (substring encoded-str cursor) result) 796 798 (apply 'concat (nreverse result))) 797 799 "")) -
/lang/elisp/twittering-mode/branches/RB-0.3/ChangeLog
r11 r25 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 1 6 2008-02-08 Tsuyoshi CHO <Tsuyoshi.CHO+develop@Gmail.com> 2 7 -
/hh2008/hayamiz/trunk/hascheme/parser.scm
r15 r23 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))) 8 10 (define-class <ast-type-decl> (<ast-decl>) 9 11 ((left :init-keyword :left :getter type-decl-left) … … 14 16 (define-class <ast-single-type> (<ast-type>) 15 17 ((type-name :init-keyword :name :getter type-name) 16 (type-arity :init-keyword :arity :accessor type-arity )18 (type-arity :init-keyword :arity :accessor type-arity :init-value #f) 17 19 (type-vars :init-keyword :vars :accessor type-vars :init-value #f) 18 20 (type-module :init-keyword :module :getter type-module :init-value #f))) 19 21 (define-class <ast-multi-type> (<ast-type>) 20 22 ((types :init-keyword :name :accessor types))) 21 (define-class <ast-simple-type> (<ast>) ()) 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 22 27 (define-method make-type-decl ((left <ast-simple-type>) (right <ast-type>)) 23 ; (make <type-decl> :left left :right right) 24 `(:type-decl ,left ,right)) 28 (make <ast-type-decl> :left left :right right)) 25 29 26 30 (define (hascheme:parse str) … … 32 36 (Body <- "{" (:decls TopDecls) "}" :return decls) 33 37 (TopDecls <- Spaces* (:decl TopDecl) (:rest-decls TopDecls%) Spaces* 34 :return `(:decls ,decl ,@rest-decls)38 :return (make <ast-decls> :decls (cons decl rest-decls)) 35 39 / Spaces* :return ()) 36 40 (TopDecls% <- Spaces* ";" Spaces* TopDecl TopDecls% … … 75 79 ) 76 80 77 (FuncApplyExpression <- AtomExpression +) 81 (FuncApplyExpression 82 <- (:atom AtomExpression) 83 (:rest-atoms ((Spaces (:inatm AtomExpression) :return inatm) *)) 84 Spaces* :return `(:funapply ,atom ,@rest-atoms)) 78 85 (AtomExpression 79 86 <- QVar … … 109 116 / "~" Spaces* AtomPattern) 110 117 111 (QVar <- LexQVarId / "(" Spaces* LexQVarSym Spaces* ")") 118 (QVar <- LexQVarId 119 / "(" Spaces* (:sym LexQVarSym) Spaces* ")" :return sym) 112 120 (GCon <- "(" Spaces* ")" 113 121 / "[" Spaces* "]" … … 122 130 / LexQtyCls "(" LexTyVar AType + ")") 123 131 (SimpleType <- (:con LexTyCon) (:vars SimpleTypeVars) 124 :return `(:type-name ,con :vars ,vars))132 :return (make <ast-simple-type> :name con :vars vars)) 125 133 (SimpleTypeVars <- Spaces (:var LexTyVar) (:vars SimpleTypeVars) 126 134 :return (cons var vars) 127 135 / :return ()) 128 136 (Type <- (:type BType) Spaces* (:rest-types Type%) 129 :return `(:type ,type ,@rest-types)) 137 :return 138 (if (null? rest-types) 139 type 140 (make <ast-multi-type> :types (cons type rest-types)))) 130 141 (Type% <- "->" Spaces* (:type Type) (:rest-types Type%) 131 142 :return (cons type rest-types) 132 143 / :return ()) 133 144 (BType <- (:type AType) (:rest-types BType%) 134 :return (cons type rest-types)) 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")))) 135 153 (BType% <- Spaces (:type AType) (:rest-types BType%) 136 154 :return (cons type rest-types) … … 140 158 / "(" Spaces* (:t1 Type) Spaces* "," 141 159 Spaces* (:t2 Type) Spaces* (:rest AType%) ")" 142 :return (make <ast-si mple-type> :name '$Tuple160 :return (make <ast-single-type> :name '$Tuple 143 161 :arity (+ 2 (length rest)) 144 162 :vars `(,t1 ,t2 ,@rest)) 145 163 / "[" Spaces* Type Spaces* "]" 146 / "(" Spaces* Type Spaces* ")")164 / "(" Spaces* (:t Type) Spaces* ")" :return t) 147 165 (AType% <- "," Spaces* (:t Type) Spaces* (:rest AType%) 148 166 :return (cons t rest) 149 167 / :return ()) 150 (GtyCon <- LexQtyCon 168 (GtyCon <- (:tycon LexQtyCon) 169 :return (make <ast-single-type> :name (cadr tycon) 170 :module (car tycon)) 151 171 / "(" Spaces* ")" 152 :return (make <ast-single-type> :name '$Unit :arity 0 :vars ())172 :return (make <ast-single-type> :name '$Unit :arity 0) 153 173 / "[" Spaces* "]" 154 174 :return '(make <ast-single-type> :name '$Unit :arity 0) … … 204 224 (LexQConSym <- (LexModId ".") ? LexConSym) 205 225 (LexQtyCon <- (:mod ((LexModId ".") ?)) (:tycon LexTyCon) 206 :return (if mod `( :module ,(car mod) ,@tycon)207 `( :module #f ,@tycon)))226 :return (if mod `(,(car mod) ,tycon) 227 `(#f ,tycon))) 208 228 (LexQtyCls <- (LexModId ".") ? LexTyCls) 209 229 (LexGConSym <- ":" / LexQConSym ) … … 229 249 230 250 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 (cond 267 ((null? vars) (display (type-name ast))) 268 (else 269 (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 (cond 276 ((null? vars) (display (type-name ast))) 277 (else 278 (display (type-name ast)) 279 (for-each (lambda (var) 280 (cond 281 ((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 231 295 (define (hascheme:parser-test) 232 296 (test* "Simplest body" '(()) -
/hh2008/naoya_t/trunk/test.hs
r18 r22 1 main = putStrLn "Hello, World!" 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] 2 11 3 -- main = do { cs <- getContents ; print $ length $ lines cs } 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 4 18 5 19 firstNLines n cs = unlines $ take n $ lines cs 6 20 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] 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] 13 25 14 26 fib 0 = 0 … … 16 28 fib n = fib (n-1) + fib (n-2) 17 29 30 square n = n * n 31 triple a = a + a + a 32 33 main = putStrLn "Hello, World!" 34 35 main = print $ 5 * 6 - 7 36 -- main = print $ \x -> x * x $ 5 * 6 - 7 -
/hh2008/naoya_t/trunk/test.sh
r18 r22 1 1 #!/bin/sh 2 sed '/^$/d; /^--/d' test.hs | gosh -I. ihci.scm3 2 # sed '/^$/d; /^--/d' test.hs | gosh -I. ihci.scm 3 gosh -I. ihci.scm < test.hs -
/hh2008/naoya_t/trunk/ihci.scm
r18 r22 1 ;; 2 ;; IHC - Ikoma Haskell Compiler 3 ;; 1 4 (use srfi-1) 2 5 … … 23 26 [%body-char ($or %unescaped)] 24 27 [%string-body ($do (chars ($many %body-char)) 25 ($return (tag :string (list->string chars))))] 28 ; ($return (tag :string (list->string chars))))] 29 ($return (list->string chars)))] 26 30 ) 27 31 ($between %dquote %string-body %dquote))) 32 33 (define %char 34 ($do (($char #\')) 35 (($optional ($char #\\))) 36 (ch anychar) 37 (($char #\')) 38 ; ($return (tag :char ch)) 39 ($return ch) 40 )) 28 41 29 42 (define %ident ;; scheme-symbolで代用 … … 32 45 ($do (head %ident-head-char) 33 46 (rest ($many %ident-rest-char)) 47 ; ($return (tag :ident (string->symbol (list->string (cons head rest)))))))) 34 48 ($return (string->symbol (list->string (cons head rest))))))) 35 49 36 50 (define %digits 37 51 ($do (d ($many digit 1)) 38 ($return (tag :number (string->number (list->string d)))))) 52 ; ($return (tag :number (string->number (list->string d)))))) 53 ($return (string->number (list->string d))))) 39 54 40 55 (define %list 41 (let* ([%begin-list ($ seq %ws ($char #\[) %ws)]42 [%end-list ($ seq %ws ($char #\]) %ws)]56 (let* ([%begin-list ($char #\[)] 57 [%end-list ($char #\])] 43 58 [%item ($or %digits %string %ident)] 44 59 [%item-separator ($seq %ws ($char #\,) %ws)] … … 51 66 52 67 (define %tuple 53 (let* ([%begin-list ($ seq %ws ($char #\() %ws)]54 [%end-list ($ seq %ws ($char #\)) %ws)]68 (let* ([%begin-list ($char #\()] 69 [%end-list ($char #\))] 55 70 [%item ($or %digits %string %ident)] 56 71 [%item-separator ($seq %ws ($char #\,) %ws)] … … 62 77 )) 63 78 79 (define %atomic 80 ($or %string %char %digits %ident %list %tuple)) 81 82 (define (char->symbol ch) 83 (string->symbol (x->string ch))) 84 85 (define %infixed 86 (let1 %infix ($or ($one-of #[-+*/<>]) 87 ($string "==") ($string "<=") ($string ">=")) 88 ($do (item1 %atomic);($or %application %atomic)) ;%atomic) 89 ; (seq ($do %ws 90 ; (infix %infix) 91 ; %ws 92 ; (rest ($or %infixed %atomic)) 93 ; ($return (cons infix rest)))) 94 %ws 95 (infix %infix) 96 %ws 97 (item2 %atomic);($or %application %atomic)) ;%atomic) 98 (rest ($many ($do %ws 99 (infix %infix) 100 %ws 101 (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 %ws 117 ; (infix %infix) 118 ; %ws 119 ; (rest %infixed) 120 ; ($return (cons infix rest))) 121 ; ($do %ws 122 ; (infix %infix) 123 ; %ws 124 ; (rest %atomic) 125 ; ($return (list infix rest))) )) 126 ; ($return (tag :infixed (cons elem1 seq)))))) 127 64 128 (define %expr 65 ($or %string %digits %ident %list %tuple)) 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))))) 66 151 67 152 (define %application … … 69 154 ($do (fn %ident) 70 155 %ws 156 (arg1 ($or %expr 157 ($between ($char #\() %expr ($char #\))))) 158 %ws 71 159 (args ($my-sep-by %expr %ws)) 72 ($return `(:apply ,fn , @args)))73 ($do (app1 %an-application)160 ($return `(:apply ,fn ,arg1 ,@args))) 161 ($do (app1 ($or %infixed %an-application %lambda %ident)) 74 162 (apps ($many ($do %ws 75 (($char #\$)) 163 (($char #\$)) ; " $ " 76 164 %ws 77 (app %an-application)165 (app ($or %infixed %an-application %lambda %ident)) 78 166 ($return app)))) 79 167 ($return (if (= 0 (length apps)) app1 `(:$ ,app1 ,@apps)))))) 80 168 169 (define %lambda 170 ($do (($char #\\)) 171 (vars ($my-sep-by %ident %ws)) 172 %ws 173 (($string "->")) 174 %ws 175 (body ($or %do %infixed %application %expr)) 176 ($return (tag ':lambda (list vars body))))) 177 178 (define %assignment 179 ($do (id %ident) 180 %ws 181 (($string "<-")) 182 %ws 183 (value ($or %infixed %application %expr)) 184 ($return `(:assign ,id ,value)) 185 )) 186 187 (define %do 188 (let1 %do-line-separator ($seq %ws ($or ($seq newline ($string " ")) ($char #\;)) %ws) 189 ($do (($string "do")) 190 %ws 191 (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 %defun 200 ($do (id %ident) 201 %ws 202 (args ($my-sep-by %ident %ws)) 203 %ws 204 (($char #\=)) 205 %ws 206 (rightside ($or %do %infixed %application %expr)) 207 ($return `(:defun (,id ,@args) ,rightside)) 208 )) 209 210 (define %pattern 211 ($do (id %ident) 212 %ws 213 (args ($my-sep-by ($or %ident %digits) %ws)) 214 %ws 215 (($char #\=)) 216 %ws 217 (rightside ($or %do %infixed %application %expr)) 218 ($return `(:pattern (,id ,@args) ,rightside)) 219 )) 220 81 221 (define %haskell 82 222 (let* ([%unknown ($my-sep-by %expr %ws)] 83 84 [%assignment ($do (id %ident)85 %ws86 (($string "<-"))87 %ws88 (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 %ws94 (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 %ws104 (args ($my-sep-by %ident %ws))105 %ws106 (($char #\=))107 %ws108 (rightside ($or %do %application))109 ($return `(:defun (,id ,@args) ,rightside))110 )]111 [%pattern ($do (id %ident)112 %ws113 (args ($my-sep-by ($or %ident %digits) %ws))114 %ws115 (($char #\=))116 %ws117 (rightside ($or %do %application))118 ($return `(:pattern (,id ,@args) ,rightside))119 )]120 121 223 ) 122 ($or %defun %pattern %assignment %application %expr 123 %unknown) 224 ($or %comment %lambda %defun %pattern %assignment %infixed %if %application %expr 225 %unknown 226 newline) 124 227 )) 125 228 … … 134 237 ;(define ident-body untag) 135 238 239 (define lambda? (tagged?$ :lambda)) 240 136 241 (define (indent w lines) 137 242 (string-join (map (lambda (line) (string-append (make-string w #\space) (x->string line))) … … 143 248 (hash-table-put! *namespace* id val) 144 249 id) 145 (define (lookup id) 146 (let1 val (hash-table-get *namespace* id)147 ; 148 val))250 251 (define (lookup id env) 252 (let1 val (lookup-variable-value id env) 253 (if val val (hash-table-get *namespace* id)))) 149 254 150 255 ;; … … 155 260 (define (heval-map exps env) (map (cut heval <> env) exps)) 156 261 (define (heval exp env) 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))] ))) 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 )])) 207 332 208 333 (define (primitive-procedure? proc) … … 210 335 putStrLn 211 336 lines length print 212 tail))) 337 tail 338 * + - /))) 213 339 214 340 (define (prim-print exp) … … 223 349 (list->haskell-string (untag obj))] 224 350 [(pair? obj) (haskell-description-of-list obj)] 351 [(number? obj) (number->string obj)] 352 [(string? obj) obj] 225 353 [else (x->string obj)])) 226 227 354 (print (haskell-description exp))) 228 355 … … 236 363 (let1 args* (heval-map args '()) 237 364 (case proc 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*))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*)) 243 370 (string-length (car args*)) 244 (length (car args*)))) 245 ((tail) (prim-tail (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)] 246 379 ))) 247 380 … … 252 385 (define (procedure-environment proc) (fourth proc)) 253 386 387 ; SICP pp225-226 388 (define (enclosing-environment env) (cdr env)) 389 (define (first-frame env) (car env)) 390 (define the-empty-environment '()) 391 254 392 (define (make-frame vars vals) (cons vars vals)) 393 (define (frame-variables frame) (car frame)) 394 (define (frame-values frame) (cdr frame)) 255 395 256 396 (define (extend-environment vars vals base-env) 257 397 ;; assert-equal (length vars) (length vals) 258 398 (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)])) 259 420 260 421 (define (happly proc args) … … 265 426 args 266 427 (procedure-environment proc)) 267 (heval- map(procedure-body proc) env))]428 (heval-sequence (procedure-body proc) env))] 268 429 [else 269 430 ; … … 274 435 (let1 input (read-line) 275 436 (if (eof-object? input) 'eof 276 ( let1 parsed (parse-haskell input); (haskell->scheme input)277 ( let1 evaled (heval parsed '())437 (begin 438 (when (and (string? input) (< 0 (string-length input))) 278 439 (print "> " input) 279 (print "=> " parsed) 280 (print "" evaled)) 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 "")) 281 447 (repl))))) 282 448 283 (define (actual-value exp); env) 284 (force-it (heval exp '()))) 285 286 (let1 main (lookup 'main) 287 (print "----") 288 (happly main '()) 289 ) 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 )
