mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

unify variant types and records; also make-foo instead of <foo>

Browse source 
* module/system/base/syntax.scm (define-record): Rework to separate the
  type and its constructor. Now (define-record (<foo> bar)) will create
  `make-foo' as the constructor, not `<foo>'. Also the constructor now
  takes either keyword or positional arguments, so that it can be used as
  the implementation of variant types as well.
  (|): Map directly to define-record instead of rolling our own thing.

* module/language/scheme/translate.scm:
* module/system/base/language.scm:
* module/system/il/compile.scm:
* module/system/il/ghil.scm:
* module/system/il/glil.scm:
* module/system/repl/common.scm:
* module/system/vm/assemble.scm:
* module/system/vm/debug.scm: Change instances of record creation to use
  the make-foo procedures instead of <foo>. Adjust module exports as
  necessary.
This commit is contained in:
Andy Wingo 2008-05-03 18:32:46 +02:00
parent 1aa0dd2b45
commit 849cefacf1
9 changed files with 151 additions and 151 deletions
Download patch file Download diff file Expand all files Collapse all files

44
module/language/scheme/translate.scm
View file

@ -52,7 +52,7 @@
(call-with-ghil-environment (make-ghil-mod e) '() (call-with-ghil-environment (make-ghil-mod e) '()
(lambda (env vars) (lambda (env vars)
(<ghil-lambda> env #f vars #f (trans env #f x)))))) (make-ghil-lambda env #f vars #f (trans env #f x))))))
;;; ;;;
@ -139,9 +139,9 @@
((symbol? x) ((symbol? x)
(let ((y (symbol-expand x))) (let ((y (symbol-expand x)))
(if (symbol? y) (if (symbol? y)
(<ghil-ref> e l (ghil-lookup e y)) (make-ghil-ref e l (ghil-lookup e y))
(trans e l y)))) (trans e l y))))
(else (<ghil-quote> e l x)))) (else (make-ghil-quote e l x))))
(define (symbol-expand x) (define (symbol-expand x)
(let loop ((s (symbol->string x))) (let loop ((s (symbol->string x)))
@ -155,7 +155,7 @@
(define (trans:x x) (trans e l x)) (define (trans:x x) (trans e l x))
(define (trans:pair x) (trans-pair e l (car x) (cdr x))) (define (trans:pair x) (trans-pair e l (car x) (cdr x)))
(define (trans:body body) (trans-body e l body)) (define (trans:body body) (trans-body e l body))
(define (make:void) (<ghil-void> e l)) (define (make:void) (make-ghil-void e l))
(define (bad-syntax) (define (bad-syntax)
(syntax-error l (format #f "bad ~A" head) (cons head tail))) (syntax-error l (format #f "bad ~A" head) (cons head tail)))
(case head (case head
@ -168,26 +168,26 @@
;; (quote OBJ) ;; (quote OBJ)
((quote) ((quote)
(match tail (match tail
((obj) (<ghil-quote> e l obj)) ((obj) (make-ghil-quote e l obj))
(else (bad-syntax)))) (else (bad-syntax))))
;; (quasiquote OBJ) ;; (quasiquote OBJ)
((quasiquote) ((quasiquote)
(match tail (match tail
((obj) (<ghil-quasiquote> e l (trans-quasiquote e l obj))) ((obj) (make-ghil-quasiquote e l (trans-quasiquote e l obj)))
(else (bad-syntax)))) (else (bad-syntax))))
((define define-private) ((define define-private)
(match tail (match tail
;; (define NAME VAL) ;; (define NAME VAL)
(((? symbol? name) val) (((? symbol? name) val)
(<ghil-define> e l (ghil-lookup e name) (trans:x val))) (make-ghil-define e l (ghil-lookup e name) (trans:x val)))
;; (define (NAME FORMALS...) BODY...) ;; (define (NAME FORMALS...) BODY...)
((((? symbol? name) . formals) . body) ((((? symbol? name) . formals) . body)
;; -> (define NAME (lambda FORMALS BODY...)) ;; -> (define NAME (lambda FORMALS BODY...))
(let ((val (trans:x `(lambda ,formals ,@body)))) (let ((val (trans:x `(lambda ,formals ,@body))))
(<ghil-define> e l (ghil-lookup e name) val))) (make-ghil-define e l (ghil-lookup e name) val)))
(else (bad-syntax)))) (else (bad-syntax))))
@ -203,7 +203,7 @@
(match tail (match tail
;; (set! NAME VAL) ;; (set! NAME VAL)
(((? symbol? name) val) (((? symbol? name) val)
(<ghil-set> e l (ghil-lookup e name) (trans:x val))) (make-ghil-set e l (ghil-lookup e name) (trans:x val)))
;; (set! (NAME ARGS...) VAL) ;; (set! (NAME ARGS...) VAL)
((((? symbol? name) . args) val) ((((? symbol? name) . args) val)
@ -216,22 +216,22 @@
((if) ((if)
(match tail (match tail
((test then) ((test then)
(<ghil-if> e l (trans:x test) (trans:x then) (make:void))) (make-ghil-if e l (trans:x test) (trans:x then) (make:void)))
((test then else) ((test then else)
(<ghil-if> e l (trans:x test) (trans:x then) (trans:x else))) (make-ghil-if e l (trans:x test) (trans:x then) (trans:x else)))
(else (bad-syntax)))) (else (bad-syntax))))
;; (and EXPS...) ;; (and EXPS...)
((and) ((and)
(<ghil-and> e l (map trans:x tail))) (make-ghil-and e l (map trans:x tail)))
;; (or EXPS...) ;; (or EXPS...)
((or) ((or)
(<ghil-or> e l (map trans:x tail))) (make-ghil-or e l (map trans:x tail)))
;; (begin EXPS...) ;; (begin EXPS...)
((begin) ((begin)
(<ghil-begin> e l (map trans:x tail))) (make-ghil-begin e l (map trans:x tail)))
((let) ((let)
(match tail (match tail
@ -243,14 +243,14 @@
;; (let () BODY...) ;; (let () BODY...)
((() body ...) ((() body ...)
;; NOTE: This differs from `begin' ;; NOTE: This differs from `begin'
(<ghil-begin> e l (list (trans:body body)))) (make-ghil-begin e l (list (trans:body body))))
;; (let ((SYM VAL) ...) BODY...) ;; (let ((SYM VAL) ...) BODY...)
(((((? symbol? sym) val) ...) body ...) (((((? symbol? sym) val) ...) body ...)
(let ((vals (map trans:x val))) (let ((vals (map trans:x val)))
(call-with-ghil-bindings e sym (call-with-ghil-bindings e sym
(lambda (vars) (lambda (vars)
(<ghil-bind> e l vars vals (trans:body body)))))) (make-ghil-bind e l vars vals (trans:body body))))))
(else (bad-syntax)))) (else (bad-syntax))))
@ -270,7 +270,7 @@
(call-with-ghil-bindings e sym (call-with-ghil-bindings e sym
(lambda (vars) (lambda (vars)
(let ((vals (map trans:x val))) (let ((vals (map trans:x val)))
(<ghil-bind> e l vars vals (trans:body body)))))) (make-ghil-bind e l vars vals (trans:body body))))))
(else (bad-syntax)))) (else (bad-syntax))))
;; (cond (CLAUSE BODY...) ...) ;; (cond (CLAUSE BODY...) ...)
@ -321,7 +321,7 @@
(receive (syms rest) (parse-formals formals) (receive (syms rest) (parse-formals formals)
(call-with-ghil-environment e syms (call-with-ghil-environment e syms
(lambda (env vars) (lambda (env vars)
(<ghil-lambda> env l vars rest (trans-body env l body)))))) (make-ghil-lambda env l vars rest (trans-body env l body))))))
(else (bad-syntax)))) (else (bad-syntax))))
((eval-case) ((eval-case)
@ -339,11 +339,11 @@
(else (else
(if (memq head %scheme-primitives) (if (memq head %scheme-primitives)
(<ghil-inline> e l head (map trans:x tail)) (make-ghil-inline e l head (map trans:x tail))
(if (memq head %forbidden-primitives) (if (memq head %forbidden-primitives)
(syntax-error l (format #f "`~a' is forbidden" head) (syntax-error l (format #f "`~a' is forbidden" head)
(cons head tail)) (cons head tail))
(<ghil-call> e l (trans:x head) (map trans:x tail))))))) (make-ghil-call e l (trans:x head) (map trans:x tail)))))))
(define (trans-quasiquote e l x) (define (trans-quasiquote e l x)
(cond ((not (pair? x)) x) (cond ((not (pair? x)) x)
@ -352,8 +352,8 @@
(match (cdr x) (match (cdr x)
((obj) ((obj)
(if (eq? (car x) 'unquote) (if (eq? (car x) 'unquote)
(<ghil-unquote> e l (trans e l obj)) (make-ghil-unquote e l (trans e l obj))
(<ghil-unquote-splicing> e l (trans e l obj)))) (make-ghil-unquote-splicing e l (trans e l obj))))
(else (syntax-error l (format #f "bad ~A" (car x)) x))))) (else (syntax-error l (format #f "bad ~A" (car x)) x)))))
(else (cons (trans-quasiquote e l (car x)) (else (cons (trans-quasiquote e l (car x))
(trans-quasiquote e l (cdr x)))))) (trans-quasiquote e l (cdr x))))))

2
module/system/base/language.scm
View file

@ -36,7 +36,7 @@
)) ))
(define-macro (define-language name . spec) (define-macro (define-language name . spec)
`(define ,name (,<language> :name ',name ,@spec))) `(define ,name (,make-language :name ',name ,@spec)))
(define (lookup-language name) (define (lookup-language name)
(let ((m (resolve-module `(language ,name spec)))) (let ((m (resolve-module `(language ,name spec))))

79
module/system/base/syntax.scm
View file

@ -73,17 +73,22 @@
;;; Record ;;; Record
;;; ;;;
(define (symbol-trim-both sym pred)
(string->symbol (string-trim-both (symbol->string sym) pred)))
(define-macro (define-record def) (define-macro (define-record def)
(let ((name (car def)) (slots (cdr def))) (let* ((name (car def)) (slots (cdr def))
(stem (symbol-trim-both name (list->char-set '(#\< #\>)))))
`(begin `(begin
(define (,name . args) (define ,(symbol-append 'make- stem)
(vector ',name (%make-struct (let ((slots (list ,@(map (lambda (slot)
args (if (pair? slot)
(list ,@(map (lambda (slot) `(cons ',(car slot) ,(cadr slot))
(if (pair? slot) `',slot))
`(cons ',(car slot) ,(cadr slot)) slots))))
`',slot)) (lambda args
slots))))) (vector ',name (%make-struct args slots)))))
(define (,(symbol-append name '?) x) (define (,(symbol-append name '?) x)
(and (vector? x) (eq? (vector-ref x 0) ',name))) (and (vector? x) (eq? (vector-ref x 0) ',name)))
,@(do ((n 1 (1+ n)) ,@(do ((n 1 (1+ n))
@ -96,22 +101,32 @@
ls))) ls)))
((null? slots) (reverse! ls)))))) ((null? slots) (reverse! ls))))))
(define *unbound* "#<unbound>")
(define (%make-struct args slots) (define (%make-struct args slots)
(map (lambda (slot) (define (finish-bindings out)
(let* ((key (if (pair? slot) (car slot) slot)) (map (lambda (slot)
(def (if (pair? slot) (cdr slot) *unbound*)) (let ((name (if (pair? slot) (car slot) slot)))
(val (get-key args (symbol->keyword key) def))) (or (assq name out)
(if (eq? val *unbound*) (if (pair? slot)
(error "slot unbound" key) (cons name (cdr slot))
(cons key val)))) (error "unbound slot" args slots name)))))
slots)) slots))
(let lp ((in args) (positional slots) (out '()))
(define (get-key klist key def) (cond
(do ((ls klist (cddr ls))) ((null? in)
((or (null? ls) (eq? (car ls) key)) (finish-bindings out))
(if (null? ls) def (cadr ls))))) ((keyword? (car in))
(let ((sym (keyword->symbol (car in))))
(cond
((and (not (memq sym slots))
(not (assq sym (filter pair? slots))))
(error "unknown slot" sym))
((assq sym out) (error "slot already set" sym out))
(else (lp (cddr in) '() (acons sym (cadr in) out))))))
((null? positional)
(error "too many initargs" args slots))
(else
(lp (cdr in) (cdr positional)
(acons (car positional) (car in) out))))))
(define (get-slot struct name . names) (define (get-slot struct name . names)
(let ((data (assq name (vector-ref struct 1)))) (let ((data (assq name (vector-ref struct 1))))
@ -134,21 +149,7 @@
;;; ;;;
(define-macro (| . rest) (define-macro (| . rest)
`(begin ,@(map %make-variant-type rest))) `(begin ,@(map (lambda (def) `(define-record ,def)) rest)))
(define (%make-variant-type def)
(let ((name (car def)) (slots (cdr def)))
`(begin
(define ,def (vector ',name ,@slots))
(define (,(symbol-append name '?) x)
(and (vector? x) (eq? (vector-ref x 0) ',name)))
,@(do ((n 1 (1+ n))
(slots slots (cdr slots))
(ls '() (cons `(define ,(string->symbol
(format #f "~A-~A" name n))
,(string->symbol (format #f "%slot-~A" n)))
ls)))
((null? slots) (reverse! ls))))))
(define (%slot-1 x) (vector-ref x 1)) (define (%slot-1 x) (vector-ref x 1))
(define (%slot-2 x) (vector-ref x 2)) (define (%slot-2 x) (vector-ref x 2))

64
module/system/il/compile.scm
View file

@ -39,23 +39,23 @@
(define (optimize x) (define (optimize x)
(match x (match x
(($ <ghil-set> env var val) (($ <ghil-set> env var val)
(<ghil-set> env var (optimize val))) (make-ghil-set env var (optimize val)))
(($ <ghil-if> test then else) (($ <ghil-if> test then else)
(<ghil-if> (optimize test) (optimize then) (optimize else))) (make-ghil-if (optimize test) (optimize then) (optimize else)))
(($ <ghil-begin> exps) (($ <ghil-begin> exps)
(<ghil-begin> (map optimize exps))) (make-ghil-begin (map optimize exps)))
(($ <ghil-bind> env vars vals body) (($ <ghil-bind> env vars vals body)
(<ghil-bind> env vars (map optimize vals) (optimize body))) (make-ghil-bind env vars (map optimize vals) (optimize body)))
(($ <ghil-lambda> env vars rest body) (($ <ghil-lambda> env vars rest body)
(<ghil-lambda> env vars rest (optimize body))) (make-ghil-lambda env vars rest (optimize body)))
;; FIXME: <ghil-inst> does not exist. -- Ludo'. ;; FIXME: <ghil-inst> does not exist. -- Ludo'.
; (($ <ghil-inst> inst args) ; (($ <ghil-inst> inst args)
; (<ghil-inst> inst (map optimize args))) ; (make-ghil-inst inst (map optimize args)))
(($ <ghil-call> env proc args) (($ <ghil-call> env proc args)
(match proc (match proc
@ -67,9 +67,9 @@
(set! v.env env) (set! v.env env)
(ghil-env-add! env v)) (ghil-env-add! env v))
lambda-env.variables) lambda-env.variables)
(optimize (<ghil-bind> env vars args body))) (optimize (make-ghil-bind env vars args body)))
(else (else
(<ghil-call> env (optimize proc) (map optimize args))))) (make-ghil-call env (optimize proc) (map optimize args)))))
(else x))) (else x)))
@ -77,25 +77,25 @@
;;; Stage 3: Code generation ;;; Stage 3: Code generation
;;; ;;;
(define *ia-void* (<glil-void>)) (define *ia-void* (make-glil-void))
(define *ia-drop* (<glil-call> 'drop 0)) (define *ia-drop* (make-glil-call 'drop 0))
(define *ia-return* (<glil-call> 'return 0)) (define *ia-return* (make-glil-call 'return 0))
(define (make-label) (gensym ":L")) (define (make-label) (gensym ":L"))
(define (make-glil-var op env var) (define (make-glil-var op env var)
(case var.kind (case var.kind
((argument) ((argument)
(<glil-argument> op var.index)) (make-glil-argument op var.index))
((local) ((local)
(<glil-local> op var.index)) (make-glil-local op var.index))
((external) ((external)
(do ((depth 0 (1+ depth)) (do ((depth 0 (1+ depth))
(e env e.parent)) (e env e.parent))
((eq? e var.env) ((eq? e var.env)
(<glil-external> op depth var.index)))) (make-glil-external op depth var.index))))
((module) ((module)
(<glil-module> op var.env var.name)) (make-glil-module op var.env var.name))
(else (error "Unknown kind of variable:" var)))) (else (error "Unknown kind of variable:" var))))
(define (codegen ghil) (define (codegen ghil)
@ -104,13 +104,13 @@
(set! stack (cons code stack))) (set! stack (cons code stack)))
(define (comp tree tail drop) (define (comp tree tail drop)
(define (push-label! label) (define (push-label! label)
(push-code! (<glil-label> label))) (push-code! (make-glil-label label)))
(define (push-branch! inst label) (define (push-branch! inst label)
(push-code! (<glil-branch> inst label))) (push-code! (make-glil-branch inst label)))
(define (push-call! loc inst args) (define (push-call! loc inst args)
(for-each comp-push args) (for-each comp-push args)
(push-code! (<glil-call> inst (length args))) (push-code! (make-glil-call inst (length args)))
(push-code! (<glil-source> loc))) (push-code! (make-glil-source loc)))
;; possible tail position ;; possible tail position
(define (comp-tail tree) (comp tree tail drop)) (define (comp-tail tree) (comp tree tail drop))
;; push the result ;; push the result
@ -132,7 +132,7 @@
(return-code! *ia-void*)) (return-code! *ia-void*))
;; return object if necessary ;; return object if necessary
(define (return-object! obj) (define (return-object! obj)
(return-code! (<glil-const> obj))) (return-code! (make-glil-const obj)))
;; ;;
;; dispatch ;; dispatch
(match tree (match tree
@ -152,14 +152,14 @@
((? pair? pp) ((? pair? pp)
(loop (car pp)) (loop (car pp))
(loop (cdr pp)) (loop (cdr pp))
(push-code! (<glil-call> 'cons 2))) (push-code! (make-glil-call 'cons 2)))
(($ <ghil-unquote> env loc exp) (($ <ghil-unquote> env loc exp)
(comp-push exp)) (comp-push exp))
(($ <ghil-unquote-splicing> env loc exp) (($ <ghil-unquote-splicing> env loc exp)
(comp-push exp) (comp-push exp)
(push-call! #f 'list-break '())) (push-call! #f 'list-break '()))
(else (else
(push-code! (<glil-const> x))))) (push-code! (make-glil-const x)))))
(maybe-drop) (maybe-drop)
(maybe-return)) (maybe-return))
@ -253,11 +253,11 @@
;; BODY ;; BODY
(for-each comp-push vals) (for-each comp-push vals)
(let ((vars (map (lambda (v) (list v.name v.kind v.index)) vars))) (let ((vars (map (lambda (v) (list v.name v.kind v.index)) vars)))
(if (not (null? vars)) (push-code! (<glil-bind> vars)))) (if (not (null? vars)) (push-code! (make-glil-bind vars))))
(for-each (lambda (var) (push-code! (make-glil-var 'set env var))) (for-each (lambda (var) (push-code! (make-glil-var 'set env var)))
(reverse vars)) (reverse vars))
(comp-tail body) (comp-tail body)
(push-code! (<glil-unbind>))) (push-code! (make-glil-unbind)))
(($ <ghil-lambda> env loc vars rest body) (($ <ghil-lambda> env loc vars rest body)
(return-code! (codegen tree))) (return-code! (codegen tree)))
@ -289,23 +289,23 @@
(finalize-index! exts) (finalize-index! exts)
;; meta bindings ;; meta bindings
(let ((vars (map (lambda (v) (list v.name v.kind v.index)) args))) (let ((vars (map (lambda (v) (list v.name v.kind v.index)) args)))
(if (not (null? vars)) (push-code! (<glil-bind> vars)))) (if (not (null? vars)) (push-code! (make-glil-bind vars))))
;; export arguments ;; export arguments
(do ((n 0 (1+ n)) (do ((n 0 (1+ n))
(l args (cdr l))) (l args (cdr l)))
((null? l)) ((null? l))
(let ((v (car l))) (let ((v (car l)))
(cond ((eq? v.kind 'external) (cond ((eq? v.kind 'external)
(push-code! (<glil-argument> 'ref n)) (push-code! (make-glil-argument 'ref n))
(push-code! (<glil-external> 'set 0 v.index)))))) (push-code! (make-glil-external 'set 0 v.index))))))
;; compile body ;; compile body
(comp body #t #f) (comp body #t #f)
;; create GLIL ;; create GLIL
(let ((vars (<glil-vars> :nargs (length args) (let ((vars (make-glil-vars :nargs (length args)
:nrest (if rest 1 0) :nrest (if rest 1 0)
:nlocs (length locs) :nlocs (length locs)
:nexts (length exts)))) :nexts (length exts))))
(<glil-asm> vars (reverse! stack)))))))) (make-glil-asm vars (reverse! stack))))))))
(define (finalize-index! list) (define (finalize-index! list)
(do ((n 0 (1+ n)) (do ((n 0 (1+ n))

47
module/system/il/ghil.scm
View file

@ -25,33 +25,33 @@
:use-module (ice-9 regex) :use-module (ice-9 regex)
:export :export
( (
<ghil-void> <ghil-void>? <ghil-void>-1 <ghil-void>-2 <ghil-void> make-ghil-void <ghil-void>? <ghil-void>-1 <ghil-void>-2
<ghil-quote> <ghil-quote>? <ghil-quote>-1 <ghil-quote>-2 <ghil-quote>-3 <ghil-quote> make-ghil-quote <ghil-quote>? <ghil-quote>-1 <ghil-quote>-2 <ghil-quote>-3
<ghil-quasiquote> <ghil-quasiquote>? <ghil-quasiquote> make-ghil-quasiquote <ghil-quasiquote>?
<ghil-quasiquote>-1 <ghil-quasiquote>-2 <ghil-quasiquote>-3 <ghil-quasiquote>-1 <ghil-quasiquote>-2 <ghil-quasiquote>-3
<ghil-unquote> <ghil-unquote>? <ghil-unquote> make-ghil-unquote <ghil-unquote>?
<ghil-unquote>-1 <ghil-unquote>-2 <ghil-unquote>-3 <ghil-unquote>-1 <ghil-unquote>-2 <ghil-unquote>-3
<ghil-unquote-splicing> <ghil-unquote-splicing>? <ghil-unquote-splicing> make-ghil-unquote-splicing <ghil-unquote-splicing>?
<ghil-unquote-splicing>-1 <ghil-unquote-splicing>-2 <ghil-unquote-splicing>-1 <ghil-unquote-splicing>-2
<ghil-unquote-splicing>-3 <ghil-unquote-splicing>-3
<ghil-ref> <ghil-ref>? <ghil-ref>-1 <ghil-ref>-2 <ghil-ref>-3 <ghil-ref> make-ghil-ref <ghil-ref>? <ghil-ref>-1 <ghil-ref>-2 <ghil-ref>-3
<ghil-set> <ghil-set>? <ghil-set>-1 <ghil-set>-2 <ghil-set>-3 <ghil-set>-4 <ghil-set> make-ghil-set <ghil-set>? <ghil-set>-1 <ghil-set>-2 <ghil-set>-3 <ghil-set>-4
<ghil-define> <ghil-define>? <ghil-define> make-ghil-define <ghil-define>?
<ghil-define>-1 <ghil-define>-2 <ghil-define>-3 <ghil-define>-4 <ghil-define>-1 <ghil-define>-2 <ghil-define>-3 <ghil-define>-4
<ghil-if> <ghil-if>? <ghil-if> make-ghil-if <ghil-if>?
<ghil-if>-1 <ghil-if>-2 <ghil-if>-3 <ghil-if>-4 <ghil-if>-5 <ghil-if>-1 <ghil-if>-2 <ghil-if>-3 <ghil-if>-4 <ghil-if>-5
<ghil-and> <ghil-and>? <ghil-and>-1 <ghil-and>-2 <ghil-and>-3 <ghil-and> make-ghil-and <ghil-and>? <ghil-and>-1 <ghil-and>-2 <ghil-and>-3
<ghil-or> <ghil-or>? <ghil-or>-1 <ghil-or>-2 <ghil-or>-3 <ghil-or> make-ghil-or <ghil-or>? <ghil-or>-1 <ghil-or>-2 <ghil-or>-3
<ghil-begin> <ghil-begin>? <ghil-begin>-1 <ghil-begin>-2 <ghil-begin>-3 <ghil-begin> make-ghil-begin <ghil-begin>? <ghil-begin>-1 <ghil-begin>-2 <ghil-begin>-3
<ghil-bind> <ghil-bind>? <ghil-bind> make-ghil-bind <ghil-bind>?
<ghil-bind>-1 <ghil-bind>-2 <ghil-bind>-3 <ghil-bind>-4 <ghil-bind>-5 <ghil-bind>-1 <ghil-bind>-2 <ghil-bind>-3 <ghil-bind>-4 <ghil-bind>-5
<ghil-lambda> <ghil-lambda>? <ghil-lambda>-1 <ghil-lambda>-2 <ghil-lambda> make-ghil-lambda <ghil-lambda>? <ghil-lambda>-1 <ghil-lambda>-2
<ghil-lambda>-3 <ghil-lambda>-4 <ghil-lambda>-5 <ghil-lambda>-3 <ghil-lambda>-4 <ghil-lambda>-5
<ghil-inline> <ghil-inline>? <ghil-inline> make-ghil-inline <ghil-inline>?
<ghil-inline>-1 <ghil-inline>-2 <ghil-inline>-3 <ghil-inline>-4 <ghil-inline>-1 <ghil-inline>-2 <ghil-inline>-3 <ghil-inline>-4
<ghil-call> <ghil-call>? <ghil-call> make-ghil-call <ghil-call>?
<ghil-call>-1 <ghil-call>-2 <ghil-call>-3 <ghil-call>-4 <ghil-call>-1 <ghil-call>-2 <ghil-call>-3 <ghil-call>-4
)) ))
@ -112,9 +112,7 @@
;;; ;;;
(define-record (<ghil-var> env name kind (type #f) (value #f) (index #f))) (define-record (<ghil-var> env name kind (type #f) (value #f) (index #f)))
(export make-ghil-var)
(define-public (make-ghil-var env name kind)
(<ghil-var> :env env :name name :kind kind))
;;; ;;;
@ -122,9 +120,7 @@
;;; ;;;
(define-record (<ghil-mod> module (table '()) (imports '()))) (define-record (<ghil-mod> module (table '()) (imports '())))
(export make-ghil-mod)
(define-public (make-ghil-mod module)
(<ghil-mod> :module module))
;;; ;;;
@ -133,10 +129,11 @@
(define-record (<ghil-env> mod parent (table '()) (variables '()))) (define-record (<ghil-env> mod parent (table '()) (variables '())))
(define %make-ghil-env make-ghil-env)
(define-public (make-ghil-env e) (define-public (make-ghil-env e)
(match e (record-case e
(($ <ghil-mod>) (<ghil-env> :mod e :parent e)) ((<ghil-mod>) (%make-ghil-env :mod e :parent e))
(($ <ghil-env> m) (<ghil-env> :mod m :parent e)))) ((<ghil-env> m) (%make-ghil-env :mod m :parent e))))
(define (ghil-env-toplevel? e) (define (ghil-env-toplevel? e)
(eq? e.mod e.parent)) (eq? e.mod e.parent))

28
module/system/il/glil.scm
View file

@ -24,26 +24,26 @@
:use-module (ice-9 match) :use-module (ice-9 match)
:export :export
(pprint-glil (pprint-glil
<glil-vars> <glil-vars> make-glil-vars
<glil-asm> <glil-asm>? <glil-asm> make-glil-asm <glil-asm>?
<glil-asm>-1 <glil-asm>-2 <glil-asm>-3 <glil-asm>-4 <glil-asm>-5 <glil-asm>-1 <glil-asm>-2 <glil-asm>-3 <glil-asm>-4 <glil-asm>-5
<glil-bind> <glil-bind>? <glil-bind>-1 <glil-bind> make-glil-bind <glil-bind>? <glil-bind>-1
<glil-unbind> <glil-unbind>? <glil-unbind> make-glil-unbind <glil-unbind>?
<glil-source> <glil-source>? <glil-source>-1 <glil-source>-2 <glil-source> make-glil-source <glil-source>? <glil-source>-1 <glil-source>-2
<glil-void> <glil-void>? <glil-void> make-glil-void <glil-void>?
<glil-const> <glil-const>? <glil-const>-1 <glil-const> make-glil-const <glil-const>? <glil-const>-1
<glil-argument> <glil-argument>? <glil-argument>-1 <glil-argument>-2 <glil-argument> make-glil-argument <glil-argument>? <glil-argument>-1 <glil-argument>-2
<glil-local> <glil-local>? <glil-local>-1 <glil-local>-2 <glil-local> make-glil-local <glil-local>? <glil-local>-1 <glil-local>-2
<glil-external> <glil-external>? <glil-external> make-glil-external <glil-external>?
<glil-external>-1 <glil-external>-2 <glil-external>-3 <glil-external>-1 <glil-external>-2 <glil-external>-3
<glil-module> <glil-module>? <glil-module> make-glil-module <glil-module>?
<glil-module>-1 <glil-module>-2 <glil-module>-3 <glil-module>-1 <glil-module>-2 <glil-module>-3
<glil-label> <glil-label>? <glil-label>-1 <glil-label> make-glil-label <glil-label>? <glil-label>-1
<glil-branch> <glil-branch>? <glil-branch>-1 <glil-branch>-2 <glil-branch> make-glil-branch <glil-branch>? <glil-branch>-1 <glil-branch>-2
<glil-call> <glil-call>? <glil-call>-1 <glil-call>-2 <glil-call> make-glil-call <glil-call>? <glil-call>-1 <glil-call>-2
)) ))
(define-record (<glil-vars> nargs nrest nlocs nexts)) (define-record (<glil-vars> nargs nrest nlocs nexts))

11
module/system/repl/common.scm
View file

@ -35,15 +35,16 @@
(define repl-default-options (define repl-default-options
'((trace . #f))) '((trace . #f)))
(define %make-repl make-repl)
(define-public (make-repl lang) (define-public (make-repl lang)
(let ((cenv (make-cenv :vm (the-vm) (let ((cenv (make-cenv :vm (the-vm)
:language (lookup-language lang) :language (lookup-language lang)
:module (current-module)))) :module (current-module))))
(<repl> :env cenv (%make-repl :env cenv
:options repl-default-options :options repl-default-options
:tm-stats (times) :tm-stats (times)
:gc-stats (gc-stats) :gc-stats (gc-stats)
:vm-stats (vm-stats cenv.vm)))) :vm-stats (vm-stats cenv.vm))))
(define-public (repl-welcome repl) (define-public (repl-welcome repl)
(format #t "~A interpreter ~A on Guile ~A\n" (format #t "~A interpreter ~A on Guile ~A\n"

24
module/system/vm/assemble.scm
View file

@ -55,9 +55,9 @@
(define (preprocess x e) (define (preprocess x e)
(record-case x (record-case x
((<glil-asm> vars body) ((<glil-asm> vars body)
(let* ((venv (<venv> :parent e :nexts (slot vars 'nexts) :closure? #f)) (let* ((venv (make-venv :parent e :nexts (slot vars 'nexts) :closure? #f))
(body (map (lambda (x) (preprocess x venv)) body))) (body (map (lambda (x) (preprocess x venv)) body)))
(<vm-asm> :venv venv :glil x :body body))) (make-vm-asm :venv venv :glil x :body body)))
((<glil-external> op depth index) ((<glil-external> op depth index)
(do ((d depth (- d 1)) (do ((d depth (- d 1))
(e e (slot e 'parent))) (e e (slot e 'parent)))
@ -147,7 +147,7 @@
(push-code! `(external-set ,(+ n index))))))) (push-code! `(external-set ,(+ n index)))))))
((<glil-module> op module name) ((<glil-module> op module name)
(push-object! (<vlink> :module #f :name name)) (push-object! (make-vlink :module #f :name name))
(if (eq? op 'ref) (if (eq? op 'ref)
(push-code! '(variable-ref)) (push-code! '(variable-ref))
(push-code! '(variable-set)))) (push-code! '(variable-set))))
@ -175,15 +175,15 @@
(let ((bytes (stack->bytes (reverse! stack) label-alist))) (let ((bytes (stack->bytes (reverse! stack) label-alist)))
(if toplevel (if toplevel
(bytecode->objcode bytes vars.nlocs vars.nexts) (bytecode->objcode bytes vars.nlocs vars.nexts)
(<bytespec> :vars vars :bytes bytes (make-bytespec :vars vars :bytes bytes
:meta (if (and (null? binding-alist) :meta (if (and (null? binding-alist)
(null? source-alist)) (null? source-alist))
#f #f
(cons (reverse! binding-alist) (cons (reverse! binding-alist)
(reverse! source-alist))) (reverse! source-alist)))
:objs (let ((objs (map car (reverse! object-alist)))) :objs (let ((objs (map car (reverse! object-alist))))
(if (null? objs) #f (list->vector objs))) (if (null? objs) #f (list->vector objs)))
:closure? venv.closure?))))))))) :closure? venv.closure?)))))))))
(define (object-assoc x alist) (define (object-assoc x alist)
(record-case x (record-case x

3
module/system/vm/debug.scm
View file

@ -38,7 +38,8 @@
(let ((chain (vm-last-frame-chain vm))) (let ((chain (vm-last-frame-chain vm)))
(if (null? chain) (if (null? chain)
(display "Nothing to debug\n") (display "Nothing to debug\n")
(debugger-repl (<debugger> :vm vm :chain chain :index (length chain)))))) (debugger-repl (make-debugger
:vm vm :chain chain :index (length chain))))))
(define (debugger-repl db) (define (debugger-repl db)
(let loop () (let loop ()