From ffjeld at common-lisp.net Mon Mar 3 22:22:18 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Mon, 3 Mar 2008 17:22:18 -0500 (EST) Subject: [movitz-cvs] CVS ia-x86 Message-ID: <20080303222218.505B1830A0@common-lisp.net> Update of /project/movitz/cvsroot/ia-x86 In directory clnet:/tmp/cvs-serv22419 Modified Files: instr-shift.lisp Log Message: Add instruction RCR. --- /project/movitz/cvsroot/ia-x86/instr-shift.lisp 2004/01/16 11:54:14 1.2 +++ /project/movitz/cvsroot/ia-x86/instr-shift.lisp 2008/03/03 22:22:17 1.3 @@ -1,6 +1,6 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 20012000, 2002, +;;;; Copyright (C) 20012000, 2002, 2005, ;;;; Department of Computer Science, University of Tromso, Norway ;;;; ;;;; Filename: instr-shift.lisp @@ -9,7 +9,7 @@ ;;;; Created at: Tue May 2 10:56:33 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: instr-shift.lisp,v 1.2 2004/01/16 11:54:14 ffjeld Exp $ +;;;; $Id: instr-shift.lisp,v 1.3 2008/03/03 22:22:17 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -138,6 +138,25 @@ (:digit (#xd3 0) 0 (cl r/m32) :operand-mode :32-bit) (:digit (#xc1 0) 1 (imm8 r/m32) :operand-mode :32-bit)) +;;; Rotate right with CF + +(def-instr rcr (instruction)) + +(def-instr rcrb (shl) + (:digit (#xd0 2) 0 (1 r/m8)) + (:digit (#xd2 2) 0 (cl r/m8)) + (:digit (#xc0 2) 1 (imm8 r/m8))) + +(def-instr rcrw (rcr) + (:digit (#xd1 3) 0 (1 r/m16) :operand-mode :16-bit) + (:digit (#xd3 3) 0 (cl r/m16) :operand-mode :16-bit) + (:digit (#xc1 3) 1 (imm8 r/m16) :operand-mode :16-bit)) + +(def-instr rcrl (rcr) + (:digit (#xd1 3) 0 (1 r/m32) :operand-mode :32-bit) + (:digit (#xd3 3) 0 (cl r/m32) :operand-mode :32-bit) + (:digit (#xc1 3) 1 (imm8 r/m32) :operand-mode :32-bit)) + ;;; Rotate right without CF (def-instr ror (instruction)) From ffjeld at common-lisp.net Mon Mar 3 22:40:55 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Mon, 3 Mar 2008 17:40:55 -0500 (EST) Subject: [movitz-cvs] CVS movitz Message-ID: <20080303224055.D3468830C0@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv26370 Modified Files: bootblock.lisp Log Message: Make bootblock construction work: use 16-bit call targets in 16-bit mode (assembler problem). --- /project/movitz/cvsroot/movitz/bootblock.lisp 2008/02/18 22:30:21 1.15 +++ /project/movitz/cvsroot/movitz/bootblock.lisp 2008/03/03 22:40:55 1.16 @@ -9,7 +9,7 @@ ;;;; Created at: Mon Oct 9 20:47:19 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: bootblock.lisp,v 1.15 2008/02/18 22:30:21 ffjeld Exp $ +;;;; $Id: bootblock.lisp,v 1.16 2008/03/03 22:40:55 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -96,19 +96,19 @@ (:movw #xfffc :bp) (:leaw (:bp ,(- +stack-frame-size+)) :sp) (:movw 'welcome :si) ; Print welcome message) - (:call 'print) + (:callw 'print) ;; ;; Enable the A20 gate ;; - (:call 'empty-8042) + (:callw 'empty-8042) (:movb #xd1 :al) (:outb :al #x64) - (:call 'empty-8042) + (:callw 'empty-8042) (:movb #xdf :al) (:outb :al #x60) - (:call 'empty-8042) + (:callw 'empty-8042) ;; Poll the floppy's sectors per track @@ -140,7 +140,7 @@ (:jg 'read-done) (:movw 'track-start-msg :si) ; Print '(' to screen for each track - (:call 'print) + (:callw 'print) (:movw (:bp ,+linear-sector+) :ax) (:movb (:bp ,+sectors-per-track+) :cl) @@ -205,7 +205,7 @@ (:jnz 'copy-loop) (:movw 'track-end-msg :si) ; Print ')' to screen after each track - (:call 'print) + (:callw 'print) (:jmp 'read-loop) @@ -216,7 +216,7 @@ (:jc 'motor-loop) (:movw 'entering :si) ; Print welcome message - (:call 'print) + (:callw 'print) ;; Read the cursor position into DH (row) and DL (column). (:movb 3 :ah) @@ -261,7 +261,7 @@ ;; read-error (:movw 'error :si) ; Print error message - (:call 'print) + (:callw 'print) halt-cpu (:halt) (:jmp 'halt-cpu) ; Infinite loop @@ -270,11 +270,11 @@ ;; Empty the 8042 Keyboard controller ;; empty-8042 - (:call 'delay) + (:callw 'delay) (:inb #x64 :al) ; 8042 status port (:testb 1 :al) ; if ( no information available ) (:jz 'no-output) ; goto no_output - (:call 'delay) + (:callw 'delay) (:inb #x60 :al) ; read it (:jmp 'empty-8042) no-output @@ -405,7 +405,8 @@ (asm:assemble-proglist (mkasm16-bios-bootloader image-size load-address skip-sectors) :start-pc #x7c00)) (multiple-value-bind (protected-loader protected-symtab) - (let ((asm-x86:*position-independent-p* nil)) + (let ((asm-x86:*position-independent-p* nil) + (asm-x86:*cpu-mode* :32-bit)) (asm:assemble-proglist (mkasm-loader image-size load-address call-address) :start-pc (cdr (or (assoc 'new-world bb-symtab) (error "No new-world defined in bios-loader."))))) From ffjeld at common-lisp.net Thu Mar 6 19:14:40 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Thu, 6 Mar 2008 14:14:40 -0500 (EST) Subject: [movitz-cvs] CVS movitz Message-ID: <20080306191440.31F215F06E@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv13555 Modified Files: asm-x86.lisp Log Message: Fix disassembly of pc-rel and far-pointer. --- /project/movitz/cvsroot/movitz/asm-x86.lisp 2008/02/28 20:33:06 1.36 +++ /project/movitz/cvsroot/movitz/asm-x86.lisp 2008/03/06 19:14:39 1.37 @@ -6,7 +6,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: asm-x86.lisp,v 1.36 2008/02/28 20:33:06 ffjeld Exp $ +;;;; $Id: asm-x86.lisp,v 1.37 2008/03/06 19:14:39 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -941,14 +941,14 @@ (ecase mod (#b00 (case r/m - (#b110 (code-call (decode-integer code '(uint 16)))) + (#b110 (list (code-call (decode-integer code '(uint 16))))) (t (operands r/m)))) (#b01 (append (operands r/m) - (code-call (decode-integer code '(sint 8))))) + (list (code-call (decode-integer code '(sint 8)))))) (#b10 (append (operands r/m) - (code-call (decode-integer code '(uint 16)))))))) + (list (code-call (decode-integer code '(uint 16))))))))) code))) (defun decode-reg-modrm-32 (code operand-size) @@ -1088,12 +1088,12 @@ (assert (= code-size (length code))) (append extra-prefixes code)))))))))) -(defmacro pc-rel (opcode operand type &rest extras) +(defmacro pc-rel (opcode operand type &optional (mode 'operator-mode) &rest extras) `(progn (assembler (return-when (encode-pc-rel operator legacy-prefixes ,opcode ,operand ',type , at extras))) (disassembler - (define-disassembler (operator ,opcode operator-mode) + (define-disassembler (operator ,opcode ,mode) decode-pc-rel ',type)))) @@ -1313,7 +1313,7 @@ :imm ',op-imm) ',type))))) -(defmacro far-pointer (opcode segment offset offset-type &rest extra) +(defmacro far-pointer (opcode segment offset offset-type &optional mode &rest extra) `(progn (assembler (when (and (immediate-p ,segment) @@ -1327,7 +1327,7 @@ (encode-integer segment '(uint 16))) , at extra))))))) (disassembler - (define-disassembler (operator ,opcode operator-mode) + (define-disassembler (operator ,opcode ,(or mode 'operator-mode)) decode-far-pointer ',offset-type)))) @@ -1728,9 +1728,9 @@ (when (or (and (eq *cpu-mode* :32-bit) *use-jcc-16-bit-p*) (eq *cpu-mode* :16-bit)) - (pc-rel ,opcode2 dst (sint 16) + (pc-rel ,opcode2 dst (sint 16) nil :operand-size :16-bit)) - (pc-rel ,opcode2 dst (sint 32) + (pc-rel ,opcode2 dst (sint 32) nil :operand-size (case *cpu-mode* ((:16-bit :32-bit) :32-bit))))) @@ -1768,7 +1768,7 @@ (define-jcc :jz #x74) (define-operator* (:16 :jcxz :32 :jecxz :64 :jrcxz) (dst) - (pc-rel #xe3 dst (sint 8) + (pc-rel #xe3 dst (sint 8) nil :operand-size operator-mode :rex default-rex)) @@ -1778,16 +1778,16 @@ (cond (dst (when (eq *cpu-mode* :16-bit) - (far-pointer #xea seg-dst dst (uint 16))) + (far-pointer #xea seg-dst dst (uint 16) :16-bit)) (when (eq *cpu-mode* :32-bit) - (far-pointer #xea seg-dst dst (xint 32)))) + (far-pointer #xea seg-dst dst (xint 32) :32-bit))) (t (let ((dst seg-dst)) (pc-rel #xeb dst (sint 8)) (when (or (and (eq *cpu-mode* :32-bit) *use-jcc-16-bit-p*) (eq *cpu-mode* :16-bit)) - (pc-rel #xe9 dst (sint 16))) - (pc-rel #xe9 dst (sint 32)) + (pc-rel #xe9 dst (sint 16) :16-bit)) + (pc-rel #xe9 dst (sint 32) :32-bit) (when (or (not *position-independent-p*) (indirect-operand-p dst)) (let ((operator-mode :32-bit)) From ffjeld at common-lisp.net Thu Mar 6 19:18:54 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Thu, 6 Mar 2008 14:18:54 -0500 (EST) Subject: [movitz-cvs] CVS movitz Message-ID: <20080306191854.6E425610AF@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv14059 Modified Files: asm.lisp Log Message: Add disassemble-proglist*. --- /project/movitz/cvsroot/movitz/asm.lisp 2008/02/25 23:34:11 1.16 +++ /project/movitz/cvsroot/movitz/asm.lisp 2008/03/06 19:18:51 1.17 @@ -6,7 +6,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: asm.lisp,v 1.16 2008/02/25 23:34:11 ffjeld Exp $ +;;;; $Id: asm.lisp,v 1.17 2008/03/06 19:18:51 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -259,6 +259,9 @@ nil)) (defun disassemble-proglist (code &key (cpu-package '#:asm-x86) (pc (or *pc* 0)) (symtab *symtab*) collect-data collect-labels) + "Return a proglist (i.e. a list of instructions), or a list of (cons instruction data) if collect-data is true, +data being the octets corresponding to that instruction. Labels will be included in the proglist if collect-labels is true. +Secondarily, return the symtab." (let* ((instruction-disassembler (find-symbol (string '#:disassemble-instruction) cpu-package)) (proglist0 (loop while code @@ -272,7 +275,6 @@ do (incf pc) collect (pop code))) (operands (instruction-operands instruction))) - ;; (format *debug-io* "~D: ~X ~S~%" pc data instruction) (cons data (if (notany #'pc-relative-operand-p operands) instruction @@ -298,3 +300,18 @@ instruction data-instruction)) symtab))) + +(defun disassemble-proglist* (code &key (cpu-package '#:asm-x86) (pc 0)) + "Print a human-readable disassembly of code." + (multiple-value-bind (proglist symtab) + (disassemble-proglist code + :cpu-package cpu-package + :collect-data t) + (format t "~&~:{~4X: ~20<~{ ~2,'0X~}~;~> ~A~%~}" + (loop with pc = pc + for (data . instruction) in proglist + when (let ((x (find pc symtab :key #'cdr))) + (when x (list pc (list (format nil " ~A" (car x))) ""))) + collect it + collect (list pc data instruction) + do (incf pc (length data)))))) From ffjeld at common-lisp.net Thu Mar 6 21:14:23 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Thu, 6 Mar 2008 16:14:23 -0500 (EST) Subject: [movitz-cvs] CVS movitz Message-ID: <20080306211423.4B28D610B9@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv11934 Modified Files: compiler.lisp Log Message: Specify asm-x86:*cpu-mode* :32-bit. --- /project/movitz/cvsroot/movitz/compiler.lisp 2008/02/23 22:36:21 1.193 +++ /project/movitz/cvsroot/movitz/compiler.lisp 2008/03/06 21:14:22 1.194 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.193 2008/02/23 22:36:21 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.194 2008/03/06 21:14:22 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -143,7 +143,8 @@ (resolved-code (finalize-code body-code nil nil))) (multiple-value-bind (code-vector symtab) - (let ((asm:*instruction-compute-extra-prefix-map* + (let ((asm-x86:*cpu-mode* :32-bit) + (asm:*instruction-compute-extra-prefix-map* '((:call . compute-call-extra-prefix)))) (asm:assemble-proglist (translate-program resolved-code :muerte.cl :cl) :symtab (list (cons :nil-value (image-nil-word *image*))))) @@ -993,7 +994,8 @@ (defun assemble-funobj (funobj combined-code) (multiple-value-bind (code-vector code-symtab) - (let ((asm:*instruction-compute-extra-prefix-map* + (let ((asm-x86:*cpu-mode* :32-bit) + (asm:*instruction-compute-extra-prefix-map* '((:call . compute-call-extra-prefix)))) (asm:assemble-proglist combined-code :symtab (list* (cons :nil-value (image-nil-word *image*)) From ffjeld at common-lisp.net Fri Mar 7 23:38:17 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Fri, 7 Mar 2008 18:38:17 -0500 (EST) Subject: [movitz-cvs] CVS movitz/losp Message-ID: <20080307233817.17A9A49114@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp In directory clnet:/tmp/cvs-serv13632 Modified Files: scratch.lisp Log Message: Implement macro destructuring-bind. --- /project/movitz/cvsroot/movitz/losp/scratch.lisp 2008/02/23 22:28:55 1.3 +++ /project/movitz/cvsroot/movitz/losp/scratch.lisp 2008/03/07 23:38:16 1.4 @@ -7,7 +7,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: scratch.lisp,v 1.3 2008/02/23 22:28:55 ffjeld Exp $ +;;;; $Id: scratch.lisp,v 1.4 2008/03/07 23:38:16 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -15,6 +15,16 @@ (in-package los0) +(defun test-bq (x y) + `(+ ,x ,y)) + + +#+ignore +(defun d-bind (x) + (destructuring-bind (a (b &optional c) d &rest e &key f) + x + (values a b c d e f))) + #+ignore (defun set.2 () (let ((*var-used-in-set-tests* 'a) From ffjeld at common-lisp.net Fri Mar 7 23:38:19 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Fri, 7 Mar 2008 18:38:19 -0500 (EST) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080307233819.8D50C49124@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv13658 Modified Files: basic-functions.lisp Log Message: Implement macro destructuring-bind. --- /project/movitz/cvsroot/movitz/losp/muerte/basic-functions.lisp 2007/02/19 20:24:51 1.22 +++ /project/movitz/cvsroot/movitz/losp/muerte/basic-functions.lisp 2008/03/07 23:38:19 1.23 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Sep 4 18:41:57 2001 ;;;; -;;;; $Id: basic-functions.lisp,v 1.22 2007/02/19 20:24:51 ffjeld Exp $ +;;;; $Id: basic-functions.lisp,v 1.23 2008/03/07 23:38:19 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -48,6 +48,33 @@ (:movl :ecx :eax))) +(defun d-bind-veryfy-keys (args keys) + (do ((allow-allow-p t) + (mismatches nil)) + ((null args) + (when mismatches + (error "Unexpected destructuring keys ~{~S~^, ~}, expected ~{~S~^, ~}." + mismatches keys))) + (let ((a (pop args)) + (v (pop args))) + (cond + ((eq a :allow-other-keys) + (when (and v allow-allow-p) + (return)) + (setf allow-allow-p nil)) + ((not (member a keys)) + (pushnew a mismatches)))))) + +(defun d-bind-lookup-key (key list) + (do () + ((endp list) + nil) + (unless (cdr list) + (error "Odd number of keyword arguments.")) + (when (eq key (pop list)) + (return list)) + (setf list (cdr list)))) + (defmacro numargs () `(with-inline-assembly (:returns :ecx) (:movzxb :cl :ecx) From ffjeld at common-lisp.net Fri Mar 7 23:38:21 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Fri, 7 Mar 2008 18:38:21 -0500 (EST) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080307233821.D06C71603F@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv13672 Modified Files: more-macros.lisp Log Message: Implement macro destructuring-bind. --- /project/movitz/cvsroot/movitz/losp/muerte/more-macros.lisp 2006/05/06 20:31:23 1.36 +++ /project/movitz/cvsroot/movitz/losp/muerte/more-macros.lisp 2008/03/07 23:38:21 1.37 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Jun 7 15:05:57 2002 ;;;; -;;;; $Id: more-macros.lisp,v 1.36 2006/05/06 20:31:23 ffjeld Exp $ +;;;; $Id: more-macros.lisp,v 1.37 2008/03/07 23:38:21 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -130,6 +130,129 @@ (let ((,var (pop ,cons-var))) , at declarations-and-body)))) + +(defmacro destructuring-bind (lambda-list expression &body declarations-and-body) + (let ((bindings (list (list (gensym) + expression))) + (ignores nil)) + (macrolet ((pop* (place) + "Like pop, but err if place is already NIL." + `(let ((x ,place)) + (assert x () "Syntax error in destructuring lambda-list: ~S" lambda-list) + (setf ,place (cdr x)) + (car x))) + (pop-match (item place) + "Pop place if (car place) is eq to item." + `(let ((item ,item) + (x ,place)) + (when (eq (car x) item) + (setf ,place (cdr x)) + (car x))))) + (labels + ((gen-end (var) + (let ((dummy-var (gensym))) + (push (list dummy-var (list 'when var '(error "Too many elements in expression for lambda-list."))) + bindings) + (push dummy-var ignores))) + (gen-lambda-list (var sub-lambda-list) + (when (pop-match '&whole sub-lambda-list) + (push (list (pop* sub-lambda-list) var) + bindings)) + (gen-reqvars var sub-lambda-list)) + (gen-reqvars (var sub-lambda-list) + (cond + ((null sub-lambda-list) + (gen-end var)) + ((symbolp sub-lambda-list) ; dotted lambda-list? + (push (list sub-lambda-list var) + bindings)) + ((pop-match '&optional sub-lambda-list) + (gen-optvars var sub-lambda-list)) + ((pop-match '&rest sub-lambda-list) + (gen-restvar var sub-lambda-list)) + ((consp (car sub-lambda-list)) ; recursive lambda-list? + (let ((sub-var (gensym))) + (push (list sub-var `(pop ,var)) + bindings) + (gen-lambda-list sub-var (pop sub-lambda-list))) + (gen-reqvars var sub-lambda-list)) + (t (push (let ((b (pop* sub-lambda-list))) + (list b + `(if (null ,var) + (error "Value for required argument ~S is missing." ',b) + (pop ,var)))) + bindings) + (gen-reqvars var sub-lambda-list)))) + (gen-optvars (var sub-lambda-list) + (cond + ((null sub-lambda-list) + (gen-end var)) + ((symbolp sub-lambda-list) ; dotted lambda-list? + (push (list sub-lambda-list var) + bindings)) + ((pop-match '&rest sub-lambda-list) + (gen-restvar var sub-lambda-list)) + ((pop-match '&key sub-lambda-list) + (gen-keyvars var sub-lambda-list)) + (t (multiple-value-bind (opt-var init-form supplied-var) + (let ((b (pop sub-lambda-list))) + (if (atom b) + (values b nil nil) + (values (pop b) (pop b) (pop b)))) + (when supplied-var + (push (list supplied-var `(if ,var t nil)) + bindings)) + (push (list opt-var + (if (not init-form) + `(pop ,var) + `(if ,var (pop ,var) ,init-form))) + bindings)) + (gen-optvars var sub-lambda-list)))) + (gen-restvar (var sub-lambda-list) + (let ((rest-var (pop* sub-lambda-list))) + (push (list rest-var var) + bindings)) + (when (pop-match '&key sub-lambda-list) + (gen-keyvars var sub-lambda-list))) + (gen-keyvars (var sub-lambda-list &optional keys) + (cond + ((endp sub-lambda-list) + (push (list (gensym) + `(d-bind-veryfy-keys ,var ',keys)) + bindings) + (push (caar bindings) + ignores)) + ((pop-match '&allow-other-keys sub-lambda-list) + (when sub-lambda-list + (error "Bad destructuring lambda-list; junk after ~S." '&allow-other-keys))) + (t (multiple-value-bind (key-var key-name init-form supplied-var) + (let ((b (pop sub-lambda-list))) + (cond + ((atom b) + (values b (intern (string b) :keyword) nil nil)) + ((atom (car b)) + (values (car b) (intern (string (car b)) :keyword) nil nil)) + (t (let ((bn (pop b))) + (values (cadr bn) (car bn) (pop b) (pop b)))))) + (when supplied-var + (push supplied-var bindings)) + (push (list key-var + `(let ((x (d-bind-lookup-key ',key-name ,var))) + ,@(when supplied-var + `((setf ,supplied-var (if x t nil)))) + ,(if (not init-form) + '(car x) + (if x + (car x) + ,init-form)))) + bindings) + (gen-keyvars var sub-lambda-list (cons key-name keys))))))) + (gen-lambda-list (caar bindings) + lambda-list) + `(let* ,(nreverse bindings) + (declare (ignore , at ignores)) + , at declarations-and-body))))) + (define-compiler-macro member (&whole form item list &key (key ''identity) (test ''eql) &environment env) (let* ((test (or (and (movitz:movitz-constantp test env) From ffjeld at common-lisp.net Fri Mar 7 23:39:33 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Fri, 7 Mar 2008 18:39:33 -0500 (EST) Subject: [movitz-cvs] CVS public_html Message-ID: <20080307233933.4F30C5301A@common-lisp.net> Update of /project/movitz/cvsroot/public_html In directory clnet:/tmp/cvs-serv13870 Modified Files: ChangeLog Log Message: *** empty log message *** --- /project/movitz/cvsroot/public_html/ChangeLog 2008/02/25 20:19:23 1.12 +++ /project/movitz/cvsroot/public_html/ChangeLog 2008/03/07 23:39:33 1.13 @@ -1,3 +1,8 @@ +2008-03-08 Frode V. Fjeld + + * movitz/losp/muerte/more-macros.lisp: Implemented macro + destructuring-bind. + 2008-02-25 Frode V. Fjeld * movitz.asd: Created an ASDF system definition. From ffjeld at common-lisp.net Sat Mar 8 13:59:48 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sat, 8 Mar 2008 08:59:48 -0500 (EST) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080308135948.F3FF15311F@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv12745 Modified Files: more-macros.lisp Log Message: Add support for &aux in destructuring-bind. --- /project/movitz/cvsroot/movitz/losp/muerte/more-macros.lisp 2008/03/07 23:38:21 1.37 +++ /project/movitz/cvsroot/movitz/losp/muerte/more-macros.lisp 2008/03/08 13:59:48 1.38 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Jun 7 15:05:57 2002 ;;;; -;;;; $Id: more-macros.lisp,v 1.37 2008/03/07 23:38:21 ffjeld Exp $ +;;;; $Id: more-macros.lisp,v 1.38 2008/03/08 13:59:48 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -170,6 +170,9 @@ (gen-optvars var sub-lambda-list)) ((pop-match '&rest sub-lambda-list) (gen-restvar var sub-lambda-list)) + ((pop-match '&aux sub-lambda-list) + (dolist (b sub-lambda-list) + (push b bindings))) ((consp (car sub-lambda-list)) ; recursive lambda-list? (let ((sub-var (gensym))) (push (list sub-var `(pop ,var)) @@ -194,6 +197,9 @@ (gen-restvar var sub-lambda-list)) ((pop-match '&key sub-lambda-list) (gen-keyvars var sub-lambda-list)) + ((pop-match '&aux sub-lambda-list) + (dolist (b sub-lambda-list) + (push b bindings))) (t (multiple-value-bind (opt-var init-form supplied-var) (let ((b (pop sub-lambda-list))) (if (atom b) @@ -212,8 +218,12 @@ (let ((rest-var (pop* sub-lambda-list))) (push (list rest-var var) bindings)) - (when (pop-match '&key sub-lambda-list) - (gen-keyvars var sub-lambda-list))) + (cond + ((pop-match '&key sub-lambda-list) + (gen-keyvars var sub-lambda-list)) + ((pop-match '&aux sub-lambda-list) + (dolist (b sub-lambda-list) + (push b bindings))))) (gen-keyvars (var sub-lambda-list &optional keys) (cond ((endp sub-lambda-list) @@ -225,6 +235,9 @@ ((pop-match '&allow-other-keys sub-lambda-list) (when sub-lambda-list (error "Bad destructuring lambda-list; junk after ~S." '&allow-other-keys))) + ((pop-match '&aux sub-lambda-list) + (dolist (b sub-lambda-list) + (push b bindings))) (t (multiple-value-bind (key-var key-name init-form supplied-var) (let ((b (pop sub-lambda-list))) (cond From ffjeld at common-lisp.net Sat Mar 8 14:03:35 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sat, 8 Mar 2008 09:03:35 -0500 (EST) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080308140335.AC5AC5317A@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv16390 Modified Files: more-macros.lisp Log Message: Don't forget &body also for d-bind. --- /project/movitz/cvsroot/movitz/losp/muerte/more-macros.lisp 2008/03/08 13:59:48 1.38 +++ /project/movitz/cvsroot/movitz/losp/muerte/more-macros.lisp 2008/03/08 14:03:35 1.39 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Jun 7 15:05:57 2002 ;;;; -;;;; $Id: more-macros.lisp,v 1.38 2008/03/08 13:59:48 ffjeld Exp $ +;;;; $Id: more-macros.lisp,v 1.39 2008/03/08 14:03:35 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -168,7 +168,8 @@ bindings)) ((pop-match '&optional sub-lambda-list) (gen-optvars var sub-lambda-list)) - ((pop-match '&rest sub-lambda-list) + ((or (pop-match '&rest sub-lambda-list) + (pop-match '&body sub-lambda-list)) (gen-restvar var sub-lambda-list)) ((pop-match '&aux sub-lambda-list) (dolist (b sub-lambda-list) @@ -193,7 +194,8 @@ ((symbolp sub-lambda-list) ; dotted lambda-list? (push (list sub-lambda-list var) bindings)) - ((pop-match '&rest sub-lambda-list) + ((or (pop-match '&rest sub-lambda-list) + (pop-match '&body sub-lambda-list)) (gen-restvar var sub-lambda-list)) ((pop-match '&key sub-lambda-list) (gen-keyvars var sub-lambda-list)) From ffjeld at common-lisp.net Fri Mar 14 11:07:48 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Fri, 14 Mar 2008 06:07:48 -0500 (EST) Subject: [movitz-cvs] CVS movitz Message-ID: <20080314110748.18C92C170@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv26975 Modified Files: asm.lisp Log Message: Fix unused variable. --- /project/movitz/cvsroot/movitz/asm.lisp 2008/03/06 19:18:51 1.17 +++ /project/movitz/cvsroot/movitz/asm.lisp 2008/03/14 11:07:47 1.18 @@ -6,7 +6,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: asm.lisp,v 1.17 2008/03/06 19:18:51 ffjeld Exp $ +;;;; $Id: asm.lisp,v 1.18 2008/03/14 11:07:47 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -289,7 +289,7 @@ symtab))))) `(quote ,(car entry))))))))))))) (values (loop for (pc data-instruction) on proglist0 by #'cddr - for (data . instruction) = data-instruction + for instruction = (cdr data-instruction) for label = (when collect-labels (rassoc pc symtab)) when label From ffjeld at common-lisp.net Sat Mar 15 00:21:38 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Fri, 14 Mar 2008 19:21:38 -0500 (EST) Subject: [movitz-cvs] CVS movitz Message-ID: <20080315002138.DC9F344071@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv4460 Modified Files: compiler.lisp Log Message: Smarten up make-compiled-two-forms-into-registers slightly, this speeds up the compiler. --- /project/movitz/cvsroot/movitz/compiler.lisp 2008/03/06 21:14:22 1.194 +++ /project/movitz/cvsroot/movitz/compiler.lisp 2008/03/15 00:21:38 1.195 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.194 2008/03/06 21:14:22 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.195 2008/03/15 00:21:38 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -5769,6 +5769,15 @@ (operands instruction) (values binding destination)))) +(defun program-is-load-constant (prg) + (and (not (cdr prg)) + (let ((i (car prg))) + (when (and (listp i) + (eq :load-constant (car i))) + (values (third i) + (second i)))))) + + (defun make-compiled-two-forms-into-registers (form0 reg0 form1 reg1 funobj env) "Returns first: code that does form0 into reg0, form1 into reg1. second: whether code is functional-p, @@ -5791,44 +5800,48 @@ :env env :result-mode reg1) (values (cond - ((and (typep final0 'binding) - (not (code-uses-binding-p code1 final0 :load nil :store t))) - (append (compiler-call #'compile-form-unprotected - :form form0 - :result-mode :ignore - :funobj funobj - :env env) - code1 - `((:load-lexical ,final0 ,reg0 :protect-registers (,reg1))))) - ((program-is-load-lexical-of-binding code1) - (destructuring-bind (src dst &key protect-registers shared-reference-p) - (cdar code1) - (assert (eq reg1 dst)) - (append code0 - `((:load-lexical ,src ,reg1 - :protect-registers ,(union protect-registers - (list reg0)) - :shared-reference-p ,shared-reference-p))))) - ;; XXX if we knew that code1 didn't mess up reg0, we could do more.. - (t #+ignore (when (and (not (tree-search code1 reg0)) - (not (tree-search code1 :call))) - (warn "got b: ~S ~S for ~S: ~{~&~A~}" form0 form1 reg0 code1)) - (let ((binding (make-instance 'temporary-name :name (gensym "tmp-"))) - (xenv (make-local-movitz-environment env funobj))) - (movitz-env-add-binding xenv binding) - (append (compiler-call #'compile-form - :form form0 - :funobj funobj - :env env - :result-mode reg0) - `((:init-lexvar ,binding :init-with-register ,reg0 - :init-with-type ,(type-specifier-primary type0))) - (compiler-call #'compile-form - :form form1 - :funobj funobj - :env xenv - :result-mode reg1) - `((:load-lexical ,binding ,reg0)))))) + ((and (typep final0 'binding) + (not (code-uses-binding-p code1 final0 :load nil :store t))) + (append (compiler-call #'compile-form-unprotected + :form form0 + :result-mode :ignore + :funobj funobj + :env env) + code1 + `((:load-lexical ,final0 ,reg0 :protect-registers (,reg1))))) + ((program-is-load-lexical-of-binding code1) + (destructuring-bind (src dst &key protect-registers shared-reference-p) + (cdar code1) + (assert (eq reg1 dst)) + (append code0 + `((:load-lexical ,src ,reg1 + :protect-registers ,(union protect-registers + (list reg0)) + :shared-reference-p ,shared-reference-p))))) + ((eq reg1 (program-is-load-constant code1)) + (append code0 + code1)) + ;; XXX if we knew that code1 didn't mess up reg0, we could do more.. + (t +;; (when (and (not (tree-search code1 reg0)) +;; (not (tree-search code1 :call))) +;; (warn "got b: ~S ~S for ~S: ~{~&~A~}" form0 form1 reg0 code1)) + (let ((binding (make-instance 'temporary-name :name (gensym "tmp-"))) + (xenv (make-local-movitz-environment env funobj))) + (movitz-env-add-binding xenv binding) + (append (compiler-call #'compile-form + :form form0 + :funobj funobj + :env env + :result-mode reg0) + `((:init-lexvar ,binding :init-with-register ,reg0 + :init-with-type ,(type-specifier-primary type0))) + (compiler-call #'compile-form + :form form1 + :funobj funobj + :env xenv + :result-mode reg1) + `((:load-lexical ,binding ,reg0)))))) (and functional0 functional1) t (compiler-values-list (all0)) From ffjeld at common-lisp.net Sat Mar 15 20:44:53 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sat, 15 Mar 2008 15:44:53 -0500 (EST) Subject: [movitz-cvs] CVS movitz Message-ID: <20080315204453.D7BA949123@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv32418 Modified Files: environment.lisp Log Message: Use hash-tables for macros in environments. --- /project/movitz/cvsroot/movitz/environment.lisp 2007/03/21 19:57:54 1.22 +++ /project/movitz/cvsroot/movitz/environment.lisp 2008/03/15 20:44:53 1.23 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Nov 3 11:40:15 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: environment.lisp,v 1.22 2007/03/21 19:57:54 ffjeld Exp $ +;;;; $Id: environment.lisp,v 1.23 2008/03/15 20:44:53 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -54,7 +54,10 @@ (setf (movitz-environment-extent-uplink instance) (movitz-environment-uplink instance)))) -(defmethod movitz-environment-compiler-macros ((env movitz-environment)) nil) +(defmethod movitz-environment-macros ((env movitz-environment)) + (load-time-value (make-hash-table :test #'eq))) +(defmethod movitz-environment-compiler-macros ((env movitz-environment)) + (load-time-value (make-hash-table :test #'eq))) (defmethod movitz-environment-function-cells ((env movitz-environment)) (load-time-value (make-hash-table :test #'eq))) (defmethod movitz-environment-modifies-stack ((env movitz-environment)) @@ -87,8 +90,11 @@ (bindings :initform nil :accessor movitz-environment-bindings) + (macros + :initform (make-hash-table :test #'eq :size 400) + :accessor movitz-environment-macros) (compiler-macros - :initform nil + :initform (make-hash-table :test #'eq :size 400) :accessor movitz-environment-compiler-macros))) (defclass with-things-on-stack-env (movitz-environment) @@ -305,7 +311,7 @@ (defparameter *movitz-macroexpand-hook* #'(lambda (macro-function form environment) -;;; (warn "Expanding form ~W" form) +;; (break "Expanding form ~W" form) ;;; (warn "..with body ~W" macro-function) (let ((expansion (funcall macro-function form environment))) (cond @@ -489,13 +495,13 @@ (environment nil) (recurse-p t)) (loop for env = (or environment *movitz-global-environment*) - then (when recurse-p (movitz-environment-uplink env)) - for plist = (and env (getf (movitz-environment-plists env) symbol)) - while env - do (let ((val (getf plist indicator '#0=#:not-found))) - (unless (eq val '#0#) - (return (values val env)))) - finally (return default))) + then (when recurse-p (movitz-environment-uplink env)) + for plist = (and env (getf (movitz-environment-plists env) symbol)) + while env + do (let ((val (getf plist indicator '#0=#:not-found))) + (unless (eq val '#0#) + (return (values val env)))) + finally (return default))) (defun (setf movitz-env-get) (val symbol indicator &optional default environment) @@ -551,41 +557,40 @@ (and (typep binding 'macro-binding) (macro-binding-expander binding))) (loop for env = (or environment *movitz-global-environment*) - then (movitz-environment-uplink env) - for val = (and env (gethash symbol (movitz-environment-function-cells env))) - while env - when val - do (return (and (typep val 'movitz-macro) - (movitz-macro-expander-function val)))))) + then (movitz-environment-uplink env) + for val = (when env + (gethash symbol (movitz-environment-macros env))) + while env + when val + do (return (movitz-macro-expander-function val))))) (defun (setf movitz-macro-function) (fun symbol &optional environment) - (let ((obj (or (gethash symbol (movitz-environment-function-cells (or environment - *movitz-global-environment*))) - (make-instance 'movitz-macro)))) - (setf (slot-value obj 'expander-function) fun) - (setf (gethash symbol (movitz-environment-function-cells (or environment - *movitz-global-environment*))) - obj)) - fun) + (let* ((env (or environment *movitz-global-environment*)) + (obj (or (gethash symbol (movitz-environment-macros env)) + (setf (gethash symbol (movitz-environment-macros env)) + (make-instance 'movitz-macro))))) + (setf (slot-value obj 'expander-function) fun))) ;;; Accessor: COMPILER-MACRO-FUNCTION (defun movitz-compiler-macro-function (name &optional environment) + (gethash name (movitz-environment-compiler-macros *movitz-global-environment*)) + #+ignore (loop for env = (or environment *movitz-global-environment*) - then (movitz-environment-uplink env) - for val = (and env (getf (movitz-environment-compiler-macros env) name)) - while env - when val do (return val))) + then (movitz-environment-uplink env) + for val = (when env + (gethash name (movitz-environment-compiler-macros env))) + while env + when val do (return val))) (defun (setf movitz-compiler-macro-function) (fun name &optional environment) - (setf (getf (movitz-environment-compiler-macros (or environment - *movitz-global-environment*)) - name) - fun)) + (setf (gethash name (movitz-environment-compiler-macros (or environment + *movitz-global-environment*))) + fun)) ;;; Special operators -(defparameter *persistent-movitz-environment* (make-global-movitz-environment)) +(defvar *persistent-movitz-environment* (make-global-movitz-environment)) (defun movitz-special-operator-p (symbol) (let ((val (gethash symbol (movitz-environment-function-cells *persistent-movitz-environment*)))) From ffjeld at common-lisp.net Sat Mar 15 20:45:22 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sat, 15 Mar 2008 15:45:22 -0500 (EST) Subject: [movitz-cvs] CVS movitz Message-ID: <20080315204522.0561249123@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv32704 Modified Files: image.lisp Log Message: Minor tweaks. --- /project/movitz/cvsroot/movitz/image.lisp 2008/02/24 12:13:06 1.116 +++ /project/movitz/cvsroot/movitz/image.lisp 2008/03/15 20:45:21 1.117 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: image.lisp,v 1.116 2008/02/24 12:13:06 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.117 2008/03/15 20:45:21 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -894,14 +894,13 @@ (unless (typep (movitz-env-named-function (car cf) nil) 'movitz-funobj) (warn "Function ~S is called (in ~S) but not defined." (car cf) (cdr cf)))) - (maphash #'(lambda (symbol function-value) - (let ((movitz-symbol (movitz-read symbol))) - (if (typep function-value 'movitz-object) - ;; (warn "SETTING ~A's funval to ~A" - ;; movitz-symbol function-value) - (setf (movitz-symbol-function-value movitz-symbol) - function-value) - #+ignore (warn "fv: ~W" (movitz-macro-expander-function function-value))))) + (maphash (lambda (symbol function-value) + (let ((movitz-symbol (movitz-read symbol))) + (etypecase function-value + (movitz-funobj + (setf (movitz-symbol-function-value movitz-symbol) function-value)) + (movitz-macro + #+ignore (warn "fv: ~S ~S ~S" symbol function-value (movitz-env-get symbol :macro-expansion)))))) (movitz-environment-function-cells (image-global-environment *image*))) (let ((run-time-context (image-run-time-context *image*))) ;; pull in functions in run-time-context @@ -1169,12 +1168,18 @@ name symbol) name))) (ensure-package (package-name lisp-package &optional context) - (assert (not (member (package-name lisp-package) - #+allegro '(excl common-lisp sys aclmop) - #-allegro '(common-lisp) - :test #'string=)) () - "I don't think you really want to dump the package ~A ~@[for symbol ~S~] with Movitz." - lisp-package context) + (restart-case (assert (not (member (package-name lisp-package) + '(common-lisp movitz + #+allegro excl + #+allegro sys + #+allegro aclmop + #+sbcl sb-ext) + :test #'string=)) () + "I don't think you really want to dump the package ~A ~@[for symbol ~S~] with Movitz." + lisp-package context) + (use-muerte () + :report "Substitute the muerte pacakge." + (return-from ensure-package (ensure-package :muerte (find-package :muerte))))) (setf (gethash lisp-package lisp-to-movitz-package) (or (gethash package-name packages-hash nil) (let* ((nicks (mapcar #'movitz-package-name (package-nicknames lisp-package))) @@ -1460,8 +1465,10 @@ (length (movitz-funobj-const-list funobj)) (movitz-funobj-const-list funobj) (loop with pc = 0 - for (data . instruction) in (asm:disassemble-proglist code :symtab (movitz-funobj-symtab funobj) - :collect-data t) + for (data . instruction) in (let ((asm-x86:*cpu-mode* :32-bit)) + (asm:disassemble-proglist code + :symtab (movitz-funobj-symtab funobj) + :collect-data t)) when (assoc pc entry-points) collect (list pc nil (format nil " => Entry-point for ~D arguments <=" (cdr (assoc pc entry-points))) From ffjeld at common-lisp.net Sat Mar 15 20:46:17 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sat, 15 Mar 2008 15:46:17 -0500 (EST) Subject: [movitz-cvs] CVS movitz Message-ID: <20080315204617.59A5249123@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv425 Modified Files: load.lisp Log Message: Remove dead cruft. --- /project/movitz/cvsroot/movitz/load.lisp 2008/02/24 11:57:35 1.13 +++ /project/movitz/cvsroot/movitz/load.lisp 2008/03/15 20:46:17 1.14 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Thu Jan 15 18:40:58 2004 ;;;; -;;;; $Id: load.lisp,v 1.13 2008/02/24 11:57:35 ffjeld Exp $ +;;;; $Id: load.lisp,v 1.14 2008/03/15 20:46:17 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -42,65 +42,38 @@ (setf (ext:default-directory) pwd)))) #-(or cmu) (load "load")) -#+allegro (progn - (load (compile-file #p"../infunix/procfs")) - (load "packages.lisp") - (load "movitz.lisp") - (excl:compile-system :movitz) - (excl:load-system :movitz) - (setf excl:*tenured-bytes-limit* #x2000000) - (setf (system::gsgc-parameter :generation-spread) 12) - (sys:resize-areas :new (* 64 1024 1024))) - -#+clisp-older-than-2.33-or-so -(progn (load "packages") - (defconstant movitz::&all 'movitz::&all) ; CLisp has this wonderful bug.. - (defconstant movitz::&code 'movitz::&code) - (defconstant movitz::&form 'movitz::&form) - (defconstant movitz::&returns 'movitz::&returns) - (defconstant movitz::&functional-p 'movitz::&functional-p) - (defconstant movitz::&modifies 'movitz::&modifies) - (defconstant movitz::&type 'movitz::&type) - (defconstant movitz::&final-form 'movitz::&final-form) - (defconstant movitz::&funobj 'movitz::&funobj) - (defconstant movitz::&top-level-p 'movitz::&top-level-p) - (defconstant movitz::&result-mode 'movitz::&result-mode) - (defconstant movitz::&env 'movitz::&env) - (defconstant movitz::&producer 'movitz::&producer)) - - -#-allegro (do () (nil) - (with-simple-restart (retry "Retry loading Movitz") - (return - (with-compilation-unit () - #+cmu (setf bt::*ignore-hidden-slots-for-pcl* t) - (mapcar (lambda (path) - (do () (nil) - #+lispworks-personal-edition (hcl:mark-and-sweep 3) - (with-simple-restart (retry "Retry loading ~S" path) - (return - (handler-bind - (#+sbcl (sb-ext:defconstant-uneql #'continue)) - (load (or (compile-file path :print nil) - (error "Compile-file of ~S failed?" path)))))))) - '("packages" - "movitz" - "parse" - "eval" - "environment" - "compiler-types" - "compiler-protocol" - "storage-types" - "multiboot" - "bootblock" - "image" - "stream-image" - ;; "procfs-image" - "assembly-syntax" - "compiler-protocol" - "compiler" - "special-operators" - "special-operators-cl")))))) +(do () (nil) + (with-simple-restart (retry "Retry loading Movitz") + (return + (with-compilation-unit () + #+cmu (setf bt::*ignore-hidden-slots-for-pcl* t) + (mapcar (lambda (path) + (do () (nil) + #+lispworks-personal-edition (hcl:mark-and-sweep 3) + (with-simple-restart (retry "Retry loading ~S" path) + (return + (handler-bind + (#+sbcl (sb-ext:defconstant-uneql #'continue)) + (load (or (compile-file path :print nil) + (error "Compile-file of ~S failed?" path)))))))) + '("packages" + "movitz" + "parse" + "eval" + "environment" + "compiler-types" + "compiler-protocol" + "storage-types" + "multiboot" + "bootblock" + "image" + "stream-image" + ;; "procfs-image" + "assembly-syntax" + "compiler-protocol" + "compiler" + "special-operators" + "special-operators-cl")))))) #+(and cmu18 (not cmu19)) (setf movitz:*compiler-compile-eval-whens* nil From ffjeld at common-lisp.net Sat Mar 15 20:57:03 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sat, 15 Mar 2008 15:57:03 -0500 (EST) Subject: [movitz-cvs] CVS movitz Message-ID: <20080315205703.E46BF49115@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv2721 Modified Files: special-operators.lisp Log Message: Have macros in the run-time. --- /project/movitz/cvsroot/movitz/special-operators.lisp 2007/02/26 18:25:21 1.56 +++ /project/movitz/cvsroot/movitz/special-operators.lisp 2008/03/15 20:57:03 1.57 @@ -8,7 +8,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Nov 24 16:22:59 2000 ;;;; -;;;; $Id: special-operators.lisp,v 1.56 2007/02/26 18:25:21 ffjeld Exp $ +;;;; $Id: special-operators.lisp,v 1.57 2008/03/15 20:57:03 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -250,7 +250,7 @@ :forward all))) (define-special-operator make-named-function (&form form &env env) - (destructuring-bind (name formals declarations docstring body) + (destructuring-bind (name formals declarations docstring body &key (type :standard-function)) (cdr form) (declare (ignore docstring)) (handler-bind (#+ignore ((or error warning) (lambda (c) @@ -258,6 +258,7 @@ (format *error-output* "~&;; In function ~S:~&" name)))) (let* ((*compiling-function-name* name) (funobj (make-compiled-funobj name formals declarations body env nil))) + (setf (movitz-funobj-type funobj) type) (setf (movitz-funobj-symbolic-name funobj) name) (setf (movitz-env-named-function name) funobj)))) (compiler-values ())) @@ -362,13 +363,12 @@ :muerte.cl :cl)) (cl-macro-body (translate-program macro-body :muerte.cl :cl))) (when (member name (image-called-functions *image*) :key #'first) - #+ignore (warn "Macro ~S defined after being called as function (first in ~S)." - name - (cdr (find name (image-called-functions *image*) :key #'first)))) + (warn "Macro ~S defined after being called as function (first in ~S)." + name + (cdr (find name (image-called-functions *image*) :key #'first)))) (multiple-value-bind (cl-body declarations doc-string) (parse-docstring-declarations-and-body cl-macro-body 'cl:declare) (declare (ignore doc-string)) -;;; (warn "defmacro ~S: ~S" name cl-body) (let ((expander-lambda (let ((form-formal (or wholevar (gensym))) (env-formal (or envvar (gensym)))) @@ -384,9 +384,9 @@ (declare , at declarations) (translate-program (block ,name , at cl-body) :cl :muerte.cl))))))) (setf (movitz-macro-function name) - (movitz-macro-expander-make-function expander-lambda - :name expander-name - :type :defmacro))))))) + (movitz-macro-expander-make-function expander-lambda + :name expander-name + :type :defmacro))))))) (compiler-values ())) (define-special-operator muerte::define-compiler-macro-compile-time (&form form) From ffjeld at common-lisp.net Sat Mar 15 20:57:11 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sat, 15 Mar 2008 15:57:11 -0500 (EST) Subject: [movitz-cvs] CVS movitz Message-ID: <20080315205711.42591405F@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv2747 Modified Files: storage-types.lisp Log Message: Have macros in the run-time. --- /project/movitz/cvsroot/movitz/storage-types.lisp 2007/02/06 20:03:53 1.59 +++ /project/movitz/cvsroot/movitz/storage-types.lisp 2008/03/15 20:57:06 1.60 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: storage-types.lisp,v 1.59 2007/02/06 20:03:53 ffjeld Exp $ +;;;; $Id: storage-types.lisp,v 1.60 2008/03/15 20:57:06 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -673,7 +673,8 @@ :binary-type (define-enum movitz-funobj-type (u8) :standard-function 0 :generic-function 1 - :method-function 2) + :method-function 2 + :macro-function 3) :initform :standard-function :accessor movitz-funobj-type) (debug-info From ffjeld at common-lisp.net Sat Mar 15 20:57:12 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sat, 15 Mar 2008 15:57:12 -0500 (EST) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080315205712.D90DB49115@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv2832 Modified Files: arrays.lisp Log Message: Have macros in the run-time. --- /project/movitz/cvsroot/movitz/losp/muerte/arrays.lisp 2007/04/08 16:03:53 1.64 +++ /project/movitz/cvsroot/movitz/losp/muerte/arrays.lisp 2008/03/15 20:57:12 1.65 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Sun Feb 11 23:14:04 2001 ;;;; -;;;; $Id: arrays.lisp,v 1.64 2007/04/08 16:03:53 ffjeld Exp $ +;;;; $Id: arrays.lisp,v 1.65 2008/03/15 20:57:12 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -21,22 +21,20 @@ (in-package muerte) -(defmacro vector-double-dispatch ((s1 s2) &rest clauses) +(defmacro/cross-compilation vector-double-dispatch ((s1 s2) &rest clauses) (flet ((make-double-dispatch-value (et1 et2) (+ (* #x100 (bt:enum-value 'movitz::movitz-vector-element-type et1)) (bt:enum-value 'movitz::movitz-vector-element-type et2)))) - `(progn - #+ignore - (warn "vdd: ~X" (+ (* #x100 (vector-element-type ,s1)) - (vector-element-type ,s2))) - (case (+ (ash (vector-element-type-code ,s1) 8) - (vector-element-type-code ,s2)) - ,@(loop for (keys . forms) in clauses - if (atom keys) - collect (cons keys forms) - else - collect (cons (make-double-dispatch-value (first keys) (second keys)) - forms)))))) + `(case (+ (ash (vector-element-type-code ,s1) 8) + (vector-element-type-code ,s2)) + ,@(mapcar (lambda (clause) + (destructuring-bind (keys . forms) + clause + (if (atom keys) + (cons keys forms) + (cons (make-double-dispatch-value (first keys) (second keys)) + forms)))) + clauses)))) (defmacro with-indirect-vector ((var form &key (check-type t)) &body body) `(let ((,var ,form)) From ffjeld at common-lisp.net Sat Mar 15 20:57:15 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sat, 15 Mar 2008 15:57:15 -0500 (EST) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080315205715.40D4A405F@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv2859 Modified Files: basic-functions.lisp Log Message: Have macros in the run-time. --- /project/movitz/cvsroot/movitz/losp/muerte/basic-functions.lisp 2008/03/07 23:38:19 1.23 +++ /project/movitz/cvsroot/movitz/losp/muerte/basic-functions.lisp 2008/03/15 20:57:14 1.24 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Sep 4 18:41:57 2001 ;;;; -;;;; $Id: basic-functions.lisp,v 1.23 2008/03/07 23:38:19 ffjeld Exp $ +;;;; $Id: basic-functions.lisp,v 1.24 2008/03/15 20:57:14 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -75,16 +75,22 @@ (return list)) (setf list (cdr list)))) -(defmacro numargs () - `(with-inline-assembly (:returns :ecx) - (:movzxb :cl :ecx) - (:shll ,movitz::+movitz-fixnum-shift+ :ecx))) - -(defmacro call-function-from-lexical (lexical) - `(with-inline-assembly (:returns :multiple-values) - (:compile-form (:result-mode :esi) ,lexical) - (:xorb :cl :cl) - (:call (:esi ,(movitz::slot-offset 'movitz::movitz-funobj 'movitz::code-vector))))) +(defun verify-macroexpand-call (key name) + "Used by macro-expander functions to separate bona fide macro-expansions +from regular function-calls." + (when (eq key name) + (error 'undefined-function-call + :name name + :arguments :unknown))) + +(defun call-macroexpander (form env expander) + "Call a macro-expander for a bona fide macro-expansion." + (with-inline-assembly (:returns :multiple-values) + (:compile-form (:result-mode :edx) 'verify-macroexpand-call) + (:load-lexical (:lexical-binding expander) :esi) + (:load-lexical (:lexical-binding form) :eax) + (:load-lexical (:lexical-binding env) :ebx) + (:call (:esi (:offset movitz-funobj code-vector%2op))))) (defun funcall%0ops (function) (with-inline-assembly (:returns :multiple-values) From ffjeld at common-lisp.net Sat Mar 15 20:57:24 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sat, 15 Mar 2008 15:57:24 -0500 (EST) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080315205724.D29B249137@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv2899 Modified Files: basic-macros.lisp Log Message: Have macros in the run-time. --- /project/movitz/cvsroot/movitz/losp/muerte/basic-macros.lisp 2007/03/26 21:11:40 1.70 +++ /project/movitz/cvsroot/movitz/losp/muerte/basic-macros.lisp 2008/03/15 20:57:16 1.71 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: basic-macros.lisp,v 1.70 2007/03/26 21:11:40 ffjeld Exp $ +;;;; $Id: basic-macros.lisp,v 1.71 2008/03/15 20:57:16 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -28,29 +28,59 @@ (in-package muerte) -(defmacro defmacro (name lambda-list &body macro-body) +(defmacro defmacro/cross-compilation (name lambda-list &body body) `(progn - (defmacro-compile-time ,name ,lambda-list ,macro-body) - #+ignore - (eval-when (:compile-toplevel) - (let ((name (intern (symbol-name ',name)))) - (when (eq (symbol-package name) - (find-package 'muerte.common-lisp)) - ;; (warn "setting ~S" name) - (setf (movitz:movitz-env-get name 'macro-expansion) - (list* 'lambda ',lambda-list - ',macro-body))))) + (defmacro-compile-time ,name ,lambda-list ,body) ',name)) +(defmacro defmacro (name lambda-list &body body) + `(defmacro/cross-compilation ,name ,lambda-list , at body)) + +(defmacro defmacro/runtime (name lambda-list &body body) + (multiple-value-bind (real-body declarations docstring) + (movitz::parse-docstring-declarations-and-body body 'cl:declare) + (let* ((block-name (compute-function-block-name name)) + (ignore-var (gensym)) + (form-var (gensym "form-")) + (env-var nil) + (operator-var (gensym)) + (destructuring-lambda-list + (do ((l lambda-list) + (r nil)) + ((atom l) + (cons operator-var + (nreconc r l))) + (let ((x (pop l))) + (if (eq x '&environment) + (setf env-var (pop l)) + (push x r)))))) + (multiple-value-bind (env-var ignore-env) + (if env-var + (values env-var nil) + (let ((e (gensym))) + (values e (list e)))) + `(make-named-function ,name + (&edx edx &optional ,form-var ,env-var &rest ,ignore-var) + ((ignore ,ignore-var , at ignore-env)) + ,docstring + (block ,block-name + (verify-macroexpand-call edx ',name) + (destructuring-bind ,destructuring-lambda-list + ,form-var + (declare (ignore ,operator-var) , at declarations) + , at real-body)) + :type :macro-function))))) + (defmacro defun (function-name lambda-list &body body) "Define a function." -;;; (warn "defun ~S.." function-name) (multiple-value-bind (real-body declarations docstring) (movitz::parse-docstring-declarations-and-body body 'cl:declare) (let ((block-name (compute-function-block-name function-name))) `(progn - (make-named-function ,function-name ,lambda-list - ,declarations ,docstring + (make-named-function ,function-name + ,lambda-list + ,declarations + ,docstring (block ,block-name , at real-body)) ',function-name)))) @@ -1078,7 +1108,7 @@ (:halt) (:jmp ',infinite-loop-label)))) -(defmacro function-name-or-nil () +(define-compiler-macro function-name-or-nil () (let ((function-name-not-found-label (gensym))) `(with-inline-assembly (:returns :eax) (:movl :edi :eax) From ffjeld at common-lisp.net Sat Mar 15 20:57:30 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sat, 15 Mar 2008 15:57:30 -0500 (EST) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080315205730.B5AC34084@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv3049 Modified Files: characters.lisp Log Message: Have macros in the run-time. --- /project/movitz/cvsroot/movitz/losp/muerte/characters.lisp 2004/07/20 08:54:00 1.4 +++ /project/movitz/cvsroot/movitz/losp/muerte/characters.lisp 2008/03/15 20:57:27 1.5 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Mon Feb 5 19:05:01 2001 ;;;; -;;;; $Id: characters.lisp,v 1.4 2004/07/20 08:54:00 ffjeld Exp $ +;;;; $Id: characters.lisp,v 1.5 2008/03/15 20:57:27 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -70,7 +70,7 @@ (return-from char/= nil))))))) -(defmacro define-char-cmp (name mode not-branch) +(defmacro/cross-compilation define-char-cmp (name mode not-branch) `(defun ,name (first-character &rest more-characters) (numargs-case (1 (x) (declare (ignore x)) t) From ffjeld at common-lisp.net Sat Mar 15 20:57:33 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sat, 15 Mar 2008 15:57:33 -0500 (EST) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080315205733.14AC749115@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv3094 Modified Files: common-lisp.lisp Log Message: Have macros in the run-time. --- /project/movitz/cvsroot/movitz/losp/muerte/common-lisp.lisp 2006/04/07 21:48:41 1.14 +++ /project/movitz/cvsroot/movitz/losp/muerte/common-lisp.lisp 2008/03/15 20:57:32 1.15 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:41:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: common-lisp.lisp,v 1.14 2006/04/07 21:48:41 ffjeld Exp $ +;;;; $Id: common-lisp.lisp,v 1.15 2008/03/15 20:57:32 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -21,6 +21,7 @@ (require :muerte/integers) (require :muerte/basic-functions) (require :muerte/variables) +(require :muerte/runtime-defmacro) (require :muerte/primitive-functions) (require :muerte/equalp) (require :muerte/typep) From ffjeld at common-lisp.net Sat Mar 15 20:57:37 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sat, 15 Mar 2008 15:57:37 -0500 (EST) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080315205737.F0CBF49124@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv3130 Modified Files: defstruct.lisp Log Message: Have macros in the run-time. --- /project/movitz/cvsroot/movitz/losp/muerte/defstruct.lisp 2006/04/03 21:22:39 1.17 +++ /project/movitz/cvsroot/movitz/losp/muerte/defstruct.lisp 2008/03/15 20:57:34 1.18 @@ -9,7 +9,7 @@ ;;;; Created at: Mon Jan 22 13:10:59 2001 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: defstruct.lisp,v 1.17 2006/04/03 21:22:39 ffjeld Exp $ +;;;; $Id: defstruct.lisp,v 1.18 2008/03/15 20:57:34 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -133,13 +133,13 @@ (defun (setf list-struct-accessor-prototype) (value s) (setf (nth 'slot-number s) value)) -(defmacro defstruct (name-and-options &optional documentation &rest slot-descriptions) +(defmacro/cross-compilation defstruct (name-and-options &optional documentation &rest slot-descriptions) (unless (stringp documentation) (push documentation slot-descriptions) (setf documentation nil)) (let ((struct-name (if (symbolp name-and-options) name-and-options - (car name-and-options)))) + (car name-and-options)))) (flet ((parse-option (option collector) (etypecase option (symbol @@ -154,7 +154,7 @@ (ecase (car option) (:conc-name (push "" (getf collector :conc-name))) (:constructor (push (intern (concatenate 'string - (string 'make-) (string struct-name))) + (string 'make-) (string struct-name))) (getf collector :constructor))) (:copier) ; do default (:predicate) ; do default @@ -184,13 +184,13 @@ collector)) (let ((options nil)) (when (listp name-and-options) - (loop for option in (cdr name-and-options) - do (setf options (parse-option option options)))) + (dolist (option (cdr name-and-options)) + (setf options (parse-option option options)))) (macrolet ((default ((option &optional (max-values 1000000)) default-form) - `(if (not (getf options ,option)) - (push ,default-form (getf options ,option)) + `(if (not (getf options ,option)) + (push ,default-form (getf options ,option)) (assert (<= 1 (length (getf options ,option)) ,max-values) () - "Option ~S given too many times." ,option)))) + "Option ~S given too many times." ,option)))) (default (:type 1) 'class-struct) (default (:superclass 1) 'structure-object) (default (:named 1) nil) @@ -209,17 +209,17 @@ (predicate-name (first (getf options :predicate))) (standard-name-and-options (if (not (consp name-and-options)) name-and-options - (remove :superclass name-and-options - :key (lambda (x) - (when (consp x) (car x)))))) + (remove :superclass name-and-options + :key (lambda (x) + (when (consp x) (car x)))))) (canonical-slot-descriptions (mapcar #'(lambda (d) "( )" (if (symbolp d) (list d nil nil nil (intern (symbol-name d) :keyword)) - (destructuring-bind (n &optional i &key type read-only) - d - (list n i type read-only (intern (symbol-name n) :keyword))))) + (destructuring-bind (n &optional i &key type read-only) + d + (list n i type read-only (intern (symbol-name n) :keyword))))) slot-descriptions)) (slot-names (mapcar #'car canonical-slot-descriptions)) (key-lambda (mapcar #'(lambda (d) (list (first d) (second d))) @@ -230,111 +230,107 @@ (eval-when (:compile-toplevel) (setf (gethash '(:translate-when :eval ,struct-name :cl :muerte.cl) (movitz::image-struct-slot-descriptions movitz:*image*)) - '(:translate-when :eval ,slot-descriptions :cl :muerte.cl)) + '(:translate-when :eval ,slot-descriptions :cl :muerte.cl)) (defstruct (:translate-when :eval ,standard-name-and-options :cl :muerte.cl) . (:translate-when :eval ,slot-names :cl :muerte.cl))) (defclass ,struct-name (,superclass) () - (:metaclass structure-class) - (:slots ,(loop for (name init-form type read-only init-arg) - in canonical-slot-descriptions - as location upfrom 0 - collect (movitz-make-instance 'structure-slot-definition - :name name - :initarg init-arg - :initform init-form - :type type - :readonly read-only - :location location)))) + (:metaclass structure-class) + (:slots ,(loop for (name init-form type read-only init-arg) in canonical-slot-descriptions + as location upfrom 0 + collect (movitz-make-instance 'structure-slot-definition + :name name + :initarg init-arg + :initform init-form + :type type + :readonly read-only + :location location)))) ,@(loop for copier in (getf options :copier) - if (and copier (symbolp copier)) - collect - `(defun ,copier (x) - (copy-structure x))) + if (and copier (symbolp copier)) + collect + `(defun ,copier (x) + (copy-structure x))) ,@(loop for constructor in (getf options :constructor) - if (and constructor (symbolp constructor)) - collect - `(defun ,constructor (&rest args) ; &key , at key-lambda) - (declare (dynamic-extent args)) - (apply 'make-structure ',struct-name args)) - else if (and constructor (listp constructor)) - collect - (let* ((boa-constructor (car constructor)) - (boa-lambda-list (cdr constructor)) - (boa-variables (movitz::list-normal-lambda-list-variables boa-lambda-list))) - `(defun ,boa-constructor ,boa-lambda-list - (let ((class (compile-time-find-class ,struct-name))) - (with-allocation-assembly (,(+ 2 (length slot-names)) - :fixed-size-p t - :object-register :eax) - (:movl ,(dpb (length slot-names) - (byte 18 14) - (movitz:tag :defstruct)) - (:eax (:offset movitz-struct type))) - (:load-lexical (:lexical-binding class) :ebx) - (:movl :ebx (:eax (:offset movitz-struct class))) - ,@(loop for slot-name in slot-names as i upfrom 0 - if (member slot-name boa-variables) - append - `((:load-lexical (:lexical-binding ,slot-name) :ebx) - (:movl :ebx (:eax (:offset movitz-struct slot0) - ,(* 4 i)))) - else append - `((:movl :edi (:eax (:offset movitz-struct slot0) - ,(* 4 i))))) - ,@(when (oddp (length slot-names)) - `((:movl :edi (:eax (:offset movitz-struct slot0) - ,(* 4 (length slot-names)))))))))) - else if constructor - do (error "Don't know how to make class-struct constructor: ~S" constructor)) + if (and constructor (symbolp constructor)) + collect + `(defun ,constructor (&rest args) ; &key , at key-lambda) + (declare (dynamic-extent args)) + (apply 'make-structure ',struct-name args)) + else if (and constructor (listp constructor)) + collect + (let* ((boa-constructor (car constructor)) + (boa-lambda-list (cdr constructor)) + (boa-variables (movitz::list-normal-lambda-list-variables boa-lambda-list))) + `(defun ,boa-constructor ,boa-lambda-list + (let ((class (compile-time-find-class ,struct-name))) + (with-allocation-assembly (,(+ 2 (length slot-names)) + :fixed-size-p t + :object-register :eax) + (:movl ,(dpb (length slot-names) + (byte 18 14) + (movitz:tag :defstruct)) + (:eax (:offset movitz-struct type))) + (:load-lexical (:lexical-binding class) :ebx) + (:movl :ebx (:eax (:offset movitz-struct class))) + ,@(loop for slot-name in slot-names as i upfrom 0 + if (member slot-name boa-variables) + append + `((:load-lexical (:lexical-binding ,slot-name) :ebx) + (:movl :ebx (:eax (:offset movitz-struct slot0) + ,(* 4 i)))) + else append + `((:movl :edi (:eax (:offset movitz-struct slot0) + ,(* 4 i))))) + ,@(when (oddp (length slot-names)) + `((:movl :edi (:eax (:offset movitz-struct slot0) + ,(* 4 (length slot-names)))))))))) + else if constructor + do (error "Don't know how to make class-struct constructor: ~S" constructor)) ,(when predicate-name - `(defun-by-proto ,predicate-name struct-predicate-prototype - (struct-class (:movitz-find-class ,struct-name)))) + `(defun-by-proto ,predicate-name struct-predicate-prototype + (struct-class (:movitz-find-class ,struct-name)))) ,@(loop for (slot-name nil nil read-only-p) in canonical-slot-descriptions - as accessor-name = (intern (concatenate 'string conc-name (string slot-name)) - (movitz::symbol-package-fix-cl struct-name)) - as slot-number upfrom 0 - unless read-only-p - collect - `(defun-by-proto (setf ,accessor-name) (setf struct-accessor-prototype) - (struct-name ,struct-name) - (slot-number ,slot-number)) - collect - `(defun-by-proto ,accessor-name struct-accessor-prototype - (struct-name ,struct-name) - (slot-number ,slot-number))) + as accessor-name = (intern (concatenate 'string conc-name (string slot-name)) + (movitz::symbol-package-fix-cl struct-name)) + as slot-number upfrom 0 + unless read-only-p + collect + `(defun-by-proto (setf ,accessor-name) (setf struct-accessor-prototype) + (struct-name ,struct-name) + (slot-number ,slot-number)) + collect + `(defun-by-proto ,accessor-name struct-accessor-prototype + (struct-name ,struct-name) + (slot-number ,slot-number))) ',struct-name)) (list `(progn ,@(if struct-named (append (loop for constructor in (getf options :constructor) - if (symbolp constructor) - collect - `(defun ,constructor (&key , at key-lambda) - (list ',struct-name ,@(mapcar #'car key-lambda))) - else do (error "don't know how to make constructor: ~S" constructor)) + if (symbolp constructor) + collect + `(defun ,constructor (&key , at key-lambda) + (list ',struct-name ,@(mapcar #'car key-lambda))) + else do (error "don't know how to make constructor: ~S" constructor)) (when predicate-name `((defun ,predicate-name (x) (and (consp x) (eq ',struct-name (car x))))))) - (loop for constructor in (getf options :constructor) - if (symbolp constructor) - collect - `(defun ,constructor (&key , at key-lambda) - (list ,@(mapcar #'car key-lambda))) - else do (error "don't know how to make constructor: ~S" constructor))) + (loop for constructor in (getf options :constructor) + if (symbolp constructor) + collect + `(defun ,constructor (&key , at key-lambda) + (list ,@(mapcar #'car key-lambda))) + else do (error "don't know how to make constructor: ~S" constructor))) ,@(loop for (slot-name nil nil read-only-p) in canonical-slot-descriptions - as accessor-name = (intern (concatenate 'string conc-name (string slot-name)) - (movitz::symbol-package-fix-cl struct-name)) - as slot-number upfrom (if struct-named 1 0) - unless read-only-p - collect - `(defun-by-proto (setf ,accessor-name) (setf list-struct-accessor-prototype) - (slot-number ,slot-number)) - collect - `(defun-by-proto ,accessor-name list-struct-accessor-prototype - (slot-number ,slot-number))) + as accessor-name = (intern (concatenate 'string conc-name (string slot-name)) + (movitz::symbol-package-fix-cl struct-name)) + as slot-number upfrom (if struct-named 1 0) + unless read-only-p + collect + `(defun-by-proto (setf ,accessor-name) (setf list-struct-accessor-prototype) + (slot-number ,slot-number)) + collect + `(defun-by-proto ,accessor-name list-struct-accessor-prototype + (slot-number ,slot-number))) ',struct-name)) )))))) - - - From ffjeld at common-lisp.net Sat Mar 15 20:57:41 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sat, 15 Mar 2008 15:57:41 -0500 (EST) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080315205741.DD6E949136@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv3211 Modified Files: eval.lisp Log Message: Have macros in the run-time. --- /project/movitz/cvsroot/movitz/losp/muerte/eval.lisp 2007/02/26 18:22:27 1.18 +++ /project/movitz/cvsroot/movitz/losp/muerte/eval.lisp 2008/03/15 20:57:39 1.19 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Oct 19 21:15:12 2001 ;;;; -;;;; $Id: eval.lisp,v 1.18 2007/02/26 18:22:27 ffjeld Exp $ +;;;; $Id: eval.lisp,v 1.19 2008/03/15 20:57:39 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -69,46 +69,52 @@ (defun eval-cons (form env) "3.1.2.1.2 Conses as Forms" - (case (car form) - (quote (cadr form)) - (function (eval-function (second form) env)) - (when (when (eval-form (second form) env) - (eval-progn (cddr form) env))) - (unless (unless (eval-form (second form) env) - (eval-progn (cddr form) env))) - (if (if (eval-form (second form) env) - (eval-form (third form) env) - (eval-form (fourth form) env))) - (progn (eval-progn (cdr form) env)) - (prog1 (prog1 (eval-form (cadr form) env) + (let ((macro-function (macro-function (car form)))) + (if macro-function + (eval-form (funcall macro-function form nil) + nil) + (case (car form) + (quote (cadr form)) + (function (eval-function (second form) env)) + (when (when (eval-form (second form) env) + (eval-progn (cddr form) env))) + (unless (unless (eval-form (second form) env) + (eval-progn (cddr form) env))) + (if (if (eval-form (second form) env) + (eval-form (third form) env) + (eval-form (fourth form) env))) + (progn (eval-progn (cdr form) env)) + (prog1 (prog1 (eval-form (cadr form) env) + (eval-progn (cddr form) env))) + (tagbody (eval-tagbody form env)) + (go (eval-go form env)) + (setq (eval-setq form env)) + (setf (eval-setf form env)) + ((defvar) (eval-defvar form env)) + (let (eval-let (cadr form) (cddr form) env)) + (time (eval-time (cadr form) env)) + ((defun) (eval-defun (cadr form) (caddr form) (cdddr form) env)) + ((lambda) (eval-function form env)) ; the lambda macro.. + ((multiple-value-prog1) + (multiple-value-prog1 (eval-form (cadr form) env) (eval-progn (cddr form) env))) - (tagbody (eval-tagbody form env)) - (go (eval-go form env)) - (setq (eval-setq form env)) - (setf (eval-setf form env)) - ((defvar) (eval-defvar form env)) - (let (eval-let (cadr form) (cddr form) env)) - (time (eval-time (cadr form) env)) - ((defun) (eval-defun (cadr form) (caddr form) (cdddr form) env)) - ((lambda) (eval-function form env)) ; the lambda macro.. - ((multiple-value-prog1) - (multiple-value-prog1 (eval-form (cadr form) env) - (eval-progn (cddr form) env))) - ((destructuring-bind) - (eval-progn (cdddr form) - (make-destructuring-env (cadr form) - (eval-form (caddr form) env) - env))) - ((catch) - (catch (eval-form (second form) env) - (eval-progn (cddr form) env))) - ((throw) - (throw (eval-form (second form) env) - (eval-form (third form) env))) - ((unwind-protect) - (unwind-protect (eval-form (second form) env) - (eval-progn (cddr form) env))) - (t (eval-funcall form env)))) + ((destructuring-bind) + (eval-progn (cdddr form) + (make-destructuring-env (cadr form) + (eval-form (caddr form) env) + env))) + ((catch) + (catch (eval-form (second form) env) + (eval-progn (cddr form) env))) + ((throw) + (throw (eval-form (second form) env) + (eval-form (third form) env))) + ((unwind-protect) + (unwind-protect (eval-form (second form) env) + (eval-progn (cddr form) env))) + ((macrolet symbol-macrolet) + (error "Special operator ~S not implemented in ~S." (car form) 'eval)) + (t (eval-funcall form env)))))) (defun eval-progn (forms env) (do ((p forms (cdr p))) @@ -456,5 +462,9 @@ (defun macro-function (symbol &optional environment) "=> function" - (declare (ignore symbol environment)) - nil) + (when (not (eq nil environment)) + (error "Unknown environment ~S." environment)) + (when (fboundp symbol) + (let ((f (symbol-function symbol))) + (when (typep f 'macro-function) + f)))) From ffjeld at common-lisp.net Sat Mar 15 20:57:52 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sat, 15 Mar 2008 15:57:52 -0500 (EST) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080315205752.1AF2849115@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv3263 Modified Files: loop.lisp Log Message: Have macros in the run-time. --- /project/movitz/cvsroot/movitz/losp/muerte/loop.lisp 2006/04/07 21:53:02 1.7 +++ /project/movitz/cvsroot/movitz/losp/muerte/loop.lisp 2008/03/15 20:57:44 1.8 @@ -256,7 +256,7 @@ , at body))) -(defmacro loop-collect-rplacd (&environment env +(defmacro/cross-compilation loop-collect-rplacd (&environment env (head-var tail-var &optional user-head-var) form) (declare #+LISPM (ignore head-var user-head-var) ;use locatives, unconditionally update through the tail. @@ -2050,13 +2050,13 @@ ) ;;;INTERFACE: ANSI -(defmacro loop (&rest keywords-and-forms) +(defmacro/cross-compilation loop (&rest keywords-and-forms) #+Genera (declare (compiler:do-not-record-macroexpansions) (zwei:indentation . zwei:indent-loop)) (loop-standard-expansion keywords-and-forms nil *loop-ansi-universe*)) ;;;INTERFACE: Traditional, ANSI, Lucid. -(defmacro loop-finish () +(defmacro/cross-compilation loop-finish () "Causes the iteration to terminate \"normally\", the same as implicit termination by an iteration driving clause, or by use of WHILE or UNTIL -- the epilogue code (if any) will be run, and any implicitly @@ -2064,12 +2064,12 @@ '(go end-loop)) -(defmacro loop-body (prologue - before-loop - main-body - after-loop - epilogue - &aux (env nil) rbefore rafter flagvar) +(defmacro/cross-compilation loop-body (prologue + before-loop + main-body + after-loop + epilogue + &aux (env nil) rbefore rafter flagvar) (unless (= (length before-loop) (length after-loop)) (error "LOOP-BODY called with non-synched before- and after-loop lists.")) ;;All our work is done from these copies, working backwards from the end: @@ -2085,11 +2085,11 @@ (pify (l) (if (null (cdr l)) (car l) `(progn , at l))) (makebody () (let ((form `(tagbody - ,@(psimp (append prologue (nreverse rbefore))) - next-loop - ,@(psimp (append main-body (nreconc rafter `((go next-loop))))) - end-loop - ,@(psimp epilogue)))) + ,@(psimp (append prologue (nreverse rbefore))) + next-loop + ,@(psimp (append main-body (nreconc rafter `((go next-loop))))) + end-loop + ,@(psimp epilogue)))) (if flagvar `(let ((,flagvar nil)) ,form) form)))) (when (or *loop-duplicate-code* (not rbefore)) (return-from loop-body (makebody))) @@ -2115,7 +2115,7 @@ ;; What chronologically precedes the non-duplicatable form will ;; be handled the next time around the outer loop. (do ((bb rbefore (cdr bb)) (aa rafter (cdr aa)) (lastdiff nil) (count 0) (inc nil)) - ((null bb) (return-from loop-body (makebody))) ;Did it. + ((null bb) (return-from loop-body (makebody))) ;Did it. (cond ((not (equal (car bb) (car aa))) (setq lastdiff bb count 0)) ((or (not (setq inc (estimate-code-size (car bb) env))) (> (incf count inc) threshold)) @@ -2141,7 +2141,7 @@ (return))))))) -(defmacro loop-really-desetq (&rest var-val-pairs &aux (env nil)) +(defmacro/cross-compilation loop-really-desetq (&rest var-val-pairs &aux (env nil)) (labels ((find-non-null (var) ;; see if there's any non-null thing here ;; recurse if the list element is itself a list From ffjeld at common-lisp.net Sat Mar 15 20:58:02 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sat, 15 Mar 2008 15:58:02 -0500 (EST) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080315205802.62A9D49123@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv3329 Modified Files: los-closette.lisp Log Message: Have macros in the run-time. --- /project/movitz/cvsroot/movitz/losp/muerte/los-closette.lisp 2007/03/11 22:43:14 1.37 +++ /project/movitz/cvsroot/movitz/losp/muerte/los-closette.lisp 2008/03/15 20:57:57 1.38 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Jul 23 14:29:10 2002 ;;;; -;;;; $Id: los-closette.lisp,v 1.37 2007/03/11 22:43:14 ffjeld Exp $ +;;;; $Id: los-closette.lisp,v 1.38 2008/03/15 20:57:57 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -873,7 +873,7 @@ (equal '(:around) (method-qualifiers method))) -(defmacro define-effective-slot-reader (name location) +(defmacro/cross-compilation define-effective-slot-reader (name location) (if movitz::*compiler-use-into-unbound-protocol* `(defun ,name (instance) (with-inline-assembly (:returns :multiple-values) @@ -1002,6 +1002,7 @@ (defclass funcallable-standard-class (std-slotted-class) ()) (defclass function (t) () (:metaclass built-in-class)) +(defclass macro-function (function) () (:metaclass built-in-class)) (defclass funcallable-standard-object (standard-object function) ()) (defclass generic-function (metaobject funcallable-standard-object) ()) (defclass standard-generic-function (generic-function) From ffjeld at common-lisp.net Sat Mar 15 20:58:07 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sat, 15 Mar 2008 15:58:07 -0500 (EST) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080315205807.2119E49130@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv3408 Modified Files: more-macros.lisp Log Message: Have macros in the run-time. --- /project/movitz/cvsroot/movitz/losp/muerte/more-macros.lisp 2008/03/08 14:03:35 1.39 +++ /project/movitz/cvsroot/movitz/losp/muerte/more-macros.lisp 2008/03/15 20:58:06 1.40 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Jun 7 15:05:57 2002 ;;;; -;;;; $Id: more-macros.lisp,v 1.39 2008/03/08 14:03:35 ffjeld Exp $ +;;;; $Id: more-macros.lisp,v 1.40 2008/03/15 20:58:06 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -171,6 +171,8 @@ ((or (pop-match '&rest sub-lambda-list) (pop-match '&body sub-lambda-list)) (gen-restvar var sub-lambda-list)) + ((pop-match '&key sub-lambda-list) + (gen-keyvars var sub-lambda-list)) ((pop-match '&aux sub-lambda-list) (dolist (b sub-lambda-list) (push b bindings))) @@ -294,47 +296,6 @@ (return p)))) (t form)))) -(defmacro letf* (bindings &body body &environment env) - "Does what one might expect, saving the old values and setting the generalized - variables to the new values in sequence. Unwind-protects and get-setf-method - are used to preserve the semantics one might expect in analogy to let*, - and the once-only evaluation of subforms." - (labels ((do-bindings - (bindings) - (cond ((null bindings) body) - (t (multiple-value-bind (dummies vals newval setter getter) - (get-setf-expansion (caar bindings) env) - (let ((save (gensym))) - `((let* (,@(mapcar #'list dummies vals) - (,(car newval) ,(cadar bindings)) - (,save ,getter)) - (unwind-protect - (progn ,setter - ,@(do-bindings (cdr bindings))) - (setq ,(car newval) ,save) - ,setter))))))))) - (car (do-bindings bindings)))) - -(defmacro with-letf (clauses &body body) - "Each clause is ( &optional ). -Execute with alternative values for each . -Note that this scheme does not work well with respect to multiple threads. -XXX This should actually be using get-setf-expansion etc. to deal with -proper evaluation of the places' subforms." - (let ((place-value-save (loop for (place . value-save) in clauses - if value-save - collect (list place `(progn ,(first value-save)) - (or (second value-save) (gensym))) - else collect (list place nil (gensym))))) - `(let (,@(loop for (place nil save-var) in place-value-save - collect `(,save-var ,place))) - (unwind-protect - (progn (setf ,@(loop for (place value) in place-value-save - append `(,place ,value))) - , at body) - (setf ,@(loop for (place nil save) in place-value-save - append `(,place ,save))))))) - (defmacro with-alternative-fdefinitions (clauses &body body) "Each clause is ( ). Execute with alternative fdefinitions for each . Note that this scheme does not work well with From ffjeld at common-lisp.net Sat Mar 15 20:58:14 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sat, 15 Mar 2008 15:58:14 -0500 (EST) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080315205814.47EF94912C@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv3459 Modified Files: primitive-functions.lisp Log Message: Have macros in the run-time. --- /project/movitz/cvsroot/movitz/losp/muerte/primitive-functions.lisp 2007/02/19 21:58:27 1.69 +++ /project/movitz/cvsroot/movitz/losp/muerte/primitive-functions.lisp 2008/03/15 20:58:08 1.70 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Oct 2 21:02:18 2001 ;;;; -;;;; $Id: primitive-functions.lisp,v 1.69 2007/02/19 21:58:27 ffjeld Exp $ +;;;; $Id: primitive-functions.lisp,v 1.70 2008/03/15 20:58:08 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -72,11 +72,9 @@ ,docstring (with-inline-assembly (:returns :nothing) (:movl :esi :edx) ; parameter for standard-gf-function. - (:movl (:esi ,(bt:slot-offset 'movitz::movitz-funobj-standard-gf - (intern (symbol-name to) :movitz))) + (:movl (:esi (:offset movitz-funobj-standard-gf ,to)) :esi) - (:jmp (:esi ,(bt:slot-offset 'movitz::movitz-funobj - (intern (symbol-name forward) :movitz))))))) + (:jmp (:esi (:offset movitz-funobj ,forward)))))) (define-gf-dispatcher standard-gf-dispatcher () "The code-vector of standard-gf instances." code-vector standard-gf-function) @@ -582,6 +580,8 @@ (find-class 'function)) (structure-object (structure-object-class object)) + (macro-function + (find-class 'macro-function)) (character (find-class 'character)) (null From ffjeld at common-lisp.net Sat Mar 15 20:58:16 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sat, 15 Mar 2008 15:58:16 -0500 (EST) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080315205816.5BBD549126@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv3550 Modified Files: print.lisp Log Message: Have macros in the run-time. --- /project/movitz/cvsroot/movitz/losp/muerte/print.lisp 2006/05/02 20:04:15 1.23 +++ /project/movitz/cvsroot/movitz/losp/muerte/print.lisp 2008/03/15 20:58:15 1.24 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Mon Sep 3 11:48:19 2001 ;;;; -;;;; $Id: print.lisp,v 1.23 2006/05/02 20:04:15 ffjeld Exp $ +;;;; $Id: print.lisp,v 1.24 2008/03/15 20:58:15 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -230,29 +230,31 @@ ((or cons tag5) (let ((level *print-level*)) (cond - ((and level (minusp level)) - (write-char #\# stream)) - ((and (eq 'quote (car object)) - (not (cddr object))) - (write-char #\' stream) - (write (cadr object))) - (t (labels ((write-cons (c stream length) - (cond - ((and length (= 0 length)) - (write-string "...)")) - (t (write (car c)) - (typecase (cdr c) - (null - (write-char #\) stream)) - (cons - (write-char #\space stream) - (write-cons (cdr c) stream (minus-if length 1))) - (t - (write-string " . " stream) - (write (cdr c)) - (write-char #\) stream))))))) - (write-char #\( stream) - (write-cons object stream *print-length*)))))) + ((and (not do-escape-p) + level + (minusp level)) + (write-char #\# stream)) + ((and (eq 'quote (car object)) + (not (cddr object))) + (write-char #\' stream) + (write (cadr object))) + (t (labels ((write-cons (c stream length) + (cond + ((and length (= 0 length)) + (write-string "...)")) + (t (write (car c)) + (typecase (cdr c) + (null + (write-char #\) stream)) + (cons + (write-char #\space stream) + (write-cons (cdr c) stream (minus-if length 1))) + (t + (write-string " . " stream) + (write (cdr c)) + (write-char #\) stream))))))) + (write-char #\( stream) + (write-cons object stream *print-length*)))))) (integer (write-integer object stream *print-base* *print-radix*)) (string @@ -326,6 +328,9 @@ (standard-gf-instance (print-unreadable-object (object stream) (format stream "gf ~S" (funobj-name object)))) + (macro-function + (print-unreadable-object (object stream) + (format stream "macro-function ~S" (funobj-name object)))) (compiled-function (print-unreadable-object (object stream) (format stream "function ~S" (funobj-name object)))) From ffjeld at common-lisp.net Sat Mar 15 20:58:19 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sat, 15 Mar 2008 15:58:19 -0500 (EST) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080315205819.A1AEC405F@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv3576 Modified Files: sequences.lisp Log Message: Have macros in the run-time. --- /project/movitz/cvsroot/movitz/losp/muerte/sequences.lisp 2007/04/07 20:14:45 1.37 +++ /project/movitz/cvsroot/movitz/losp/muerte/sequences.lisp 2008/03/15 20:58:17 1.38 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Sep 11 14:19:23 2001 ;;;; -;;;; $Id: sequences.lisp,v 1.37 2007/04/07 20:14:45 ffjeld Exp $ +;;;; $Id: sequences.lisp,v 1.38 2008/03/15 20:58:17 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -46,11 +46,13 @@ (defmacro sequence-double-dispatch ((seq0 seq1) &rest clauses) `(case (logior (if (typep ,seq0 'list) 2 0) (if (typep ,seq1 'list) 1 0)) - ,@(loop for ((type0 type1) . forms) in clauses - as index = (logior (ecase type0 (list 2) (vector 0)) - (ecase type1 (list 1) (vector 0))) - collect - `(,index , at forms)) + ,@(mapcar (lambda (clause) + (destructuring-bind ((type0 type1) . forms) + clause + (list* (logior (ecase type0 (list 2) (vector 0)) + (ecase type1 (list 1) (vector 0))) + forms))) + clauses) (t (sequence-double-dispatch-error ,seq0 ,seq1)))) (defun length (sequence) From ffjeld at common-lisp.net Sat Mar 15 20:58:22 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sat, 15 Mar 2008 15:58:22 -0500 (EST) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080315205822.A577D49123@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv3615 Modified Files: simple-streams.lisp Log Message: Have macros in the run-time. --- /project/movitz/cvsroot/movitz/losp/muerte/simple-streams.lisp 2005/06/10 18:35:44 1.8 +++ /project/movitz/cvsroot/movitz/losp/muerte/simple-streams.lisp 2008/03/15 20:58:20 1.9 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Aug 29 13:39:43 2003 ;;;; -;;;; $Id: simple-streams.lisp,v 1.8 2005/06/10 18:35:44 ffjeld Exp $ +;;;; $Id: simple-streams.lisp,v 1.9 2008/03/15 20:58:20 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -60,7 +60,7 @@ ,@(cdr dual-clause)) (t ,@(cdr string-clause)))))))) -(defmacro with-stream-class ((class-name &optional stream) &body body) +(defmacro/cross-compilation with-stream-class ((class-name &optional stream) &body body) (if stream (let ((stream-var (gensym "stream-")) (slots-var (gensym "stream-slots-"))) From ffjeld at common-lisp.net Sat Mar 15 20:58:28 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sat, 15 Mar 2008 15:58:28 -0500 (EST) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080315205828.DCA7931033@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv3653 Modified Files: typep.lisp Log Message: Have macros in the run-time. --- /project/movitz/cvsroot/movitz/losp/muerte/typep.lisp 2006/05/06 20:29:10 1.54 +++ /project/movitz/cvsroot/movitz/losp/muerte/typep.lisp 2008/03/15 20:58:24 1.55 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 8 11:07:53 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: typep.lisp,v 1.54 2006/05/06 20:29:10 ffjeld Exp $ +;;;; $Id: typep.lisp,v 1.55 2008/03/15 20:58:24 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -265,6 +265,8 @@ (std-instance (make-other-typep :std-instance) #+ignore (make-tag-typep :std-instance)) + (macro-function + (make-function-typep :macro-function)) (standard-gf-instance (make-function-typep :generic-function)) (list @@ -648,6 +650,9 @@ (define-simple-typep (function functionp) (x) (typep x 'function)) +(define-simple-typep (macro-function macro-function-p) (x) + (typep x 'macro-function)) + (define-simple-typep (hash-table hash-table-p)) (define-simple-typep (package packagep)) From ffjeld at common-lisp.net Sat Mar 15 20:58:32 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sat, 15 Mar 2008 15:58:32 -0500 (EST) Subject: [movitz-cvs] CVS movitz/losp/x86-pc Message-ID: <20080315205832.9E64349124@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory clnet:/tmp/cvs-serv3749 Modified Files: textmode.lisp Log Message: Have macros in the run-time. --- /project/movitz/cvsroot/movitz/losp/x86-pc/textmode.lisp 2007/04/09 16:05:25 1.17 +++ /project/movitz/cvsroot/movitz/losp/x86-pc/textmode.lisp 2008/03/15 20:58:30 1.18 @@ -9,7 +9,7 @@ ;;;; Created at: Thu Nov 9 15:38:56 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: textmode.lisp,v 1.17 2007/04/09 16:05:25 ffjeld Exp $ +;;;; $Id: textmode.lisp,v 1.18 2008/03/15 20:58:30 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -196,7 +196,7 @@ (defun write-word-bottom3 (word) (write-word-lowlevel word #.(cl:+ 140 #xb8000 (cl:* 24 160)))) -(defmacro write-word-lowlevel-macro (word dest) +(define-compiler-macro write-word-lowlevel-macro (word dest) (let ((loop-label (make-symbol "write-word-loop")) (l1 (make-symbol "write-word-l1")) (l2 (make-symbol "write-word-l2")) From ffjeld at common-lisp.net Sun Mar 16 22:27:54 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sun, 16 Mar 2008 17:27:54 -0500 (EST) Subject: [movitz-cvs] CVS movitz Message-ID: <20080316222754.416926A005@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv6583 Modified Files: compiler.lisp Log Message: Make code-uses-binding-p not barf on certain labels forms. --- /project/movitz/cvsroot/movitz/compiler.lisp 2008/03/15 00:21:38 1.195 +++ /project/movitz/cvsroot/movitz/compiler.lisp 2008/03/16 22:27:54 1.196 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.195 2008/03/15 00:21:38 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.196 2008/03/16 22:27:54 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -3160,16 +3160,37 @@ (defun code-uses-binding-p (code binding &key (load t) store call) "Does extended potentially read/write/call ?" - (labels ((search-funobj (funobj binding load store call) + (labels ((search-funobj (funobj binding load store call path) ;; If this is a recursive lexical call (i.e. labels), ;; the function-envs might not be bound, but then this ;; code is searched already. - (when (slot-boundp funobj 'function-envs) - (some (lambda (function-env-spec) - (code-search (extended-code (cdr function-env-spec)) binding - load store call)) - (function-envs funobj)))) - (code-search (code binding load store call) + (if (member funobj path) + nil + (when (slot-boundp funobj 'function-envs) + (some (lambda (function-env-spec) + (or (not (slot-boundp (cdr function-env-spec) 'extended-code)) ; Don't know yet, assume yes. + (code-search (extended-code (cdr function-env-spec)) binding + load store call + (cons funobj path)))) + (function-envs funobj)))) + #+ignore + (if (member funobj path) + nil + (let* ((memo (assoc funobj memos)) + (x (cdr (or memo + (car (push (cons funobj + (when (slot-boundp funobj 'function-envs) + (some (lambda (function-env-spec) + (or (not (slot-boundp (cdr function-env-spec) 'extended-code)) ; Don't know yet, assume yes. + (code-search (extended-code (cdr function-env-spec)) + binding + load store call + (cons funobj path)))) + (function-envs funobj)))) + memos)))))) + (warn "search ~S ~S: ~S" funobj binding x) + x))) + (code-search (code binding load store call path) (dolist (instruction code) (when (consp instruction) (let ((x (or (when load @@ -3183,7 +3204,9 @@ (case (car instruction) (:local-function-init (search-funobj (function-binding-funobj (second instruction)) - binding load store call)) + binding + load store call + path)) (:load-lambda (or (when load (binding-eql binding (second instruction))) @@ -3193,16 +3216,22 @@ (typep allocation 'with-dynamic-extent-scope-env)) (binding-eql binding (base-binding allocation)))) (search-funobj (function-binding-funobj (second instruction)) - binding load store call))) + binding + load store call + path))) (:call-lexical (or (when call (binding-eql binding (second instruction))) (search-funobj (function-binding-funobj (second instruction)) - binding load store call)))) + binding + load store call + path)))) (code-search (instruction-sub-program instruction) - binding load store call)))) + binding + load store call + path)))) (when x (return t))))))) - (code-search code binding load store call))) + (code-search code binding load store call nil))) (defun bindingp (x) (typep x 'binding)) From ffjeld at common-lisp.net Sun Mar 16 22:28:07 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sun, 16 Mar 2008 17:28:07 -0500 (EST) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080316222807.AC5DE4D0A3@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv6674 Modified Files: basic-macros.lisp Log Message: Working on making macros work. --- /project/movitz/cvsroot/movitz/losp/muerte/basic-macros.lisp 2008/03/15 20:57:16 1.71 +++ /project/movitz/cvsroot/movitz/losp/muerte/basic-macros.lisp 2008/03/16 22:28:07 1.72 @@ -9,68 +9,14 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: basic-macros.lisp,v 1.71 2008/03/15 20:57:16 ffjeld Exp $ +;;;; $Id: basic-macros.lisp,v 1.72 2008/03/16 22:28:07 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ (provide :muerte/basic-macros) -;; First of all we must define DEFMACRO.. -(muerte::defmacro-compile-time muerte.cl:defmacro (name lambda-list &body macro-body) - (`(muerte.cl:progn - (muerte::defmacro-compile-time ,name ,lambda-list ,macro-body) - ',name))) - -(muerte.cl:defmacro muerte.cl:in-package (name) - `(progn - (eval-when (:compile-toplevel) - (in-package ,(movitz::movitzify-package-name name))))) - (in-package muerte) -(defmacro defmacro/cross-compilation (name lambda-list &body body) - `(progn - (defmacro-compile-time ,name ,lambda-list ,body) - ',name)) - -(defmacro defmacro (name lambda-list &body body) - `(defmacro/cross-compilation ,name ,lambda-list , at body)) - -(defmacro defmacro/runtime (name lambda-list &body body) - (multiple-value-bind (real-body declarations docstring) - (movitz::parse-docstring-declarations-and-body body 'cl:declare) - (let* ((block-name (compute-function-block-name name)) - (ignore-var (gensym)) - (form-var (gensym "form-")) - (env-var nil) - (operator-var (gensym)) - (destructuring-lambda-list - (do ((l lambda-list) - (r nil)) - ((atom l) - (cons operator-var - (nreconc r l))) - (let ((x (pop l))) - (if (eq x '&environment) - (setf env-var (pop l)) - (push x r)))))) - (multiple-value-bind (env-var ignore-env) - (if env-var - (values env-var nil) - (let ((e (gensym))) - (values e (list e)))) - `(make-named-function ,name - (&edx edx &optional ,form-var ,env-var &rest ,ignore-var) - ((ignore ,ignore-var , at ignore-env)) - ,docstring - (block ,block-name - (verify-macroexpand-call edx ',name) - (destructuring-bind ,destructuring-lambda-list - ,form-var - (declare (ignore ,operator-var) , at declarations) - , at real-body)) - :type :macro-function))))) - (defmacro defun (function-name lambda-list &body body) "Define a function." (multiple-value-bind (real-body declarations docstring) From ffjeld at common-lisp.net Sun Mar 16 22:28:09 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sun, 16 Mar 2008 17:28:09 -0500 (EST) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080316222809.8E5244D0B1@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv6693 Modified Files: common-lisp.lisp Log Message: Working on making macros work. --- /project/movitz/cvsroot/movitz/losp/muerte/common-lisp.lisp 2008/03/15 20:57:32 1.15 +++ /project/movitz/cvsroot/movitz/losp/muerte/common-lisp.lisp 2008/03/16 22:28:09 1.16 @@ -9,19 +9,24 @@ ;;;; Created at: Wed Nov 8 18:41:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: common-lisp.lisp,v 1.15 2008/03/15 20:57:32 ffjeld Exp $ +;;;; $Id: common-lisp.lisp,v 1.16 2008/03/16 22:28:09 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ +(require :muerte/defmacro-bootstrap) (require :muerte/basic-macros) (require :muerte/setf) (require :muerte/more-macros) (require :muerte/arithmetic-macros) + +(require :muerte/defmacro-runtime) +;; (include :muerte/basic-macros) +(include :muerte/more-macros) + (require :muerte/memref) (require :muerte/integers) (require :muerte/basic-functions) (require :muerte/variables) -(require :muerte/runtime-defmacro) (require :muerte/primitive-functions) (require :muerte/equalp) (require :muerte/typep) From ffjeld at common-lisp.net Sun Mar 16 22:28:16 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sun, 16 Mar 2008 17:28:16 -0500 (EST) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080316222816.C83DE4D0A7@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv6708 Modified Files: eval.lisp Log Message: Working on making macros work. --- /project/movitz/cvsroot/movitz/losp/muerte/eval.lisp 2008/03/15 20:57:39 1.19 +++ /project/movitz/cvsroot/movitz/losp/muerte/eval.lisp 2008/03/16 22:28:12 1.20 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Oct 19 21:15:12 2001 ;;;; -;;;; $Id: eval.lisp,v 1.19 2008/03/15 20:57:39 ffjeld Exp $ +;;;; $Id: eval.lisp,v 1.20 2008/03/16 22:28:12 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -92,9 +92,10 @@ (setf (eval-setf form env)) ((defvar) (eval-defvar form env)) (let (eval-let (cadr form) (cddr form) env)) - (time (eval-time (cadr form) env)) ((defun) (eval-defun (cadr form) (caddr form) (cdddr form) env)) ((lambda) (eval-function form env)) ; the lambda macro.. + ((multiple-value-bind) + (eval-m-v-bind form env)) ((multiple-value-prog1) (multiple-value-prog1 (eval-form (cadr form) env) (eval-progn (cddr form) env))) @@ -139,18 +140,6 @@ (apply f a0 a1 evaluated-args))) f env a0 a1 form)))))) -(defun eval-time (form env) - "Supposed to be the time macro." - (cond - ((cpu-featurep :tsc) - (time (eval-form form env))) - (t (let ((start-mem (malloc-cons-pointer))) - (multiple-value-prog1 - (eval-form form env) - (let ((clumps (- (malloc-cons-pointer) start-mem))) - (format t ";; Space used: ~D clumps = ~/muerte:pprint-clumps/.~%" - clumps clumps))))))) - (defun parse-declarations-and-body (forms) "From the list of FORMS, return first the list of non-declaration forms, ~ second the list of declaration-specifiers." @@ -322,6 +311,15 @@ (progv special-vars special-values (eval-progn body local-env)))))) +(defun eval-m-v-bind (form env) + (destructuring-bind (variables values-form &body body) + (cdr form) + (let ((values (multiple-value-list (eval-form values-form env)))) + (dolist (variable variables) + (push (cons variable (pop values)) + env)) + (eval-progn body env)))) + (defun eval-function (function-name env) (etypecase function-name (symbol From ffjeld at common-lisp.net Sun Mar 16 22:28:19 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sun, 16 Mar 2008 17:28:19 -0500 (EST) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080316222819.CB3E7610E9@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv6804 Modified Files: more-macros.lisp Log Message: Working on making macros work. --- /project/movitz/cvsroot/movitz/losp/muerte/more-macros.lisp 2008/03/15 20:58:06 1.40 +++ /project/movitz/cvsroot/movitz/losp/muerte/more-macros.lisp 2008/03/16 22:28:18 1.41 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Jun 7 15:05:57 2002 ;;;; -;;;; $Id: more-macros.lisp,v 1.40 2008/03/15 20:58:06 ffjeld Exp $ +;;;; $Id: more-macros.lisp,v 1.41 2008/03/16 22:28:18 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -255,13 +255,13 @@ (push supplied-var bindings)) (push (list key-var `(let ((x (d-bind-lookup-key ',key-name ,var))) - ,@(when supplied-var - `((setf ,supplied-var (if x t nil)))) + ,@(when supplied-var + `((setf ,supplied-var (if x t nil)))) ,(if (not init-form) '(car x) - (if x - (car x) - ,init-form)))) + `(if x + (car x) + ,init-form)))) bindings) (gen-keyvars var sub-lambda-list (cons key-name keys))))))) (gen-lambda-list (caar bindings) @@ -300,20 +300,30 @@ "Each clause is ( ). Execute with alternative fdefinitions for each . Note that this scheme does not work well with respect to multiple threads." - (let ((tmp-name-def (loop for (name def) in clauses - collect (list (gensym) name def)))) - `(let (,@(loop for (tmp name) in tmp-name-def collect `(,tmp (fdefinition ',name)))) + (let ((tmp-name-def (mapcar (lambda (clause) + (destructuring-bind (name def) + clause + (list (gensym) name def))) + clauses))) + `(let (,@(mapcar (lambda (tnd) + `(,(car tnd) (fdefinition ',(cadr tnd)))) + tmp-name-def)) (macrolet ((previous-fdefinition (&whole form name) (case name - ,@(loop for (tmp name) in tmp-name-def - collect `(,name ',tmp)) + ,@(mapcar (lambda (tnd) + `(,(car tnd) ',(cadr tnd))) + tmp-name-def) (t form)))) (unwind-protect - (progn (setf ,@(loop for (nil name def) in tmp-name-def - append `((fdefinition ',name) ,def))) - , at body) - (setf ,@(loop for (tmp name) in tmp-name-def - append `((fdefinition ',name) ,tmp)))))))) + (progn (setf ,@(mapcan (lambda (tnd) + (list `(fdefinition ',(cadr tnd)) + (caddr tnd))) + tmp-name-def)) + , at body) + (setf ,@(mapcan (lambda (tnd) + (list `(fdefinition ',(cadr tnd)) + (car tnd))) + tmp-name-def))))))) (defmacro eof-or-lose (stream eof-errorp eof-value) `(if ,eof-errorp @@ -336,12 +346,14 @@ , at forms)))))) (defmacro handler-case (expression &rest clauses) - (multiple-value-bind (normal-clauses no-error-clauses) - (loop for clause in clauses - if (eq :no-error (car clause)) - collect clause into no-error-clauses - else collect clause into normal-clauses - finally (return (values normal-clauses no-error-clauses))) + (let ((normal-clauses (mapcan (lambda (clause) + (when (not (eq :no-error (car clause))) + (list clause))) + clauses)) + (no-error-clauses (mapcan (lambda (clause) + (when (eq :no-error (car clause)) + (list clause))) + clauses))) (case (length no-error-clauses) (0 (let ((block-name (gensym "handler-case-block-")) (var-name (gensym "handler-case-var-")) @@ -383,8 +395,11 @@ (let ((instance-variable (gensym "with-accessors-instance-"))) `(let ((,instance-variable ,instance-form)) (declare (ignorable ,instance-variable)) - (symbol-macrolet ,(loop for (variable-name accessor-name) in slot-entries - collecting `(,variable-name (,accessor-name ,instance-variable))) + (symbol-macrolet ,(mapcar (lambda (slot-entry) + (destructuring-bind (variable-name accessor-name) + slot-entry + `(,variable-name (,accessor-name ,instance-variable)))) + slot-entries) , at declarations-and-forms)))) (defmacro with-slots (slot-entries instance-form &body declarations-and-forms) @@ -525,10 +540,8 @@ (define-unimplemented-macro with-open-file) (define-unimplemented-macro restart-case) -(defmacro load (filespec &key verbose print if-does-not-exist external-format) +(defmacro/cross-compilation load (filespec &key verbose print if-does-not-exist external-format) "hm..." - (assert (movitz:movitz-constantp filespec) (filespec) - "Can't load a non-constant filename: ~S" filespec) (warn "load-compile: ~S" filespec) `(funcall ',(movitz:movitz-compile-file (format nil "losp/ansi-tests/~A" filespec)))) From ffjeld at common-lisp.net Mon Mar 17 08:00:46 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Mon, 17 Mar 2008 03:00:46 -0500 (EST) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080317080046.9789E4406D@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv25010 Added Files: defmacro-bootstrap.lisp Log Message: Working on making macros work. --- /project/movitz/cvsroot/movitz/losp/muerte/defmacro-bootstrap.lisp 2008/03/17 08:00:46 NONE +++ /project/movitz/cvsroot/movitz/losp/muerte/defmacro-bootstrap.lisp 2008/03/17 08:00:46 1.1 ;;;;------------------------------------------------------------------ ;;;; ;;;; Copyright (C) 2008, Frode V. Fjeld ;;;; ;;;; Filename: defmacro-bootstrap.lisp ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; ;;;; $Id: defmacro-bootstrap.lisp,v 1.1 2008/03/17 08:00:21 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ (provide :muerte/defmacro-bootstrap) (muerte::defmacro-compile-time muerte.cl:defmacro (name lambda-list &body macro-body) (`(muerte::defmacro-compile-time ,name ,lambda-list ,macro-body))) (muerte.cl:defmacro muerte.cl:in-package (name) `(progn (eval-when (:compile-toplevel) (in-package ,(movitz::movitzify-package-name name))))) (in-package #:muerte) (defmacro defmacro/cross-compilation (name lambda-list &body body) `(progn (defmacro-compile-time ,name ,lambda-list ,body) ',name)) (defmacro defmacro (name lambda-list &body body) `(defmacro/cross-compilation ,name ,lambda-list , at body)) (defmacro defmacro/runtime (name lambda-list &body body) (multiple-value-bind (real-body declarations docstring) (movitz::parse-docstring-declarations-and-body body 'cl:declare) (let* ((block-name (compute-function-block-name name)) (ignore-var (gensym)) (form-var (gensym "form-")) (env-var nil) (operator-var (gensym)) (destructuring-lambda-list (do ((l lambda-list) (r nil)) ((atom l) (cons operator-var (nreconc r l))) (let ((x (pop l))) (if (eq x '&environment) (setf env-var (pop l)) (push x r)))))) (multiple-value-bind (env-var ignore-env) (if env-var (values env-var nil) (let ((e (gensym))) (values e (list e)))) `(make-named-function ,name (&edx edx &optional ,form-var ,env-var &rest ,ignore-var) ((ignore ,ignore-var , at ignore-env)) ,docstring (block ,block-name (verify-macroexpand-call edx ',name) (destructuring-bind ,destructuring-lambda-list ,form-var (declare (ignore ,operator-var) , at declarations) , at real-body)) :type :macro-function))))) From ffjeld at common-lisp.net Mon Mar 17 08:01:07 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Mon, 17 Mar 2008 03:01:07 -0500 (EST) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080317080107.35738751B2@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv25217 Added Files: defmacro-runtime.lisp Log Message: Working on making macros work. --- /project/movitz/cvsroot/movitz/losp/muerte/defmacro-runtime.lisp 2008/03/17 08:01:07 NONE +++ /project/movitz/cvsroot/movitz/losp/muerte/defmacro-runtime.lisp 2008/03/17 08:01:07 1.1 ;;;;------------------------------------------------------------------ ;;;; ;;;; Copyright (C) 2008, Frode V. Fjeld ;;;; ;;;; Filename: defmacro-runtime.lisp ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; ;;;; $Id: defmacro-runtime.lisp,v 1.1 2008/03/17 08:01:03 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ (in-package #:muerte) (provide :muerte/defmacro-runtime) (defmacro defmacro (name lambda-list &body macro-body) (warn "rmacro: ~S" name) `(progn (defmacro/runtime ,name ,lambda-list , at macro-body) (defmacro-compile-time ,name ,lambda-list ,macro-body) ',name)) From ffjeld at common-lisp.net Mon Mar 17 17:24:43 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Mon, 17 Mar 2008 12:24:43 -0500 (EST) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080317172443.4430672094@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv17019 Modified Files: arithmetic-macros.lisp Log Message: Make (in principle) all macros compiled into run-time. There are notable exceptions still, which need to be worked on. --- /project/movitz/cvsroot/movitz/losp/muerte/arithmetic-macros.lisp 2007/11/19 20:39:52 1.20 +++ /project/movitz/cvsroot/movitz/losp/muerte/arithmetic-macros.lisp 2008/03/17 17:24:42 1.21 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Sat Jul 17 13:42:46 2004 ;;;; -;;;; $Id: arithmetic-macros.lisp,v 1.20 2007/11/19 20:39:52 ffjeld Exp $ +;;;; $Id: arithmetic-macros.lisp,v 1.21 2008/03/17 17:24:42 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -24,9 +24,12 @@ (defmacro number-double-dispatch ((x y) &rest clauses) `(let ((x ,x) (y ,y)) - (cond ,@(loop for ((x-type y-type) . then-body) in clauses - collect `((and (typep x ',x-type) (typep y ',y-type)) - , at then-body)) + (cond ,@(mapcar (lambda (clause) + (destructuring-bind ((x-type y-type) . then-body) + clause + `((and (typep x ',x-type) (typep y ',y-type)) + , at then-body))) + clauses) (t (error "Not numbers or not implemented: ~S or ~S." x y))))) @@ -517,7 +520,7 @@ ;;; -(defmacro define-number-relational (name 2op-name condition &key (defun-p t) 3op-name) +(defmacro/cross-compilation define-number-relational (name 2op-name condition &key (defun-p t) 3op-name) `(progn ,(when condition `(define-compiler-macro ,2op-name (n1 n2 &environment env) From ffjeld at common-lisp.net Mon Mar 17 17:24:50 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Mon, 17 Mar 2008 12:24:50 -0500 (EST) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080317172450.C632672135@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv17049 Modified Files: basic-macros.lisp Log Message: Make (in principle) all macros compiled into run-time. There are notable exceptions still, which need to be worked on. --- /project/movitz/cvsroot/movitz/losp/muerte/basic-macros.lisp 2008/03/16 22:28:07 1.72 +++ /project/movitz/cvsroot/movitz/losp/muerte/basic-macros.lisp 2008/03/17 17:24:45 1.73 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: basic-macros.lisp,v 1.72 2008/03/16 22:28:07 ffjeld Exp $ +;;;; $Id: basic-macros.lisp,v 1.73 2008/03/17 17:24:45 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -128,7 +128,7 @@ `(declaim (special ,name)) `(defparameter ,name ,value ,documentation))) -(defmacro define-compile-time-variable (name value) +(defmacro/cross-compilation define-compile-time-variable (name value) (let ((the-value (eval value))) `(progn (eval-when (:compile-toplevel) @@ -139,7 +139,7 @@ (eval-when (:load-toplevel :excute) (defvar ,name 'uninitialized-compile-time-variable))))) -(defmacro let* (var-list &body declarations-and-body) +(defmacro/cross-compilation let* (var-list &body declarations-and-body) (multiple-value-bind (body declarations) (movitz::parse-declarations-and-body declarations-and-body 'cl:declare) (labels ((expand (rest-vars body) @@ -185,15 +185,19 @@ (0 nil) (2 `(setq ,(first pairs) ,(second pairs))) (t (multiple-value-bind (setq-specs let-specs) - (loop for (var form) on pairs by #'cddr - as temp-var = (gensym) - collect (list temp-var form) into let-specs - collect var into setq-specs - collect temp-var into setq-specs - finally (return (values setq-specs let-specs))) - `(let ,(butlast let-specs) - (setq ,@(last pairs 2) ,@(butlast setq-specs 2))))))) - + (do (ss ls (p pairs)) + ((endp p) + (values (nreverse ss) + (nreverse ls))) + (let ((var (pop p)) + (form (pop p)) + (temp-var (gensym))) + (push (list temp-var form) ls) + (push var ss) + (push temp-var ss))) + `(let ,let-specs + (setq , at setq-specs)))))) + (defmacro return (&optional (result-form nil result-form-p)) (if result-form-p `(return-from nil ,result-form) @@ -235,7 +239,7 @@ (unless ,end-test-form (go ,loop-tag))) , at result-forms)))))) -(defmacro do* (var-specs (end-test-form &rest result-forms) &body declarations-and-body) +(defmacro/cross-compilation do* (var-specs (end-test-form &rest result-forms) &body declarations-and-body) (flet ((var-spec-let-spec (var-spec) (cond ((symbolp var-spec) @@ -300,26 +304,23 @@ (defmacro case (keyform &rest clauses) - (flet ((otherwise-clause-p (x) - (member (car x) '(t otherwise)))) - (let ((key-var (make-symbol "case-key-var"))) - `(let ((,key-var ,keyform)) - (cond - ,@(loop for clause-head on clauses - as clause = (first clause-head) - as keys = (first clause) - as forms = (rest clause) - ;; do (warn "clause: ~S, op: ~S" clause (otherwise-clause-p clause)) - if (and (endp (rest clause-head)) (otherwise-clause-p clause)) - collect (cons t forms) - else if (otherwise-clause-p clause) - do (error "Case's otherwise clause must be the last clause.") - else if (atom keys) - collect `((eql ,key-var ',keys) , at forms) - else collect `((or ,@(mapcar #'(lambda (c) - `(eql ,key-var ',c)) - keys)) - , at forms))))))) + (let ((key-var (make-symbol "case-key-var"))) + `(let ((,key-var ,keyform)) + (cond + ,@(mapcar (lambda (clause) + (destructuring-bind (keys . forms) + clause + (cond + ((or (eq keys 't) + (eq keys 'otherwise)) + `(t , at forms)) + ((atom keys) + `((eql ,key-var ',keys) , at forms)) + (t `((or ,@(mapcar (lambda (k) + `(eql ,key-var ',k)) + keys)) + , at forms))))) + clauses))))) (define-compiler-macro case (keyform &rest clauses) (case (length clauses) @@ -347,7 +348,7 @@ `(with-inline-assembly (:returns :eax) (:movl ,register-name :eax)))) -(defmacro movitz-accessor (object-form type slot-name) +(defmacro/cross-compilation movitz-accessor (object-form type slot-name) (warn "movitz-accesor deprecated.") `(with-inline-assembly (:returns :register :side-effects nil) (:compile-form (:result-mode :eax) ,object-form) @@ -356,7 +357,7 @@ (find-symbol (string slot-name) :movitz))) (:result-register)))) -(defmacro setf-movitz-accessor ((object-form type slot-name) value-form) +(defmacro/cross-compilation setf-movitz-accessor ((object-form type slot-name) value-form) (warn "setf-movitz-accesor deprecated.") `(with-inline-assembly (:returns :eax :side-effects t) (:compile-two-forms (:eax :ebx) ,value-form ,object-form) @@ -364,23 +365,23 @@ :movl :eax (:ebx ,(bt:slot-offset (find-symbol (string type) :movitz) (find-symbol (string slot-name) :movitz)))))) -(defmacro movitz-accessor-u16 (object-form type slot-name) - `(with-inline-assembly (:returns :eax) - (:compile-form (:result-mode :eax) ,object-form) - (:movzxw (:eax ,(bt:slot-offset (find-symbol (string type) :movitz) - (find-symbol (string slot-name) :movitz))) - :ecx) - (:leal ((:ecx #.movitz::+movitz-fixnum-factor+) :edi ,(- (movitz::image-nil-word movitz::*image*))) - :eax))) - -(defmacro set-movitz-accessor-u16 (object-form type slot-name value) - `(with-inline-assembly (:returns :eax) - (:compile-two-forms (:eax :ecx) ,object-form ,value) - (:shrl ,movitz::+movitz-fixnum-shift+ :ecx) - (:movw :cx (:eax ,(bt:slot-offset (find-symbol (string type) :movitz) - (find-symbol (string slot-name) :movitz)))) - (:leal ((:ecx #.movitz::+movitz-fixnum-factor+) :edi ,(- (movitz::image-nil-word movitz::*image*))) - :eax))) +;; (defmacro movitz-accessor-u16 (object-form type slot-name) +;; `(with-inline-assembly (:returns :eax) +;; (:compile-form (:result-mode :eax) ,object-form) +;; (:movzxw (:eax ,(bt:slot-offset (find-symbol (string type) :movitz) +;; (find-symbol (string slot-name) :movitz))) +;; :ecx) +;; (:leal ((:ecx #.movitz::+movitz-fixnum-factor+) :edi ,(- (movitz::image-nil-word movitz::*image*))) +;; :eax))) + +;; (defmacro set-movitz-accessor-u16 (object-form type slot-name value) +;; `(with-inline-assembly (:returns :eax) +;; (:compile-two-forms (:eax :ecx) ,object-form ,value) +;; (:shrl ,movitz::+movitz-fixnum-shift+ :ecx) +;; (:movw :cx (:eax ,(bt:slot-offset (find-symbol (string type) :movitz) +;; (find-symbol (string slot-name) :movitz)))) +;; (:leal ((:ecx #.movitz::+movitz-fixnum-factor+) :edi ,(- (movitz::image-nil-word movitz::*image*))) +;; :eax))) (define-compiler-macro movitz-type-word-size (type &environment env) (if (not (movitz:movitz-constantp type env)) @@ -476,13 +477,12 @@ `(block nil (let* ,variable-list (declare , at declarations) (tagbody , at body))))) (defmacro multiple-value-setq (vars form) - (let ((tmp-vars (loop repeat (length vars) collect (gensym)))) + (let ((tmp-vars (mapcar (lambda (v) + (declare (ignore v)) + (gensym)) + vars))) `(multiple-value-bind ,tmp-vars ,form - (setq ,@(loop for v in vars and tmp in tmp-vars collect v collect tmp))))) - -;;;(defmacro declaim (&rest declarations) -;;; (movitz::movitz-env-load-declarations declarations nil :declaim) -;;; (values)) + (setq ,@(mapcan #'list vars tmp-vars))))) (define-compiler-macro defconstant (name initial-value &optional documentation) (declare (ignore documentation)) @@ -504,7 +504,7 @@ (symbol-value movitz-name) movitz-value))) (declaim (muerte::constant-variable ,name)))) -(defmacro define-symbol-macro (symbol expansion) +(defmacro/cross-compilation define-symbol-macro (symbol expansion) (check-type symbol symbol "a symbol-macro symbol") `(progn (eval-when (:compile-toplevel) @@ -672,7 +672,7 @@ (t form))) -(defmacro with-unbound-protect (x &body error-continuation &environment env) +(defmacro/cross-compilation with-unbound-protect (x &body error-continuation &environment env) (cond ((movitz:movitz-constantp x env) `(values ,x)) @@ -877,7 +877,7 @@ (defmacro lambda (&whole form) `(function ,form)) -(defmacro backquote (form) +(defmacro/cross-compilation backquote (form) (typecase form (list (if (eq 'backquote-comma (car form)) @@ -937,7 +937,7 @@ (:andl #x7 :ecx) (:call (:edi (:ecx 4) ,(movitz::global-constant-offset 'fast-class-of))))) -(defmacro std-instance-reader (slot instance-form) +(defmacro/cross-compilation std-instance-reader (slot instance-form) (let ((slot (intern (symbol-name slot) :movitz))) `(with-inline-assembly-case () (do-case (:ecx) @@ -953,7 +953,7 @@ :movl ((:result-register) ,(bt:slot-offset 'movitz::movitz-std-instance slot)) (:result-register)))))) -(defmacro std-instance-writer (slot value instance-form) +(defmacro/cross-compilation std-instance-writer (slot value instance-form) (let ((slot (intern (symbol-name slot) :movitz))) `(with-inline-assembly-case () (do-case (t :eax) @@ -1016,17 +1016,17 @@ (defmacro spin-wait-pause ()) -(defmacro capture-reg8 (reg) - `(with-inline-assembly (:returns :eax) - (:movzxb ,reg :eax) - (:shll ,movitz::+movitz-fixnum-shift+ :eax))) +;; (defmacro capture-reg8 (reg) +;; `(with-inline-assembly (:returns :eax) +;; (:movzxb ,reg :eax) +;; (:shll ,movitz::+movitz-fixnum-shift+ :eax))) -(defmacro asm (&rest prg) +(define-compiler-macro asm (&rest prg) "Insert a single assembly instruction that returns noting." `(with-inline-assembly (:returns :nothing) ,prg)) -(defmacro asm1 (&rest prg) +(define-compiler-macro asm1 (&rest prg) "Insert a single assembly instruction that returns a value in eax." `(with-inline-assembly (:returns :eax) ,prg)) From ffjeld at common-lisp.net Mon Mar 17 17:24:52 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Mon, 17 Mar 2008 12:24:52 -0500 (EST) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080317172452.02B1371123@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv17081 Modified Files: common-lisp.lisp Log Message: Make (in principle) all macros compiled into run-time. There are notable exceptions still, which need to be worked on. --- /project/movitz/cvsroot/movitz/losp/muerte/common-lisp.lisp 2008/03/16 22:28:09 1.16 +++ /project/movitz/cvsroot/movitz/losp/muerte/common-lisp.lisp 2008/03/17 17:24:52 1.17 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:41:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: common-lisp.lisp,v 1.16 2008/03/16 22:28:09 ffjeld Exp $ +;;;; $Id: common-lisp.lisp,v 1.17 2008/03/17 17:24:52 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -20,8 +20,9 @@ (require :muerte/arithmetic-macros) (require :muerte/defmacro-runtime) -;; (include :muerte/basic-macros) +(include :muerte/basic-macros) (include :muerte/more-macros) +(include :muerte/arithmetic-macros) (require :muerte/memref) (require :muerte/integers) From ffjeld at common-lisp.net Mon Mar 17 23:23:30 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Mon, 17 Mar 2008 18:23:30 -0500 (EST) Subject: [movitz-cvs] CVS movitz Message-ID: <20080317232330.65CB64E035@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv27133 Modified Files: compiler.lisp Log Message: Fix accounting of function-bindings, for (flet ((foo ...)) .. (lambda () (foo ..))). --- /project/movitz/cvsroot/movitz/compiler.lisp 2008/03/16 22:27:54 1.196 +++ /project/movitz/cvsroot/movitz/compiler.lisp 2008/03/17 23:23:30 1.197 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.196 2008/03/16 22:27:54 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.197 2008/03/17 23:23:30 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -613,14 +613,19 @@ (labels ((process-binding (funobj binding usages) (cond ((typep binding 'constant-object-binding)) + ((and (typep binding 'function-binding) + (equal usages '(:call))) + (pushnew :call (getf (sub-function-binding-usage (function-binding-parent binding)) + binding)) + (pushnew :call (getf function-binding-usage binding))) ((not (eq funobj (binding-funobj binding))) (let ((borrowing-binding (or (find binding (borrowed-bindings funobj) - :key #'borrowed-binding-target) + :key #'borrowed-binding-target) (car (push (movitz-env-add-binding (funobj-env funobj) (make-instance 'borrowed-binding - :name (binding-name binding) - :target-binding binding)) + :name (binding-name binding) + :target-binding binding)) (borrowed-bindings funobj)))))) ;; We don't want to borrow a forwarding-binding.. (when (typep (borrowed-binding-target borrowing-binding) @@ -2521,7 +2526,7 @@ (incf (getf constants funobj 0)))) (closure-binding) (function-binding - (error "No function-binding now..: ~S" binding)))) + (warn "No function-binding now..: ~S" binding)))) (process (sub-code) "This local function side-effects the variables jumper-sets and constants." (loop for instruction in sub-code @@ -3785,8 +3790,9 @@ (mapcar #'movitz-funobj-extent (mapcar #'binding-funobj (getf (binding-lending lended-binding) :lended-to)))) - (append (make-load-lexical lended-binding :eax funobj t frame-map) - (unless (or (typep lended-binding 'borrowed-binding) + (when (typep lended-binding 'funobj-binding) + (break "Lending ~S ?" lended-binding)) + (append (unless (or (typep lended-binding 'borrowed-binding) (getf (binding-lending lended-binding) :dynamic-extent-p) (every (lambda (borrower) (member (movitz-funobj-extent (binding-funobj borrower)) From ffjeld at common-lisp.net Mon Mar 17 23:24:44 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Mon, 17 Mar 2008 18:24:44 -0500 (EST) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080317232444.5DA2C5301A@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv27744 Modified Files: basic-macros.lisp Log Message: Add run-time macro do. --- /project/movitz/cvsroot/movitz/losp/muerte/basic-macros.lisp 2008/03/17 17:24:45 1.73 +++ /project/movitz/cvsroot/movitz/losp/muerte/basic-macros.lisp 2008/03/17 23:24:44 1.74 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: basic-macros.lisp,v 1.73 2008/03/17 17:24:45 ffjeld Exp $ +;;;; $Id: basic-macros.lisp,v 1.74 2008/03/17 23:24:44 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -203,6 +203,42 @@ `(return-from nil ,result-form) `(return-from nil))) +(defmacro do (var-specs (end-test-form &rest result-forms) &body declarations-and-body) + (flet ((var-spec-let-spec (var-spec) + (cond + ((symbolp var-spec) + var-spec) + ((cddr var-spec) + (subseq var-spec 0 2)) + (t var-spec))) + (var-spec-var (spec) + (if (symbolp spec) spec (car spec))) + (var-spec-step-form (var-spec) + (and (listp var-spec) + (= 3 (list-length var-spec)) + (or (third var-spec) + '(quote nil))))) + (multiple-value-bind (body declarations) + (parse-declarations-and-body declarations-and-body) + (let* ((loop-tag (gensym "do-loop")) + (start-tag (gensym "do-start"))) + `(block nil + (let ,(mapcar #'var-spec-let-spec var-specs) + (declare , at declarations) + (tagbody + (go ,start-tag) + ,loop-tag + , at body + (psetq ,@(mapcan (lambda (var-spec) + (let ((step-form (var-spec-step-form var-spec))) + (when step-form + (list (var-spec-var var-spec) + step-form)))) + var-specs)) + ,start-tag + (unless ,end-test-form (go ,loop-tag))) + , at result-forms)))))) + (define-compiler-macro do (var-specs (end-test-form &rest result-forms) &body declarations-and-body) (flet ((var-spec-let-spec (var-spec) (cond @@ -219,16 +255,16 @@ (or (third var-spec) '(quote nil))))) (multiple-value-bind (body declarations) - (movitz::parse-declarations-and-body declarations-and-body 'cl:declare) + (parse-declarations-and-body declarations-and-body 'cl:declare) (let* ((loop-tag (gensym "do-loop")) (start-tag (gensym "do-start"))) `(block nil (let ,(mapcar #'var-spec-let-spec var-specs) (declare , at declarations (loop-tag ,loop-tag)) (tagbody - ,(unless (and (movitz:movitz-constantp end-test-form) - (not (movitz::movitz-eval end-test-form))) - `(go ,start-tag)) + ,(unless (and (movitz:movitz-constantp end-test-form) + (not (movitz::movitz-eval end-test-form))) + `(go ,start-tag)) ,loop-tag , at body (psetq ,@(loop for var-spec in var-specs From ffjeld at common-lisp.net Mon Mar 17 23:25:05 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Mon, 17 Mar 2008 18:25:05 -0500 (EST) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080317232505.697957C071@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv27970 Modified Files: lists.lisp Log Message: Add trivial mapcan. --- /project/movitz/cvsroot/movitz/losp/muerte/lists.lisp 2007/03/21 20:17:48 1.22 +++ /project/movitz/cvsroot/movitz/losp/muerte/lists.lisp 2008/03/17 23:25:05 1.23 @@ -9,7 +9,7 @@ ;;;; Created at: Tue Dec 5 18:40:11 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: lists.lisp,v 1.22 2007/03/21 20:17:48 ffjeld Exp $ +;;;; $Id: lists.lisp,v 1.23 2008/03/17 23:25:05 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -312,6 +312,18 @@ result))) (t (error "mapcar not fully implemented.")))) + +(defun mapcan (function first-list &rest more-lists) + (declare (dynamic-extent more-lists)) + (cond + ((null more-lists) + ;; 1 list + (do ((result nil) + (p first-list (cdr p))) + ((endp p) result) + (setf result (nconc result (funcall function (car p)))))) + (t (error "~S not implemented." 'mapcan)))) + (defun mapc (function first-list &rest more-lists) (numargs-case (2 (function first-list) From ffjeld at common-lisp.net Mon Mar 17 23:25:26 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Mon, 17 Mar 2008 18:25:26 -0500 (EST) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080317232526.331E34083@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv28118 Modified Files: eval.lisp Log Message: Pass on env when eval macro-forms. --- /project/movitz/cvsroot/movitz/losp/muerte/eval.lisp 2008/03/16 22:28:12 1.20 +++ /project/movitz/cvsroot/movitz/losp/muerte/eval.lisp 2008/03/17 23:25:26 1.21 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Oct 19 21:15:12 2001 ;;;; -;;;; $Id: eval.lisp,v 1.20 2008/03/16 22:28:12 ffjeld Exp $ +;;;; $Id: eval.lisp,v 1.21 2008/03/17 23:25:26 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -72,7 +72,7 @@ (let ((macro-function (macro-function (car form)))) (if macro-function (eval-form (funcall macro-function form nil) - nil) + env) (case (car form) (quote (cadr form)) (function (eval-function (second form) env)) From ffjeld at common-lisp.net Tue Mar 18 16:24:30 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Tue, 18 Mar 2008 11:24:30 -0500 (EST) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080318162430.82CA1610B4@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv32093 Modified Files: eval.lisp Log Message: Add support for BLOCK in eval. --- /project/movitz/cvsroot/movitz/losp/muerte/eval.lisp 2008/03/17 23:25:26 1.21 +++ /project/movitz/cvsroot/movitz/losp/muerte/eval.lisp 2008/03/18 16:24:30 1.22 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Oct 19 21:15:12 2001 ;;;; -;;;; $Id: eval.lisp,v 1.21 2008/03/17 23:25:26 ffjeld Exp $ +;;;; $Id: eval.lisp,v 1.22 2008/03/18 16:24:30 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -45,6 +45,7 @@ ;; named by integers. (defconstant +eval-binding-type-flet+ 0) (defconstant +eval-binding-type-go-tag+ 1) +(defconstant +eval-binding-type-block+ 2) (defun eval-symbol (form env) "3.1.2.1.1 Symbols as Forms" @@ -76,10 +77,6 @@ (case (car form) (quote (cadr form)) (function (eval-function (second form) env)) - (when (when (eval-form (second form) env) - (eval-progn (cddr form) env))) - (unless (unless (eval-form (second form) env) - (eval-progn (cddr form) env))) (if (if (eval-form (second form) env) (eval-form (third form) env) (eval-form (fourth form) env))) @@ -87,6 +84,18 @@ (prog1 (prog1 (eval-form (cadr form) env) (eval-progn (cddr form) env))) (tagbody (eval-tagbody form env)) + ((block) + (catch form + (eval-progn (cddr form) + (cons (list* +eval-binding-type-block+ + (cadr form) + form) + env)))) + ((return-from) + (let ((b (op-env-binding +eval-binding-type-block+ env (cadr form)))) + (unless b (error "Block ~S is not visible." (cadr form))) + (throw (cdr b) + (eval-form (caddr form) env)))) (go (eval-go form env)) (setq (eval-setq form env)) (setf (eval-setf form env)) @@ -111,7 +120,8 @@ (throw (eval-form (second form) env) (eval-form (third form) env))) ((unwind-protect) - (unwind-protect (eval-form (second form) env) + (unwind-protect + (eval-form (second form) env) (eval-progn (cddr form) env))) ((macrolet symbol-macrolet) (error "Special operator ~S not implemented in ~S." (car form) 'eval)) From ffjeld at common-lisp.net Tue Mar 18 16:24:49 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Tue, 18 Mar 2008 11:24:49 -0500 (EST) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080318162449.7F6384E035@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv32184 Modified Files: lists.lisp Log Message: Improve mapcar and mapcan. --- /project/movitz/cvsroot/movitz/losp/muerte/lists.lisp 2008/03/17 23:25:05 1.23 +++ /project/movitz/cvsroot/movitz/losp/muerte/lists.lisp 2008/03/18 16:24:49 1.24 @@ -9,7 +9,7 @@ ;;;; Created at: Tue Dec 5 18:40:11 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: lists.lisp,v 1.23 2008/03/17 23:25:05 ffjeld Exp $ +;;;; $Id: lists.lisp,v 1.24 2008/03/18 16:24:49 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -284,45 +284,73 @@ (return (values (car p) (cadr p) p))))) (defun mapcar (function first-list &rest more-lists) - (declare (dynamic-extent more-lists)) - (cond - ((null more-lists) - ;; 1 list - (do ((result nil) - (p first-list (cdr p))) - ((endp p) (nreverse result)) - (push (funcall function (car p)) - result))) - ((null (cdr more-lists)) - ;; two lists - (do ((result nil) - (p1 first-list (cdr p1)) - (p2 (car more-lists) (cdr p2))) - ((or (endp p1) (endp p2)) (nreverse result)) - (push (funcall function (car p1) (car p2)) - result))) - ((null (cddr more-lists)) - ;; three lists - (do ((result nil) - (p1 first-list (cdr p1)) - (p2 (car more-lists) (cdr p2)) - (p3 (cadr more-lists) (cdr p2))) - ((or (endp p1) (endp p2) (endp p3)) (nreverse result)) - (push (funcall function (car p1) (car p2) (car p3)) - result))) - (t (error "mapcar not fully implemented.")))) + (numargs-case + (2 (function first-list) + (do ((result nil) + (p first-list (cdr p))) + ((endp p) + (nreverse result)) + (push (funcall function (car p)) + result))) + (3 (function first-list second-list) + (do ((result nil) + (p1 first-list (cdr p1)) + (p2 second-list (cdr p2))) + ((or (endp p1) (endp p2)) + (nreverse result)) + (push (funcall function (car p1) (car p2)) + result))) + (t (function first-list &rest more-lists) + (declare (dynamic-extent more-lists)) + (do ((result nil)) + ((or (endp first-list) + (some #'endp more-lists)) + (nreverse result)) + (push (apply function (pop first-list) (mapcar #'car more-lists)) + result) + (setf more-lists + (map-into more-lists #'cdr more-lists)))))) (defun mapcan (function first-list &rest more-lists) - (declare (dynamic-extent more-lists)) - (cond - ((null more-lists) - ;; 1 list - (do ((result nil) - (p first-list (cdr p))) - ((endp p) result) - (setf result (nconc result (funcall function (car p)))))) - (t (error "~S not implemented." 'mapcan)))) + (numargs-case + (2 (function first-list) + (do ((result nil) + (tail nil) + (p first-list (cdr p))) + ((endp p) result) + (let ((m (funcall function (car p)))) + (if tail + (setf (cdr tail) m) + (setf result m)) + (setf tail (last m))))) + (3 (function first-list second-list) + (do ((result nil) + (tail nil) + (p first-list (cdr p)) + (q second-list (cdr q))) + ((or (endp p) + (endp q)) + result) + (let ((m (funcall function (car p) (car q)))) + (if tail + (setf (cdr tail) m) + (setf result m)) + (setf tail (last m))))) + (t (function first-list &rest more-lists) + (declare (dynamic-extent more-lists)) + (do ((result nil) + (tail nil)) + ((or (endp first-list) + (some #'endp more-lists)) + result) + (let ((m (apply function (pop first-list) (mapcar #'car more-lists)))) + (if tail + (setf (cdr tail) m) + (setf result m)) + (setf tail (last m))) + (setf more-lists + (map-into more-lists #'cdr more-lists)))))) (defun mapc (function first-list &rest more-lists) (numargs-case From ffjeld at common-lisp.net Wed Mar 19 12:37:24 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Wed, 19 Mar 2008 07:37:24 -0500 (EST) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080319123724.24ECA3203F@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv19458 Modified Files: eval.lisp Log Message: Add macroexpand, macroexpand-1, and *macroexpand-hook*. --- /project/movitz/cvsroot/movitz/losp/muerte/eval.lisp 2008/03/18 16:24:30 1.22 +++ /project/movitz/cvsroot/movitz/losp/muerte/eval.lisp 2008/03/19 12:37:22 1.23 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Oct 19 21:15:12 2001 ;;;; -;;;; $Id: eval.lisp,v 1.22 2008/03/18 16:24:30 ffjeld Exp $ +;;;; $Id: eval.lisp,v 1.23 2008/03/19 12:37:22 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -25,11 +25,15 @@ (defun eval-form (form env) "3.1.2.1 Form Evaluation." (check-stack-limit) - (typecase form - (null nil) - (symbol (eval-symbol form env)) - (cons (eval-cons form env)) - (t form))) + (multiple-value-bind (macro-expansion expanded-p) + (macroexpand form env) + (if expanded-p + (eval-form macro-expansion env) + (typecase form + (null nil) + (symbol (eval-symbol form env)) + (cons (eval-cons form env)) + (t form))))) (defun env-binding (env var) ;; (warn "env: ~S in ~S" var env) @@ -70,62 +74,58 @@ (defun eval-cons (form env) "3.1.2.1.2 Conses as Forms" - (let ((macro-function (macro-function (car form)))) - (if macro-function - (eval-form (funcall macro-function form nil) - env) - (case (car form) - (quote (cadr form)) - (function (eval-function (second form) env)) - (if (if (eval-form (second form) env) - (eval-form (third form) env) - (eval-form (fourth form) env))) - (progn (eval-progn (cdr form) env)) - (prog1 (prog1 (eval-form (cadr form) env) - (eval-progn (cddr form) env))) - (tagbody (eval-tagbody form env)) - ((block) - (catch form - (eval-progn (cddr form) - (cons (list* +eval-binding-type-block+ - (cadr form) - form) - env)))) - ((return-from) - (let ((b (op-env-binding +eval-binding-type-block+ env (cadr form)))) - (unless b (error "Block ~S is not visible." (cadr form))) - (throw (cdr b) - (eval-form (caddr form) env)))) - (go (eval-go form env)) - (setq (eval-setq form env)) - (setf (eval-setf form env)) - ((defvar) (eval-defvar form env)) - (let (eval-let (cadr form) (cddr form) env)) - ((defun) (eval-defun (cadr form) (caddr form) (cdddr form) env)) - ((lambda) (eval-function form env)) ; the lambda macro.. - ((multiple-value-bind) - (eval-m-v-bind form env)) - ((multiple-value-prog1) - (multiple-value-prog1 (eval-form (cadr form) env) - (eval-progn (cddr form) env))) - ((destructuring-bind) - (eval-progn (cdddr form) - (make-destructuring-env (cadr form) - (eval-form (caddr form) env) - env))) - ((catch) - (catch (eval-form (second form) env) - (eval-progn (cddr form) env))) - ((throw) - (throw (eval-form (second form) env) - (eval-form (third form) env))) - ((unwind-protect) - (unwind-protect - (eval-form (second form) env) + (case (car form) + (quote (cadr form)) + (function (eval-function (second form) env)) + (if (if (eval-form (second form) env) + (eval-form (third form) env) + (eval-form (fourth form) env))) + (progn (eval-progn (cdr form) env)) + (prog1 (prog1 (eval-form (cadr form) env) (eval-progn (cddr form) env))) - ((macrolet symbol-macrolet) - (error "Special operator ~S not implemented in ~S." (car form) 'eval)) - (t (eval-funcall form env)))))) + (tagbody (eval-tagbody form env)) + ((block) + (catch form + (eval-progn (cddr form) + (cons (list* +eval-binding-type-block+ + (cadr form) + form) + env)))) + ((return-from) + (let ((b (op-env-binding +eval-binding-type-block+ env (cadr form)))) + (unless b (error "Block ~S is not visible." (cadr form))) + (throw (cdr b) + (eval-form (caddr form) env)))) + (go (eval-go form env)) + (setq (eval-setq form env)) + (setf (eval-setf form env)) + ((defvar) (eval-defvar form env)) + (let (eval-let (cadr form) (cddr form) env)) + ((defun) (eval-defun (cadr form) (caddr form) (cdddr form) env)) + ((lambda) (eval-function form env)) ; the lambda macro.. + ((multiple-value-bind) + (eval-m-v-bind form env)) + ((multiple-value-prog1) + (multiple-value-prog1 (eval-form (cadr form) env) + (eval-progn (cddr form) env))) + ((destructuring-bind) + (eval-progn (cdddr form) + (make-destructuring-env (cadr form) + (eval-form (caddr form) env) + env))) + ((catch) + (catch (eval-form (second form) env) + (eval-progn (cddr form) env))) + ((throw) + (throw (eval-form (second form) env) + (eval-form (third form) env))) + ((unwind-protect) + (unwind-protect + (eval-form (second form) env) + (eval-progn (cddr form) env))) + ((macrolet symbol-macrolet) + (error "Special operator ~S not implemented in ~S." (car form) 'eval)) + (t (eval-funcall form env)))) (defun eval-progn (forms env) (do ((p forms (cdr p))) @@ -453,6 +453,24 @@ (setf (symbol-function name) function)) t nil))) +(defun macroexpand-1 (form &optional env) + (if (atom form) + (values form nil) + (let ((macro-function (macro-function (car form)))) + (if macro-function + (values (funcall *macroexpand-hook* macro-function form env) + t) + (values form + nil))))) + +(defun macroexpand (form &optional env) + (do ((expanded-at-all-p nil)) (nil) + (multiple-value-bind (expansion expanded-p) + (macroexpand-1 form env) + (when (not expanded-p) + (return (values expansion expanded-at-all-p))) + (setf form expansion + expanded-at-all-p t)))) (defun proclaim (declaration) ;; What do do? From ffjeld at common-lisp.net Wed Mar 19 12:37:30 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Wed, 19 Mar 2008 07:37:30 -0500 (EST) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080319123730.2691344070@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv19487 Modified Files: variables.lisp Log Message: Add macroexpand, macroexpand-1, and *macroexpand-hook*. --- /project/movitz/cvsroot/movitz/losp/muerte/variables.lisp 2006/04/10 11:58:27 1.10 +++ /project/movitz/cvsroot/movitz/losp/muerte/variables.lisp 2008/03/19 12:37:29 1.11 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Nov 5 21:53:34 2003 ;;;; -;;;; $Id: variables.lisp,v 1.10 2006/04/10 11:58:27 ffjeld Exp $ +;;;; $Id: variables.lisp,v 1.11 2008/03/19 12:37:29 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -37,6 +37,7 @@ (defvar *read-base* 10) (defvar *package* nil) +(defvar *macroexpand-hook* 'funcall) (defparameter *debugger-hook* nil) (defvar *active-condition-handlers* nil) (defvar *multiboot-data* nil) From ffjeld at common-lisp.net Wed Mar 19 15:00:13 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Wed, 19 Mar 2008 10:00:13 -0500 (EST) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080319150013.6B76615071@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv29610 Modified Files: defmacro-runtime.lisp Log Message: Remove noise. --- /project/movitz/cvsroot/movitz/losp/muerte/defmacro-runtime.lisp 2008/03/17 08:01:03 1.1 +++ /project/movitz/cvsroot/movitz/losp/muerte/defmacro-runtime.lisp 2008/03/19 15:00:13 1.2 @@ -7,7 +7,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: defmacro-runtime.lisp,v 1.1 2008/03/17 08:01:03 ffjeld Exp $ +;;;; $Id: defmacro-runtime.lisp,v 1.2 2008/03/19 15:00:13 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -16,7 +16,6 @@ (provide :muerte/defmacro-runtime) (defmacro defmacro (name lambda-list &body macro-body) - (warn "rmacro: ~S" name) `(progn (defmacro/runtime ,name ,lambda-list , at macro-body) (defmacro-compile-time ,name ,lambda-list ,macro-body) From ffjeld at common-lisp.net Wed Mar 19 15:00:32 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Wed, 19 Mar 2008 10:00:32 -0500 (EST) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080319150032.0F6A94908D@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv30223 Modified Files: eval.lisp Log Message: No let* yet. --- /project/movitz/cvsroot/movitz/losp/muerte/eval.lisp 2008/03/19 12:37:22 1.23 +++ /project/movitz/cvsroot/movitz/losp/muerte/eval.lisp 2008/03/19 15:00:31 1.24 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Oct 19 21:15:12 2001 ;;;; -;;;; $Id: eval.lisp,v 1.23 2008/03/19 12:37:22 ffjeld Exp $ +;;;; $Id: eval.lisp,v 1.24 2008/03/19 15:00:31 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -123,7 +123,7 @@ (unwind-protect (eval-form (second form) env) (eval-progn (cddr form) env))) - ((macrolet symbol-macrolet) + ((macrolet symbol-macrolet let*) (error "Special operator ~S not implemented in ~S." (car form) 'eval)) (t (eval-funcall form env)))) From ffjeld at common-lisp.net Wed Mar 19 15:06:11 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Wed, 19 Mar 2008 10:06:11 -0500 (EST) Subject: [movitz-cvs] CVS movitz Message-ID: <20080319150611.4149E4908D@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv32262 Modified Files: compiler.lisp Log Message: Fix (again) the borrowing/lending of function-bindings. The compiler would get confused when local functions called eachother. --- /project/movitz/cvsroot/movitz/compiler.lisp 2008/03/17 23:23:30 1.197 +++ /project/movitz/cvsroot/movitz/compiler.lisp 2008/03/19 15:06:10 1.198 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.197 2008/03/17 23:23:30 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.198 2008/03/19 15:06:10 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -611,13 +611,14 @@ (check-type toplevel-funobj movitz-funobj) (let ((function-binding-usage ())) (labels ((process-binding (funobj binding usages) + (when (typep binding 'function-binding) + (dolist (usage usages) + (pushnew usage + (getf (sub-function-binding-usage (function-binding-parent binding)) + binding)) + (pushnew usage (getf function-binding-usage binding)))) (cond ((typep binding 'constant-object-binding)) - ((and (typep binding 'function-binding) - (equal usages '(:call))) - (pushnew :call (getf (sub-function-binding-usage (function-binding-parent binding)) - binding)) - (pushnew :call (getf function-binding-usage binding))) ((not (eq funobj (binding-funobj binding))) (let ((borrowing-binding (or (find binding (borrowed-bindings funobj) @@ -643,17 +644,7 @@ (t ; Binding is local to this funobj (typecase binding (forwarding-binding - (process-binding funobj (forwarding-binding-target binding) usages) - #+ignore - (setf (forwarding-binding-target binding) - (process-binding funobj (forwarding-binding-target binding) usages))) - (function-binding - (dolist (usage usages) - (pushnew usage - (getf (sub-function-binding-usage (function-binding-parent binding)) - binding)) - (pushnew usage (getf function-binding-usage binding))) - binding) + (process-binding funobj (forwarding-binding-target binding) usages)) (t binding))))) (resolve-sub-funobj (funobj sub-funobj) (dolist (binding-we-lend (borrowed-bindings (resolve-funobj-borrowing sub-funobj))) @@ -760,6 +751,22 @@ (t (change-class function-binding 'closure-binding) (setf (movitz-funobj-extent sub-funobj) :indefinite-extent)))))) + ;; Each time we change a function-binding to funobj-binding, that binding + ;; no longer needs to be borrowed (because it doesn't share lexical bindings), + ;; and therefore should be removed from any borrowed-binding list, which in + ;; turn can cause the borrowing funobj to become a funobj-binding, and so on. + (loop for modified-p = nil + do (loop for function-binding in function-binding-usage by #'cddr + do (let ((sub-funobj (function-binding-funobj function-binding))) + (when (not (null (borrowed-bindings sub-funobj))) + (check-type function-binding closure-binding) + (when (null (setf (borrowed-bindings sub-funobj) + (delete-if (lambda (b) + (when (typep (borrowed-binding-target b) 'funobj-binding) + (setf modified-p t))) + (borrowed-bindings sub-funobj)))) + (change-class function-binding 'funobj-binding))))) + while modified-p) (loop for function-binding in function-binding-usage by #'cddr do (finalize-funobj (function-binding-funobj function-binding))) (finalize-funobj toplevel-funobj)) @@ -2526,7 +2533,7 @@ (incf (getf constants funobj 0)))) (closure-binding) (function-binding - (warn "No function-binding now..: ~S" binding)))) + (error "No function-binding now..: ~S" binding)))) (process (sub-code) "This local function side-effects the variables jumper-sets and constants." (loop for instruction in sub-code @@ -3791,8 +3798,9 @@ (mapcar #'binding-funobj (getf (binding-lending lended-binding) :lended-to)))) (when (typep lended-binding 'funobj-binding) - (break "Lending ~S ?" lended-binding)) - (append (unless (or (typep lended-binding 'borrowed-binding) + (break "Lending ~S from ~S: ~S" lended-binding funobj (binding-lending lended-binding))) + (append (make-load-lexical lended-binding :eax funobj t frame-map) + (unless (or (typep lended-binding 'borrowed-binding) (getf (binding-lending lended-binding) :dynamic-extent-p) (every (lambda (borrower) (member (movitz-funobj-extent (binding-funobj borrower)) @@ -3811,7 +3819,7 @@ binding (or (find binding (borrowed-bindings funobj) :key #'borrowed-binding-target) - (error "Can't install non-local binding ~W." binding))))) + (error "Can't install non-local binding ~S for ~S." binding funobj))))) (labels ((fix-edi-offset (tree) (cond ((atom tree) @@ -3896,14 +3904,15 @@ no-alignment-needed) (make-load-constant sub-funobj :eax funobj frame-map) ))) - (t (assert (not (null (borrowed-bindings sub-funobj)))) + (t (assert (not (null (borrowed-bindings sub-funobj))) () + "Binding ~S with ~S borrows no nothing, which makes no sense." function-binding sub-funobj) (append (make-load-constant sub-funobj :eax funobj frame-map) `((:movl (:edi ,(global-constant-offset 'copy-funobj)) :esi) (:call (:esi ,(bt:slot-offset 'movitz-funobj 'code-vector%1op))) (:movl :eax :edx)) (make-store-lexical function-binding :eax nil funobj frame-map) (loop for bb in (borrowed-bindings sub-funobj) - append (make-lend-lexical bb :edx nil)))))) + append (make-lend-lexical bb :edx nil)))))) funobj frame-map))) (:load-lambda (destructuring-bind (function-binding register capture-env) @@ -3912,7 +3921,7 @@ (finalize-code (let* ((sub-funobj (function-binding-funobj function-binding)) (lend-code (loop for bb in (borrowed-bindings sub-funobj) - appending + appending (make-lend-lexical bb :edx nil)))) (cond ((null lend-code) From ffjeld at common-lisp.net Thu Mar 20 22:21:00 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Thu, 20 Mar 2008 17:21:00 -0500 (EST) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080320222100.9F9DE40040@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv27582 Modified Files: common-lisp.lisp Log Message: Add trivial implementations of complexes and pathnames. --- /project/movitz/cvsroot/movitz/losp/muerte/common-lisp.lisp 2008/03/17 17:24:52 1.17 +++ /project/movitz/cvsroot/movitz/losp/muerte/common-lisp.lisp 2008/03/20 22:21:00 1.18 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:41:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: common-lisp.lisp,v 1.17 2008/03/17 17:24:52 ffjeld Exp $ +;;;; $Id: common-lisp.lisp,v 1.18 2008/03/20 22:21:00 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -44,6 +44,8 @@ (require :muerte/run-time-context) (require :muerte/defstruct) (require :muerte/hash-tables) +(require :muerte/pathnames) +(require :muerte/complexes) (require :muerte/ratios) (require :muerte/packages) (require :muerte/format) From ffjeld at common-lisp.net Thu Mar 20 22:21:02 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Thu, 20 Mar 2008 17:21:02 -0500 (EST) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080320222102.0C0B640041@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv27598 Added Files: complexes.lisp Log Message: Add trivial implementations of complexes and pathnames. --- /project/movitz/cvsroot/movitz/losp/muerte/complexes.lisp 2008/03/20 22:21:02 NONE +++ /project/movitz/cvsroot/movitz/losp/muerte/complexes.lisp 2008/03/20 22:21:02 1.1 ;;;;------------------------------------------------------------------ ;;;; ;;;; Copyright (C) 2008, Frode V. Fjeld ;;;; ;;;; Description: Complex numbers ;;;; Author: Frode Vatvedt Fjeld ;;;; Distribution: See the accompanying file COPYING. ;;;; ;;;; $Id: complexes.lisp,v 1.1 2008/03/20 22:21:01 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ (require :muerte/basic-macros) (require :muerte/defstruct) (in-package muerte) (provide :muerte/complexes) (defstruct (complex (:constructor make-complex-number) (:conc-name "")) realpart imagpart) From ffjeld at common-lisp.net Thu Mar 20 22:21:06 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Thu, 20 Mar 2008 17:21:06 -0500 (EST) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080320222106.18BE440040@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv27638 Added Files: pathnames.lisp Log Message: Add trivial implementations of complexes and pathnames. --- /project/movitz/cvsroot/movitz/losp/muerte/pathnames.lisp 2008/03/20 22:21:06 NONE +++ /project/movitz/cvsroot/movitz/losp/muerte/pathnames.lisp 2008/03/20 22:21:06 1.1 ;;;;------------------------------------------------------------------ ;;;; ;;;; Copyright (C) 2008, Frode V. Fjeld ;;;; ;;;; Description: Pathnames ;;;; Author: Frode Vatvedt Fjeld ;;;; Distribution: See the accompanying file COPYING. ;;;; ;;;; $Id: pathnames.lisp,v 1.1 2008/03/20 22:21:05 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ (require :muerte/basic-macros) (require :muerte/defstruct) (in-package muerte) (provide :muerte/pathnames) (defstruct (pathname (:constructor make-pathname-object)) name) From ffjeld at common-lisp.net Thu Mar 20 22:21:31 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Thu, 20 Mar 2008 17:21:31 -0500 (EST) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080320222131.AF0181F012@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv27759 Modified Files: lists.lisp Log Message: Add maplist. Tweak copy-list. --- /project/movitz/cvsroot/movitz/losp/muerte/lists.lisp 2008/03/18 16:24:49 1.24 +++ /project/movitz/cvsroot/movitz/losp/muerte/lists.lisp 2008/03/20 22:21:31 1.25 @@ -9,7 +9,7 @@ ;;;; Created at: Tue Dec 5 18:40:11 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: lists.lisp,v 1.24 2008/03/18 16:24:49 ffjeld Exp $ +;;;; $Id: lists.lisp,v 1.25 2008/03/20 22:21:31 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -200,10 +200,12 @@ (defun copy-list (list) (if (null list) nil - (let ((new-list (cons (pop list) list))) - (do ((new-tail new-list (cdr new-tail))) - ((atom list) new-list) - (setf (cdr new-tail) (cons (pop list) list)))))) + (let* ((new-list (cons (pop list) nil)) + (new-tail new-list)) + (do () ((atom list) new-list) + (setf new-tail + (setf (cdr new-tail) + (cons (pop list) nil))))))) (defun list (&rest objects) (numargs-case @@ -390,6 +392,33 @@ (setf (car p) x))))) first-list)))) +(defun maplist (function first-list &rest more-lists) + (numargs-case + (2 (function first-list) + (do ((result nil) + (p first-list (cdr p))) + ((endp p) + (nreverse result)) + (push (funcall function p) + result))) + (3 (function first-list second-list) + (do ((result nil) + (p1 first-list (cdr p1)) + (p2 second-list (cdr p2))) + ((or (endp p1) (endp p2)) + (nreverse result)) + (push (funcall function p1 p2) + result))) + (t (function first-list &rest more-lists) + (declare (dynamic-extent more-lists)) + (do ((result nil)) + ((or (endp first-list) + (some #'endp more-lists)) + (nreverse result)) + (push (apply function first-list more-lists) + result) + (setf first-list (cdr first-list) + more-lists (map-into more-lists #'cdr more-lists)))))) (defun nbutlast (list &optional (n 1)) (let ((start-right (nthcdr n list))) From ffjeld at common-lisp.net Thu Mar 20 22:22:41 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Thu, 20 Mar 2008 17:22:41 -0500 (EST) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080320222241.2E58871141@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv27833 Modified Files: typep.lisp Log Message: Add a silly deftype float. --- /project/movitz/cvsroot/movitz/losp/muerte/typep.lisp 2008/03/15 20:58:24 1.55 +++ /project/movitz/cvsroot/movitz/losp/muerte/typep.lisp 2008/03/20 22:22:40 1.56 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 8 11:07:53 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: typep.lisp,v 1.55 2008/03/15 20:58:24 ffjeld Exp $ +;;;; $Id: typep.lisp,v 1.56 2008/03/20 22:22:40 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -698,6 +698,9 @@ (deftype bit () '(integer 0 1)) +(deftype float () + 'real) + (defun type-of (x) (class-name (class-of x))) From ffjeld at common-lisp.net Thu Mar 20 22:23:28 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Thu, 20 Mar 2008 17:23:28 -0500 (EST) Subject: [movitz-cvs] CVS movitz Message-ID: <20080320222328.DFD6771141@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv27903 Modified Files: packages.lisp Log Message: Add package muerte.cl-user. --- /project/movitz/cvsroot/movitz/packages.lisp 2008/02/25 23:34:46 1.57 +++ /project/movitz/cvsroot/movitz/packages.lisp 2008/03/20 22:23:28 1.58 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Sat Nov 15 21:39:55 2003 ;;;; -;;;; $Id: packages.lisp,v 1.57 2008/02/25 23:34:46 ffjeld Exp $ +;;;; $Id: packages.lisp,v 1.58 2008/03/20 22:23:28 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1084,6 +1084,11 @@ yes-or-no-p zerop)) +(defpackage muerte.common-lisp-user + (:nicknames muerte.cl-user) + (:use muerte.common-lisp)) + + (defpackage muerte (:use muerte.mop muerte.common-lisp) (:import-from common-lisp cl:nil) @@ -1101,6 +1106,8 @@ #:check-the #:index + #:defmacro/cross-compilation + #:*print-safely* #:*debugger-function* From ffjeld at common-lisp.net Thu Mar 20 22:24:06 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Thu, 20 Mar 2008 17:24:06 -0500 (EST) Subject: [movitz-cvs] CVS movitz Message-ID: <20080320222406.6729471141@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv27966 Modified Files: image.lisp Log Message: Add package muerte.cl-user. Add reading of complexes and pathnames. --- /project/movitz/cvsroot/movitz/image.lisp 2008/03/15 20:45:21 1.117 +++ /project/movitz/cvsroot/movitz/image.lisp 2008/03/20 22:24:06 1.118 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: image.lisp,v 1.117 2008/03/15 20:45:21 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.118 2008/03/20 22:24:06 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1201,6 +1201,8 @@ (find-package :muerte.common-lisp)))) (setf (gethash "NIL" (funcall 'muerte:package-object-external-symbols movitz-cl-package)) nil)) + (ensure-package (symbol-name :common-lisp-user) + (find-package :muerte.common-lisp-user)) (loop for symbol being the hash-key of (image-oblist *image*) as lisp-package = (symbol-package symbol) as package-name = (and lisp-package @@ -1668,6 +1670,17 @@ (movitz-read (cdr expr))))))) (hash-table (make-movitz-hash-table expr)) + (pathname + (make-instance 'movitz-struct + :class (muerte::movitz-find-class 'muerte::pathname) + :length 1 + :slot-values (list (movitz-read (namestring expr))))) + (complex + (make-instance 'movitz-struct + :class (muerte::movitz-find-class 'muerte::complex) + :length 2 + :slot-values (list (movitz-read (realpart expr)) + (movitz-read (imagpart expr))))) (ratio (make-instance 'movitz-ratio :value expr)) @@ -1687,7 +1700,10 @@ slot-descriptions)) movitz-object))) (float ; XXX - (movitz-read (rationalize expr)))))))) + (movitz-read (rationalize expr))) + (class + (muerte::movitz-find-class (translate-program (class-name expr) + :cl :muerte.cl)))))))) ;;; From ffjeld at common-lisp.net Thu Mar 20 22:24:27 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Thu, 20 Mar 2008 17:24:27 -0500 (EST) Subject: [movitz-cvs] CVS movitz Message-ID: <20080320222427.318835C182@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv28020 Modified Files: storage-types.lisp Log Message: Add update-movitz-object (movitz-std-instance). --- /project/movitz/cvsroot/movitz/storage-types.lisp 2008/03/15 20:57:06 1.60 +++ /project/movitz/cvsroot/movitz/storage-types.lisp 2008/03/20 22:24:27 1.61 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: storage-types.lisp,v 1.60 2008/03/15 20:57:06 ffjeld Exp $ +;;;; $Id: storage-types.lisp,v 1.61 2008/03/20 22:24:27 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1218,6 +1218,9 @@ :stream stream)))) object) +(defmethod update-movitz-object ((object movitz-std-instance) lisp-object) + object) + ;;;; (define-binary-class movitz-bignum (movitz-heap-object-other) From ffjeld at common-lisp.net Thu Mar 20 22:49:28 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Thu, 20 Mar 2008 17:49:28 -0500 (EST) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080320224928.6098740002@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv1296 Modified Files: eval.lisp Log Message: Add special operator let* to eval. --- /project/movitz/cvsroot/movitz/losp/muerte/eval.lisp 2008/03/19 15:00:31 1.24 +++ /project/movitz/cvsroot/movitz/losp/muerte/eval.lisp 2008/03/20 22:49:28 1.25 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Oct 19 21:15:12 2001 ;;;; -;;;; $Id: eval.lisp,v 1.24 2008/03/19 15:00:31 ffjeld Exp $ +;;;; $Id: eval.lisp,v 1.25 2008/03/20 22:49:28 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -101,6 +101,9 @@ (setf (eval-setf form env)) ((defvar) (eval-defvar form env)) (let (eval-let (cadr form) (cddr form) env)) + (let* (multiple-value-bind (body declarations) + (parse-declarations-and-body (cddr form)) + (eval-let* (cadr form) declarations body env))) ((defun) (eval-defun (cadr form) (caddr form) (cdddr form) env)) ((lambda) (eval-function form env)) ; the lambda macro.. ((multiple-value-bind) @@ -321,6 +324,30 @@ (progv special-vars special-values (eval-progn body local-env)))))) +(defun eval-let* (var-specs declarations body env) + (if (null var-specs) + (eval-progn body env) + (multiple-value-bind (var init-form) + (let ((var-spec (pop var-specs))) + (if (atom var-spec) + (values var-spec nil) + (destructuring-bind (var init-form) + var-spec + (values var init-form)))) + (if (or (symbol-special-variable-p var) + (declared-special-p var declarations)) + (progv (list var) (list (eval-form init-form env)) + (eval-let* var-specs + declarations + body + env)) + (eval-let* var-specs + declarations + body + (cons (cons var + (eval-form init-form env)) + env)))))) + (defun eval-m-v-bind (form env) (destructuring-bind (variables values-form &body body) (cdr form) From ffjeld at common-lisp.net Thu Mar 20 22:50:02 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Thu, 20 Mar 2008 17:50:02 -0500 (EST) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080320225002.3F67F3307D@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv1370 Modified Files: basic-macros.lisp Log Message: Add a runtime do* macro. --- /project/movitz/cvsroot/movitz/losp/muerte/basic-macros.lisp 2008/03/17 23:24:44 1.74 +++ /project/movitz/cvsroot/movitz/losp/muerte/basic-macros.lisp 2008/03/20 22:50:01 1.75 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: basic-macros.lisp,v 1.74 2008/03/17 23:24:44 ffjeld Exp $ +;;;; $Id: basic-macros.lisp,v 1.75 2008/03/20 22:50:01 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -275,14 +275,14 @@ (unless ,end-test-form (go ,loop-tag))) , at result-forms)))))) -(defmacro/cross-compilation do* (var-specs (end-test-form &rest result-forms) &body declarations-and-body) +(defmacro do* (var-specs (end-test-form &rest result-forms) &body declarations-and-body) (flet ((var-spec-let-spec (var-spec) (cond - ((symbolp var-spec) - var-spec) - ((cddr var-spec) - (subseq var-spec 0 2)) - (t var-spec))) + ((symbolp var-spec) + var-spec) + ((cddr var-spec) + (subseq var-spec 0 2)) + (t var-spec))) (var-spec-var (var-spec) (if (symbolp var-spec) var-spec (car var-spec))) (var-spec-step-form (var-spec) @@ -291,22 +291,24 @@ (or (third var-spec) '(quote nil))))) (multiple-value-bind (body declarations) - (movitz::parse-declarations-and-body declarations-and-body 'cl:declare) + (parse-declarations-and-body declarations-and-body) (let* ((loop-tag (gensym "do*-loop")) (start-tag (gensym "do*-start"))) `(block nil (let* ,(mapcar #'var-spec-let-spec var-specs) (declare , at declarations) (tagbody - (go ,start-tag) - ,loop-tag - , at body - (setq ,@(loop for var-spec in var-specs - as step-form = (var-spec-step-form var-spec) - when step-form - append (list (var-spec-var var-spec) step-form))) - ,start-tag - (unless ,end-test-form (go ,loop-tag))) + (go ,start-tag) + ,loop-tag + , at body + (setq ,@(mapcan (lambda (var-spec) + (let ((step-form (var-spec-step-form var-spec))) + (when step-form + (list (var-spec-var var-spec) + step-form)))) + var-specs)) + ,start-tag + (unless ,end-test-form (go ,loop-tag))) , at result-forms)))))) (define-compiler-macro do* (var-specs (end-test-form &rest result-forms) &body declarations-and-body) From ffjeld at common-lisp.net Fri Mar 21 00:06:07 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Thu, 20 Mar 2008 19:06:07 -0500 (EST) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080321000607.E79EE15020@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv16983 Modified Files: eval.lisp Log Message: Support macrolet in eval. --- /project/movitz/cvsroot/movitz/losp/muerte/eval.lisp 2008/03/20 22:49:28 1.25 +++ /project/movitz/cvsroot/movitz/losp/muerte/eval.lisp 2008/03/21 00:06:07 1.26 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Oct 19 21:15:12 2001 ;;;; -;;;; $Id: eval.lisp,v 1.25 2008/03/20 22:49:28 ffjeld Exp $ +;;;; $Id: eval.lisp,v 1.26 2008/03/21 00:06:07 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -39,24 +39,29 @@ ;; (warn "env: ~S in ~S" var env) (find var env :key #'car)) -(defun op-env-binding (type env var) +(defun op-env-binding (env var &rest types) + (declare (dynamic-extent types)) (dolist (binding env) - (when (and (eq type (car binding)) - (eq var (cadr binding))) - (return (cdr binding))))) + (when (and (consp (cdr binding)) + (eq var (cadr binding)) + (or (null types) + (member (car binding) types))) + (return binding)))) ;; These are integers because regular (lexical) bindings are never ;; named by integers. (defconstant +eval-binding-type-flet+ 0) (defconstant +eval-binding-type-go-tag+ 1) (defconstant +eval-binding-type-block+ 2) +(defconstant +eval-binding-type-macrolet+ 3) (defun eval-symbol (form env) "3.1.2.1.1 Symbols as Forms" (if (symbol-constant-variable-p form) (symbol-value form) (let ((binding (env-binding env form))) - (or (and binding (cdr binding)) + (if binding + (cdr binding) (symbol-value form))))) ;;; block let* return-from @@ -91,8 +96,20 @@ (cadr form) form) env)))) + ((macrolet) + (dolist (macrolet (cadr form)) + (destructuring-bind (name lambda &body body) + macrolet + (check-type name symbol) + (check-type lambda list) + (push (list* +eval-binding-type-macrolet+ + name + (cdr macrolet)) + env))) + (eval-progn (cddr form) + env)) ((return-from) - (let ((b (op-env-binding +eval-binding-type-block+ env (cadr form)))) + (let ((b (cdr (op-env-binding env (cadr form) +eval-binding-type-block+)))) (unless b (error "Block ~S is not visible." (cadr form))) (throw (cdr b) (eval-form (caddr form) env)))) @@ -126,7 +143,7 @@ (unwind-protect (eval-form (second form) env) (eval-progn (cddr form) env))) - ((macrolet symbol-macrolet let*) + ((symbol-macrolet let*) (error "Special operator ~S not implemented in ~S." (car form) 'eval)) (t (eval-funcall form env)))) @@ -360,7 +377,7 @@ (defun eval-function (function-name env) (etypecase function-name (symbol - (let ((binding (op-env-binding +eval-binding-type-flet+ env function-name))) + (let ((binding (cdr (op-env-binding env function-name +eval-binding-type-flet+)))) (or (and binding (cdr binding)) (symbol-function function-name)))) (list @@ -420,7 +437,7 @@ (defun eval-go (form env) (declare (ignore)) (let* ((tag (cadr form)) - (b (op-env-binding +eval-binding-type-go-tag+ env tag))) + (b (cdr (op-env-binding env tag +eval-binding-type-go-tag+)))) (unless b (error "Go-tag ~S is not visible." tag)) (throw (cdr b) (values tag)))) @@ -482,13 +499,26 @@ (defun macroexpand-1 (form &optional env) (if (atom form) - (values form nil) - (let ((macro-function (macro-function (car form)))) - (if macro-function - (values (funcall *macroexpand-hook* macro-function form env) - t) - (values form - nil))))) + (values form nil) ; no symbol-macros yet + (let* ((operator (car form)) + (macrolet-binding (op-env-binding env operator +eval-binding-type-macrolet+))) + (if macrolet-binding + (destructuring-bind (lambda-list &body body) + (cddr macrolet-binding) + (let ((expander (lambda (form env) + (eval-form `(destructuring-bind (ignore-operator , at lambda-list) + ',form + (declare (ignore ignore-operator)) + , at body) + env)))) + (values (funcall *macroexpand-hook* expander form env) + t))) + (let ((macro-function (macro-function operator))) + (if macro-function + (values (funcall *macroexpand-hook* macro-function form env) + t) + (values form + nil))))))) (defun macroexpand (form &optional env) (do ((expanded-at-all-p nil)) (nil) From ffjeld at common-lisp.net Fri Mar 21 00:20:22 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Thu, 20 Mar 2008 19:20:22 -0500 (EST) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080321002022.E0F662407B@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv19575 Modified Files: setf.lisp Log Message: Add a trivial run-time get-setf-expander. --- /project/movitz/cvsroot/movitz/losp/muerte/setf.lisp 2007/04/13 23:29:31 1.6 +++ /project/movitz/cvsroot/movitz/losp/muerte/setf.lisp 2008/03/21 00:20:22 1.7 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Thu Feb 8 20:43:20 2001 ;;;; -;;;; $Id: setf.lisp,v 1.6 2007/04/13 23:29:31 ffjeld Exp $ +;;;; $Id: setf.lisp,v 1.7 2008/03/21 00:20:22 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -60,6 +60,14 @@ `(funcall #'(setf ,(car place)) ,store-var , at arglist) (list* (car place) arglist))))))))))) +(eval-when (:load-toplevel) + (defun get-setf-expansion (place &optional env) + (cond + ((symbolp place) + (let ((store-var (gensym "store-var-"))) + (values nil nil (list store-var) `(setq ,place ,store-var) place))) + (t (error "Place ~S not implemented."))))) + ;;;(defsetf subseq (sequence start &optional end) (new-sequence) ;;; `(progn (replace ,sequence ,new-sequence From ffjeld at common-lisp.net Fri Mar 21 00:20:48 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Thu, 20 Mar 2008 19:20:48 -0500 (EST) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080321002048.85F7A24117@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv20381 Modified Files: eval.lisp Log Message: Have evaluated m-v-bind deal with declarations and special bindings. --- /project/movitz/cvsroot/movitz/losp/muerte/eval.lisp 2008/03/21 00:06:07 1.26 +++ /project/movitz/cvsroot/movitz/losp/muerte/eval.lisp 2008/03/21 00:20:48 1.27 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Oct 19 21:15:12 2001 ;;;; -;;;; $Id: eval.lisp,v 1.26 2008/03/21 00:06:07 ffjeld Exp $ +;;;; $Id: eval.lisp,v 1.27 2008/03/21 00:20:48 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -366,13 +366,25 @@ env)))))) (defun eval-m-v-bind (form env) - (destructuring-bind (variables values-form &body body) + (destructuring-bind (variables values-form &body declarations-and-body) (cdr form) - (let ((values (multiple-value-list (eval-form values-form env)))) - (dolist (variable variables) - (push (cons variable (pop values)) - env)) - (eval-progn body env)))) + (multiple-value-bind (body declarations) + (parse-declarations-and-body declarations-and-body) + (let ((values (multiple-value-list (eval-form values-form env))) + special-vars + special-values) + (dolist (var variables) + (let ((value (pop values))) + (cond + ((or (symbol-special-variable-p var) + (declared-special-p var declarations)) + ;; special + (push var special-vars) + (push value special-values)) + (t ;; lexical + (push (cons var value) + env))))) + (eval-progn body env))))) (defun eval-function (function-name env) (etypecase function-name From ffjeld at common-lisp.net Fri Mar 21 22:17:06 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Fri, 21 Mar 2008 17:17:06 -0500 (EST) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080321221706.E7A8A610B2@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv839 Modified Files: sequences.lisp Log Message: Fix dynamic-extent bug in concatenate. --- /project/movitz/cvsroot/movitz/losp/muerte/sequences.lisp 2008/03/15 20:58:17 1.38 +++ /project/movitz/cvsroot/movitz/losp/muerte/sequences.lisp 2008/03/21 22:17:06 1.39 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Sep 11 14:19:23 2001 ;;;; -;;;; $Id: sequences.lisp,v 1.38 2008/03/15 20:58:17 ffjeld Exp $ +;;;; $Id: sequences.lisp,v 1.39 2008/03/21 22:17:06 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1799,7 +1799,9 @@ (replace r s :start1 i) (incf i (length s))) r)) - (t (error "Can't concatenate ~S yet: ~:S" result-type sequences)))) + (t (error "Can't concatenate ~S yet: ~:S" + result-type + (copy-list sequences))))) ; no more dynamic-extent. (defun substitute (newitem olditem sequence From ffjeld at common-lisp.net Fri Mar 21 22:27:17 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Fri, 21 Mar 2008 17:27:17 -0500 (EST) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080321222717.D5867610B4@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv3728 Modified Files: eval.lisp Log Message: Add multiple-value-call special-operator. --- /project/movitz/cvsroot/movitz/losp/muerte/eval.lisp 2008/03/21 00:20:48 1.27 +++ /project/movitz/cvsroot/movitz/losp/muerte/eval.lisp 2008/03/21 22:27:17 1.28 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Oct 19 21:15:12 2001 ;;;; -;;;; $Id: eval.lisp,v 1.27 2008/03/21 00:20:48 ffjeld Exp $ +;;;; $Id: eval.lisp,v 1.28 2008/03/21 22:27:17 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -117,12 +117,19 @@ (setq (eval-setq form env)) (setf (eval-setf form env)) ((defvar) (eval-defvar form env)) - (let (eval-let (cadr form) (cddr form) env)) - (let* (multiple-value-bind (body declarations) - (parse-declarations-and-body (cddr form)) - (eval-let* (cadr form) declarations body env))) + ((let) + (eval-let (cadr form) (cddr form) env)) + ((let*) + (multiple-value-bind (body declarations) + (parse-declarations-and-body (cddr form)) + (eval-let* (cadr form) declarations body env))) ((defun) (eval-defun (cadr form) (caddr form) (cdddr form) env)) ((lambda) (eval-function form env)) ; the lambda macro.. + ((multiple-value-call) + (apply (eval-form (cadr form) env) + (mapcan (lambda (args-form) + (multiple-value-list (eval-form args-form env))) + (cddr form)))) ((multiple-value-bind) (eval-m-v-bind form env)) ((multiple-value-prog1) From ffjeld at common-lisp.net Fri Mar 21 22:28:26 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Fri, 21 Mar 2008 17:28:26 -0500 (EST) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080321222826.BED773F017@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv3803 Modified Files: primitive-functions.lisp Log Message: Bounds-check of the stack while unwinding can be problematic. Don't. --- /project/movitz/cvsroot/movitz/losp/muerte/primitive-functions.lisp 2008/03/15 20:58:08 1.70 +++ /project/movitz/cvsroot/movitz/losp/muerte/primitive-functions.lisp 2008/03/21 22:28:26 1.71 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Oct 2 21:02:18 2001 ;;;; -;;;; $Id: primitive-functions.lisp,v 1.70 2008/03/15 20:58:08 ffjeld Exp $ +;;;; $Id: primitive-functions.lisp,v 1.71 2008/03/21 22:28:26 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -138,7 +138,7 @@ search-loop (:jecxz '(:sub-program () (:int 63))) - (:locally (:bound (:edi (:edi-offset stack-bottom)) :ecx)) + ;; (:locally (:bound (:edi (:edi-offset stack-bottom)) :ecx)) (:cmpl :ecx :eax) (:je 'found-dynamic-env) From ffjeld at common-lisp.net Fri Mar 21 22:29:58 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Fri, 21 Mar 2008 17:29:58 -0500 (EST) Subject: [movitz-cvs] CVS movitz Message-ID: <20080321222958.079C47114F@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv3896 Modified Files: compiler.lisp Log Message: Add boolean-mode :boolean-overflow and :boolean-no-overflow. --- /project/movitz/cvsroot/movitz/compiler.lisp 2008/03/19 15:06:10 1.198 +++ /project/movitz/cvsroot/movitz/compiler.lisp 2008/03/21 22:29:57 1.199 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.198 2008/03/19 15:06:10 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.199 2008/03/21 22:29:57 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -4951,7 +4951,9 @@ (:boolean-zf=1 :boolean-zf=0) (:boolean-zf=0 :boolean-zf=1) (:boolean-cf=1 :boolean-cf=0) - (:boolean-cf=0 :boolean-cf=1))) + (:boolean-cf=0 :boolean-cf=1) + (:boolean-overflow :boolean-no-overflow) + (:boolean-no-overflow :boolean-overflow))) (cons (let ((args (cdr mode))) (ecase (car mode) @@ -4976,7 +4978,9 @@ (:boolean-zf=0 :jnz) (:boolean-cf=1 :jc) (:boolean-cf=0 :jnc) - (:boolean-true :jmp)) + (:boolean-true :jmp) + (:boolean-overflow :jo) + (:boolean-no-overflow :jno)) (list 'quote label))) From ffjeld at common-lisp.net Fri Mar 21 22:30:05 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Fri, 21 Mar 2008 17:30:05 -0500 (EST) Subject: [movitz-cvs] CVS movitz Message-ID: <20080321223005.53C5D33088@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv3954 Modified Files: compiler-protocol.lisp Log Message: Add boolean-mode :boolean-overflow and :boolean-no-overflow. --- /project/movitz/cvsroot/movitz/compiler-protocol.lisp 2005/08/20 20:30:03 1.4 +++ /project/movitz/cvsroot/movitz/compiler-protocol.lisp 2008/03/21 22:30:05 1.5 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Oct 10 13:02:03 2001 ;;;; -;;;; $Id: compiler-protocol.lisp,v 1.4 2005/08/20 20:30:03 ffjeld Exp $ +;;;; $Id: compiler-protocol.lisp,v 1.5 2008/03/21 22:30:05 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -30,7 +30,9 @@ :boolean-zf=0 :boolean-cf=1 :boolean-cf=0 - :boolean-ecx)) + :boolean-ecx + :boolean-overflow + :boolean-no-overflow)) (defconstant +multiple-value-result-modes+ '(:multiple-values From ffjeld at common-lisp.net Fri Mar 21 22:30:40 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Fri, 21 Mar 2008 17:30:40 -0500 (EST) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080321223040.C7FBB7633E@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv4096 Modified Files: variables.lisp Log Message: Less extreme call-arguments-limit. --- /project/movitz/cvsroot/movitz/losp/muerte/variables.lisp 2008/03/19 12:37:29 1.11 +++ /project/movitz/cvsroot/movitz/losp/muerte/variables.lisp 2008/03/21 22:30:40 1.12 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Nov 5 21:53:34 2003 ;;;; -;;;; $Id: variables.lisp,v 1.11 2008/03/19 12:37:29 ffjeld Exp $ +;;;; $Id: variables.lisp,v 1.12 2008/03/21 22:30:40 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -65,8 +65,8 @@ (defvar long-float-negative-epsilon -1/1000) -(defconstant call-arguments-limit #xffff0) -(defconstant lambda-parameters-limit #x1000) ; ? +(defconstant call-arguments-limit 512) +(defconstant lambda-parameters-limit 512) ; ? (defvar *print-pprint-dispatch* nil) From ffjeld at common-lisp.net Fri Mar 21 22:31:07 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Fri, 21 Mar 2008 17:31:07 -0500 (EST) Subject: [movitz-cvs] CVS movitz/losp/muerte Message-ID: <20080321223107.49172330CA@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv4249 Modified Files: print.lisp Log Message: Safe printing of unbound-value. --- /project/movitz/cvsroot/movitz/losp/muerte/print.lisp 2008/03/15 20:58:15 1.24 +++ /project/movitz/cvsroot/movitz/losp/muerte/print.lisp 2008/03/21 22:31:07 1.25 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Mon Sep 3 11:48:19 2001 ;;;; -;;;; $Id: print.lisp,v 1.24 2008/03/15 20:58:15 ffjeld Exp $ +;;;; $Id: print.lisp,v 1.25 2008/03/21 22:31:07 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -216,6 +216,8 @@ (t (let ((do-escape-p (or *print-escape* *print-readably*)) (*print-level* (minus-if *print-level* 1))) (typecase object + (unbound-value + (write-string "#" stream)) (character (if (not do-escape-p) (write-char object stream) From ffjeld at common-lisp.net Sun Mar 23 12:19:19 2008 From: ffjeld at common-lisp.net (ffjeld) Date: Sun, 23 Mar 2008 07:19:19 -0500 (EST) Subject: [movitz-cvs] CVS movitz Message-ID: <20080323121919.ADC2A6209D@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv14395 Modified Files: storage-types.lisp Log Message: Support dumping of bit-vectors. --- /project/movitz/cvsroot/movitz/storage-types.lisp 2008/03/20 22:24:27 1.61 +++ /project/movitz/cvsroot/movitz/storage-types.lisp 2008/03/23 12:19:19 1.62 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: storage-types.lisp,v 1.61 2008/03/20 22:24:27 ffjeld Exp $ +;;;; $Id: storage-types.lisp,v 1.62 2008/03/23 12:19:19 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -417,15 +417,26 @@ (:character (write-binary 'char8 stream data)) (:any-t (write-binary 'word stream (movitz-read-and-intern data 'word)))))) (+ (call-next-method) ; header - (etypecase (movitz-vector-symbolic-data obj) - (list - (loop for data in (movitz-vector-symbolic-data obj) - with type = (movitz-vector-element-type obj) - summing (write-element type stream data))) - (vector - (loop for data across (movitz-vector-symbolic-data obj) - with type = (movitz-vector-element-type obj) - summing (write-element type stream data))))))) + (multiple-value-bind (data type) + (case (movitz-vector-element-type obj) + (:bit (let ((data (movitz-vector-symbolic-data obj))) + (values (loop for byte upfrom 0 below (ceiling (length data) 8) + collect (loop for bit from 0 to 7 + sum (* (let ((b (+ (* byte 8) bit))) + (if (< b (length data)) + (bit data b) + 0)) + (expt 2 bit)))) + :u8))) + (t (values (movitz-vector-symbolic-data obj) + (movitz-vector-element-type obj)))) + (etypecase data + (list + (loop for datum in data + sum (write-element type stream datum))) + (vector + (loop for datum across data + sum (write-element type stream datum)))))))) (defmethod read-binary-record ((type-name (eql 'movitz-basic-vector)) stream &key &allow-other-keys) (let ((object (call-next-method))) @@ -452,6 +463,8 @@ (cond ((eq type 'code) (values :code 0)) + ((subtypep type 'bit) + (values :bit 0)) ((subtypep type '(unsigned-byte 8)) (values :u8 0)) ((subtypep type '(unsigned-byte 16)) @@ -502,7 +515,7 @@ (setf initial-contents (make-array size :initial-element (or (and initial-element-p initial-element) default-element)))) - (assert (member et '(:any-t :character :u8 :u32 :code))) + (assert (member et '(:any-t :bit :character :u8 :u32 :code))) (when flags (break "flags: ~S" flags)) (when (and alignment-offset (plusp alignment-offset)) (break "alignment: ~S" alignment-offset))