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

adding array? 

adding vararg apply
This commit is contained in:
JeffBezanson 2009-05-08 04:08:31 +00:00
parent af72c4f5bd
commit afa77a8c5f
3 changed files with 19 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
femtolisp/compiler.lsp
View File

@ -346,6 +346,14 @@
head))) head)))
(let ((b (and (builtin? head) (let ((b (and (builtin? head)
(builtin->instruction head)))) (builtin->instruction head))))
(if (eq? b :apply)
(cond ((length= x 4)
(set! x `(,head ,(cadr x) (cons ,@(cddr x)))))
((length> x 4)
(set! x `(,head ,(cadr x)
(nconc (list ,@(list-head (cddr x)
(- (length x) 3)))
,(car (last-pair x))))))))
(if (not b) (if (not b)
(compile-in g env #f head)) (compile-in g env #f head))
(let ((nargs (compile-arglist g env (cdr x)))) (let ((nargs (compile-arglist g env (cdr x))))

4
femtolisp/flisp.boot
View File

@ -239,7 +239,7 @@ compile-for
compile-f compile-f
#function("o2b0d130d2e131p43;" [#function("qf02A@6D0d0e0d1325w0d2e131A6_0d0e0d3d4e131335w0d0e0d5e1?6o0_5u0d4e131332d6e0d7e131f00K\\d8f0131342d0e0d9322d:d;e0_Z31d<e03142;" [emit :let lastcdr :argc length :vargc compile-in to-proper caddr :ret function encode-byte-code const-to-idx-vec]) make-code-emitter cadr]) #function("o2b0d130d2e131p43;" [#function("qf02A@6D0d0e0d1325w0d2e131A6_0d0e0d3d4e131335w0d0e0d5e1?6o0_5u0d4e131332d6e0d7e131f00K\\d8f0131342d0e0d9322d:d;e0_Z31d<e03142;" [emit :let lastcdr :argc length :vargc compile-in to-proper caddr :ret function encode-byte-code const-to-idx-vec]) make-code-emitter cadr])
compile-call compile-call
#function("n4b0e3Mp42;" [#function("qb0e0C16d02d1e0f0132@16d02e0E16d02d2e03116d02d3e031G6p0d3e0315r0e0p42;" [#function("qb0e0G16A02d1e031p42;" [#function("qe0@6H0d0f20f21]f00345I0]2b1d2f20f21f23N33p42;" [compile-in #function("qf006G0b0d1d2f00]33p42;d3f30f326W0d45Y0d5e043;" [#function("qe016C02d0f43Ne032@6R0d1f20e0325S0]2b2f10p42;" [length= argc-error #function("qe0d0=6Y0f10_V6K0d1f50d242;d1f50f20f1043;e0d3=6\x940f10_V6s0d1f50d442;f10a2V6\x860d1f50d542;d1f50f20f1043;e0d6=6\xe00f10_V6\xad0d7f30`42;f10`V6\xbf0d1f50d842;f10a2V6\xd20d1f50d942;d1f50f20f1043;e0d:=6\x080f10_V6\xfa0d1f50d;42;d1f50f20f1043;e0d<=6/0f10_V6!0d7f30`42;d1f50f20f1043;e0d==6Y1f10_V6K1d1f50d>b?43;d1f50f20f1043;d1f50f5216l12f20d@<6t1dA5w1f2042;" [:list emit :loadnil :+ :load0 :add2 :- argc-error :neg :sub2 :* :load1 :/ :vector :loadv [] :apply :tapply])]) get arg-counts emit :tcall :call]) compile-arglist]) builtin->instruction]) in-env? constant? top-level-value])]) #function("n4b0e3Mp42;" [#function("qb0e0C16d02d1e0f0132@16d02e0E16d02d2e03116d02d3e031G6p0d3e0315r0e0p42;" [#function("qb0e0G16A02d1e031p42;" [#function("qe0d0<6\xb90d1f23a4326j0f00d2f2331d3b4L1d5d6f23313132L3j235\xb60d7f23a4326\xb50f00d2f2331b3d3b8L1d5d9d6f2331d:f2331a3u323132d;f2331ML3L3j235\xb60]5\xba0]2e0@6\xd20d<f20f21]f00345\xd30]2b=d>f20f21f23N33p42;" [:apply length= cadr nconc cons copy-list cddr length> list list-head length last-pair compile-in #function("qf006G0b0d1d2f00]33p42;d3f30f326W0d45Y0d5e043;" [#function("qe016C02d0f43Ne032@6R0d1f20e0325S0]2b2f10p42;" [length= argc-error #function("qe0d0=6Y0f10_V6K0d1f50d242;d1f50f20f1043;e0d3=6\x940f10_V6s0d1f50d442;f10a2V6\x860d1f50d542;d1f50f20f1043;e0d6=6\xe00f10_V6\xad0d7f30`42;f10`V6\xbf0d1f50d842;f10a2V6\xd20d1f50d942;d1f50f20f1043;e0d:=6\x080f10_V6\xfa0d1f50d;42;d1f50f20f1043;e0d<=6/0f10_V6!0d7f30`42;d1f50f20f1043;e0d==6Y1f10_V6K1d1f50d>b?43;d1f50f20f1043;d1f50f5216l12f20d@<6t1dA5w1f2042;" [:list emit :loadnil :+ :load0 :add2 :- argc-error :neg :sub2 :* :load1 :/ :vector :loadv [] :apply :tapply])]) get arg-counts emit :tcall :call]) compile-arglist]) builtin->instruction]) in-env? constant? top-level-value])])
compile-begin compile-begin
#function("n4e3?6D0d0e0e1e2]44;e3N?6Y0d0e0e1e2e3M44;d0e0e1]e3M342d1e0d2322d3e0e1e2e3N44;" [compile-in emit :pop compile-begin]) #function("n4e3?6D0d0e0e1e2]44;e3N?6Y0d0e0e1e2e3M44;d0e0e1]e3M342d1e0d2322d3e0e1e2e3N44;" [compile-in emit :pop compile-begin])
compile-arglist compile-arglist
@ -290,6 +290,8 @@ assv
#function("n2e1?6:0];d0e131e0=6J0e1M;d1e0e1N42;" [caar assv]) #function("n2e1?6:0];d0e131e0=6J0e1M;d1e0e1N42;" [caar assv])
assoc assoc
#function("n2e1?6:0];d0e131e0>6J0e1M;d1e0e1N42;" [caar assoc]) #function("n2e1?6:0];d0e131e0>6J0e1M;d1e0e1N42;" [caar assoc])
array?
#function("n1e0H17E02b0d1e031p42;" [#function("qe0F16?02e0Mb0<;" [array]) typeof])
argc-error argc-error
#function("n2d0d1b2e0b3e1e1`V6J0b45L0b53541;" [error string "compile error: " " expects " " argument." " arguments."]) #function("n2d0d1b2e0b3e1e1`V6J0b45L0b53541;" [error string "compile error: " " expects " " argument." " arguments."])
arg-counts arg-counts

13
femtolisp/system.lsp
View File

@ -111,6 +111,9 @@
(define (abs x) (if (< x 0) (- x) x)) (define (abs x) (if (< x 0) (- x) x))
(define (identity x) x) (define (identity x) x)
(define (char? x) (eq? (typeof x) 'wchar)) (define (char? x) (eq? (typeof x) 'wchar))
(define (array? x) (or (vector? x)
(let ((t (typeof x)))
(and (pair? t) (eq? (car t) 'array)))))
(define (caar x) (car (car x))) (define (caar x) (car (car x)))
(define (cadr x) (car (cdr x))) (define (cadr x) (car (cdr x)))
@ -200,7 +203,7 @@
(set! mapcar (set! mapcar
(lambda (f . lsts) (mapcar- f lsts)))) (lambda (f . lsts) (mapcar- f lsts))))
(define (transpose M) (apply mapcar (cons list M))) (define (transpose M) (apply mapcar list M))
(letrec ((filter- (letrec ((filter-
(lambda (pred lst accum) (lambda (pred lst accum)
@ -488,8 +491,8 @@
; text I/O -------------------------------------------------------------------- ; text I/O --------------------------------------------------------------------
(define (print . args) (apply io.print (cons *output-stream* args))) (define (print . args) (apply io.print *output-stream* args))
(define (princ . args) (apply io.princ (cons *output-stream* args))) (define (princ . args) (apply io.princ *output-stream* args))
(define (newline) (princ *linefeed*) #t) (define (newline) (princ *linefeed*) #t)
(define (display x) (princ x) #t) (define (display x) (princ x) #t)
@ -691,8 +694,8 @@
(newline)) (newline))
(define (print-exception e) (define (print-exception e)
(define (eprinc . args) (apply io.princ (cons *error-stream* args))) (define (eprinc . args) (apply io.princ *error-stream* args))
(define (eprint . args) (apply io.print (cons *error-stream* args))) (define (eprint . args) (apply io.print *error-stream* args))
(cond ((and (pair? e) (cond ((and (pair? e)
(eq? (car e) 'type-error) (eq? (car e) 'type-error)
(length= e 4)) (length= e 4))