mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-13 09:10:26 +02:00
81fd315299
* doc/ref/api-procedures.texi (Compiled Procedures): Fix for API changes. * doc/ref/compiler.texi (Compiling to the Virtual Machine): Replace GHIL docs with Tree-IL docs. Update the bits about the Scheme compiler to talk about Tree-IL and the expander instead of GHIL. Remove <glil-argument>. Add placeholder sections for assembly and bytecode. * doc/ref/vm.texi: Update examples with what currently happens. Reword some things. Fix a couple errors. * libguile/vm-i-system.c (externals): Remove this instruction, it's not used. * module/ice-9/documentation.scm (object-documentation): If the object is a macro, try to return documentation on the macro transformer. * module/language/assembly/disassemble.scm (disassemble-load-program): Fix problem in which we skipped the first element of the object vector, because of changes to procedure layouts a few months ago. * module/language/scheme/spec.scm (read-file): Remove read-file definition. * module/language/tree-il.scm: Reorder exports. Remove <lexical>, it was a compat shim to something that was never released. Fix `location'. * module/language/tree-il/primitives.scm (/): Fix expander for more than two args to /. * module/system/base/compile.scm (read-file-in): Remove unused definition. * module/system/base/language.scm (system): Remove language-read-file. * module/language/ecmascript/spec.scm (ecmascript): Remove read-file definition.
206 lines
7.1 KiB
Scheme
206 lines
7.1 KiB
Scheme
;;; GHIL macros
|
||
|
||
;; Copyright (C) 2001 Free Software Foundation, Inc.
|
||
|
||
;; This program is free software; you can redistribute it and/or modify
|
||
;; it under the terms of the GNU General Public License as published by
|
||
;; the Free Software Foundation; either version 2, or (at your option)
|
||
;; any later version.
|
||
;;
|
||
;; This program is distributed in the hope that it will be useful,
|
||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||
;; GNU General Public License for more details.
|
||
;;
|
||
;; You should have received a copy of the GNU General Public License
|
||
;; along with this program; see the file COPYING. If not, write to
|
||
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
||
;; Boston, MA 02111-1307, USA.
|
||
|
||
;;; Code:
|
||
|
||
(define-module (language tree-il primitives)
|
||
#:use-module (system base syntax)
|
||
#:use-module (language tree-il)
|
||
#:use-module (srfi srfi-16)
|
||
#:export (resolve-primitives! add-interesting-primitive!
|
||
expand-primitives!))
|
||
|
||
(define *interesting-primitive-names*
|
||
'(apply @apply
|
||
call-with-values @call-with-values
|
||
call-with-current-continuation @call-with-current-continuation
|
||
call/cc
|
||
values
|
||
eq? eqv? equal?
|
||
= < > <= >= zero?
|
||
+ * - / 1- 1+ quotient remainder modulo
|
||
not
|
||
pair? null? list? acons cons cons*
|
||
|
||
list vector
|
||
|
||
car cdr
|
||
set-car! set-cdr!
|
||
|
||
caar cadr cdar cddr
|
||
|
||
caaar caadr cadar caddr cdaar cdadr cddar cdddr
|
||
|
||
caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
|
||
cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr))
|
||
|
||
(define (add-interesting-primitive! name)
|
||
(hashq-set! *interesting-primitive-vars*
|
||
(module-variable (current-module) name) name))
|
||
|
||
(define *interesting-primitive-vars* (make-hash-table))
|
||
|
||
(for-each add-interesting-primitive! *interesting-primitive-names*)
|
||
|
||
(define (resolve-primitives! x mod)
|
||
(post-order!
|
||
(lambda (x)
|
||
(record-case x
|
||
((<toplevel-ref> src name)
|
||
(and (hashq-ref *interesting-primitive-vars*
|
||
(module-variable mod name))
|
||
(make-primitive-ref src name)))
|
||
((<module-ref> src mod name public?)
|
||
;; for the moment, we're disabling primitive resolution for
|
||
;; public refs because resolve-interface can raise errors.
|
||
(let ((m (and (not public?) (resolve-module mod))))
|
||
(and m (hashq-ref *interesting-primitive-vars*
|
||
(module-variable m name))
|
||
(make-primitive-ref src name))))
|
||
(else #f)))
|
||
x))
|
||
|
||
|
||
|
||
(define *primitive-expand-table* (make-hash-table))
|
||
|
||
(define (expand-primitives! x)
|
||
(pre-order!
|
||
(lambda (x)
|
||
(record-case x
|
||
((<application> src proc args)
|
||
(and (primitive-ref? proc)
|
||
(let ((expand (hashq-ref *primitive-expand-table*
|
||
(primitive-ref-name proc))))
|
||
(and expand (apply expand src args)))))
|
||
(else #f)))
|
||
x))
|
||
|
||
;;; I actually did spend about 10 minutes trying to redo this with
|
||
;;; syntax-rules. Patches appreciated.
|
||
;;;
|
||
(define-macro (define-primitive-expander sym . clauses)
|
||
(define (inline-args args)
|
||
(let lp ((in args) (out '()))
|
||
(cond ((null? in) `(list ,@(reverse out)))
|
||
((symbol? in) `(cons* ,@(reverse out) ,in))
|
||
((pair? (car in))
|
||
(lp (cdr in)
|
||
(cons `(make-application src (make-primitive-ref src ',(caar in))
|
||
,(inline-args (cdar in)))
|
||
out)))
|
||
((symbol? (car in))
|
||
;; assume it's locally bound
|
||
(lp (cdr in) (cons (car in) out)))
|
||
((number? (car in))
|
||
(lp (cdr in) (cons `(make-const src ,(car in)) out)))
|
||
(else
|
||
(error "what what" (car in))))))
|
||
(define (consequent exp)
|
||
(cond
|
||
((pair? exp)
|
||
`(make-application src (make-primitive-ref src ',(car exp))
|
||
,(inline-args (cdr exp))))
|
||
((symbol? exp)
|
||
;; assume locally bound
|
||
exp)
|
||
((number? exp)
|
||
`(make-const src ,exp))
|
||
(else (error "bad consequent yall" exp))))
|
||
`(hashq-set! *primitive-expand-table*
|
||
',sym
|
||
(case-lambda
|
||
,@(let lp ((in clauses) (out '()))
|
||
(if (null? in)
|
||
(reverse (cons '(else #f) out))
|
||
(lp (cddr in)
|
||
(cons `((src . ,(car in))
|
||
,(consequent (cadr in))) out)))))))
|
||
|
||
(define-primitive-expander +
|
||
() 0
|
||
(x) x
|
||
(x y z . rest) (+ x (+ y z . rest)))
|
||
|
||
(define-primitive-expander *
|
||
() 1
|
||
(x) x
|
||
(x y z . rest) (* x (* y z . rest)))
|
||
|
||
(define-primitive-expander -
|
||
(x) (- 0 x)
|
||
(x y z . rest) (- x (+ y z . rest)))
|
||
|
||
(define-primitive-expander 1-
|
||
(x) (- x 1))
|
||
|
||
(define-primitive-expander /
|
||
(x) (/ 1 x)
|
||
(x y z . rest) (/ x (* y z . rest)))
|
||
|
||
(define-primitive-expander caar (x) (car (car x)))
|
||
(define-primitive-expander cadr (x) (car (cdr x)))
|
||
(define-primitive-expander cdar (x) (cdr (car x)))
|
||
(define-primitive-expander cddr (x) (cdr (cdr x)))
|
||
(define-primitive-expander caaar (x) (car (car (car x))))
|
||
(define-primitive-expander caadr (x) (car (car (cdr x))))
|
||
(define-primitive-expander cadar (x) (car (cdr (car x))))
|
||
(define-primitive-expander caddr (x) (car (cdr (cdr x))))
|
||
(define-primitive-expander cdaar (x) (cdr (car (car x))))
|
||
(define-primitive-expander cdadr (x) (cdr (car (cdr x))))
|
||
(define-primitive-expander cddar (x) (cdr (cdr (car x))))
|
||
(define-primitive-expander cdddr (x) (cdr (cdr (cdr x))))
|
||
(define-primitive-expander caaaar (x) (car (car (car (car x)))))
|
||
(define-primitive-expander caaadr (x) (car (car (car (cdr x)))))
|
||
(define-primitive-expander caadar (x) (car (car (cdr (car x)))))
|
||
(define-primitive-expander caaddr (x) (car (car (cdr (cdr x)))))
|
||
(define-primitive-expander cadaar (x) (car (cdr (car (car x)))))
|
||
(define-primitive-expander cadadr (x) (car (cdr (car (cdr x)))))
|
||
(define-primitive-expander caddar (x) (car (cdr (cdr (car x)))))
|
||
(define-primitive-expander cadddr (x) (car (cdr (cdr (cdr x)))))
|
||
(define-primitive-expander cdaaar (x) (cdr (car (car (car x)))))
|
||
(define-primitive-expander cdaadr (x) (cdr (car (car (cdr x)))))
|
||
(define-primitive-expander cdadar (x) (cdr (car (cdr (car x)))))
|
||
(define-primitive-expander cdaddr (x) (cdr (car (cdr (cdr x)))))
|
||
(define-primitive-expander cddaar (x) (cdr (cdr (car (car x)))))
|
||
(define-primitive-expander cddadr (x) (cdr (cdr (car (cdr x)))))
|
||
(define-primitive-expander cdddar (x) (cdr (cdr (cdr (car x)))))
|
||
(define-primitive-expander cddddr (x) (cdr (cdr (cdr (cdr x)))))
|
||
|
||
(define-primitive-expander cons*
|
||
(x) x
|
||
(x y) (cons x y)
|
||
(x y . rest) (cons x (cons* y . rest)))
|
||
|
||
(define-primitive-expander acons (x y z)
|
||
(cons (cons x y) z))
|
||
|
||
(define-primitive-expander apply (f . args)
|
||
(@apply f . args))
|
||
|
||
(define-primitive-expander call-with-values (producer consumer)
|
||
(@call-with-values producer consumer))
|
||
|
||
(define-primitive-expander call-with-current-continuation (proc)
|
||
(@call-with-current-continuation proc))
|
||
|
||
(define-primitive-expander call/cc (proc)
|
||
(@call-with-current-continuation proc))
|
||
|
||
(define-primitive-expander values (x) x)
|