mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-01-14 13:21:54 -08:00
Instead of using system property lists, create dispatch tables for handling the C1, T1, C2 forms and others.
This commit is contained in:
Juan Jose Garcia Ripoll
parent
75ba91304a
commit
910e79852e
27 changed files with 323 additions and 315 deletions
|
|
@ -93,5 +93,3 @@
|
|||
(wt ");")))
|
||||
(push 'BDS-BIND *unwind-exit*)
|
||||
(wt-comment (var-name var)))
|
||||
|
||||
(put-sysprop 'BIND 'SET-LOC 'bind)
|
||||
|
|
|
|||
|
|
@ -115,11 +115,3 @@
|
|||
(*exit* (blk-exit blk)))
|
||||
(c2expr val))))
|
||||
)
|
||||
|
||||
;;; ----------------------------------------------------------------------
|
||||
|
||||
(put-sysprop 'BLOCK 'C1SPECIAL 'c1block)
|
||||
(put-sysprop 'BLOCK 'C2 'c2block)
|
||||
|
||||
(put-sysprop 'RETURN-FROM 'C1SPECIAL 'c1return-from)
|
||||
(put-sysprop 'RETURN-FROM 'C2 'c2return-from)
|
||||
|
|
|
|||
|
|
@ -28,7 +28,7 @@
|
|||
|
||||
(defun wt-h1 (form)
|
||||
(if (consp form)
|
||||
(let ((fun (get-sysprop (car form) 'wt-loc)))
|
||||
(let ((fun (gethash (car form) *wt-loc-dispatch-table*)))
|
||||
(if fun
|
||||
(let ((*compiler-output1* *compiler-output2*))
|
||||
(apply fun (cdr form)))
|
||||
|
|
|
|||
|
|
@ -273,13 +273,3 @@
|
|||
(when (fun-needs-narg fun)
|
||||
(push narg args))
|
||||
(wt-call fun-c-name args fun-lisp-name env)))
|
||||
|
||||
;;; ----------------------------------------------------------------------
|
||||
|
||||
(put-sysprop 'funcall 'C1 'c1funcall)
|
||||
(put-sysprop 'funcall 'c2 'c2funcall)
|
||||
(put-sysprop 'call-global 'c2 'c2call-global)
|
||||
|
||||
(put-sysprop 'CALL 'WT-LOC #'wt-call)
|
||||
(put-sysprop 'CALL-NORMAL 'WT-LOC #'wt-call-normal)
|
||||
(put-sysprop 'CALL-INDIRECT 'WT-LOC #'wt-call-indirect)
|
||||
|
|
|
|||
|
|
@ -97,12 +97,3 @@
|
|||
(let ((*destination* loc)) (c2expr* tag))))
|
||||
(let ((*destination* 'VALUES)) (c2expr* val))
|
||||
(wt-nl "cl_throw(" loc ");"))
|
||||
|
||||
;;; ----------------------------------------------------------------------
|
||||
|
||||
(put-sysprop 'CATCH 'C1SPECIAL 'c1catch)
|
||||
(put-sysprop 'CATCH 'C2 'c2catch)
|
||||
(put-sysprop 'UNWIND-PROTECT 'C1SPECIAL 'c1unwind-protect)
|
||||
(put-sysprop 'UNWIND-PROTECT 'C2 'c2unwind-protect)
|
||||
(put-sysprop 'THROW 'C1SPECIAL 'c1throw)
|
||||
(put-sysprop 'THROW 'C2 'c2throw)
|
||||
|
|
|
|||
|
|
@ -133,5 +133,3 @@
|
|||
(foreign-elt-type-code return-type) ",aux);")
|
||||
(wt-nl "return output;"))
|
||||
(wt-nl1 "}")))
|
||||
|
||||
(put-sysprop 'FFI:DEFCALLBACK 'C1 #'c1-defcallback)
|
||||
|
|
|
|||
|
|
@ -48,14 +48,9 @@
|
|||
(defun c1t () *c1t*)
|
||||
|
||||
(defun c1call-symbol (fname args &aux fd)
|
||||
(cond ((setq fd (get-sysprop fname 'c1special)) (funcall fd args))
|
||||
((c1call-local fname args))
|
||||
((and (setq fd (get-sysprop fname 'C1))
|
||||
(inline-possible fname))
|
||||
(cond ((setq fd (gethash fname *c1-dispatch-table*))
|
||||
(funcall fd args))
|
||||
((and (setq fd (get-sysprop fname 'C1CONDITIONAL))
|
||||
(inline-possible fname)
|
||||
(funcall fd args)))
|
||||
((c1call-local fname args))
|
||||
((and (setq fd (compiler-macro-function fname))
|
||||
(inline-possible fname)
|
||||
(let ((success nil))
|
||||
|
|
@ -118,7 +113,7 @@
|
|||
(with-c1form-env (form form)
|
||||
(let* ((name (c1form-name form))
|
||||
(args (c1form-args form))
|
||||
(dispatch (get-sysprop name 'C2)))
|
||||
(dispatch (gethash name *c2-dispatch-table*)))
|
||||
(if (or (eq name 'LET) (eq name 'LET*))
|
||||
(let ((*volatile* (c1form-volatile* form)))
|
||||
(declare (special *volatile*))
|
||||
|
|
@ -191,10 +186,3 @@
|
|||
`(progn
|
||||
(defun ,name ,vars ,@body)
|
||||
(define-compiler-macro ,name ,temps (list* 'LET ,binding ',body))))))
|
||||
|
||||
;;; ----------------------------------------------------------------------
|
||||
|
||||
(put-sysprop 'PROGN 'C1SPECIAL 'c1progn)
|
||||
(put-sysprop 'PROGN 'C2 'c2progn)
|
||||
(put-sysprop 'EXT:WITH-BACKEND 'C1SPECIAL 'c1with-backend)
|
||||
(put-sysprop 'EXT:WITH-BACKEND 'T1 'c1with-backend)
|
||||
|
|
|
|||
|
|
@ -563,9 +563,3 @@
|
|||
(cmperr "C-INLINE: Variable code exceeds number of arguments")))))
|
||||
(otherwise
|
||||
(write-char c *compiler-output1*))))))
|
||||
|
||||
(put-sysprop 'FFI:CLINES 'C1SPECIAL #'c1clines)
|
||||
(put-sysprop 'FFI:C-INLINE 'C1SPECIAL #'c1c-inline)
|
||||
(put-sysprop 'FFI:C-INLINE 'C2 #'c2c-inline)
|
||||
(put-sysprop 'FFI:C-INLINE 'WT-LOC #'wt-c-inline-loc)
|
||||
(put-sysprop 'COERCE-LOC 'WT-LOC #'wt-coerce-loc)
|
||||
|
|
|
|||
|
|
@ -263,16 +263,3 @@
|
|||
(*temp* *temp*))
|
||||
(unwind-exit (list 'CALL-NORMAL fun (coerce-locs (inline-args args))))
|
||||
(close-inline-blocks))))
|
||||
|
||||
;;; ----------------------------------------------------------------------
|
||||
|
||||
(put-sysprop 'FLET 'C1SPECIAL 'c1flet)
|
||||
(put-sysprop 'LABELS 'C1SPECIAL 'c1labels)
|
||||
(put-sysprop 'LOCALLY 'C1SPECIAL 'c1locally)
|
||||
(put-sysprop 'MACROLET 'C1SPECIAL 'c1macrolet)
|
||||
(put-sysprop 'SYMBOL-MACROLET 'C1SPECIAL 'c1symbol-macrolet)
|
||||
|
||||
(put-sysprop 'LOCALS 'c2 'c2locals) ; replaces both c2flet and c2lables
|
||||
;;; c2macrolet is not defined, because MACROLET is replaced by PROGN
|
||||
;;; during Pass 1.
|
||||
(put-sysprop 'CALL-LOCAL 'C2 'c2call-local)
|
||||
|
|
|
|||
|
|
@ -104,39 +104,6 @@
|
|||
(unwind-exit x)
|
||||
(close-inline-blocks)))
|
||||
|
||||
(defun co1nth (args)
|
||||
(and (not (endp args))
|
||||
(not (endp (cdr args)))
|
||||
(endp (cddr args))
|
||||
(numberp (car args))
|
||||
(<= 0 (car args) 7)
|
||||
(c1expr (case (car args)
|
||||
(0 (cons 'CAR (cdr args)))
|
||||
(1 (cons 'CADR (cdr args)))
|
||||
(2 (cons 'CADDR (cdr args)))
|
||||
(3 (cons 'CADDDR (cdr args)))
|
||||
(4 (list 'CAR (cons 'CDDDDR (cdr args))))
|
||||
(5 (list 'CADR (cons 'CDDDDR (cdr args))))
|
||||
(6 (list 'CADDR (cons 'CDDDDR (cdr args))))
|
||||
(7 (list 'CADDDR (cons 'CDDDDR (cdr args))))
|
||||
))))
|
||||
|
||||
(defun co1nthcdr (args)
|
||||
(and (not (endp args))
|
||||
(not (endp (cdr args)))
|
||||
(endp (cddr args))
|
||||
(numberp (car args))
|
||||
(<= 0 (car args) 7)
|
||||
(c1expr (case (car args)
|
||||
(0 (second args))
|
||||
(1 (cons 'CDR (cdr args)))
|
||||
(2 (cons 'CDDR (cdr args)))
|
||||
(3 (cons 'CDDDR (cdr args)))
|
||||
(4 (cons 'CDDDDR (cdr args)))
|
||||
(5 (list 'CDR (cons 'CDDDDR (cdr args))))
|
||||
(6 (list 'CDDR (cons 'CDDDDR (cdr args))))
|
||||
(7 (list 'CDDDR (cons 'CDDDDR (cdr args))))))))
|
||||
|
||||
;;----------------------------------------------------------------------
|
||||
;; We transform BOOLE into the individual operations, which have
|
||||
;; inliners
|
||||
|
|
@ -165,41 +132,6 @@
|
|||
|
||||
;----------------------------------------------------------------------
|
||||
|
||||
(defun co1coerce (args &aux expr type (info (make-info)))
|
||||
(and args (cdr args) (endp (cddr args))
|
||||
(let ((expr (first args))
|
||||
(type (second args)))
|
||||
(and (listp type)
|
||||
(eq (car type) 'QUOTE)
|
||||
(case (second type)
|
||||
((CHARACTER BASE-CHAR) (c1expr `(CHARACTER ,expr)))
|
||||
(FLOAT (c1expr `(FLOAT ,expr)))
|
||||
(SHORT-FLOAT (c1expr `(FLOAT ,expr 0.0S0)))
|
||||
(SINGLE-FLOAT (c1expr `(FLOAT ,expr 0.0F0)))
|
||||
(DOUBLE-FLOAT (c1expr `(FLOAT ,expr 0.0D0)))
|
||||
(LONG-FLOAT (c1expr `(FLOAT ,expr 0.0L0)))
|
||||
)))))
|
||||
|
||||
;----------------------------------------------------------------------
|
||||
;; turn repetitious cons's into a list*
|
||||
|
||||
(defun co1cons (args &aux temp)
|
||||
(labels ((cons-to-lista (x)
|
||||
(let ((tem (last x)))
|
||||
(if (and (consp tem)
|
||||
(consp (car tem))
|
||||
(eq (caar tem) 'CONS)
|
||||
(eql (length (cdar tem)) 2))
|
||||
(cons-to-lista (append (butlast x) (cdar tem)))
|
||||
x))))
|
||||
(and (eql (length args) 2)
|
||||
(not (eq args (setq temp (cons-to-lista args))))
|
||||
(c1expr (if (equal '(nil) (last temp))
|
||||
(cons 'LIST (butlast temp))
|
||||
(cons 'LIST* temp))))))
|
||||
|
||||
;----------------------------------------------------------------------
|
||||
|
||||
;; Return the most particular type we can EASILY obtain from x.
|
||||
(defun result-type (x)
|
||||
(cond ((symbolp x)
|
||||
|
|
@ -210,34 +142,3 @@
|
|||
(second x))
|
||||
(t t)))
|
||||
|
||||
;----------------------------------------------------------------------
|
||||
|
||||
;;; Look for inline expansion of LDB1 in sysfun.lsp
|
||||
|
||||
(defun co1ldb (args &aux (arg1 (first args))
|
||||
(len (integer-length most-positive-fixnum))
|
||||
size pos)
|
||||
(and (consp arg1)
|
||||
(eq 'BYTE (car arg1))
|
||||
(integerp (setq size (second arg1)))
|
||||
(integerp (setq pos (third arg1)))
|
||||
(<= (+ size pos) len)
|
||||
(subtypep (result-type (second args)) 'FIXNUM)
|
||||
(c1expr `(the fixnum (ldb1 ,size ,pos ,(second args))))))
|
||||
|
||||
;;; ----------------------------------------------------------------------
|
||||
|
||||
(put-sysprop 'princ 'C1 'c1princ)
|
||||
(put-sysprop 'c2princ 'C2 'c2princ)
|
||||
(put-sysprop 'terpri 'C1 'c1terpri)
|
||||
|
||||
(put-sysprop 'apply 'C1 'c1apply)
|
||||
|
||||
(put-sysprop 'rplacd 'C1 'c1rplacd)
|
||||
(put-sysprop 'rplacd 'C2 'c2rplacd)
|
||||
|
||||
(put-sysprop 'nth 'C1CONDITIONAL 'co1nth)
|
||||
(put-sysprop 'nthcdr 'C1CONDITIONAL 'co1nthcdr)
|
||||
|
||||
(put-sysprop 'cons 'C1CONDITIONAL 'co1cons)
|
||||
(put-sysprop 'ldb 'C1CONDITIONAL 'co1ldb)
|
||||
|
|
|
|||
|
|
@ -197,16 +197,3 @@
|
|||
(t
|
||||
(unwind-no-exit label)
|
||||
(wt-nl) (wt-go label)))))
|
||||
|
||||
;;; ----------------------------------------------------------------------
|
||||
|
||||
(put-sysprop 'if 'c1special 'c1if)
|
||||
(put-sysprop 'if 'c2 'c2if)
|
||||
(put-sysprop 'not 'c1 'c1not)
|
||||
(put-sysprop 'fmla-not 'c2 'c2fmla-not)
|
||||
(put-sysprop 'and 'c1 'c1and)
|
||||
(put-sysprop 'fmla-and 'c2 'c2fmla-and)
|
||||
(put-sysprop 'or 'c1 'c1or)
|
||||
(put-sysprop 'fmla-or 'c2 'c2fmla-or)
|
||||
(put-sysprop 'jump-true 'set-loc 'set-jump-true)
|
||||
(put-sysprop 'jump-false 'set-loc 'set-jump-false)
|
||||
|
|
|
|||
|
|
@ -168,7 +168,7 @@
|
|||
;; Those functions that use INLINE-FUNCTION must rebind
|
||||
;; the variable *INLINE-BLOCKS*.
|
||||
(and (inline-possible fname)
|
||||
(not (get-sysprop fname 'C2))
|
||||
(not (gethash fname *c2-dispatch-table*))
|
||||
(let* ((dest-rep-type (loc-representation-type *destination*))
|
||||
(dest-type (rep-type->lisp-type dest-rep-type))
|
||||
(ii (get-inline-info fname arg-types return-type return-rep-type)))
|
||||
|
|
|
|||
|
|
@ -328,9 +328,3 @@
|
|||
(and (member (var-kind v2) '(SPECIAL GLOBAL))
|
||||
(eql (var-name v1) (var-name v2)))))
|
||||
(member var list))))
|
||||
|
||||
;;; ----------------------------------------------------------------------
|
||||
|
||||
(put-sysprop 'LET 'C1SPECIAL 'c1let)
|
||||
(put-sysprop 'LET* 'C1SPECIAL 'c1let*)
|
||||
(put-sysprop 'LET* 'C2 'c2let*)
|
||||
|
|
|
|||
|
|
@ -148,14 +148,15 @@
|
|||
((or (not (consp *destination*))
|
||||
(not (symbolp (car *destination*))))
|
||||
(baboon))
|
||||
((setq fd (get-sysprop (car *destination*) 'SET-LOC))
|
||||
((setq fd (gethash (car *destination*) *set-loc-dispatch-table*))
|
||||
(apply fd loc (cdr *destination*)))
|
||||
((setq fd (get-sysprop (car *destination*) 'WT-LOC))
|
||||
((setq fd (gethash (car *destination*) *wt-loc-dispatch-table*))
|
||||
(wt-nl) (apply fd (cdr *destination*)) (wt "= ")
|
||||
(wt-coerce-loc (loc-representation-type *destination*) loc)
|
||||
(wt ";"))
|
||||
(t (baboon)))))
|
||||
)
|
||||
(t (baboon :format-control "Unknown location found in SET-LOC~%~S"
|
||||
:format-arguments (list loc)))))))
|
||||
|
||||
|
||||
(defun wt-loc (loc &aux fd)
|
||||
(cond ((eq loc nil) (wt "Cnil"))
|
||||
|
|
@ -174,11 +175,12 @@
|
|||
(wt-var loc))
|
||||
((or (not (consp loc))
|
||||
(not (symbolp (car loc))))
|
||||
(baboon))
|
||||
((setq fd (get-sysprop (car loc) 'WT-LOC))
|
||||
(baboon :format-control "Unknown location found in WT-LOC~%~S"
|
||||
:format-arguments (list loc)))
|
||||
((setq fd (gethash (car loc) *wt-loc-dispatch-table*))
|
||||
(apply fd (cdr loc)))
|
||||
(t (baboon)))
|
||||
)
|
||||
(t (baboon :format-control "Unknown location found in WT-LOC~%~S"
|
||||
:format-arguments (list loc)))))
|
||||
|
||||
(defun last-call-p ()
|
||||
(member *exit*
|
||||
|
|
@ -234,20 +236,3 @@
|
|||
|
||||
(defun values-loc (n)
|
||||
(list 'VALUE n))
|
||||
|
||||
;;; -----------------------------------------------------------------
|
||||
|
||||
(put-sysprop 'TEMP 'WT-LOC #'wt-temp)
|
||||
(put-sysprop 'LCL 'WT-LOC #'wt-lcl-loc)
|
||||
(put-sysprop 'VV 'WT-LOC #'wt-vv)
|
||||
(put-sysprop 'VV-temp 'WT-LOC #'wt-vv-temp)
|
||||
(put-sysprop 'CAR 'WT-LOC #'wt-car)
|
||||
(put-sysprop 'CDR 'WT-LOC #'wt-cdr)
|
||||
(put-sysprop 'CADR 'WT-LOC #'wt-cadr)
|
||||
(put-sysprop 'FIXNUM-VALUE 'WT-LOC #'wt-number)
|
||||
(put-sysprop 'CHARACTER-VALUE 'WT-LOC #'wt-character)
|
||||
(put-sysprop 'LONG-FLOAT-VALUE 'WT-LOC #'wt-number)
|
||||
(put-sysprop 'DOUBLE-FLOAT-VALUE 'WT-LOC #'wt-number)
|
||||
(put-sysprop 'SINGLE-FLOAT-VALUE 'WT-LOC #'wt-number)
|
||||
(put-sysprop 'VALUE 'WT-LOC #'wt-value)
|
||||
(put-sysprop 'KEYVARS 'WT-LOC #'wt-keyvars)
|
||||
|
|
|
|||
|
|
@ -298,15 +298,3 @@
|
|||
(wt "}"))
|
||||
)
|
||||
|
||||
;;; ----------------------------------------------------------------------
|
||||
|
||||
(put-sysprop 'multiple-value-call 'c1special 'c1multiple-value-call)
|
||||
(put-sysprop 'multiple-value-call 'c2 'c2multiple-value-call)
|
||||
(put-sysprop 'multiple-value-prog1 'c1special 'c1multiple-value-prog1)
|
||||
(put-sysprop 'multiple-value-prog1 'c2 'c2multiple-value-prog1)
|
||||
(put-sysprop 'values 'c1 'c1values)
|
||||
(put-sysprop 'values 'c2 'c2values)
|
||||
(put-sysprop 'multiple-value-setq 'c1 'c1multiple-value-setq)
|
||||
(put-sysprop 'multiple-value-setq 'c2 'c2multiple-value-setq)
|
||||
(put-sysprop 'multiple-value-bind 'c1 'c1multiple-value-bind)
|
||||
(put-sysprop 'multiple-value-bind 'c2 'c2multiple-value-bind)
|
||||
|
|
|
|||
33
src/cmp/cmpopt-bits.lsp
Normal file
33
src/cmp/cmpopt-bits.lsp
Normal file
|
|
@ -0,0 +1,33 @@
|
|||
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*-
|
||||
;;;;
|
||||
;;;; Copyright (c) 2010, Juan Jose Garcia-Ripoll
|
||||
;;;;
|
||||
;;;; This program is free software; you can redistribute it and/or
|
||||
;;;; modify it under the terms of the GNU Library General Public
|
||||
;;;; License as published by the Free Software Foundation; either
|
||||
;;;; version 2 of the License, or (at your option) any later version.
|
||||
;;;;
|
||||
;;;; See file '../Copyright' for full details.
|
||||
;;;;
|
||||
;;;; CMPOPT-BITS -- Optimize operations acting on bits
|
||||
;;;;
|
||||
|
||||
(in-package "COMPILER")
|
||||
|
||||
;;;
|
||||
;;; LDB
|
||||
;;; Look for inline expansion of LDB1 in sysfun.lsp
|
||||
;;;
|
||||
|
||||
(define-compiler-macro ldb (&whole whole &rest args)
|
||||
(let ((arg1 (first args))
|
||||
(len (integer-length most-positive-fixnum))
|
||||
size pos)
|
||||
(if (and (consp arg1)
|
||||
(eq 'BYTE (car arg1))
|
||||
(integerp (setq size (second arg1)))
|
||||
(integerp (setq pos (third arg1)))
|
||||
(<= (+ size pos) len)
|
||||
(subtypep (result-type (second args)) 'FIXNUM))
|
||||
`(the fixnum (ldb1 ,size ,pos ,(second args)))
|
||||
whole)))
|
||||
|
|
@ -44,6 +44,28 @@
|
|||
`(ffi:c-inline (,x) (:object) :object "ECL_CONS_CDR(#0)"
|
||||
:one-liner t :side-effects nil))
|
||||
;;;
|
||||
;;; CONS
|
||||
;;; turn repetitious cons's into a list*
|
||||
;;;
|
||||
|
||||
(define-compiler-macro cons (&whole whole &rest args)
|
||||
(labels ((cons-to-lista (x)
|
||||
(let ((tem (last x)))
|
||||
(if (and (consp tem)
|
||||
(consp (car tem))
|
||||
(eq (caar tem) 'CONS)
|
||||
(eql (length (cdar tem)) 2))
|
||||
(cons-to-lista (append (butlast x) (cdar tem)))
|
||||
x))))
|
||||
(let (temp)
|
||||
(if (and (eql (length args) 2)
|
||||
(not (eq args (setq temp (cons-to-lista args)))))
|
||||
(if (equal '(nil) (last temp))
|
||||
(cons 'LIST (butlast temp))
|
||||
(cons 'LIST* temp))
|
||||
whole))))
|
||||
|
||||
;;;
|
||||
;;; RPLACA / RPLACD
|
||||
;;;
|
||||
|
||||
|
|
@ -57,3 +79,44 @@
|
|||
(define-simple-optimizer rplacd ((c cons) value)
|
||||
(:object :object) :object
|
||||
"@0;(ECL_CONS_CDR(#0)=#1,#0)" :one-liner t)
|
||||
|
||||
;;;
|
||||
;;; NTH / NTHCDR
|
||||
;;;
|
||||
|
||||
(define-compiler-macro nth (&whole whole &rest args)
|
||||
(if (and (not (endp args))
|
||||
(not (endp (cdr args)))
|
||||
(endp (cddr args))
|
||||
(numberp (car args))
|
||||
(<= 0 (car args) 7))
|
||||
(case (car args)
|
||||
(0 (cons 'CAR (cdr args)))
|
||||
(1 (cons 'CADR (cdr args)))
|
||||
(2 (cons 'CADDR (cdr args)))
|
||||
(3 (cons 'CADDDR (cdr args)))
|
||||
(4 (list 'CAR (cons 'CDDDDR (cdr args))))
|
||||
(5 (list 'CADR (cons 'CDDDDR (cdr args))))
|
||||
(6 (list 'CADDR (cons 'CDDDDR (cdr args))))
|
||||
(7 (list 'CADDDR (cons 'CDDDDR (cdr args))))
|
||||
(t whole))
|
||||
whole))
|
||||
|
||||
(define-compiler-macro nthcdr (&whole whole &rest args)
|
||||
(if (and (not (endp args))
|
||||
(not (endp (cdr args)))
|
||||
(endp (cddr args))
|
||||
(numberp (car args))
|
||||
(<= 0 (car args) 7))
|
||||
(case (car args)
|
||||
(0 (second args))
|
||||
(1 (cons 'CDR (cdr args)))
|
||||
(2 (cons 'CDDR (cdr args)))
|
||||
(3 (cons 'CDDDR (cdr args)))
|
||||
(4 (cons 'CDDDDR (cdr args)))
|
||||
(5 (list 'CDR (cons 'CDDDDR (cdr args))))
|
||||
(6 (list 'CDDR (cons 'CDDDDR (cdr args))))
|
||||
(7 (list 'CDDDR (cons 'CDDDDR (cdr args))))
|
||||
(t whole))
|
||||
whole))
|
||||
|
||||
|
|
|
|||
|
|
@ -46,5 +46,3 @@
|
|||
(declare ,@declarations)
|
||||
,body)))
|
||||
,@output)))))
|
||||
|
||||
(put-sysprop 'EXT:COMPILER-TYPECASE 'C1SPECIAL 'C1COMPILER-TYPECASE)
|
||||
|
|
|
|||
|
|
@ -1,7 +1,6 @@
|
|||
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*-
|
||||
;;;;
|
||||
;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
|
||||
;;;; Copyright (c) 1990, Giuseppe Attardi.
|
||||
;;;; Copyright (c) 2010, Juan Jose Garcia-Ripoll
|
||||
;;;;
|
||||
;;;; This program is free software; you can redistribute it and/or
|
||||
;;;; modify it under the terms of the GNU Library General Public
|
||||
|
|
@ -181,20 +180,6 @@ of the occurrences in those lists."
|
|||
(let ((type (p1propagate body assumptions)))
|
||||
(values type assumptions)))
|
||||
|
||||
(defun p1let (c1form base-assumptions vars forms body)
|
||||
(let ((new-assumptions base-assumptions))
|
||||
(loop for v in vars
|
||||
for f in forms
|
||||
do (multiple-value-bind (type ass)
|
||||
(p1propagate f base-assumptions)
|
||||
(setf new-assumptions (p1expand-assumptions v type new-assumptions))))
|
||||
(multiple-value-bind (type assumptions)
|
||||
(p1propagate body new-assumptions)
|
||||
(loop for v in vars
|
||||
do (revise-var-type v assumptions base-assumptions))
|
||||
(values (setf (c1form-type c1form) type)
|
||||
assumptions))))
|
||||
|
||||
(defun p1let* (c1form base-assumptions vars forms body)
|
||||
(let ((assumptions base-assumptions))
|
||||
(loop for v in vars
|
||||
|
|
@ -307,7 +292,6 @@ as 2^*tagbody-limit* in the worst cases.")
|
|||
(put-sysprop 'decl-body 'p1propagate 'p1decl-body)
|
||||
(put-sysprop 'if 'p1propagate #'p1if)
|
||||
(put-sysprop 'LAMBDA 'P1PROPAGATE 'p1lambda)
|
||||
(put-sysprop 'LET 'P1PROPAGATE 'p1let)
|
||||
(put-sysprop 'LET* 'P1PROPAGATE 'p1let*)
|
||||
(put-sysprop 'LOCALS 'p1propagate 'p1locals)
|
||||
(put-sysprop 'MULTIPLE-VALUE-BIND 'p1propagate 'p1multiple-value-bind)
|
||||
|
|
|
|||
|
|
@ -148,18 +148,3 @@
|
|||
(wt "ecl_make_cfun((cl_objectfn_fixed)" cfun ",Cnil,Cblock," narg ")"))
|
||||
(t ; empty environment variable number of args
|
||||
(wt "ecl_make_cfun_va((cl_objectfn)" cfun ",Cnil,Cblock)")))))
|
||||
|
||||
|
||||
;;; ----------------------------------------------------------------------
|
||||
|
||||
(put-sysprop 'quote 'c1special 'c1quote)
|
||||
(put-sysprop 'function 'c1special 'c1function)
|
||||
(put-sysprop 'function 'c2 'c2function)
|
||||
(put-sysprop 'the 'c1special 'c1the)
|
||||
(put-sysprop 'eval-when 'c1special 'c1eval-when)
|
||||
(put-sysprop 'declare 'c1special 'c1declare)
|
||||
(put-sysprop 'ext:compiler-let 'c1special 'c1compiler-let)
|
||||
(put-sysprop 'ext:compiler-let 'c2 'c2compiler-let)
|
||||
|
||||
(put-sysprop 'fdefinition 'wt-loc 'wt-fdefinition)
|
||||
(put-sysprop 'make-cclosure 'wt-loc 'wt-make-closure)
|
||||
|
|
|
|||
|
|
@ -79,12 +79,3 @@
|
|||
(c1expr `(c-inline ,args (t t) (values &rest t)
|
||||
"cl_env_copy->values[0]=ecl_apply_from_stack_frame(#0,#1);"
|
||||
:one-liner nil :side-effects t)))
|
||||
|
||||
(put-sysprop 'with-stack 'C1 #'c1with-stack)
|
||||
(put-sysprop 'with-stack 'c2 #'c2with-stack)
|
||||
(put-sysprop 'innermost-stack-frame 'C1 #'c1innermost-stack-frame)
|
||||
(put-sysprop 'stack-push 'C1 #'c1stack-push)
|
||||
(put-sysprop 'stack-push-values 'C1 #'c1stack-push-values)
|
||||
(put-sysprop 'stack-push-values 'C2 #'c2stack-push-values)
|
||||
(put-sysprop 'stack-pop 'C1 #'c1stack-pop)
|
||||
(put-sysprop 'si::apply-from-stack-frame 'c1 #'c1apply-from-stack-frame)
|
||||
|
|
@ -142,9 +142,3 @@
|
|||
(wt-nl "(" x ")->str.self[" index "]= " y ";"))
|
||||
(unwind-exit y)
|
||||
(close-inline-blocks)))
|
||||
|
||||
(put-sysprop 'SYS:STRUCTURE-REF 'C1 'c1structure-ref)
|
||||
(put-sysprop 'SYS:STRUCTURE-REF 'C2 'c2structure-ref)
|
||||
(put-sysprop 'SYS:STRUCTURE-REF 'WT-LOC 'wt-structure-ref)
|
||||
(put-sysprop 'SYS:STRUCTURE-SET 'C1 'c1structure-set)
|
||||
(put-sysprop 'SYS:STRUCTURE-SET 'C2 'c2structure-set)
|
||||
|
|
|
|||
206
src/cmp/cmptables.lsp
Normal file
206
src/cmp/cmptables.lsp
Normal file
|
|
@ -0,0 +1,206 @@
|
|||
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*-
|
||||
;;;;
|
||||
;;;; Copyright (c) 2010, Juan Jose Garcia-Ripoll
|
||||
;;;;
|
||||
;;;; This program is free software; you can redistribute it and/or
|
||||
;;;; modify it under the terms of the GNU Library General Public
|
||||
;;;; License as published by the Free Software Foundation; either
|
||||
;;;; version 2 of the License, or (at your option) any later version.
|
||||
;;;;
|
||||
;;;; See file '../Copyright' for full details.
|
||||
|
||||
;;;; CMPPROP Type propagation.
|
||||
|
||||
(in-package "COMPILER")
|
||||
|
||||
(defconstant +c1-dispatch-alist+
|
||||
'((block . c1block) ; c1special
|
||||
(return-from . c1return-from) ; c1special
|
||||
(funcall . c1funcall) ; c1
|
||||
(catch . c1catch) ; c1special
|
||||
(unwind-protect . c1unwind-protect) ; c1special
|
||||
(throw . c1throw) ; c1special
|
||||
(ffi:defcallback . c1-defcallback) ; c1
|
||||
(progn . c1progn) ; c1special
|
||||
(ext:with-backend . c1with-backend) ; c1special
|
||||
(ffi:clines . c1clines) ; c1special
|
||||
(ffi:c-inline . c1c-inline) ; c1special
|
||||
(flet . c1flet) ; c1special
|
||||
(labels . c1labels) ; c1special
|
||||
(locally . c1locally) ; c1special
|
||||
(macrolet . c1macrolet) ; c1special
|
||||
(symbol-macrolet . c1symbol-macrolet) ; c1special
|
||||
|
||||
(if . c1if) ; c1special
|
||||
(not . c1not) ; c1special
|
||||
(and . c1and) ; c1special
|
||||
(or . c1or) ; c1special
|
||||
|
||||
(let . c1let) ; c1special
|
||||
(let* . c1let*) ; c1special
|
||||
|
||||
(multiple-value-call . c1multiple-value-call) ; c1special
|
||||
(multiple-value-prog1 . c1multiple-value-prog1) ; c1special
|
||||
(values . c1values) ; c1
|
||||
(multiple-value-setq . c1multiple-value-setq) ; c1
|
||||
(multiple-value-bind . c1multiple-value-bind) ; c1
|
||||
|
||||
(ext:compiler-typecase . c1compiler-typecase) ; c1special
|
||||
|
||||
(quote . c1quote) ; c1special
|
||||
(function . c1function) ; c1special
|
||||
(the . c1the) ; c1special
|
||||
(eval-when . c1eval-when) ; c1special
|
||||
(declare . c1declare) ; c1special
|
||||
(ext:compiler-let . c1compiler-let) ; c1special
|
||||
|
||||
(with-stack . c1with-stack) ; c1
|
||||
(innermost-stack-frame . c1innermost-stack-frame) ; c1
|
||||
(stack-push . c1stack-push) ; c1
|
||||
(stack-push-values . c1stack-push-values) ; c1
|
||||
(stack-pop . c1stack-pop) ; c1
|
||||
(si::apply-from-stack-frame . c1apply-from-stack-frame) ; c1
|
||||
|
||||
(tagbody . c1tagbody) ; c1special
|
||||
(go . c1go) ; c1special
|
||||
|
||||
(setq . c1setq) ; c1special
|
||||
(progv . c1progv) ; c1special
|
||||
(psetq . c1psetq) ; c1special
|
||||
|
||||
(sys:structure-ref . c1structure-ref) ; c1
|
||||
(sys:structure-set . c1structure-set) ; c1
|
||||
|
||||
(load-time-value . c1load-time-value) ; c1
|
||||
(si:fset . c1fset) ; c1
|
||||
|
||||
(princ . c1princ) ; c1
|
||||
(terpri . c1terpri) ; c1
|
||||
(apply . c1apply) ; c1
|
||||
(rplacd . c1rplacd) ; c1
|
||||
))
|
||||
|
||||
(defconstant +t1-dispatch-alist+
|
||||
'((ext:with-backend . c1with-backend) ; t1
|
||||
|
||||
(defmacro . t1defmacro)
|
||||
(compiler-let . c1compiler-let)
|
||||
(eval-when . c1eval-when)
|
||||
(progn . c1progn)
|
||||
(macrolet . c1macrolet)
|
||||
(locally . c1locally)
|
||||
(symbol-macrolet . c1symbol-macrolet)
|
||||
))
|
||||
|
||||
(defconstant +set-loc-dispatch-alist+
|
||||
'((bind . bind)
|
||||
(jump-true . set-jump-true)
|
||||
(jump-false . set-jump-false)
|
||||
))
|
||||
|
||||
(defconstant +wt-loc-dispatch-alist+
|
||||
'((call . wt-call)
|
||||
(call-normal . wt-call-normal)
|
||||
(call-indirect . wt-call-indirect)
|
||||
(ffi:c-inline . wt-c-inline-loc)
|
||||
(coerce-loc . wt-coerce-loc)
|
||||
|
||||
(temp . wt-temp)
|
||||
(lcl . wt-lcl-loc)
|
||||
(vv . wt-vv)
|
||||
(vv-temp . wt-vv-temp)
|
||||
(car . wt-car)
|
||||
(cdr . wt-cdr)
|
||||
(cadr . wt-cadr)
|
||||
(fixnum-value . wt-number)
|
||||
(long-float-value . wt-number)
|
||||
(double-float-value . wt-number)
|
||||
(single-float-value . wt-number)
|
||||
(short-float-value . wt-number)
|
||||
(character-value . wt-character)
|
||||
(value . wt-value)
|
||||
(keyvars . wt-keyvars)
|
||||
|
||||
(fdefinition . wt-fdefinition)
|
||||
(make-cclosure . wt-make-closure)
|
||||
|
||||
(structure-ref . wt-structure-ref)
|
||||
))
|
||||
|
||||
(defconstant +c2-dispatch-alist+
|
||||
'((block . c2block) ; c2
|
||||
(return-from . c2return-from) ; c2
|
||||
(funcall . c2funcall) ; c2
|
||||
(call-global . c2call-global) ; c2
|
||||
(catch . c2catch) ; c2
|
||||
(unwind-protect . c2unwind-protect) ; c2
|
||||
(throw . c2throw) ; c2
|
||||
(progn . c2progn) ; c2
|
||||
(ffi:c-inline . c2c-inline) ; c2
|
||||
(locals . c2locals) ; c2
|
||||
(call-local . c2call-local) ; c2
|
||||
|
||||
(if . c2if)
|
||||
(fmla-not . c2fmla-not)
|
||||
(fmla-and . c2fmla-and)
|
||||
(fmla-or . c2fmla-or)
|
||||
|
||||
(let* . c2let*)
|
||||
|
||||
(multiple-value-call . c2multiple-value-call) ; c2
|
||||
(multiple-value-prog1 . c2multiple-value-prog1) ; c2
|
||||
(values . c2values) ; c2
|
||||
(multiple-value-setq . c2multiple-value-setq) ; c2
|
||||
(multiple-value-bind . c2multiple-value-bind) ; c2
|
||||
|
||||
(function . c2function) ; c2
|
||||
(ext:compiler-let . c2compiler-let) ; c2
|
||||
|
||||
(with-stack . c2with-stack) ; c2
|
||||
(stack-push-values . c2stack-push-values) ; c2
|
||||
|
||||
(tagbody . c2tagbody) ; c2
|
||||
(go . c2go) ; c2
|
||||
|
||||
(var . c2var) ; c2
|
||||
(location . c2location) ; c2
|
||||
(setq . c2setq) ; c2
|
||||
(progv . c2progv) ; c2
|
||||
(psetq . c2psetq) ; c2
|
||||
|
||||
(si:fset . c2fset) ; c2
|
||||
|
||||
(sys:structure-ref . c2structure-ref) ; c2
|
||||
(sys:structure-set . c2structure-set) ; c2
|
||||
|
||||
(c2princ . c2princ) ; c2
|
||||
(rplacd . c2rplacd) ; c2
|
||||
))
|
||||
|
||||
(defconstant +t2-dispatch-alist+
|
||||
'((compiler-let . t2compiler-let)
|
||||
(progn . t2progn)
|
||||
(ordinary . t2ordinary)
|
||||
(load-time-value . t2load-time-value)
|
||||
(make-form . t2make-form)
|
||||
(init-form . t2init-form)
|
||||
))
|
||||
|
||||
(defun make-dispatch-table (alist)
|
||||
(loop with hash = (make-hash-table :size (max 128 (* 2 (length alist)))
|
||||
:test #'eq)
|
||||
for (name . function) in alist
|
||||
do (setf (gethash name hash) function)
|
||||
finally (return hash)))
|
||||
|
||||
(defparameter *c1-dispatch-table* (make-dispatch-table +c1-dispatch-alist+))
|
||||
|
||||
(defparameter *t1-dispatch-table* (make-dispatch-table +t1-dispatch-alist+))
|
||||
|
||||
(defparameter *c2-dispatch-table* (make-dispatch-table +c2-dispatch-alist+))
|
||||
|
||||
(defparameter *set-loc-dispatch-table* (make-dispatch-table +set-loc-dispatch-alist+))
|
||||
|
||||
(defparameter *wt-loc-dispatch-table* (make-dispatch-table +wt-loc-dispatch-alist+))
|
||||
|
||||
(defparameter *t2-dispatch-table* (make-dispatch-table +t2-dispatch-alist+))
|
||||
|
|
@ -217,11 +217,3 @@
|
|||
(progn
|
||||
(unwind-no-exit (tag-unwind-exit tag))
|
||||
(wt-nl) (wt-go (tag-label tag)))))
|
||||
|
||||
;;; ------------------------------------------------------------
|
||||
|
||||
(put-sysprop 'tagbody 'c1special 'c1tagbody)
|
||||
(put-sysprop 'tagbody 'c2 'c2tagbody)
|
||||
|
||||
(put-sysprop 'go 'c1special 'c1go)
|
||||
(put-sysprop 'go 'c2 'c2go)
|
||||
|
|
|
|||
|
|
@ -41,9 +41,9 @@
|
|||
(cmperr "~s is illegal function." fun))
|
||||
((eq fun 'QUOTE)
|
||||
(t1ordinary 'NIL))
|
||||
((setq fd (get-sysprop fun 'T1))
|
||||
((setq fd (gethash fun *t1-dispatch-table*))
|
||||
(funcall fd args))
|
||||
((or (get-sysprop fun 'C1) (get-sysprop fun 'C1SPECIAL))
|
||||
((gethash fun *c1-dispatch-table*)
|
||||
(t1ordinary form))
|
||||
((and (setq fd (compiler-macro-function fun))
|
||||
(inline-possible fun)
|
||||
|
|
@ -69,7 +69,7 @@
|
|||
|
||||
(defun t2expr (form)
|
||||
(when form
|
||||
(let* ((def (get-sysprop (c1form-name form) 'T2)))
|
||||
(let* ((def (gethash (c1form-name form) *t2-dispatch-table*)))
|
||||
(if def
|
||||
(let ((*compile-file-truename* (c1form-file form))
|
||||
(*compile-file-position* (c1form-file-position form))
|
||||
|
|
@ -812,29 +812,7 @@
|
|||
|
||||
;;; ----------------------------------------------------------------------
|
||||
|
||||
;;; Pass 1 top-levels.
|
||||
|
||||
(put-sysprop 'DEFMACRO 'T1 't1defmacro)
|
||||
(put-sysprop 'COMPILER-LET 'T1 'c1compiler-let)
|
||||
(put-sysprop 'EVAL-WHEN 'T1 'c1eval-when)
|
||||
(put-sysprop 'PROGN 'T1 'c1progn)
|
||||
(put-sysprop 'MACROLET 'T1 'c1macrolet)
|
||||
(put-sysprop 'LOCALLY 'T1 'c1locally)
|
||||
(put-sysprop 'SYMBOL-MACROLET 'T1 'c1symbol-macrolet)
|
||||
(put-sysprop 'LOAD-TIME-VALUE 'C1 'c1load-time-value)
|
||||
(put-sysprop 'SI:FSET 'C1 'c1fset)
|
||||
|
||||
;;; Pass 1 1/2 type propagation
|
||||
|
||||
(put-sysprop 'ORDINARY 'P1PROPAGATE 'p1ordinary)
|
||||
(put-sysprop 'SI:FSET 'P1PROPAGATE 'p1fset)
|
||||
|
||||
;;; Pass 2 initializers.
|
||||
|
||||
(put-sysprop 'COMPILER-LET 'T2 't2compiler-let)
|
||||
(put-sysprop 'PROGN 'T2 't2progn)
|
||||
(put-sysprop 'ORDINARY 'T2 't2ordinary)
|
||||
(put-sysprop 'LOAD-TIME-VALUE 'T2 't2load-time-value)
|
||||
(put-sysprop 'MAKE-FORM 'T2 't2make-form)
|
||||
(put-sysprop 'INIT-FORM 'T2 't2init-form)
|
||||
(put-sysprop 'SI:FSET 'C2 'c2fset)
|
||||
|
|
|
|||
|
|
@ -448,14 +448,3 @@
|
|||
(dotimes (i blocks) (wt "}"))
|
||||
(unwind-exit nil)
|
||||
)
|
||||
|
||||
;;; ----------------------------------------------------------------------
|
||||
|
||||
(put-sysprop 'VAR 'C2 'c2var)
|
||||
(put-sysprop 'LOCATION 'C2 'c2location)
|
||||
(put-sysprop 'SETQ 'c1special 'c1setq)
|
||||
(put-sysprop 'SETQ 'C2 'c2setq)
|
||||
(put-sysprop 'PROGV 'c1special 'c1progv)
|
||||
(put-sysprop 'PROGV 'C2 'c2progv)
|
||||
(put-sysprop 'PSETQ 'c1 'c1psetq)
|
||||
(put-sysprop 'PSETQ 'C2 'c2psetq)
|
||||
|
|
|
|||
|
|
@ -7,6 +7,7 @@
|
|||
"build:cmp;cmpdefs.lsp"
|
||||
"src:cmp;cmpmac.lsp"
|
||||
"src:cmp;cmpform.lsp"
|
||||
"src:cmp;cmptables.lsp"
|
||||
"src:cmp;cmpc-wt.lsp"
|
||||
"src:cmp;cmpinline.lsp"
|
||||
"src:cmp;cmputil.lsp"
|
||||
|
|
@ -45,6 +46,7 @@
|
|||
"src:cmp;cmpnum.lsp"
|
||||
"src:cmp;cmpname.lsp"
|
||||
"src:cmp;cmpopt.lsp"
|
||||
"src:cmp;cmpopt-bits.lsp"
|
||||
"src:cmp;cmpopt-constant.lsp"
|
||||
"src:cmp;cmpopt-cons.lsp"
|
||||
"src:cmp;cmpopt-sequence.lsp"
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue