Create a gist now

Instantly share code, notes, and snippets.

What would you like to do?
$-expression for gauche
(define-module $exp-convert
(use srfi-1)
(use util.match)
(export
$exp-list->sexp)
;;; port->$exp-listで読まれたものをS式に変換する。
(define ($exp-list->sexp $exp)
($ reverse
$ (cut match-let1 ((-1 . s)) <> s)
$ shift-to -1
$ (cut fold bag <> $exp)
$ unshift -1 '()))
(define get-indent-level
caar)
(define (bag token stack)
(match-let1 (indent . elem) token
(match (cons elem (compare indent (get-indent-level stack)))
[(('paren . _) . 1) (unshift indent stack)]
[(('paren . _) . 0) (unshift indent (shift stack))]
[(('paren . _) . -1) (unshift indent (shift-to (- indent 1) stack))]
[(('token . s) . 1) (add s stack)]
[(('token . s) . 0) (add s (shift stack))]
[(('token . s) . -1) (add s (shift-to (- indent 1) stack))])))
(define (shift stack)
(match-let1 ((_ . list) (l . next) . rest) stack
`((,l . (,(reverse list) . ,next)) . ,rest)))
(define (unshift level stack)
`((,level . ()) . ,stack))
(define (shift-to level stack)
(do ([stack stack (shift stack)])
((>= level (get-indent-level stack)) stack)))
(define (add s stack)
(match-let1 ((l . list) . rest) stack
`((,l . (,s . ,list)) . ,rest)))
)
(define-module $exp-read
(use gauche.vport)
(use text.parse)
(export
string->$exp-list
port->$exp-list
read-$exp)
;;; 文字列から$式をすべて読み取る。
(define (string->$exp-list string)
(port->$exp-list (open-input-string string)))
;;; ポートが終わるまで$式をすべて読み取る。
(define (port->$exp-list port)
(port->list read-$exp (make-port-with-caret port)))
;;; ポートから$式のトークンをひとつ読み取る。
(define (read-$exp port)
(let* ([peek (skip-while #[\s] port)]
[column (port-current-column port)]
[token (read port)])
(if (eof-object? token)
token
(list* column (token-kind peek token) token))))
(define (token-kind peek token)
; $ opens parentheses. |$| is a symbol.
(if (and (eq? token '$) (not (eq? peek #\|)))
'paren
'token))
(define-class <port-with-caret> (<virtual-input-port>)
([line :init-value 0]
[column :init-value 0]))
(define-method port-current-line ((iport <port-with-caret>))
(ref iport 'line))
(define-method port-current-column ((iport <port-with-caret>))
(ref iport 'column))
(define (make-port-with-caret input-port)
(rec self
(make <port-with-caret>
:ready
(^ (kind)
((if kind char-ready? byte-ready?) input-port))
:seek
(^ (offset from)
(port-seek input-port offset from))
:getc
(^ ()
(let1 c (read-char input-port)
(cond
[(eq? #\newline c)
(inc! (ref self 'line))
(set! (ref self 'column) 0)]
[(not (eof-object? c))
(inc! (ref self 'column))])
c)))))
)
(import $exp-convert)
(import $exp-read)
(define (usage)
(format (current-error-port)
"Usage: ~a {- | file.$cm} [file.$cm ...]\n" *program-name*)
(exit 2))
(define ($exp-port->source-string port)
(string-join
(map write-to-string
($exp-list->sexp
(port->$exp-list port)))))
(define (main args)
(if (null? (cdr args))
(usage)
(for-each
(^ (source-file)
(let1 source
(if (equal? source-file "-")
($exp-port->source-string (current-input-port))
(call-with-input-file source-file $exp-port->source-string))
(call-with-input-string source load-from-port)))
(cdr args))))
$ define-module infer
$ use srfi-1
$ use srfi-27
$ use srfi-13
$ use util.match
$ use text.tr
$ export
infer
generate-expr
pretty-expr
<infer-error>
<infer-internal-error>
<infer-type-mismatch-error>
<infer-type-loop-error>
<infer-syntax-error>
$ select-module infer
$ define-class <infer> $
$ $ type-count :init-value -1
$ cxt :init-value '()
$ define-condition-type <infer-error> <error> #f
$ define-condition-type <infer-internal-error> <infer-error> #f
$ define-condition-type <infer-type-mismatch-error> <infer-error> #f
$ define-condition-type <infer-type-loop-error> <infer-error> #f
$ define-condition-type <infer-syntax-error> <infer-error> #f
$ define-method newtype! $ (self <infer>)
$ inc! $ ref self 'type-count
$ ref self 'type-count
$ define-method add-substitution! $ (self <infer>) var type
$ update! $ ref self 'cxt
$ ^ $ cxt
$ and-let $ $ entry $ assq var cxt
$ error <infer-internal-error> "already registered" entry
$ acons var type cxt
$ define-method infer $ expr env
$ infer (make <infer>) expr env
$ define-method infer $ (self <infer>) expr env
$ check-syntax expr
$ make-typevar-readable $ resolve self $ infer-raw self expr env
$ define-method infer-raw $ (self <infer>) expr env
$ let1 texpr $ newtype! self
$ check self texpr expr env
texpr
$ define $ number->symbol n
$ unless $ <= 0 n (- (* 26 27) 1)
$ error <infer-internal-error> #`"n must be between 0..,(- (* 26 27) 1)" n
$ string->symbol
$ tr "0-9a-p" "a-z"
$ (cut string-copy <> 1)
$ number->string (+ n (* 26 25)) 26
$ define $ memoize value-proc
$ let1 dict '()
$ ^ $ key
$ or $ assq-ref dict key
$ let1 value $ value-proc key
$ push! dict $ cons key value
value
$ define $ make-typevar-readable type
$ let1 count -1
$ rewrite-type type
$ memoize
$ ^_ $ inc! count
$ number->name count
$ define $ rewrite-type type lookup
$ let loop $ $ t type
$ cond
$ $ pair? type
$ map loop type
$ $ symbol? type
type
$ $ number? type
$ lookup type
$ else
$ error <infer-internal-error> "unexpected type:" type
$ define-method resolve $ (self <infer>) n
$ let1 cxt $ ref self 'cxt
$ let loop $ $ n n
$ history '()
$ cond
$ $ memq n history
$ raise <infer-type-loop-error> "loop detected" history n
$ $ number? n
$ let1 d $ assq-ref cxt n
$ if d
$ loop d $ cons n prev
n
$ $ pair? n
$ map (cut loop <> (cons n prev)) type
$ $ symbol? n
n
$ $ null? type
$ error <infer-internal-error> "definition not found" n prev
$ else
$ error <infer-internal-error> "unexpected query" n prev
$ define-method unify $ (self <infer>) a b
$ let $ $ a $ resolve self a
$ b $ resolve self b
$ cond
$ $ and (pair? a) (pair? b) (= (length a) (length b))
$ for-each (cut unify self <> <>) a b
$ $ and (number? a) (number? b)
; as both are tip (local minimum), ensured by resolve, we can just join the set
$ let1 t $ newtype! self
$ add-substitution! self a t
$ add-substitution! self b t
$ $ number? a
$ add-substitution! self a b
$ $ number? b
$ add-substitution! self b a
$ $ equal? a b
'ok
$ else
$ error <infer-type-mismatch-error> "type mismatch" a b
$ define-method unify-as-function $ (self <infer>) expected-type
$ let1 t $ resolve self expected-type
$ if $ pair? t
t
$ let1 pair $ cons $ newtype! self
$ newtype! self
$ unify self pair expected-type
pair
$ define $ refresh-type-variables type
$ rewrite-type type
$ memoize
$ ^n $ if $ >= n 0
n
$ newtype! self
$ define-method check $ (self <infer>) expected-type expr env
$ cond
$ $ symbol? expr
$ let1 t $ assq-ref (ref self 'env) expr
$ unless t
$ raise <infer-error> "type not found:" expr
$ unify self expected-type $ refresh-type-variables t
$ $ pair? expr
$ case $ car expr
$ $ ^
$ check-abs self expected-type expr env
$ $ let
$ check-let self expected-type expr env
$ else
$ check-app self expected-type expr env
$ $ number? expr
$ unify self expected-type 'num
$ $ boolean? expr
$ unify self expected-type 'bool
$ $ null? expr
$ unify self expected-type 'null
$ else
$ error <infer-internal-error> "unknown expression" expr
$ define $ generalize type env
$ let $ $ ftv $ collect-free-type-variables env
$ count 0
$ rewrite-type $ resolve type
$ memoize
$ ^t
$ if $ memq t ftv
t
$ begin
$ inc! count
$ - count
$ define $ collect-free-type-variables env
$ map resolve
$ filter $ every-pred number? ($ <= 0 $)
$ apply append
$ map cdr env
$ define-method check-let $ (self <infer>) expected-type expr env
; actually it's let1
$ match-let1 (_ var var-expr body) expr
$ let* $ $ tvar $ newtype! self
$ var-env $ acons var tvar newtype
$ check tvar var-expr var-env
$ let1 body-env $ acons var (generalize tvar var-env) var-env
$ check self expected-type body body-env
$ define-method check-app $ (self <infer>) expected-type expr env
$ let1 callee-type $ newtype! self
; currying
$ case $ length expr
$ [1] $ error <infer-syntax-error> "malformed application" expr
$ [2] $ check self callee-type (car expr) env
$ else $ check-app self callee-type (drop-right expr 1) env
$ match-let1 (targ . tresult) $ unify-as-function self callee-type
$ check self targ (last expr) env
$ unify self tresult expected-type
$ define-method check-abs $ (self <infer>) expected-type expr env
$ match-let1 (targ . tresult) $ unify-as-function self expected-type
$ match expr
$ (_ ((? symbol? arg) rest ..1) body)
$ check-abs self tresult `(^ ,rest ,body) $ acons arg targ env
$ (_ (or ((? symbol? arg)) (? symbol? arg)) body)
$ check self tresult body $ acons arg targ env
$ else
$ error <infer-syntax-error> "malformed lambda" expr
$ define $ check-syntax expr
$ match expr
$ $ _
$ error <infer-syntax-error> "application without argument is not allowed" expr
$ ('^ . args-and-body)
$ match args-and-body
$ ((or (? symbol?) ((? symbol?) ..1)) body)
$ check-syntax body
$ else
$ error <infer-syntax-error> "malformed lambda" expr
$ ('let . bind-and-body)
$ match bind-and-body
$ $ (? symbol?) bind-expr body
$ check-syntax bind-expr
$ check-syntax body
$ else
$ error <infer-syntax-error> "malformed let" expr
$ $ ? pair?
$ for-each check-syntax expr
$ else
'ok
$ define $ pretty-expr e
$ match e
$ $ '^ arg body
#`"(\\,arg -> ,(pretty-expr body))"
$ $ 'let var expr body
#`"(let ,var = ,(pretty-expr expr) in ,(pretty-expr body))"
$ $ ? pair?
#`"(,(string-join (map prety-expr e)))"
$ else
$ x->string e
$ define $ generate-expr depth
$ define var!
$ let1 count -1
$ ^ $
$ inc! count
$ number->name count
$ let loop $ $ depth depth
$ vars '()
$ case $ cond
$ $ < depth 0
2
$ $ and (= depth 0) (null? vars)
1
$ else
$ random-integer $ if (null? vars) 2 3
$ $ 0
$ list $ loop (- depth 1) vars
$ loop (- depth 1) vars
$ $ 1
$ let1 v $ var!
$ if $ zero? $ random-integer 1
$ list '^ v $ loop (- depth 1) $ cons v vars
$ list 'let v $ loop (- depth 1) $ cons v vars
$ loop (- depth 1) $ cons v vars
$ else
$ ref vars $ random-integer $ length vars
Owner

snipsnipsnip commented Dec 14, 2013

an evaluator of $-expression with a random source in $exp syntax for example.

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment