conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

* Removed the collection of open-coded primititives in compiler.ss

This commit is contained in:
Abdulaziz Ghuloum 2007-07-13 13:23:54 +03:00
parent 598d7ae99c
commit 61edf6d5a2
4 changed files with 91 additions and 225 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
src/ikarus.boot
View File

Binary file not shown.

197
src/ikarus.compiler.ss
View File

@ -43,203 +43,6 @@
(include "set-operations.ss")
(define open-coded-primitives
;;; these primitives, when found in operator position with the correct
;;; number of arguments, will be open-coded by the generator. If an
;;; incorrect number of args is detected, or if they appear in non-operator
;;; position, then they cannot be open-coded, and the pcb-primitives table
;;; is consulted for a reference of the pcb slot containing the primitive.
;;; If it's not found there, an error is signalled.
;;;
;;; prim-name args
'([$constant-ref 1 value]
[$constant-set! 2 effect]
[$pcb-ref 1 value]
[$pcb-set! 2 effect]
;;; type predicates
[fixnum? 1 pred]
[bignum? 1 pred]
[flonum? 1 pred]
[immediate? 1 pred]
[boolean? 1 pred]
[char? 1 pred]
[pair? 1 pred]
[symbol? 1 pred]
[vector? 1 pred]
[string? 1 pred]
[procedure? 1 pred]
[null? 1 pred]
[eof-object? 1 pred]
[bwp-object? 1 pred]
[$unbound-object? 1 pred]
[$forward-ptr? 1 pred]
[not 1 pred]
[pointer-value 1 value]
[eq? 2 pred]
;;; fixnum primitives
[$fxadd1 1 value]
[$fxsub1 1 value]
[$fx+ 2 value]
[$fx- 2 value]
[$fx* 2 value]
[$fxsll 2 value]
[$fxsra 2 value]
[$fxlogand 2 value]
[$fxlogor 2 value]
[$fxlogxor 2 value]
[$fxlognot 1 value]
[$fxquotient 2 value]
[$fxmodulo 2 value]
;;; fixnum predicates
[$fxzero? 1 pred]
[$fx= 2 pred]
[$fx< 2 pred]
[$fx<= 2 pred]
[$fx> 2 pred]
[$fx>= 2 pred]
;;; character predicates
[$char= 2 pred]
[$char< 2 pred]
[$char<= 2 pred]
[$char> 2 pred]
[$char>= 2 pred]
;;; character conversion
[$fixnum->char 1 value]
[$char->fixnum 1 value]
;;; lists/pairs
[cons 2 value]
[list* positive value]
[list any value]
[car 1 value]
[cdr 1 value]
[$car 1 value]
[$cdr 1 value]
[$set-car! 2 effect]
[$set-cdr! 2 effect]
;;; vectors
[$make-vector 1 value]
[vector any value]
[$vector-length 1 value]
[$vector-ref 2 value]
[$vector-set! 3 effect]
;;; strings
[$make-string 1 value]
[$string any value]
[$string-length 1 value]
[$string-ref 2 value]
[$string-set! 3 effect]
;;; bytevectors
[bytevector? 1 pred]
[$make-bytevector 1 value]
[$bytevector-length 1 value]
[$bytevector-u8-ref 2 value]
[$bytevector-s8-ref 2 value]
[$bytevector-set! 3 effect]
;;; bignums
[$make-bignum 2 value]
[$bignum-positive? 1 pred]
[$bignum-size 1 value]
[$bignum-byte-ref 2 value]
[$bignum-byte-set! 3 effect]
;;; ratnums
[$make-ratnum 2 value]
[ratnum? 1 pred]
[$ratnum-n 1 value]
[$ratnum-d 1 value]
;;; symbols
[$make-symbol 1 value]
[$symbol-value 1 value]
[$symbol-string 1 value]
[$symbol-unique-string 1 value]
[$set-symbol-value! 2 effect]
[$set-symbol-function! 2 effect]
[$set-symbol-string! 2 effect]
[$set-symbol-unique-string! 2 effect]
[$symbol-plist 1 value]
[$set-symbol-plist! 2 effect]
[top-level-value 1 value]
;;; ports
[port? 1 pred]
[input-port? 1 pred]
[output-port? 1 pred]
[$make-port/input 7 value]
[$make-port/output 7 value]
[$make-port/both 7 value]
[$port-handler 1 value]
[$port-input-buffer 1 value]
[$port-input-index 1 value]
[$port-input-size 1 value]
[$port-output-buffer 1 value]
[$port-output-index 1 value]
[$port-output-size 1 value]
[$set-port-input-index! 2 effect]
[$set-port-input-size! 2 effect]
[$set-port-output-index! 2 effect]
[$set-port-output-size! 2 effect]
;;; tcbuckets
[$make-tcbucket 4 value]
[$tcbucket-key 1 value]
[$tcbucket-val 1 value]
[$tcbucket-next 1 value]
[$set-tcbucket-val! 2 effect]
[$set-tcbucket-next! 2 effect]
[$set-tcbucket-tconc! 2 effect]
;;; misc
[eof-object 0 value]
[void 0 value]
[$exit 1 effect]
[$fp-at-base 0 pred]
[$current-frame 0 value]
[$arg-list 0 value]
[base-rtd 0 value]
[$seal-frame-and-call 1 tail]
[$frame->continuation 1 value]
[$interrupted? 0 pred]
[$unset-interrupted! 0 effect]
;;;
;;; records
;;;
[$make-record 2 value]
[$record? 1 pred]
[$record/rtd? 2 pred]
[$record-rtd 1 value]
[$record-ref 2 value]
[$record-set! 3 effect]
[$record any value]
;;;
;;; asm
;;;
[code? 1 pred]
[$code-size 1 value]
[$code-reloc-vector 1 value]
[$code-freevars 1 value]
[$code-ref 2 value]
[$code-set! 3 value]
[$code->closure 1 value]
[$closure-code 1 value]
;;;
[$make-call-with-values-procedure 0 value]
[$make-values-procedure 0 value]
))
(define (primitive-context x)
(cond
[(assq x open-coded-primitives) => caddr]
[else (error 'primitive-context "unknown prim ~s" x)]))
(define (open-codeable? x)
(cond
[(assq x open-coded-primitives) #t]
[else #f]))
(define (open-coded-primitive-args x)
(cond
[(assq x open-coded-primitives) => cadr]
[else (error 'open-coded-primitive-args "invalid ~s" x)]))
;;; end of primitives table section
(define-record constant (value))
(define-record code-loc (label))
(define-record foreign-label (label))

116
src/lab/ikarus.r6rs.records.procedural.ss
View File

@ -4,14 +4,20 @@
make-record-type-descriptor
make-record-constructor-descriptor
record-accessor record-mutator
record-constructor record-predicate)
record-constructor record-predicate
record? record-rtd record-type-name
record-type-parent record-type-uid record-type-generative?
record-type-sealed? record-type-opaque? record-type-field-names)
(import
(except (ikarus) record-constructor record-predicate
set-rtd-printer!)
(except (ikarus) record-constructor record-predicate set-rtd-printer!
record? record-type-name record-type-parent
record-type-field-names)
(prefix (only (ikarus) set-rtd-printer!) core:)
(ikarus system $records))
(define-record rtd
(name size old-fields printer symbol parent sealed? opaque? uid fields))
(define rtd-alist '())
(define (intern-rtd! uid rtd)
(set! rtd-alist (cons (cons uid rtd) rtd-alist)))
@ -23,20 +29,78 @@
(define (record-type-descriptor? x) (rtd? x))
(define (record? x)
(and ($record? x)
(let ([rtd ($record-rtd x)])
(and (rtd? rtd)
(not (rtd-opaque? rtd))))))
(define (record-rtd x)
(define (err x)
(error 'record-rtd "~s is not a record" x))
(if ($record? x)
(let ([rtd ($record-rtd x)])
(if (rtd? rtd)
(if (not (rtd-opaque? rtd))
rtd
(err x))
(err x)))
(err x)))
(define (record-type-name x)
(if (rtd? x)
(rtd-name x)
(error 'record-type-name "~s is not an rtd" x)))
(define (record-type-parent x)
(if (rtd? x)
(rtd-parent x)
(error 'record-type-parent "~s is not an rtd" x)))
(define (record-type-uid x)
(if (rtd? x)
(rtd-uid x)
(error 'record-type-uid "~s is not an rtd" x)))
(define (record-type-sealed? x)
(if (rtd? x)
(rtd-sealed? x)
(error 'record-type-sealed? "~s is not an rtd" x)))
(define (record-type-opaque? x)
(if (rtd? x)
(rtd-opaque? x)
(error 'record-type-opaque? "~s is not an rtd" x)))
(define (record-type-generative? x)
(if (rtd? x)
(not (rtd-sealed? x))
(error 'record-type-generative? "~s is not an rtd" x)))
(define (record-type-field-names x)
(if (rtd? x)
(let ([v (rtd-fields x)])
(let ([n (vector-length v)])
(let f ([x (make-vector n)] [v v] [n n] [i 0])
(if (= i n)
x
(begin
(vector-set! x i (cdr (vector-ref v i)))
(f x v n (fxadd1 i)))))))
(error 'record-type-field-names "~s is not an rtd" x)))
(module (make-record-type-descriptor)
(define who 'make-record-type-descriptor)
(define (make-rtd-aux name parent uid sealed? opaque? fields)
(make-rtd name (vector-length fields) #f #f #f parent sealed? opaque? uid fields))
(define (convert-fields pfv sv)
(define (make-rtd-aux name parent uid sealed? opaque?
parent-size fields)
(make-rtd name (+ parent-size (vector-length fields))
#f #f #f parent sealed? opaque? uid fields))
(define (convert-fields sv)
(unless (vector? sv)
(error who "invalid fields argument ~s" sv))
(let ([n1 (vector-length pfv)]
[n2 (vector-length sv)])
(let ([v (make-vector (+ n1 n2))])
(let f ([i 0])
(unless (= i n1)
(vector-set! v i (vector-ref pfv i))
(f (add1 i))))
(let ([n2 (vector-length sv)])
(let ([v (make-vector n2)])
(let f ([i 0])
(unless (= i n2)
(let ([x (vector-ref sv i)])
@ -46,7 +110,7 @@
(let ([name (car x)])
(unless (and (null? (cdr x)) (symbol? name))
(error who "invalid fields argument ~s" sv))
(vector-set! v (+ i n1)
(vector-set! v i
(cons (case m/u
[(mutable) #t]
[(immutable) #f]
@ -65,10 +129,11 @@
(error who "cannot extend sealed parent ~s" parent))
(make-rtd-aux name parent uid sealed?
(or opaque? (rtd-opaque? parent))
(convert-fields (rtd-fields parent) fields))]
(rtd-size parent)
(convert-fields fields))]
[(eqv? parent #f)
(make-rtd-aux name parent uid sealed? opaque?
(convert-fields '#() fields))]
(make-rtd-aux name parent uid sealed? opaque? 0
(convert-fields fields))]
[else (error who "~s is not a valid parent" parent)])))
(define (same-fields-as-rtd? fields rtd)
(let* ([fv (rtd-fields rtd)]
@ -146,8 +211,8 @@
(error who "descriptor ~s does not apply to ~s"
prcd rtd))
(make-rcd rtd prcd protocol)]
[else (error who "~s is not a valid record constructor
descriptor" prcd)]))))
[else
(error who "~s is not a valid record constructor descriptor" prcd)]))))
(define (iota i n)
(if (= i n)
@ -234,7 +299,6 @@
[prcd (rcd-prcd rcd)])
(let ([c*
(let ([n (rtd-size rtd)])
(printf "base=~s\n" n)
(let f ([c0 ((base-constructor-maker n) rtd)]
[prcd prcd]
[n n])
@ -243,7 +307,6 @@
[else
(let ([r (rcd-rtd prcd)])
(let ([m (rtd-size r)])
(printf "ext ~s ~s\n" n m)
(f ((extended-constructor-maker n m) c0)
(rcd-prcd prcd)
m)))])))])
@ -255,10 +318,6 @@
(let ([proc (rcd-proc rcd)])
(if proc (proc c*) c*)))])))))
(define (record-accessor rtd k)
(define who 'record-accessor)
(unless (rtd? rtd)
@ -332,7 +391,14 @@
[else (f (rtd-parent prtd) rtd)]))))]
[else #f]))))
(core:set-rtd-printer! (type-descriptor rtd)
(lambda (x p)
(display (format "#<record-type-descriptor ~s>" (rtd-name x)) p)))
(core:set-rtd-printer! (type-descriptor rcd)
(lambda (x p)
(display (format "#<record-constructor-descriptor ~s>"
(rtd-name (rcd-rtd x))) p)))

3
src/libaltcogen.ss
View File

@ -56,9 +56,6 @@
(cond
[(primop? name)
(make-primcall name arg*)]
[(open-codeable? name)
(error 'chaitin-compiler "primitive ~s is not supported"
name)]
[else (make-funcall op arg*)])]
[else (make-funcall op arg*)]))
;;;