module/system/il/ghil.scm

   1 ;;; Guile High Intermediate Language
   2
   3 ;; Copyright (C) 2001 Free Software Foundation, Inc.
   4
   5 ;; This program is free software; you can redistribute it and/or modify
   6 ;; it under the terms of the GNU General Public License as published by
   7 ;; the Free Software Foundation; either version 2, or (at your option)
   8 ;; any later version.
   9 ;;
  10 ;; This program is distributed in the hope that it will be useful,
  11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 ;; GNU General Public License for more details.
  14 ;;
  15 ;; You should have received a copy of the GNU General Public License
  16 ;; along with this program; see the file COPYING.  If not, write to
  17 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  18 ;; Boston, MA 02111-1307, USA.
  19
  20 ;;; Code:
  21
  22 (define-module (system il ghil)
  23   :use-syntax (system base syntax)
  24   :use-module (ice-9 regex)
  25   :export
  26   (<ghil-void> make-ghil-void ghil-void?
  27    ghil-void-env ghil-void-loc
  28
  29    <ghil-quote> make-ghil-quote ghil-quote?
  30    ghil-quote-env ghil-quote-loc ghil-quote-obj
  31
  32    <ghil-quasiquote> make-ghil-quasiquote ghil-quasiquote?
  33    ghil-quasiquote-env ghil-quasiquote-loc ghil-quasiquote-exp
  34
  35    <ghil-unquote> make-ghil-unquote ghil-unquote?
  36    ghil-unquote-env ghil-unquote-loc ghil-unquote-exp
  37
  38    <ghil-unquote-splicing> make-ghil-unquote-splicing ghil-unquote-splicing?
  39    ghil-unquote-env ghil-unquote-loc ghil-unquote-exp
  40
  41    <ghil-ref> make-ghil-ref ghil-ref?
  42    ghil-ref-env ghil-ref-loc ghil-ref-var
  43
  44    <ghil-set> make-ghil-set ghil-set?
  45    ghil-set-env ghil-set-loc ghil-set-var ghil-set-val
  46
  47    <ghil-define> make-ghil-define ghil-define?
  48    ghil-define-env ghil-define-loc ghil-define-var ghil-define-val
  49
  50    <ghil-if> make-ghil-if ghil-if?
  51    ghil-if-env ghil-if-loc ghil-if-test ghil-if-then ghil-if-else
  52
  53    <ghil-and> make-ghil-and ghil-and?
  54    ghil-and-env ghil-and-loc ghil-and-exps
  55
  56    <ghil-or> make-ghil-or ghil-or?
  57    ghil-or-env ghil-or-loc ghil-or-exps
  58
  59    <ghil-begin> make-ghil-begin ghil-begin?
  60    ghil-begin-env ghil-begin-loc ghil-begin-exps
  61
  62    <ghil-bind> make-ghil-bind ghil-bind?
  63    ghil-bind-env ghil-bind-loc ghil-bind-vars ghil-bind-vals ghil-bind-body
  64
  65    <ghil-lambda> make-ghil-lambda ghil-lambda?
  66    ghil-lambda-env ghil-lambda-loc ghil-lambda-vars ghil-lambda-rest ghil-lambda-body
  67
  68    <ghil-inline> make-ghil-inline ghil-inline?
  69    ghil-inline-env ghil-inline-loc ghil-inline-inline ghil-inline-args
  70
  71    <ghil-call> make-ghil-call ghil-call?
  72    ghil-call-env ghil-call-loc ghil-call-proc ghil-call-args
  73
  74    <ghil-var> make-ghil-var ghil-var?
  75    ghil-var-env ghil-var-name ghil-var-kind ghil-var-type ghil-var-value
  76    ghil-var-index
  77
  78    <ghil-mod> make-ghil-mod ghil-mod?
  79    ghil-mod-module ghil-mod-table ghil-mod-imports
  80
  81    <ghil-env> make-ghil-env ghil-env?
  82    ghil-env-mod ghil-env-parent ghil-env-table ghil-env-variables
  83
  84    ghil-primitive-macro? ghil-env-add! ghil-lookup ghil-define
  85    ghil-env-toplevel?
  86    call-with-ghil-environment call-with-ghil-bindings))
  87
  88 \f
  89 ;;;
  90 ;;; Parse tree
  91 ;;;
  92
  93 (define-type <ghil>
  94   (|
  95    ;; Objects
  96    (<ghil-void> env loc)
  97    (<ghil-quote> env loc obj)
  98    (<ghil-quasiquote> env loc exp)
  99    (<ghil-unquote> env loc exp)
 100    (<ghil-unquote-splicing> env loc exp)
 101    ;; Variables
 102    (<ghil-ref> env loc var)
 103    (<ghil-set> env loc var val)
 104    (<ghil-define> env loc var val)
 105    ;; Controls
 106    (<ghil-if> env loc test then else)
 107    (<ghil-and> env loc exps)
 108    (<ghil-or> env loc exps)
 109    (<ghil-begin> env loc exps)
 110    (<ghil-bind> env loc vars vals body)
 111    (<ghil-lambda> env loc vars rest body)
 112    (<ghil-call> env loc proc args)
 113    (<ghil-inline> env loc inline args)))
 114
 115 \f
 116 ;;;
 117 ;;; Procedures
 118 ;;;
 119
 120 (define *core-primitives*
 121   '(@void @quote @define @set! @if @begin @let @letrec @lambda))
 122
 123 (define *macro-module* (resolve-module '(system il macros)))
 124
 125 (define (ghil-primitive-macro? x)
 126   (and (module-defined? *macro-module* x)
 127        (procedure? (module-ref *macro-module* x))))
 128
 129 (define (ghil-macro-expander x)
 130   (module-ref *macro-module* x))
 131
 132 (define (ghil-primitive? x)
 133   (or (memq x *core-primitives*)
 134       (ghil-primitive-macro? x)))
 135
 136 \f
 137 ;;;
 138 ;;; Variables
 139 ;;;
 140
 141 (define-record (<ghil-var> env name kind (type #f) (value #f) (index #f)))
 142
 143 \f
 144 ;;;
 145 ;;; Modules
 146 ;;;
 147
 148 (define-record (<ghil-mod> module (table '()) (imports '())))
 149
 150 \f
 151 ;;;
 152 ;;; Environments
 153 ;;;
 154
 155 (define-record (<ghil-env> mod parent (table '()) (variables '())))
 156
 157 (define %make-ghil-env make-ghil-env)
 158 (define (make-ghil-env e)
 159   (record-case e
 160     ((<ghil-mod>) (%make-ghil-env :mod e :parent e))
 161     ((<ghil-env> mod) (%make-ghil-env :mod mod :parent e))))
 162
 163 (define (ghil-env-toplevel? e)
 164   (eq? (ghil-env-mod e) (ghil-env-parent e)))
 165
 166 (define (ghil-env-ref env sym)
 167   (assq-ref (ghil-env-table env) sym))
 168
 169 (define-macro (push! item loc)
 170   `(set! ,loc (cons ,item ,loc)))
 171 (define-macro (apush! k v loc)
 172   `(set! ,loc (acons ,k ,v ,loc)))
 173 (define-macro (apopq! k loc)
 174   `(set! ,loc (assq-remove! ,loc ,k)))
 175
 176 (define (ghil-env-add! env var)
 177   (apush! (ghil-var-name var) var (ghil-env-table env))
 178   (push! var (ghil-env-variables env)))
 179
 180 (define (ghil-env-remove! env var)
 181   (apopq! (ghil-var-name var) (ghil-env-table env)))
 182
 183 \f
 184 ;;;
 185 ;;; Public interface
 186 ;;;
 187
 188 (define (module-lookup module sym)
 189   (let ((iface (module-import-interface module sym)))
 190     (and iface
 191          (make-ghil-env (make-ghil-mod iface)))))
 192
 193 (define (fix-ghil-mod! mod for-sym)
 194   ;;; So, these warnings happen for all instances of define-module.
 195   ;;; Rather than fixing the problem, I'm going to suppress the common
 196   ;;; warnings.
 197   (if (not (eq? for-sym 'process-define-module))
 198       (warn "during lookup of" for-sym ":"
 199             (ghil-mod-module mod) "!= current" (current-module)))
 200   (if (not (null? (ghil-mod-table mod)))
 201       (warn "throwing away old variable table"
 202             (ghil-mod-module) (ghil-mod-table mod)))
 203   (set! (ghil-mod-module mod) (current-module))
 204   (set! (ghil-mod-table mod) '())
 205   (set! (ghil-mod-imports mod) '()))
 206
 207 ;; looking up a var has side effects?
 208 (define (ghil-lookup env sym)
 209   (or (ghil-env-ref env sym)
 210       (let loop ((e (ghil-env-parent env)))
 211         (record-case e
 212           ((<ghil-mod> module table imports)
 213            (cond ((not (eq? module (current-module)))
 214                   ;; FIXME: the primitive-eval in eval-case and/or macro
 215                   ;; expansion can have side effects on the compilation
 216                   ;; environment, for example changing the current
 217                   ;; module. We probably need to add a special case in
 218                   ;; compilation to handle define-module.
 219                   (fix-ghil-mod! e sym)
 220                   (loop e))
 221                  ((assq-ref table sym)) ;; when does this hit?
 222                  ((module-lookup module sym)
 223                   => (lambda (found-env)
 224                        (make-ghil-var found-env sym 'module)))
 225                  (else
 226                   ;; a free variable that we have not resolved
 227                   (warn "unresolved variable during compilation:" sym)
 228                   (let ((var (make-ghil-var #f sym 'unresolved)))
 229                     (apush! sym var table)
 230                     var))))
 231           ((<ghil-env> mod parent table variables)
 232            (let ((found (assq-ref table sym)))
 233              (if found
 234                  (begin (set! (ghil-var-kind found) 'external) found)
 235                  (loop parent))))))))
 236
 237 (define (ghil-define mod sym)
 238   (if (not (eq? (ghil-mod-module mod) (current-module)))
 239       (fix-ghil-mod! mod sym))
 240   (or (assq-ref (ghil-mod-table mod) sym)
 241       (let ((var (make-ghil-var (make-ghil-env mod) sym 'module)))
 242         (apush! sym var (ghil-mod-table mod))
 243         var)))
 244
 245 (define (call-with-ghil-environment e syms func)
 246   (let* ((e (make-ghil-env e))
 247          (vars (map (lambda (s)
 248                       (let ((v (make-ghil-var e s 'argument)))
 249                         (ghil-env-add! e v) v))
 250                     syms)))
 251     (func e vars)))
 252
 253 (define (call-with-ghil-bindings e syms func)
 254   (let* ((vars (map (lambda (s)
 255                       (let ((v (make-ghil-var e s 'local)))
 256                         (ghil-env-add! e v) v))
 257                     syms))
 258          (ret (func vars)))
 259     (for-each (lambda (v) (ghil-env-remove! e v)) vars)
 260     ret))
 261
 262 \f
 263 ;;;
 264 ;;; Parser
 265 ;;;
 266
 267 ;;; (define-public (parse-ghil x e)
 268 ;;;   (parse `(@lambda () ,x) (make-ghil-mod e)))
 269 ;;;
 270 ;;; (define (parse x e)
 271 ;;;   (cond ((pair? x) (parse-pair x e))
 272 ;;;     ((symbol? x)
 273 ;;;      (let ((str (symbol->string x)))
 274 ;;;        (case (string-ref str 0)
 275 ;;;          ((#\@) (error "Invalid use of IL primitive" x))
 276 ;;;          ((#\:) (let ((sym (string->symbol (substring str 1))))
 277 ;;;                   (<ghil-quote> (symbol->keyword sym))))
 278 ;;;          (else (<ghil-ref> e (ghil-lookup e x))))))
 279 ;;;     (else (<ghil-quote> x))))
 280 ;;;
 281 ;;; (define (map-parse x e)
 282 ;;;   (map (lambda (x) (parse x e)) x))
 283 ;;;
 284 ;;; (define (parse-pair x e)
 285 ;;;   (let ((head (car x)) (tail (cdr x)))
 286 ;;;     (if (and (symbol? head) (eq? (string-ref (symbol->string head) 0) #\@))
 287 ;;;     (if (ghil-primitive-macro? head)
 288 ;;;         (parse (apply (ghil-macro-expander head) tail) e)
 289 ;;;         (parse-primitive head tail e))
 290 ;;;     (<ghil-call> e (parse head e) (map-parse tail e)))))
 291 ;;;
 292 ;;; (define (parse-primitive prim args e)
 293 ;;;   (case prim
 294 ;;;     ;; (@ IDENTIFIER)
 295 ;;;     ((@)
 296 ;;;      (match args
 297 ;;;        (()
 298 ;;;     (<ghil-ref> e (make-ghil-var '@ '@ 'module)))
 299 ;;;        ((identifier)
 300 ;;;     (receive (module name) (identifier-split identifier)
 301 ;;;       (<ghil-ref> e (make-ghil-var module name 'module))))))
 302 ;;;
 303 ;;;     ;; (@@ OP ARGS...)
 304 ;;;     ((@@)
 305 ;;;      (match args
 306 ;;;        ((op . args)
 307 ;;;     (<ghil-inline> op (map-parse args e)))))
 308 ;;;
 309 ;;;     ;; (@void)
 310 ;;;     ((@void)
 311 ;;;      (match args
 312 ;;;        (() (<ghil-void>))))
 313 ;;;
 314 ;;;     ;; (@quote OBJ)
 315 ;;;     ((@quote)
 316 ;;;      (match args
 317 ;;;        ((obj)
 318 ;;;     (<ghil-quote> obj))))
 319 ;;;
 320 ;;;     ;; (@define NAME VAL)
 321 ;;;     ((@define)
 322 ;;;      (match args
 323 ;;;        ((name val)
 324 ;;;     (let ((v (ghil-lookup e name)))
 325 ;;;       (<ghil-set> e v (parse val e))))))
 326 ;;;
 327 ;;;     ;; (@set! NAME VAL)
 328 ;;;     ((@set!)
 329 ;;;      (match args
 330 ;;;        ((name val)
 331 ;;;     (let ((v (ghil-lookup e name)))
 332 ;;;       (<ghil-set> e v (parse val e))))))
 333 ;;;
 334 ;;;     ;; (@if TEST THEN [ELSE])
 335 ;;;     ((@if)
 336 ;;;      (match args
 337 ;;;        ((test then)
 338 ;;;     (<ghil-if> (parse test e) (parse then e) (<ghil-void>)))
 339 ;;;        ((test then else)
 340 ;;;     (<ghil-if> (parse test e) (parse then e) (parse else e)))))
 341 ;;;
 342 ;;;     ;; (@begin BODY...)
 343 ;;;     ((@begin)
 344 ;;;      (parse-body args e))
 345 ;;;
 346 ;;;     ;; (@let ((SYM INIT)...) BODY...)
 347 ;;;     ((@let)
 348 ;;;      (match args
 349 ;;;        ((((sym init) ...) body ...)
 350 ;;;     (let* ((vals (map-parse init e))
 351 ;;;            (vars (map (lambda (s)
 352 ;;;                         (let ((v (make-ghil-var e s 'local)))
 353 ;;;                           (ghil-env-add! e v) v))
 354 ;;;                       sym))
 355 ;;;            (body (parse-body body e)))
 356 ;;;       (for-each (lambda (v) (ghil-env-remove! e v)) vars)
 357 ;;;       (<ghil-bind> e vars vals body)))))
 358 ;;;
 359 ;;;     ;; (@letrec ((SYM INIT)...) BODY...)
 360 ;;;     ((@letrec)
 361 ;;;      (match args
 362 ;;;        ((((sym init) ...) body ...)
 363 ;;;     (let* ((vars (map (lambda (s)
 364 ;;;                         (let ((v (make-ghil-var e s 'local)))
 365 ;;;                           (ghil-env-add! e v) v))
 366 ;;;                       sym))
 367 ;;;            (vals (map-parse init e))
 368 ;;;            (body (parse-body body e)))
 369 ;;;       (for-each (lambda (v) (ghil-env-remove! e v)) vars)
 370 ;;;       (<ghil-bind> e vars vals body)))))
 371 ;;;
 372 ;;;     ;; (@lambda FORMALS BODY...)
 373 ;;;     ((@lambda)
 374 ;;;      (match args
 375 ;;;        ((formals . body)
 376 ;;;     (receive (syms rest) (parse-formals formals)
 377 ;;;       (let* ((e (make-ghil-env e))
 378 ;;;              (vars (map (lambda (s)
 379 ;;;                           (let ((v (make-ghil-var e s 'argument)))
 380 ;;;                             (ghil-env-add! e v) v))
 381 ;;;                         syms)))
 382 ;;;         (<ghil-lambda> e vars rest (parse-body body e)))))))
 383 ;;;
 384 ;;;     ;; (@eval-case CLAUSE...)
 385 ;;;     ((@eval-case)
 386 ;;;      (let loop ((clauses args))
 387 ;;;        (cond ((null? clauses) (<ghil-void>))
 388 ;;;          ((or (eq? (caar clauses) '@else)
 389 ;;;               (and (memq 'load-toplevel (caar clauses))
 390 ;;;                    (ghil-env-toplevel? e)))
 391 ;;;           (parse-body (cdar clauses) e))
 392 ;;;          (else
 393 ;;;           (loop (cdr clauses))))))
 394 ;;;
 395 ;;;     (else (error "Unknown primitive:" prim))))
 396 ;;;
 397 ;;; (define (parse-body x e)
 398 ;;;   (<ghil-begin> (map-parse x e)))
 399 ;;;
 400 ;;; (define (parse-formals formals)
 401 ;;;   (cond
 402 ;;;    ;; (@lambda x ...)
 403 ;;;    ((symbol? formals) (values (list formals) #t))
 404 ;;;    ;; (@lambda (x y z) ...)
 405 ;;;    ((list? formals) (values formals #f))
 406 ;;;    ;; (@lambda (x y . z) ...)
 407 ;;;    ((pair? formals)
 408 ;;;     (let loop ((l formals) (v '()))
 409 ;;;       (if (pair? l)
 410 ;;;       (loop (cdr l) (cons (car l) v))
 411 ;;;       (values (reverse! (cons l v)) #t))))
 412 ;;;    (else (error "Invalid formals:" formals))))
 413 ;;;
 414 ;;; (define (identifier-split identifier)
 415 ;;;   (let ((m (string-match "::([^:]*)$" (symbol->string identifier))))
 416 ;;;     (if m
 417 ;;;     (values (string->symbol (match:prefix m))
 418 ;;;             (string->symbol (match:substring m 1)))
 419 ;;;     (values #f identifier))))