diff options
Diffstat (limited to 'share/txr/stdlib')
40 files changed, 0 insertions, 8967 deletions
diff --git a/share/txr/stdlib/asm.tl b/share/txr/stdlib/asm.tl deleted file mode 100644 index 8dd64ec4..00000000 --- a/share/txr/stdlib/asm.tl +++ /dev/null @@ -1,815 +0,0 @@ -;; Copyright 2018-2020 -;; Kaz Kylheku <kaz@kylheku.com> -;; Vancouver, Canada -;; All rights reserved. -;; -;; Redistribution and use in source and binary forms, with or without -;; modification, are permitted provided that the following conditions are met: -;; -;; 1. Redistributions of source code must retain the above copyright notice, this -;; list of conditions and the following disclaimer. -;; -;; 2. Redistributions in binary form must reproduce the above copyright notice, -;; this list of conditions and the following disclaimer in the documentation -;; and/or other materials provided with the distribution. -;; -;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -(load "vm-param") - -(defstruct oc-base nil - (:method synerr (me fmt . args) - (error `opcode @{me.symbol}: @fmt` . args)) - - (:method chk-arg-count (me n syntax) - (when (neq (length (rest syntax)) n) - me.(synerr "~s arguments required; ~s is invalid" - n syntax))) - - (:method chk-arg-count-min (me n syntax) - (when (< (length (rest syntax)) n) - me.(synerr "~s arguments required; ~s is invalid" - n syntax))) - - (:method backpatch (me asm at offs) - (asm-error `@{me.symbol} doesn't backpatch`))) - -(compile-only - (defstruct assembler nil - buf - bstr - (max-treg 0) - (labdef (hash)) - (labref (hash)) - (:static imm-width (relate '(si mi bi) '(10 16 32))) - (:static sign-bits (relate '(fixnum bignum chr) '(1 1 0))) - (:static operand-name (relate '(si mi bi l r rs d ds n o) - '("small immediate" - "medium immediate" - "big immediate" - "label" - "register operand" - "register small operand" - "register destination operand" - "register small destination operand" - "integer" - "any object"))))) - -(defmeth assembler :postinit (me) - (cond - (me.buf (set me.bstr (make-buf-stream me.buf))) - (me.bstr (set me.buf (get-buf-from-stream me.bstr))) - (t (set me.bstr (make-buf-stream) - me.buf (get-buf-from-stream me.bstr))))) - -(defmeth assembler cur-pos (me) - (seek-stream me.bstr 0 :from-current)) - -(defmeth assembler set-pos (me pos) - (seek-stream me.bstr pos :from-start)) - -(defmeth assembler lookup-label (me sym oc) - (condlet - (((n [me.labdef sym])) n) - (t (push (cons oc (trunc me.(cur-pos) 4)) [me.labref sym]) - 0))) - -(defmeth assembler define-label (me sym) - (let* ((pos me.(cur-pos)) - (ins (trunc pos 4))) - (set [me.labdef sym] ins) - (each ((entry (del [me.labref sym]))) - (tree-bind (oc . offs) entry - me.(set-pos (* 4 offs)) - oc.(backpatch me (* 4 offs) ins))) - me.(set-pos pos) - ins)) - -(defmeth assembler read-buf (me bytes) - (let ((buf (make-buf bytes))) - (when (neql (fill-buf buf 0 me.bstr) bytes) - (asm-error "read past instruction block")) - buf)) - -(defmeth assembler put-word (me word) - (let* ((buf (make-buf 0))) - (buf-put-u32 buf 0 word) - (put-buf buf 0 me.bstr))) - -(defmeth assembler put-insn (me code extension operand) - (let ((word (logior (ash code 26) (ash extension 16) operand)) - (buf (make-buf 0))) - (buf-put-u32 buf 0 word) - (put-buf buf 0 me.bstr))) - -(defmeth assembler put-pair (me op1 op2) - (let ((word (logior (ash op1 16) op2)) - (buf (make-buf 0))) - (buf-put-u32 buf 0 word) - (put-buf buf 0 me.bstr))) - -(defmeth assembler get-word (me) - (let* ((buf me.(read-buf (sizeof uint32)))) - (buf-get-u32 buf 0))) - -(defmeth assembler get-insn (me) - (let* ((buf me.(read-buf (sizeof uint32))) - (word (buf-get-u32 buf 0))) - (list (ash word -26) - (logtrunc (ash word -16) 10) - (logtrunc word 16)))) - -(defmeth assembler get-pair (me) - (let* ((buf me.(read-buf (sizeof uint32))) - (word (buf-get-u32 buf 0))) - (list (ash word -16) (logtrunc word 16)))) - -(defmeth assembler immediate-fits-type (me arg operand-type) - (and (member (typeof arg) - '(fixnum chr)) - (<= (+ (width arg) - [me.sign-bits (typeof arg)] - 2) - [me.imm-width operand-type]))) - -(defmeth assembler parse-args (me oc syntax pattern) - (mapcar (lambda (type arg n) - (let ((parg (caseql type - ((si mi bi) - (when me.(immediate-fits-type arg type) - arg)) - (l (cond - ((is-label arg) me.(lookup-label arg oc)) - ((integerp arg) arg))) - (n (if (integerp arg) arg)) - (o arg) - ((r rs d ds) - (cond - ((null arg) 0) - ((consp arg) - (parse-compound-operand arg)) - ((symbolp arg) - (parse-operand (symbol-name arg))))) - (t (asm-error "invalid arg type spec ~s" type))))) - (unless (or parg (eq type 'o)) - oc.(synerr "argument ~a of ~s invalid; ~a expected" - n syntax [me.operand-name type])) - (when (and (member type '(d ds)) - (or (zerop parg))) - oc.(synerr "argument ~a of ~s cannot be destination" - n syntax)) - (when (and (member type '(rs ds)) - (not (small-op-p parg))) - oc.(synerr "argument ~a of ~s isn't a small register" - n syntax)) - (when (and (member type '(r rs d ds)) (< parg %lev-size%)) - (set me.max-treg (max parg me.max-treg))) - parg)) - pattern (rest syntax) (range 1))) - -(defmeth assembler asm-one (me syntax) - (let ((oc (cond - ((is-label syntax) [%oc-hash% 'label]) - ((consp syntax) [%oc-hash% (car syntax)])))) - (unless oc - (asm-error "invalid instruction ~s" syntax)) - oc.(asm me syntax))) - -(defmeth assembler asm (me insns) - (each ((i insns)) - me.(asm-one i)) - (unless (empty me.labref) - (asm-error "dangling label references")) - (whenlet ((n (cdr [find-max me.labdef : cdr]))) - (unless (< -1 n (len me.buf)) - (asm-error "labels outside of code")))) - -(defmeth assembler dis-one (me) - (tree-bind (code extension operand) me.(get-insn) - (let ((oc [%oc-hash% code])) - oc.(dis me extension operand)))) - -(defmeth assembler dis (me) - me.(set-pos 0) - (build - (while (< me.(cur-pos) (len me.buf)) - (add me.(dis-one))))) - -(defmeth assembler dis-listing (me : (stream *stdout*)) - (let ((p 0) - (c 0) - (l (len me.buf))) - me.(set-pos p) - (while (< p l) - (let* ((dis me.(dis-one)) - (dis-txt (cat-str [mapcar tostringp dis] " ")) - (q me.(cur-pos))) - (inc c) - me.(set-pos p) - (format t "~,5d: ~,08X ~a\n" (trunc p 4) me.(get-word) dis-txt) - (while (< (inc p 4) q) - (format t "~,5d: ~,08X\n" (trunc p 4) me.(get-word))) - me.(set-pos q) - (set p q))) - c)) - -(defvarl %oc-list-builder% (new list-builder)) - -(defvarl %oc-hash% (hash)) - -(defparml %oc-code% 0) - -(defun asm-error (msg . args) - (error `~s: @msg` 'assembler . args)) - -(defun register-opcode (oc) - %oc-list-builder%.(add oc) - (set [%oc-hash% oc.symbol] oc) - (set [%oc-hash% oc.code] oc)) - -(defun is-label (obj) - (or (keywordp obj) - (and (symbolp obj) - (not (symbol-package obj))))) - -(defun parse-compound-operand (cons) - (tree-case cons - ((sym arg) - (when (< -1 arg %lev-size%) - (caseq sym - ((t) arg) - (d (+ arg %lev-size%))))) - ((sym arg1 arg2) - (when (and (<= 0 arg1 %max-v-lev%) - (<= 0 arg2 %max-lev-idx%)) - (caseq sym - (v (+ (* (ssucc arg1) %lev-size%) arg2))))))) - -(defun parse-operand (str) - (cond - ((r^$ #/t[0-9A-Fa-f][0-9A-Fa-f]?[0-9A-Fa-f]?/ str) - (int-str [str 1..:] 16)) - ((r^$ #/d[0-9A-Fa-f][0-9A-Fa-f]?[0-9A-Fa-f]?/ str) - (+ %lev-size% (int-str [str 1..:] 16))) - ((r^$ #/v[0-9A-Fa-f][0-9A-Fa-f][0-9A-Fa-f][0-9A-Fa-f][0-9A-Fa-f]/ str) - (let ((lv (int-str [`0@{str[1..:]}` -5..-3] 16)) - (ix (int-str [str -3..:] 16))) - (+ (* %lev-size% (ssucc lv)) ix))))) - -(eval-only - (defmacro with-lev-idx ((lev-var idx-var) val-expr . body) - (with-gensyms (val-var) - ^(let* ((,val-var ,val-expr) - (,lev-var (ash ,val-var (macro-time (- %lev-bits%)))) - (,idx-var (logtrunc ,val-var %lev-bits%))) - ,*body)))) - -(defun operand-to-sym (val) - (with-lev-idx (lv ix) val - (caseql lv - (0 (if (zerop ix) - nil - (intern (fmt "t~s" ix)))) - (1 (intern (fmt "d~s" ix))) - (t (intern (fmt "v~,02X~,03X" (ppred lv) ix)))))) - -(defun operand-to-exp (val) - (with-lev-idx (lv ix) val - (caseql lv - (0 (if (zerop ix) - nil - ^(t ,ix))) - (1 ^(d ,ix)) - (t ^(v ,(ppred lv) ,ix))))) - -(defun bits-to-obj (bits width) - (let ((tag (logtrunc bits 2)) - (val (ash bits -2))) - (caseq tag - (1 (sign-extend val (- width 2))) - (2 (chr-int val)) - (t (error "~s: bad immediate operand: ~x" 'assembler bits))))) - -(defun small-op-p (val) - (with-lev-idx (lv ix) val - (and (<= 0 ix %max-sm-lev-idx%) - (<= 0 lv %max-sm-lev%)))) - -(defun enc-small-op (val) - (with-lev-idx (lv ix) val - (logior (ash lv %sm-lev-bits%) ix))) - -(defun small-op-to-sym (sval) - (let ((lv (ash sval (- %sm-lev-bits%))) - (ix (logtrunc sval %sm-lev-bits%))) - (operand-to-sym (+ (* lv %lev-size%) ix)))) - -(defstruct backpatch-low16 nil - (:method backpatch (me asm at offs) - (tree-bind (hi lo) asm.(get-pair) - asm.(set-pos at) - asm.(put-pair hi offs)))) - -(defstruct backpatch-high16 nil - (:method backpatch (me asm at offs) - (tree-bind (hi lo) asm.(get-pair) - asm.(set-pos at) - asm.(put-pair offs lo)))) - -(defvarl %backpatch-low16% (new backpatch-low16)) -(defvarl %backpatch-high16% (new backpatch-high16)) - -(eval-only - (defmacro defopcode (class symbol code . slot-defs) - ^(symacrolet ((auto (pinc %oc-code%))) - (defstruct ,class oc-base - (:static symbol ',symbol) - (:static code ,code) - ,*slot-defs) - (register-opcode (new ,class)))) - - (defmacro defopcode-derived (class symbol code orig-class) - ^(symacrolet ((auto (pinc %oc-code%))) - (defstruct ,class ,orig-class - (:static symbol ',symbol) - (:static code ,code)) - (register-opcode (new ,class))))) - -(defopcode op-label label nil - (:method asm (me asm syntax) - (unless (is-label syntax) - asm.(synerr "label must be keyword or gensym")) - asm.(define-label syntax)) - - (:method dis (me asm extension operand))) - -(defopcode op-noop noop auto - (:method asm (me asm syntax) - me.(chk-arg-count 0 syntax) - asm.(put-insn me.code 0 0)) - - (:method dis (me asm extension operand) - ^(,me.symbol))) - -(defopcode op-frame frame auto - (:method asm (me asm syntax) - me.(chk-arg-count 2 syntax) - (tree-bind (lev size) asm.(parse-args me syntax '(n n)) - (unless (<= 2 lev %max-v-lev%) - me.(synerr "level must range from 2 to ~a" - %max-v-lev%)) - (unless (<= 0 size %lev-size%) - me.(synerr "size must range from 0 to ~a" - %lev-size%)) - asm.(put-insn me.code lev size))) - (:method dis (me asm lev size) - ^(,me.symbol ,lev ,size))) - -(defopcode-derived op-sframe sframe auto op-frame) - -(defopcode-derived op-dframe dframe auto op-frame) - -(defopcode op-end end auto - (:method asm (me asm syntax) - me.(chk-arg-count 1 syntax) - (let ((res (car asm.(parse-args me syntax '(r))))) - asm.(put-insn me.code 0 res))) - (:method dis (me asm extension res) - ^(,me.symbol ,(operand-to-sym res)))) - -(defopcode-derived op-fin fin auto op-end) - -(defopcode-derived op-prof prof auto op-fin) - -(defopcode op-call call auto - (:method asm (me asm syntax) - me.(chk-arg-count-min 2 syntax) - (let* ((nargs (pred (len syntax))) - (syn-pat (repeat '(r) (succ nargs))) - (funargs (ppred nargs)) - (args asm.(parse-args me syntax syn-pat))) - asm.(put-insn me.code funargs (pop args)) - (while args - (let ((x (pop args)) - (y (or (pop args) 0))) - asm.(put-pair y x))))) - - (:method dis (me asm funargs arg0) - (build - (add me.symbol) - (add (operand-to-sym arg0)) - (inc funargs 1) - (while (> funargs 0) - (dec funargs 2) - (tree-bind (y x) asm.(get-pair) - (add (operand-to-sym x)) - (unless (minusp funargs) - (add (operand-to-sym y)))))))) - -(defopcode-derived op-apply apply auto op-call) - -(defopcode op-gcall gcall auto - (:method asm (me asm syntax) - me.(chk-arg-count-min 2 syntax) - (let* ((nargs (pred (len syntax))) - (syn-pat (list* 'r 'n (repeat '(r) (sssucc nargs)))) - (funargs (ppred nargs)) - (args asm.(parse-args me syntax syn-pat))) - asm.(put-insn me.code funargs (pop args)) - (while args - (let ((x (pop args)) - (y (or (pop args) 0))) - asm.(put-pair y x))))) - - (:method dis (me asm funargs arg0) - (let ((first t)) - (build - (add me.symbol) - (add (operand-to-sym arg0)) - (inc funargs 1) - (while (> funargs 0) - (dec funargs 2) - (tree-bind (y x) asm.(get-pair) - (add (if (zap first) x (operand-to-sym x))) - (unless (minusp funargs) - (add (operand-to-sym y))))))))) - -(defopcode-derived op-gapply gapply auto op-gcall) - -(defopcode op-movrs movrs auto - (:method asm (me asm syntax) - me.(chk-arg-count 2 syntax) - (tree-bind (dst src) asm.(parse-args me syntax '(d rs)) - asm.(put-insn me.code (enc-small-op src) dst))) - - (:method dis (me asm src dst) - ^(,me.symbol ,(operand-to-sym dst) ,(small-op-to-sym src)))) - -(defopcode op-movsr movsr auto - (:method asm (me asm syntax) - me.(chk-arg-count 2 syntax) - (tree-bind (dst src) asm.(parse-args me syntax '(ds r)) - asm.(put-insn me.code (enc-small-op dst) src))) - - (:method dis (me asm dst src) - ^(,me.symbol ,(small-op-to-sym dst) ,(operand-to-sym src)))) - -(defopcode op-movrr movrr auto - (:method asm (me asm syntax) - me.(chk-arg-count 2 syntax) - (tree-bind (dst src) asm.(parse-args me syntax '(d r)) - asm.(put-insn me.code 0 dst) - asm.(put-pair 0 src))) - - (:method dis (me asm extension dst) - (let ((src (cadr asm.(get-pair)))) - ^(,me.symbol ,(operand-to-sym dst) ,(operand-to-sym src))))) - -(defopcode op-mov-pseudo mov nil - (:method asm (me asm syntax) - (tree-bind (dst src) asm.(parse-args me syntax '(d r)) - (let ((real [%oc-hash% (cond - ((small-op-p dst) 'movsr) - ((small-op-p src) 'movrs) - (t 'movrr))])) - real.(asm asm syntax))))) - -(defopcode op-movrsi movrsi auto - (:method asm (me asm syntax) - me.(chk-arg-count 2 syntax) - (tree-bind (dst imm) asm.(parse-args me syntax '(d si)) - asm.(put-insn me.code (logtrunc (sys:bits imm) 10) dst))) - - (:method dis (me asm imm dst) - ^(,me.symbol ,(operand-to-sym dst) ,(bits-to-obj imm 10)))) - -(defopcode op-movsmi movsmi auto - (:method asm (me asm syntax) - me.(chk-arg-count 2 syntax) - (tree-bind (dst imm) asm.(parse-args me syntax '(ds mi)) - asm.(put-insn me.code (enc-small-op dst) - (logtrunc (sys:bits imm) 16)))) - - (:method dis (me asm dst imm ) - ^(,me.symbol ,(small-op-to-sym dst) ,(bits-to-obj imm 16)))) - -(defopcode op-movrbi movrbi auto - (:method asm (me asm syntax) - me.(chk-arg-count 2 syntax) - (tree-bind (dst imm) asm.(parse-args me syntax '(d bi)) - asm.(put-insn me.code 0 dst) - asm.(put-word (logtrunc (sys:bits imm) 32)))) - - (:method dis (me asm extension dst) - (let ((imm asm.(get-word))) - ^(,me.symbol ,(operand-to-sym dst) ,(bits-to-obj imm 32))))) - -(defopcode op-movi-pseudo movi nil - (:method asm (me asm syntax) - (tree-bind (dst src) asm.(parse-args me syntax '(d bi)) - (let ((real [%oc-hash% (cond - (asm.(immediate-fits-type src 'si) 'movrsi) - ((and asm.(immediate-fits-type src 'si) - (small-op-p dst)) 'movsmi) - (t 'movrbi))])) - real.(asm asm syntax))))) - -(defopcode op-jmp jmp auto - (:method asm (me asm syntax) - me.(chk-arg-count 1 syntax) - (let ((dst (car asm.(parse-args me syntax '(l))))) - asm.(put-insn me.code (ash dst -16) (logtrunc dst 16)))) - - (:method backpatch (me asm at dst) - asm.(put-insn me.code (ash dst -16) (logtrunc dst 16))) - - (:method dis (me asm high16 low16) - ^(,me.symbol ,(logior (ash high16 16) low16)))) - -(defopcode op-if if auto - (:method asm (me asm syntax) - me.(chk-arg-count 2 syntax) - (tree-bind (reg dst) asm.(parse-args me syntax '(r l)) - asm.(put-insn me.code (ash dst -16) (logtrunc dst 16)) - asm.(put-pair 0 reg))) - - (:method backpatch (me asm at dst) - asm.(put-insn me.code (ash dst -16) (logtrunc dst 16))) - - (:method dis (me asm high16 low16) - (let ((dst (logior (ash high16 16) low16)) - (reg (cadr asm.(get-pair)))) - ^(,me.symbol ,(operand-to-sym reg) ,dst)))) - -(defopcode op-ifq ifq auto - (:method asm (me asm syntax) - me.(chk-arg-count 3 syntax) - (tree-bind (lreg rreg dst) asm.(parse-args me syntax '(r r l)) - asm.(put-insn me.code (ash dst -16) (logtrunc dst 16)) - asm.(put-pair lreg rreg))) - - (:method backpatch (me asm at dst) - asm.(put-insn me.code (ash dst -16) (logtrunc dst 16))) - - (:method dis (me asm high16 low16) - (let ((dst (logior (ash high16 16) low16))) - (tree-bind (lreg rreg) asm.(get-pair) - ^(,me.symbol ,(operand-to-sym lreg) ,(operand-to-sym rreg) ,dst))))) - -(defopcode-derived op-ifql ifql auto op-ifq) - -(defopcode op-swtch swtch auto - (:method asm (me asm syntax) - me.(chk-arg-count-min 1 syntax) - (let* ((args asm.(parse-args me syntax '(r))) - (lbls (cddr syntax)) - (tblsz (len lbls))) - asm.(put-insn me.code tblsz (car args)) - (while lbls - (let ((x asm.(lookup-label (pop lbls) %backpatch-low16%)) - (y (if lbls - asm.(lookup-label (pop lbls) %backpatch-high16%) - 0))) - asm.(put-pair y x))))) - - (:method dis (me asm tblsz switch-val) - (build - (add me.symbol) - (add (operand-to-sym switch-val)) - (while (> tblsz 0) - (dec tblsz 2) - (tree-bind (y x) asm.(get-pair) - (add x) - (unless (minusp tblsz) - (add y))))))) - -(defopcode-derived op-uwprot uwprot auto op-jmp) - -(defopcode op-block block auto - (:method asm (me asm syntax) - me.(chk-arg-count 3 syntax) - (tree-bind (outreg blname exitpt) asm.(parse-args me syntax '(d r l)) - asm.(put-insn me.code (ash exitpt -16) (logtrunc exitpt 16)) - asm.(put-pair outreg blname))) - - (:method backpatch (me asm at exitpt) - asm.(put-insn me.code (ash exitpt -16) (logtrunc exitpt 16))) - - (:method dis (me asm high16 low16) - (let ((exitpt (logior (ash high16 16) low16))) - (tree-bind (outreg blname) asm.(get-pair) - ^(,me.symbol ,(operand-to-sym outreg) ,(operand-to-sym blname) - ,exitpt))))) - -(defopcode op-retsr retsr auto - (:method asm (me asm syntax) - me.(chk-arg-count 2 syntax) - (tree-bind (name reg) asm.(parse-args me syntax '(rs r)) - asm.(put-insn me.code (enc-small-op name) reg))) - - (:method dis (me asm name reg) - ^(,me.symbol ,(small-op-to-sym name) ,(operand-to-sym reg)))) - -(defopcode op-retrs retrs auto - (:method asm (me asm syntax) - me.(chk-arg-count 2 syntax) - (tree-bind (name reg) asm.(parse-args me syntax '(r rs)) - asm.(put-insn me.code (enc-small-op reg) name))) - - (:method dis (me asm reg name) - ^(,me.symbol ,(operand-to-sym name) ,(small-op-to-sym reg)))) - -(defopcode op-retrr retrr auto - (:method asm (me asm syntax) - me.(chk-arg-count 2 syntax) - (tree-bind (name reg) asm.(parse-args me syntax '(r r)) - asm.(put-insn me.code 0 reg) - asm.(put-pair 0 name))) - - (:method dis (me asm extension reg) - (let ((name (cadr asm.(get-pair)))) - ^(,me.symbol ,(operand-to-sym name) ,(operand-to-sym reg))))) - -(defopcode op-ret-pseudo ret nil - (:method asm (me asm syntax) - me.(chk-arg-count 2 syntax) - (tree-bind (name reg) asm.(parse-args me syntax '(r r)) - (let ((real [%oc-hash% (cond - ((small-op-p name) 'retsr) - ((small-op-p reg) 'retrs) - (t 'retrr))])) - real.(asm asm syntax))))) - -(defopcode-derived op-abscsr abscsr auto op-retsr) - -(defopcode op-catch catch auto - (:method asm (me asm syntax) - me.(chk-arg-count 5 syntax) - (tree-bind (sym args catch-syms desc dst) - asm.(parse-args me syntax '(d d r r l)) - asm.(put-insn me.code (ash dst -16) (logtrunc dst 16)) - asm.(put-pair sym args) - asm.(put-pair desc catch-syms))) - - (:method backpatch (me asm at dst) - asm.(put-insn me.code (ash dst -16) (logtrunc dst 16))) - - (:method dis (me asm high16 low16) - (let ((dst (logior (ash high16 16) low16))) - (tree-bind (sym args) asm.(get-pair) - (tree-bind (desc catch-syms) asm.(get-pair) - ^(,me.symbol ,(operand-to-sym sym) ,(operand-to-sym args) - ,(operand-to-sym catch-syms) - ,(operand-to-sym desc) ,dst)))))) - -(defopcode op-handle handle auto - (:method asm (me asm syntax) - me.(chk-arg-count 2 syntax) - (tree-bind (fun handle-syms) asm.(parse-args me syntax '(r r)) - asm.(put-insn me.code 0 fun) - asm.(put-pair fun handle-syms))) - - (:method dis (me asm extension fun) - (let ((handle-syms (cadr asm.(get-pair)))) - ^(,me.symbol ,(operand-to-sym fun) ,(operand-to-sym handle-syms))))) - -(defopcode op-getv getv auto - (:method asm (me asm syntax) - me.(chk-arg-count 2 syntax) - (tree-bind (reg name) asm.(parse-args me syntax '(d r)) - (unless (small-op-p name) - asm.(asm-one ^(mov (t 1) ,(operand-to-exp name))) - (set name 1)) - asm.(put-insn me.code (enc-small-op name) reg))) - (:method dis (me asm name reg) - ^(,me.symbol ,(operand-to-sym reg) ,(small-op-to-sym name)))) - -(defopcode-derived op-oldgetf oldgetf auto op-getv) - -(defopcode-derived op-getl1 getl1 auto op-getv) - -(defopcode-derived op-getvb getvb auto op-getv) - -(defopcode-derived op-getfb getfb auto op-getv) - -(defopcode-derived op-getl1b getl1b auto op-getv) - -(defopcode op-setv setv auto - (:method asm (me asm syntax) - me.(chk-arg-count 2 syntax) - (tree-bind (reg name) asm.(parse-args me syntax '(r r)) - (unless (small-op-p name) - asm.(asm-one ^(mov (t 1) ,(operand-to-exp name))) - (set name 1)) - asm.(put-insn me.code (enc-small-op name) reg))) - (:method dis (me asm name reg) - ^(,me.symbol ,(operand-to-sym reg) ,(small-op-to-sym name)))) - -(defopcode-derived op-setl1 setl1 auto op-setv) - -(defopcode-derived op-bindv bindv auto op-setv) - -(defopcode op-close close auto - (:method asm (me asm syntax) - me.(chk-arg-count-min 6 syntax) - (let* ((syn-pat (repeat '(d) (- (length syntax) 7)))) - (tree-bind (reg frsize dst fix req vari . regs) - asm.(parse-args me syntax ^(d n l n n o ,*syn-pat)) - (unless (<= 0 frsize %lev-size%) - me.(synerr "frame size must be 0 to ~a" %lev-size%)) - asm.(put-insn me.code (ash dst -16) (logtrunc dst 16)) - asm.(put-pair (logior (ash (if vari 1 0) %lev-bits%) frsize) reg) - asm.(put-pair req fix) - (unless (eql fix (- (len regs) (if vari 1 0))) - me.(synerr "wrong number of registers")) - (while regs - (let ((x (pop regs)) - (y (or (pop regs) 0))) - asm.(put-pair y x)))))) - - (:method backpatch (me asm at dst) - asm.(put-insn me.code (ash dst -16) (logtrunc dst 16))) - - (:method dis (me asm high16 low16) - (let ((dst (logior (ash high16 16) low16))) - (tree-bind (vari-frsize reg) asm.(get-pair) - (let ((vari (bit vari-frsize %lev-bits%))) - (tree-bind (req fix) asm.(get-pair) - (build - (add me.symbol (operand-to-sym reg) - (logtrunc vari-frsize %lev-bits%) - dst fix req vari) - (when vari - (inc fix)) - (while (> fix 0) - (dec fix 2) - (tree-bind (y x) asm.(get-pair) - (add (operand-to-sym x)) - (unless (minusp fix) - (add (operand-to-sym y)))))))))))) - -(defopcode op-getlx getlx auto - (:method asm (me asm syntax) - me.(chk-arg-count 2 syntax) - (tree-bind (dst idx) asm.(parse-args me syntax '(d n)) - (cond - ((small-op-p dst) - asm.(put-insn me.code (enc-small-op dst) idx)) - (t asm.(put-insn me.code (enc-small-op 1) idx) - asm.(asm-one ^(mov ,(operand-to-exp dst) t1)))))) - (:method dis (me asm dst idx) - ^(,me.symbol ,(small-op-to-sym dst) ,idx))) - -(defopcode op-setlx setlx auto - (:method asm (me asm syntax) - me.(chk-arg-count 2 syntax) - (tree-bind (src idx) asm.(parse-args me syntax '(r n)) - (cond - ((small-op-p src) - asm.(put-insn me.code (enc-small-op src) idx)) - (t asm.(asm-one ^(mov t1 ,(operand-to-exp src))) - asm.(put-insn me.code (enc-small-op 1) idx))))) - (:method dis (me asm src idx) - ^(,me.symbol ,(small-op-to-sym src) ,idx))) - -(defopcode-derived op-getf getf auto op-getlx) - -(defun disassemble-cdf (code data funv *stdout*) - (let ((asm (new assembler buf code))) - (put-line "data:") - (mapdo (do format t "~5d: ~s\n" @1 @2) (range 0) data) - (put-line "syms:") - (mapdo (do format t "~5d: ~s\n" @1 @2) (range 0) funv) - (put-line "code:") - (let ((ninsn asm.(dis-listing))) - (put-line "instruction count:") - (format t "~5d\n" ninsn)))) - -(defun disassemble (obj : (stream *stdout*)) - (symacrolet ((self 'vm-disassemble-obj)) - (typecase obj - (vm-desc (disassemble-cdf (vm-desc-bytecode obj) - (vm-desc-datavec obj) - (vm-desc-symvec obj) - stream)) - (fun (unless (vm-fun-p obj) - (error "~s: not a vm function: ~s" self obj)) - (let* ((clo (func-get-env obj)) - (desc (sys:vm-closure-desc clo)) - (ip (sys:vm-closure-entry clo))) - (disassemble desc stream) - (put-line "entry point:") - (format stream "~5d\n" ip))) - (t (iflet ((fun (symbol-function obj))) - (disassemble fun stream) - (error "~s: not a compiled object: ~s" self obj)))) - obj)) diff --git a/share/txr/stdlib/awk.tl b/share/txr/stdlib/awk.tl deleted file mode 100644 index 33776a1c..00000000 --- a/share/txr/stdlib/awk.tl +++ /dev/null @@ -1,522 +0,0 @@ -;; Copyright 2016-2020 -;; Kaz Kylheku <kaz@kylheku.com> -;; Vancouver, Canada -;; All rights reserved. -;; -;; Redistribution and use in source and binary forms, with or without -;; modification, are permitted provided that the following conditions are met: -;; -;; 1. Redistributions of source code must retain the above copyright notice, this -;; list of conditions and the following disclaimer. -;; -;; 2. Redistributions in binary form must reproduce the above copyright notice, -;; this list of conditions and the following disclaimer in the documentation -;; and/or other materials provided with the distribution. -;; -;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -(load "conv.tl") - -(defstruct sys:awk-state () - (rs "\n") krs - fs ft kfs - fw fw-prev fw-ranges - (ofs " ") - (ors "\n") - (inputs) - (output *stdout*) - (file-num 0) - file-name - (file-rec-num 0) - (rec-num 0) - rec orig-rec fields nf - rng-vec (rng-n 0) - par-mode par-mode-fs par-mode-prev-fs - (streams (hash :equal-based)) - (:fini (self) - (dohash (k v self.streams) - (close-stream v))) - (:postinit (self) - (set self.inputs (or self.inputs (zap *args*) (list *stdin*))) - (if (plusp self.rng-n) - (set self.rng-vec (vector self.rng-n))) - (unless (streamp self.output) - (let ((stream (open-file self.output "w"))) - (set [self.streams ^(:outf ,self.output)] stream - self.output stream))))) - -(defstruct sys:awk-compile-time () - inputs output name lets - begin-file-actions end-file-actions - begin-actions end-actions - cond-actions - (nranges 0) - (rng-rec-temp (gensym)) - (rng-vec-temp (gensym)) - rng-expr-temps - rng-exprs - outer-env) - -(defmeth sys:awk-state rec-to-f (self) - (cond - (self.fw - (unless (eq self.fw-prev self.fw) - (let ((ranges (reduce-left - (tb ((list . sum) item) - (let ((ns (+ sum item))) - ^((,*list #R(,sum ,ns)) . ,ns))) - self.fw '(nil . 0)))) - (set self.fw-prev self.fw - self.fw-ranges (car ranges)))) - (let ((i 0) end - (l (length self.rec))) - (set self.fields - (build (each ((r self.fw-ranges)) - (set end (to r)) - (if (>= (from r) l) - (return nil)) - (add [self.rec r]) - (inc i)) - (if (< end l) - (add [self.rec end..:]))) - self.nf i))) - (self.fs - (when self.ft - (awk-error "both fs and ft set")) - (if (and (not self.kfs) (equal self.rec "")) - (set self.fields nil - self.nf 0) - (let ((eff-fs (if self.par-mode - (if (equal self.fs self.par-mode-prev-fs) - self.par-mode-fs - (set self.par-mode-prev-fs self.fs - self.par-mode-fs - (regex-compile ^(or ,(if (regexp self.fs) - (regex-source self.fs) - self.fs) - "\n")))) - self.fs))) - (set self.fields (split-str self.rec eff-fs self.kfs) - self.nf (length self.fields))))) - (self.ft - (set self.fields (tok-str self.rec self.ft self.kfs) - self.nf (length self.fields))) - ((set self.fields (tok-str self.rec #/[^ \t\n]+/ self.kfs) - self.nf (length self.fields))))) - -(defmeth sys:awk-state f-to-rec (self) - (set self.rec `@{self.fields self.ofs}`)) - -(defmeth sys:awk-state nf-to-f (self) - (set self.fields (take self.nf (append self.fields (repeat '(""))))) - self.(f-to-rec)) - -(defmeth sys:awk-state loop (aws func beg-file-func end-file-func) - (whilet ((in (pop aws.inputs))) - (block :awk-file - (inc aws.file-num) - (set aws.file-name (if (streamp in) - (stream-get-prop in :name) - in)) - (when beg-file-func - [beg-file-func aws]) - (let* ((*stdin* (cond - ((streamp in) in) - ((listp in) (make-strlist-input-stream in)) - ((open-file in)))) - (noted-rs (not aws.rs)) - (noted-krs (not aws.krs)) - (cached-rr nil)) - (flet ((get-rec-reader (*stdin*) - (cond - ((and (equal noted-rs aws.rs) (eq noted-krs aws.krs)) - cached-rr) - (t - (set noted-rs aws.rs noted-krs aws.krs) - (set cached-rr - (cond - ((and (equal aws.rs "\n") (not aws.krs)) - (set aws.par-mode nil) - (lambda () (get-line *stdin*))) - ((null aws.rs) - (set aws.par-mode t) - (let ((rin (record-adapter #/\n[ \n\t]*\n/)) - (flag t)) - (lambda () - (let ((r (get-line rin))) - (cond - (flag - (set flag nil) - (if (equal r "") - (get-line rin) - r)) - (t r)))))) - (t - (set aws.par-mode nil) - (let ((rin (record-adapter (if (regexp aws.rs) - aws.rs - (regex-compile aws.rs)) - *stdin* - aws.krs))) - (lambda () (get-line rin)))))))))) - (set aws.file-rec-num 0) - (unwind-protect - (whilet ((rr (get-rec-reader *stdin*)) - (rec (call rr))) - (set aws.rec rec aws.orig-rec rec) - (inc aws.rec-num) - (inc aws.file-rec-num) - (while* (eq :awk-again (block* :awk-rec [func aws])) - aws.(rec-to-f))) - (when end-file-func - [end-file-func aws]))))))) - -(defmeth sys:awk-state prn (self . args) - (cond - (args (for ((a args) next) (a) ((set a next)) - (put-string `@(car a)`) - (put-string (if (set next (cdr a)) self.ofs self.ors)))) - (t (put-string self.rec) - (put-string self.ors)))) - -(defmeth sys:awk-state ensure-stream (self kind path mode) - (hash-update-1 self.streams - ^(,kind ,path) - (do or @1 (caseq kind - ((:inf :outf) (open-file path mode)) - ((:inp :outp) (open-command path mode)))) - nil)) - -(defmeth sys:awk-state close-or-flush (self stream kind path val) - (cond - ((eq val :close) (whenlet ((s (del [self.streams ^(,kind ,path)]))) - (close-stream s))) - ((memq kind '(:outf outp)) (flush-stream stream) val) - (val))) - -(defun awk-error (msg . args) - (throwf 'eval-error `~s: @msg` 'awk . args)) - -(defun sys:awk-test (val rec) - (caseq (typeof val) - ((regex fun) (call val rec)) - (t val))) - -(defun sys:awk%--rng (rng-vec idx from-val to-val) - (placelet ((state (vecref rng-vec idx))) - (caseq state - (nil (cond - ((and from-val to-val) nil) - (from-val (set state :mid) nil))) - (:mid (cond - (to-val (set state nil) (not from-val)) - (from-val nil) - (t (set state t)))) - (t (cond - (to-val (set (vecref rng-vec idx) nil) t) - (t t)))))) - -(defun sys:awk%--rng- (rng-vec idx from-val to-val) - (placelet ((state (vecref rng-vec idx))) - (caseq state - (nil (cond - ((and from-val to-val) nil) - (from-val (set state :mid) nil))) - (:mid (cond - (to-val (set state nil)) - (from-val nil) - (t (set state t)))) - (t (cond - (to-val (set (vecref rng-vec idx) nil)) - (t t)))))) - -(defun sys:awk%rng+ (rng-vec idx from-val to-val) - (placelet ((state (vecref rng-vec idx))) - (caseq state - (nil (cond - ((and from-val to-val) (set state :end) t) - (from-val (set state t)))) - (:end (cond - (to-val t) - (from-val (set state t)) - (t (set state nil) nil))) - (t (cond - (to-val (set state :end) t) - (t t)))))) - -(defun sys:awk%-rng+ (rng-vec idx from-val to-val) - (placelet ((state (vecref rng-vec idx))) - (caseq state - (nil (cond - ((and from-val to-val) (set state :end) nil) - (from-val (set state t) nil))) - (:end (cond - (to-val t) - (from-val (set state t) nil) - (t (set state nil) nil))) - (t (cond - (to-val (set state :end) t) - (t t)))))) - -(defun sys:awk%--rng+ (rng-vec idx from-val to-val) - (placelet ((state (vecref rng-vec idx))) - (caseq state - (nil (cond - ((and from-val to-val) (set state :mid) nil) - (from-val (set state :mid) nil))) - (:mid (cond - (to-val (set state :end) (not from-val)) - (from-val nil) - (t (set state t)))) - (:end (cond - (to-val t) - (from-val (set state t) nil) - (t (set state nil) nil))) - (t (cond - (to-val (set state :end) t) - (t t)))))) - -(defmacro sys:awk-redir (aws-sym stream-var kind mode path body) - (with-gensyms (res-sym) - ^(let ((,res-sym ,path) - (,stream-var (qref ,aws-sym (ensure-stream ,kind ,res-sym ,mode)))) - ,(if body - ^(qref ,aws-sym (close-or-flush ,stream-var ,kind ,res-sym - (progn ,*body))) - stream-var)))) - -(defun sys:awk-expander (outer-env clauses) - (let ((awc (new sys:awk-compile-time outer-env outer-env))) - (each ((cl clauses)) - (tree-case cl - ((pattern . actions) (caseql pattern - (:inputs - (when awc.inputs - (awk-error "duplicate :input clauses")) - (set awc.inputs actions)) - (:output - (when awc.output - (awk-error "duplicate :output clauses")) - (when (or (atom actions) (cdr actions)) - (awk-error "bad :output syntax")) - (set awc.output (car actions))) - (:name - (when awc.name - (awk-error "duplicate :name clauses")) - (when (or (atom actions) (cdr actions)) - (awk-error "bad :name syntax")) - (unless (car actions) - (awk-error "null :name not permitted")) - (unless (symbolp (car actions)) - (awk-error ":name must be a symbol")) - (set awc.name (car actions))) - (:let (push actions awc.lets)) - (:begin (push actions awc.begin-actions)) - (:set (push ^((set ,*actions)) awc.begin-actions)) - (:end (push actions awc.end-actions)) - (:begin-file (push actions awc.begin-file-actions)) - (:set-file (push ^((set ,*actions)) awc.begin-actions)) - (:end-file (push actions awc.end-file-actions)) - (t (push (if actions - cl - ^(,pattern (prn))) - awc.cond-actions)))) - (junk (awk-error "bad clause syntax ~s" junk)))) - (set awc.lets [apply append (nreverse awc.lets)] - awc.begin-actions [apply append (nreverse awc.begin-actions)] - awc.end-actions [apply append (nreverse awc.end-actions)] - awc.begin-file-actions [apply append (nreverse awc.begin-file-actions)] - awc.end-file-actions [apply append (nreverse awc.end-file-actions)] - awc.cond-actions (nreverse awc.cond-actions)) - awc)) - -(defun sys:awk-code-move-check (awc aws-sym mainform subform - suspicious-vars kind) - (when suspicious-vars - (compile-warning mainform "~!form ~s\n\ - is moved out of the apparent scope\n\ - and thus cannot refer to ~a ~s" - subform kind suspicious-vars))) - -(defmacro sys:awk-mac-let (awc aws-sym . body) - ^(symacrolet ((rec (usr:rslot ,aws-sym 'rec 'rec-to-f)) - (orec (usr:rslot ,aws-sym 'orig-rec 'rec-to-f)) - (f (usr:rslot ,aws-sym 'fields 'f-to-rec)) - (nf (usr:rslot ,aws-sym 'nf 'nf-to-f)) - (nr (qref ,aws-sym rec-num)) - (fnr (qref ,aws-sym file-rec-num)) - (arg (qref ,aws-sym file-num)) - (fname (qref ,aws-sym file-name)) - (rs (qref ,aws-sym rs)) - (krs (qref ,aws-sym krs)) - (fs (qref ,aws-sym fs)) - (ft (qref ,aws-sym ft)) - (fw (qref ,aws-sym fw)) - (kfs (qref ,aws-sym kfs)) - (ofs (qref ,aws-sym ofs)) - (ors (qref ,aws-sym ors))) - (macrolet ((next () '(return-from :awk-rec)) - (again () '(return-from :awk-rec :awk-again)) - (next-file () '(return-from :awk-file)) - (sys:rng-if (form from-expr to-expr :env e) - ^(sys:rng-impl ,form - (sys:awk-test ,from-expr ,(qref ,awc rng-rec-temp)) - (sys:awk-test ,to-expr ,(qref ,awc rng-rec-temp)))) - (sys:rng-impl (form from-expr to-expr :env e) - (let* ((style (car form)) - (ix (pinc (qref ,awc nranges))) - (rng-temp (gensym)) - (from-expr-ex (expand from-expr e)) - (from-expr-val (gensym)) - (to-expr-ex (expand to-expr e)) - (to-expr-val (gensym)) - (vec-temp (qref ,awc rng-vec-temp)) - (emul-broken (and (plusp sys:compat) (<= sys:compat 177))) - (rng-fun - (caseq style - (--rng 'sys:awk%--rng) - (--rng- 'sys:awk%--rng-) - (rng+ 'sys:awk%rng+) - (-rng+ 'sys:awk%-rng+) - (--rng+ 'sys:awk%--rng+))) - (state (gensym))) - (tree-bind ((from-expr-ex fe-fv fe-ff fe-ev fe-ef) - (to-expr-ex te-fv te-ff te-ev te-ef) - (from-expr-orig to-expr-orig)) - (list - (expand-with-free-refs from-expr e ,awc.outer-env) - (expand-with-free-refs to-expr e ,awc.outer-env) - (list (cadr form) (caddr form))) - (sys:awk-code-move-check ,awc ',aws-sym - form from-expr-orig - (diff fe-ev fe-fv) - 'variables) - (sys:awk-code-move-check ,awc ',aws-sym - form from-expr-orig - (diff fe-ef fe-ff) - 'functions) - (sys:awk-code-move-check ,awc ',aws-sym - form to-expr-orig - (diff te-ev te-fv) - 'variables) - (sys:awk-code-move-check ,awc ',aws-sym - form to-expr-orig - (diff te-ef te-ff) - 'functions) - (push rng-temp (qref ,awc rng-expr-temps)) - (caseq style - ((--rng --rng- rng+ -rng+ --rng+) - (push - ^(,rng-fun ,vec-temp ,ix ,from-expr-ex ,to-expr-ex) - (qref ,awc rng-exprs))) - (t (push - ^(placelet ((,state (vecref ,(qref ,awc rng-vec-temp) ,ix))) - (let ((,to-expr-val ,to-expr-ex)) - (caseq ,state - (nil (let ((,from-expr-val ,from-expr-ex)) - (cond - ((and ,from-expr-val ,to-expr-val) - ,(if (and (eq style 'rng) (not emul-broken)) t)) - (,from-expr-val (set ,state t) - ,(if (memq style '(rng rng-)) t))))) - (t (cond - (,to-expr-val (set ,state nil) - ,(if (memq style '(rng -rng)) t)) - (t t)))))) - (qref ,awc rng-exprs)))) - rng-temp))) - (rng (:form form from-expr to-expr) ^(sys:rng-if ,form ,from-expr ,to-expr)) - (-rng (:form form from-expr to-expr) ^(sys:rng-if ,form ,from-expr ,to-expr)) - (rng- (:form form from-expr to-expr) ^(sys:rng-if ,form ,from-expr ,to-expr)) - (-rng- (:form form from-expr to-expr) ^(sys:rng-if ,form ,from-expr ,to-expr)) - (--rng (:form form from-expr to-expr) ^(sys:rng-if ,form ,from-expr ,to-expr)) - (--rng- (:form form from-expr to-expr) ^(sys:rng-if ,form ,from-expr ,to-expr)) - (rng+ (:form form from-expr to-expr) ^(sys:rng-if ,form ,from-expr ,to-expr)) - (-rng+ (:form form from-expr to-expr) ^(sys:rng-if ,form ,from-expr ,to-expr)) - (--rng+ (:form form from-expr to-expr) ^(sys:rng-if ,form ,from-expr ,to-expr)) - (ff (. opip-args) - ^(symacrolet ((f (usr:rslot ,',aws-sym 'fields 'f-to-rec))) - (set f [(opip ,*opip-args) f]))) - (mf (. opip-args) - ^(symacrolet ((f (usr:rslot ,',aws-sym 'fields 'f-to-rec))) - (set f (mapcar (opip ,*opip-args) f)))) - (fconv (. conv-args) - ^(set f (sys:conv (,*conv-args) f))) - (-> (path . body) - ^(sys:awk-redir ,',aws-sym *stdout* :outf "w" ,path ,body)) - (->> (path . body) - ^(sys:awk-redir ,',aws-sym *stdout* :apf "a" ,path ,body)) - (<- (path . body) - ^(sys:awk-redir ,',aws-sym *stdin* :inf "r" ,path ,body)) - (!> (path . body) - ^(sys:awk-redir ,',aws-sym *stdout* :outp "w" ,path ,body)) - (<! (path . body) - ^(sys:awk-redir ,',aws-sym *stdin* :inp "r" ,path ,body))) - ,*body))) - -(defmacro sys:awk-fun-let (aws-sym . body) - ^(flet ((prn (. args) - (qref ,aws-sym (prn . args)))) - ,*body)) - -(defun sys:awk-fun-shadowing-env (up-env) - (make-env nil '((prn . sys:special)) up-env)) - -(defmacro awk (:env outer-env . clauses) - (let ((awc (sys:awk-expander outer-env clauses))) - (with-gensyms (aws-sym awk-begf-fun awk-fun awk-endf-fun awk-retval) - (let* ((p-actions-xform-unex (mapcar (aret ^(when (sys:awk-test ,@1 rec) - ,*@rest)) - awc.cond-actions)) - (p-actions-xform (expand - ^(sys:awk-mac-let ,awc ,aws-sym - ,*p-actions-xform-unex) - (sys:awk-fun-shadowing-env outer-env)))) - ^(block ,(or awc.name 'awk) - (let* (,*awc.lets ,awk-retval - (,aws-sym (new sys:awk-state - ,*(if awc.inputs ^(inputs (list ,*awc.inputs))) - ,*(if awc.output ^(output ,awc.output)) - rng-n (macro-time (qref ,awc nranges))))) - (sys:awk-mac-let ,awc ,aws-sym - (sys:awk-fun-let ,aws-sym - (let* (,*(if awc.output - ^((*stdout* (qref ,aws-sym output)))) - ,*(if (and awc.cond-actions awc.begin-file-actions) - ^((,awk-begf-fun (lambda (,aws-sym) - ,*awc.begin-file-actions)))) - ,*(if (and awc.cond-actions awc.end-file-actions) - ^((,awk-endf-fun (lambda (,aws-sym) - ,*awc.end-file-actions)))) - ,*(if (or awc.cond-actions awc.begin-file-actions - awc.end-file-actions awc.end-actions) - ^((,awk-fun (lambda (,aws-sym) - ,(if awc.rng-exprs - ^(let* ((,awc.rng-rec-temp rec) - (,awc.rng-vec-temp (qref ,aws-sym rng-vec)) - ,*(nreverse - (zip awc.rng-expr-temps - awc.rng-exprs))) - ,p-actions-xform) - p-actions-xform)))))) - ,*awc.begin-actions - (unwind-protect - ,(if (or awc.cond-actions awc.begin-file-actions - awc.end-file-actions awc.end-actions) - ^(qref ,aws-sym (loop ,awk-fun - ,(if awc.begin-file-actions - awk-begf-fun) - ,(if awc.end-file-actions - awk-endf-fun)))) - (set ,awk-retval (progn ,*awc.end-actions)) - (call-finalizers ,aws-sym)) - ,awk-retval))))))))) diff --git a/share/txr/stdlib/build.tl b/share/txr/stdlib/build.tl deleted file mode 100644 index 527460be..00000000 --- a/share/txr/stdlib/build.tl +++ /dev/null @@ -1,140 +0,0 @@ -;; Copyright 2016-2020 -;; Kaz Kylheku <kaz@kylheku.com> -;; Vancouver, Canada -;; All rights reserved. -;; -;; Redistribution and use in source and binary forms, with or without -;; modification, are permitted provided that the following conditions are met: -;; -;; 1. Redistributions of source code must retain the above copyright notice, this -;; list of conditions and the following disclaimer. -;; -;; 2. Redistributions in binary form must reproduce the above copyright notice, -;; this list of conditions and the following disclaimer in the documentation -;; and/or other materials provided with the distribution. -;; -;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -(defstruct list-builder () - head tail - - (:postinit (bc) - (set bc.head (cons nil bc.head) - bc.tail bc.head)) - - (:method add (self . items) - (let ((st self.tail)) - (rplacd st (append (cdr st) nil)) - (let ((tl (last st))) - (usr:rplacd tl (append (cdr tl) items)) - (set self.tail tl))) - nil) - - (:method add* (self . items) - (let ((h self.head)) - (usr:rplacd h (append items (cdr h)))) - nil) - - (:method pend (self . lists) - (when lists - (let ((st self.tail)) - (rplacd st (append (cdr st) nil)) - (let* ((tl (last st)) - (cp (tailp tl (car (last lists)))) - (nl [apply append lists])) - (usr:rplacd tl (append (cdr tl) (if cp (copy-list nl) nl))) - (set self.tail tl))) - nil)) - - (:method pend* (self . lists) - (let* ((h self.head) - (pf [apply append (append lists (list (cdr h)))])) - (usr:rplacd h pf) - (set self.tail h)) - nil) - - (:method ncon (self . lists) - (when lists - (let* ((tl (last self.tail)) - (nl [apply nconc lists])) - (usr:rplacd tl (nconc (cdr tl) nl)) - (set self.tail tl)) - nil)) - - (:method ncon* (self . lists) - (let* ((h self.head) - (pf [apply nconc (append lists (list (cdr h)))])) - (usr:rplacd h pf) - (if (eq self.tail h) - (set self.tail pf))) - nil) - - (:method get (self) - (cdr self.head)) - - (:method del (self) - (whenlet ((hd self.head) - (chd (cdr self.head))) - (when (eq self.tail chd) - (set self.tail hd)) - (prog1 (car chd) (usr:rplacd hd (cdr chd))))) - - (:method del* (self) - (whenlet ((hd self.head) - (chd (cdr self.head))) - (if (cdr chd) - (let* ((tl self.tail) - (l2 (nthlast 2 tl))) - (if (cdr l2) - (prog1 - (cadr l2) - (usr:rplacd l2 nil)) - (let* ((l10 (nthlast 10 hd)) - (l2 (nthlast 2 l10))) - (prog1 - (cadr l2) - (usr:rplacd l2 nil) - (set self.tail l10))))) - (prog1 - (car chd) - (usr:rplacd hd nil) - (set self.tail hd)))))) - -(defun sys:list-builder-flets (lb-form) - (nconc - (collect-each ((op '(add add* pend pend* ncon ncon*))) - ^(,op (. args) - (qref ,lb-form (,op . args)))) - ^((get () - (qref ,lb-form (get))) - (del* () - (qref ,lb-form (del*))) - (do-del () - (qref ,lb-form (del)))))) - -(defun build-list (: init) - (new list-builder head init)) - -(defun sys:build-expander (forms return-get) - (with-gensyms (name) - ^(let ((,name (new list-builder))) - (flet ,(sys:list-builder-flets name) - (macrolet ((del (:form f : (expr nil expr-p)) - (if expr-p f '(do-del)))) - ,*forms - ,*(if return-get ^((qref ,name (get))))))))) - -(defmacro build (. forms) - (sys:build-expander forms t)) - -(defmacro buildn (. forms) - (sys:build-expander forms nil)) diff --git a/share/txr/stdlib/cadr.tl b/share/txr/stdlib/cadr.tl deleted file mode 100644 index 4c334562..00000000 --- a/share/txr/stdlib/cadr.tl +++ /dev/null @@ -1,1107 +0,0 @@ -;; This file is generated by gencadr.txr - -;; Copyright 2015-2020 -;; Kaz Kylheku <kaz@kylheku.com> -;; Vancouver, Canada -;; All rights reserved. -;; -;; Redistribution and use in source and binary forms, with or without -;; modification, are permitted provided that the following conditions are met: -;; -;; 1. Redistributions of source code must retain the above copyright notice, this -;; list of conditions and the following disclaimer. -;; -;; 2. Redistributions in binary form must reproduce the above copyright notice, -;; this list of conditions and the following disclaimer in the documentation -;; and/or other materials provided with the distribution. -;; -;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -(defplace (caar cell) body - (getter setter - (with-gensyms (cell-sym) - ^(let ((,cell-sym (car ,cell))) - (macrolet ((,getter () ^(car ,',cell-sym)) - (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) - ,body)))) - (ssetter - ^(macrolet ((,ssetter (val) ^(sys:rplaca (car ,',cell) ,val))) - ,body)) - (deleter - ^(macrolet ((,deleter () - (with-gensyms (tmp) - (with-update-expander (cgetter csetter) '(car ,cell) nil - ^(let ((,tmp (,cgetter))) - (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) - ,body))) - -(defplace (cadr cell) body - (getter setter - (with-gensyms (cell-sym) - ^(let ((,cell-sym (cdr ,cell))) - (macrolet ((,getter () ^(car ,',cell-sym)) - (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) - ,body)))) - (ssetter - ^(macrolet ((,ssetter (val) ^(sys:rplaca (cdr ,',cell) ,val))) - ,body)) - (deleter - ^(macrolet ((,deleter () - (with-gensyms (tmp) - (with-update-expander (cgetter csetter) '(cdr ,cell) nil - ^(let ((,tmp (,cgetter))) - (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) - ,body))) - -(defplace (cdar cell) body - (getter setter - (with-gensyms (cell-sym) - ^(let ((,cell-sym (car ,cell))) - (macrolet ((,getter () ^(cdr ,',cell-sym)) - (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) - ,body)))) - (ssetter - ^(macrolet ((,ssetter (val) ^(sys:rplacd (car ,',cell) ,val))) - ,body)) - (deleter - ^(macrolet ((,deleter () - (with-gensyms (tmp) - (with-update-expander (cgetter csetter) '(car ,cell) nil - ^(let ((,tmp (,cgetter))) - (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) - ,body))) - -(defplace (cddr cell) body - (getter setter - (with-gensyms (cell-sym) - ^(let ((,cell-sym (cdr ,cell))) - (macrolet ((,getter () ^(cdr ,',cell-sym)) - (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) - ,body)))) - (ssetter - ^(macrolet ((,ssetter (val) ^(sys:rplacd (cdr ,',cell) ,val))) - ,body)) - (deleter - ^(macrolet ((,deleter () - (with-gensyms (tmp) - (with-update-expander (cgetter csetter) '(cdr ,cell) nil - ^(let ((,tmp (,cgetter))) - (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) - ,body))) - -(defplace (caaar cell) body - (getter setter - (with-gensyms (cell-sym) - ^(let ((,cell-sym (caar ,cell))) - (macrolet ((,getter () ^(car ,',cell-sym)) - (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) - ,body)))) - (ssetter - ^(macrolet ((,ssetter (val) ^(sys:rplaca (caar ,',cell) ,val))) - ,body)) - (deleter - ^(macrolet ((,deleter () - (with-gensyms (tmp) - (with-update-expander (cgetter csetter) '(caar ,cell) nil - ^(let ((,tmp (,cgetter))) - (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) - ,body))) - -(defplace (caadr cell) body - (getter setter - (with-gensyms (cell-sym) - ^(let ((,cell-sym (cadr ,cell))) - (macrolet ((,getter () ^(car ,',cell-sym)) - (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) - ,body)))) - (ssetter - ^(macrolet ((,ssetter (val) ^(sys:rplaca (cadr ,',cell) ,val))) - ,body)) - (deleter - ^(macrolet ((,deleter () - (with-gensyms (tmp) - (with-update-expander (cgetter csetter) '(cadr ,cell) nil - ^(let ((,tmp (,cgetter))) - (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) - ,body))) - -(defplace (cadar cell) body - (getter setter - (with-gensyms (cell-sym) - ^(let ((,cell-sym (cdar ,cell))) - (macrolet ((,getter () ^(car ,',cell-sym)) - (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) - ,body)))) - (ssetter - ^(macrolet ((,ssetter (val) ^(sys:rplaca (cdar ,',cell) ,val))) - ,body)) - (deleter - ^(macrolet ((,deleter () - (with-gensyms (tmp) - (with-update-expander (cgetter csetter) '(cdar ,cell) nil - ^(let ((,tmp (,cgetter))) - (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) - ,body))) - -(defplace (caddr cell) body - (getter setter - (with-gensyms (cell-sym) - ^(let ((,cell-sym (cddr ,cell))) - (macrolet ((,getter () ^(car ,',cell-sym)) - (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) - ,body)))) - (ssetter - ^(macrolet ((,ssetter (val) ^(sys:rplaca (cddr ,',cell) ,val))) - ,body)) - (deleter - ^(macrolet ((,deleter () - (with-gensyms (tmp) - (with-update-expander (cgetter csetter) '(cddr ,cell) nil - ^(let ((,tmp (,cgetter))) - (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) - ,body))) - -(defplace (cdaar cell) body - (getter setter - (with-gensyms (cell-sym) - ^(let ((,cell-sym (caar ,cell))) - (macrolet ((,getter () ^(cdr ,',cell-sym)) - (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) - ,body)))) - (ssetter - ^(macrolet ((,ssetter (val) ^(sys:rplacd (caar ,',cell) ,val))) - ,body)) - (deleter - ^(macrolet ((,deleter () - (with-gensyms (tmp) - (with-update-expander (cgetter csetter) '(caar ,cell) nil - ^(let ((,tmp (,cgetter))) - (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) - ,body))) - -(defplace (cdadr cell) body - (getter setter - (with-gensyms (cell-sym) - ^(let ((,cell-sym (cadr ,cell))) - (macrolet ((,getter () ^(cdr ,',cell-sym)) - (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) - ,body)))) - (ssetter - ^(macrolet ((,ssetter (val) ^(sys:rplacd (cadr ,',cell) ,val))) - ,body)) - (deleter - ^(macrolet ((,deleter () - (with-gensyms (tmp) - (with-update-expander (cgetter csetter) '(cadr ,cell) nil - ^(let ((,tmp (,cgetter))) - (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) - ,body))) - -(defplace (cddar cell) body - (getter setter - (with-gensyms (cell-sym) - ^(let ((,cell-sym (cdar ,cell))) - (macrolet ((,getter () ^(cdr ,',cell-sym)) - (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) - ,body)))) - (ssetter - ^(macrolet ((,ssetter (val) ^(sys:rplacd (cdar ,',cell) ,val))) - ,body)) - (deleter - ^(macrolet ((,deleter () - (with-gensyms (tmp) - (with-update-expander (cgetter csetter) '(cdar ,cell) nil - ^(let ((,tmp (,cgetter))) - (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) - ,body))) - -(defplace (cdddr cell) body - (getter setter - (with-gensyms (cell-sym) - ^(let ((,cell-sym (cddr ,cell))) - (macrolet ((,getter () ^(cdr ,',cell-sym)) - (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) - ,body)))) - (ssetter - ^(macrolet ((,ssetter (val) ^(sys:rplacd (cddr ,',cell) ,val))) - ,body)) - (deleter - ^(macrolet ((,deleter () - (with-gensyms (tmp) - (with-update-expander (cgetter csetter) '(cddr ,cell) nil - ^(let ((,tmp (,cgetter))) - (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) - ,body))) - -(defplace (caaaar cell) body - (getter setter - (with-gensyms (cell-sym) - ^(let ((,cell-sym (caaar ,cell))) - (macrolet ((,getter () ^(car ,',cell-sym)) - (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) - ,body)))) - (ssetter - ^(macrolet ((,ssetter (val) ^(sys:rplaca (caaar ,',cell) ,val))) - ,body)) - (deleter - ^(macrolet ((,deleter () - (with-gensyms (tmp) - (with-update-expander (cgetter csetter) '(caaar ,cell) nil - ^(let ((,tmp (,cgetter))) - (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) - ,body))) - -(defplace (caaadr cell) body - (getter setter - (with-gensyms (cell-sym) - ^(let ((,cell-sym (caadr ,cell))) - (macrolet ((,getter () ^(car ,',cell-sym)) - (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) - ,body)))) - (ssetter - ^(macrolet ((,ssetter (val) ^(sys:rplaca (caadr ,',cell) ,val))) - ,body)) - (deleter - ^(macrolet ((,deleter () - (with-gensyms (tmp) - (with-update-expander (cgetter csetter) '(caadr ,cell) nil - ^(let ((,tmp (,cgetter))) - (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) - ,body))) - -(defplace (caadar cell) body - (getter setter - (with-gensyms (cell-sym) - ^(let ((,cell-sym (cadar ,cell))) - (macrolet ((,getter () ^(car ,',cell-sym)) - (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) - ,body)))) - (ssetter - ^(macrolet ((,ssetter (val) ^(sys:rplaca (cadar ,',cell) ,val))) - ,body)) - (deleter - ^(macrolet ((,deleter () - (with-gensyms (tmp) - (with-update-expander (cgetter csetter) '(cadar ,cell) nil - ^(let ((,tmp (,cgetter))) - (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) - ,body))) - -(defplace (caaddr cell) body - (getter setter - (with-gensyms (cell-sym) - ^(let ((,cell-sym (caddr ,cell))) - (macrolet ((,getter () ^(car ,',cell-sym)) - (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) - ,body)))) - (ssetter - ^(macrolet ((,ssetter (val) ^(sys:rplaca (caddr ,',cell) ,val))) - ,body)) - (deleter - ^(macrolet ((,deleter () - (with-gensyms (tmp) - (with-update-expander (cgetter csetter) '(caddr ,cell) nil - ^(let ((,tmp (,cgetter))) - (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) - ,body))) - -(defplace (cadaar cell) body - (getter setter - (with-gensyms (cell-sym) - ^(let ((,cell-sym (cdaar ,cell))) - (macrolet ((,getter () ^(car ,',cell-sym)) - (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) - ,body)))) - (ssetter - ^(macrolet ((,ssetter (val) ^(sys:rplaca (cdaar ,',cell) ,val))) - ,body)) - (deleter - ^(macrolet ((,deleter () - (with-gensyms (tmp) - (with-update-expander (cgetter csetter) '(cdaar ,cell) nil - ^(let ((,tmp (,cgetter))) - (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) - ,body))) - -(defplace (cadadr cell) body - (getter setter - (with-gensyms (cell-sym) - ^(let ((,cell-sym (cdadr ,cell))) - (macrolet ((,getter () ^(car ,',cell-sym)) - (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) - ,body)))) - (ssetter - ^(macrolet ((,ssetter (val) ^(sys:rplaca (cdadr ,',cell) ,val))) - ,body)) - (deleter - ^(macrolet ((,deleter () - (with-gensyms (tmp) - (with-update-expander (cgetter csetter) '(cdadr ,cell) nil - ^(let ((,tmp (,cgetter))) - (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) - ,body))) - -(defplace (caddar cell) body - (getter setter - (with-gensyms (cell-sym) - ^(let ((,cell-sym (cddar ,cell))) - (macrolet ((,getter () ^(car ,',cell-sym)) - (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) - ,body)))) - (ssetter - ^(macrolet ((,ssetter (val) ^(sys:rplaca (cddar ,',cell) ,val))) - ,body)) - (deleter - ^(macrolet ((,deleter () - (with-gensyms (tmp) - (with-update-expander (cgetter csetter) '(cddar ,cell) nil - ^(let ((,tmp (,cgetter))) - (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) - ,body))) - -(defplace (cadddr cell) body - (getter setter - (with-gensyms (cell-sym) - ^(let ((,cell-sym (cdddr ,cell))) - (macrolet ((,getter () ^(car ,',cell-sym)) - (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) - ,body)))) - (ssetter - ^(macrolet ((,ssetter (val) ^(sys:rplaca (cdddr ,',cell) ,val))) - ,body)) - (deleter - ^(macrolet ((,deleter () - (with-gensyms (tmp) - (with-update-expander (cgetter csetter) '(cdddr ,cell) nil - ^(let ((,tmp (,cgetter))) - (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) - ,body))) - -(defplace (cdaaar cell) body - (getter setter - (with-gensyms (cell-sym) - ^(let ((,cell-sym (caaar ,cell))) - (macrolet ((,getter () ^(cdr ,',cell-sym)) - (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) - ,body)))) - (ssetter - ^(macrolet ((,ssetter (val) ^(sys:rplacd (caaar ,',cell) ,val))) - ,body)) - (deleter - ^(macrolet ((,deleter () - (with-gensyms (tmp) - (with-update-expander (cgetter csetter) '(caaar ,cell) nil - ^(let ((,tmp (,cgetter))) - (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) - ,body))) - -(defplace (cdaadr cell) body - (getter setter - (with-gensyms (cell-sym) - ^(let ((,cell-sym (caadr ,cell))) - (macrolet ((,getter () ^(cdr ,',cell-sym)) - (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) - ,body)))) - (ssetter - ^(macrolet ((,ssetter (val) ^(sys:rplacd (caadr ,',cell) ,val))) - ,body)) - (deleter - ^(macrolet ((,deleter () - (with-gensyms (tmp) - (with-update-expander (cgetter csetter) '(caadr ,cell) nil - ^(let ((,tmp (,cgetter))) - (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) - ,body))) - -(defplace (cdadar cell) body - (getter setter - (with-gensyms (cell-sym) - ^(let ((,cell-sym (cadar ,cell))) - (macrolet ((,getter () ^(cdr ,',cell-sym)) - (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) - ,body)))) - (ssetter - ^(macrolet ((,ssetter (val) ^(sys:rplacd (cadar ,',cell) ,val))) - ,body)) - (deleter - ^(macrolet ((,deleter () - (with-gensyms (tmp) - (with-update-expander (cgetter csetter) '(cadar ,cell) nil - ^(let ((,tmp (,cgetter))) - (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) - ,body))) - -(defplace (cdaddr cell) body - (getter setter - (with-gensyms (cell-sym) - ^(let ((,cell-sym (caddr ,cell))) - (macrolet ((,getter () ^(cdr ,',cell-sym)) - (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) - ,body)))) - (ssetter - ^(macrolet ((,ssetter (val) ^(sys:rplacd (caddr ,',cell) ,val))) - ,body)) - (deleter - ^(macrolet ((,deleter () - (with-gensyms (tmp) - (with-update-expander (cgetter csetter) '(caddr ,cell) nil - ^(let ((,tmp (,cgetter))) - (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) - ,body))) - -(defplace (cddaar cell) body - (getter setter - (with-gensyms (cell-sym) - ^(let ((,cell-sym (cdaar ,cell))) - (macrolet ((,getter () ^(cdr ,',cell-sym)) - (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) - ,body)))) - (ssetter - ^(macrolet ((,ssetter (val) ^(sys:rplacd (cdaar ,',cell) ,val))) - ,body)) - (deleter - ^(macrolet ((,deleter () - (with-gensyms (tmp) - (with-update-expander (cgetter csetter) '(cdaar ,cell) nil - ^(let ((,tmp (,cgetter))) - (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) - ,body))) - -(defplace (cddadr cell) body - (getter setter - (with-gensyms (cell-sym) - ^(let ((,cell-sym (cdadr ,cell))) - (macrolet ((,getter () ^(cdr ,',cell-sym)) - (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) - ,body)))) - (ssetter - ^(macrolet ((,ssetter (val) ^(sys:rplacd (cdadr ,',cell) ,val))) - ,body)) - (deleter - ^(macrolet ((,deleter () - (with-gensyms (tmp) - (with-update-expander (cgetter csetter) '(cdadr ,cell) nil - ^(let ((,tmp (,cgetter))) - (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) - ,body))) - -(defplace (cdddar cell) body - (getter setter - (with-gensyms (cell-sym) - ^(let ((,cell-sym (cddar ,cell))) - (macrolet ((,getter () ^(cdr ,',cell-sym)) - (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) - ,body)))) - (ssetter - ^(macrolet ((,ssetter (val) ^(sys:rplacd (cddar ,',cell) ,val))) - ,body)) - (deleter - ^(macrolet ((,deleter () - (with-gensyms (tmp) - (with-update-expander (cgetter csetter) '(cddar ,cell) nil - ^(let ((,tmp (,cgetter))) - (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) - ,body))) - -(defplace (cddddr cell) body - (getter setter - (with-gensyms (cell-sym) - ^(let ((,cell-sym (cdddr ,cell))) - (macrolet ((,getter () ^(cdr ,',cell-sym)) - (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) - ,body)))) - (ssetter - ^(macrolet ((,ssetter (val) ^(sys:rplacd (cdddr ,',cell) ,val))) - ,body)) - (deleter - ^(macrolet ((,deleter () - (with-gensyms (tmp) - (with-update-expander (cgetter csetter) '(cdddr ,cell) nil - ^(let ((,tmp (,cgetter))) - (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) - ,body))) - -(defplace (caaaaar cell) body - (getter setter - (with-gensyms (cell-sym) - ^(let ((,cell-sym (caaaar ,cell))) - (macrolet ((,getter () ^(car ,',cell-sym)) - (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) - ,body)))) - (ssetter - ^(macrolet ((,ssetter (val) ^(sys:rplaca (caaaar ,',cell) ,val))) - ,body)) - (deleter - ^(macrolet ((,deleter () - (with-gensyms (tmp) - (with-update-expander (cgetter csetter) '(caaaar ,cell) nil - ^(let ((,tmp (,cgetter))) - (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) - ,body))) - -(defplace (caaaadr cell) body - (getter setter - (with-gensyms (cell-sym) - ^(let ((,cell-sym (caaadr ,cell))) - (macrolet ((,getter () ^(car ,',cell-sym)) - (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) - ,body)))) - (ssetter - ^(macrolet ((,ssetter (val) ^(sys:rplaca (caaadr ,',cell) ,val))) - ,body)) - (deleter - ^(macrolet ((,deleter () - (with-gensyms (tmp) - (with-update-expander (cgetter csetter) '(caaadr ,cell) nil - ^(let ((,tmp (,cgetter))) - (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) - ,body))) - -(defplace (caaadar cell) body - (getter setter - (with-gensyms (cell-sym) - ^(let ((,cell-sym (caadar ,cell))) - (macrolet ((,getter () ^(car ,',cell-sym)) - (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) - ,body)))) - (ssetter - ^(macrolet ((,ssetter (val) ^(sys:rplaca (caadar ,',cell) ,val))) - ,body)) - (deleter - ^(macrolet ((,deleter () - (with-gensyms (tmp) - (with-update-expander (cgetter csetter) '(caadar ,cell) nil - ^(let ((,tmp (,cgetter))) - (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) - ,body))) - -(defplace (caaaddr cell) body - (getter setter - (with-gensyms (cell-sym) - ^(let ((,cell-sym (caaddr ,cell))) - (macrolet ((,getter () ^(car ,',cell-sym)) - (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) - ,body)))) - (ssetter - ^(macrolet ((,ssetter (val) ^(sys:rplaca (caaddr ,',cell) ,val))) - ,body)) - (deleter - ^(macrolet ((,deleter () - (with-gensyms (tmp) - (with-update-expander (cgetter csetter) '(caaddr ,cell) nil - ^(let ((,tmp (,cgetter))) - (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) - ,body))) - -(defplace (caadaar cell) body - (getter setter - (with-gensyms (cell-sym) - ^(let ((,cell-sym (cadaar ,cell))) - (macrolet ((,getter () ^(car ,',cell-sym)) - (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) - ,body)))) - (ssetter - ^(macrolet ((,ssetter (val) ^(sys:rplaca (cadaar ,',cell) ,val))) - ,body)) - (deleter - ^(macrolet ((,deleter () - (with-gensyms (tmp) - (with-update-expander (cgetter csetter) '(cadaar ,cell) nil - ^(let ((,tmp (,cgetter))) - (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) - ,body))) - -(defplace (caadadr cell) body - (getter setter - (with-gensyms (cell-sym) - ^(let ((,cell-sym (cadadr ,cell))) - (macrolet ((,getter () ^(car ,',cell-sym)) - (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) - ,body)))) - (ssetter - ^(macrolet ((,ssetter (val) ^(sys:rplaca (cadadr ,',cell) ,val))) - ,body)) - (deleter - ^(macrolet ((,deleter () - (with-gensyms (tmp) - (with-update-expander (cgetter csetter) '(cadadr ,cell) nil - ^(let ((,tmp (,cgetter))) - (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) - ,body))) - -(defplace (caaddar cell) body - (getter setter - (with-gensyms (cell-sym) - ^(let ((,cell-sym (caddar ,cell))) - (macrolet ((,getter () ^(car ,',cell-sym)) - (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) - ,body)))) - (ssetter - ^(macrolet ((,ssetter (val) ^(sys:rplaca (caddar ,',cell) ,val))) - ,body)) - (deleter - ^(macrolet ((,deleter () - (with-gensyms (tmp) - (with-update-expander (cgetter csetter) '(caddar ,cell) nil - ^(let ((,tmp (,cgetter))) - (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) - ,body))) - -(defplace (caadddr cell) body - (getter setter - (with-gensyms (cell-sym) - ^(let ((,cell-sym (cadddr ,cell))) - (macrolet ((,getter () ^(car ,',cell-sym)) - (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) - ,body)))) - (ssetter - ^(macrolet ((,ssetter (val) ^(sys:rplaca (cadddr ,',cell) ,val))) - ,body)) - (deleter - ^(macrolet ((,deleter () - (with-gensyms (tmp) - (with-update-expander (cgetter csetter) '(cadddr ,cell) nil - ^(let ((,tmp (,cgetter))) - (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) - ,body))) - -(defplace (cadaaar cell) body - (getter setter - (with-gensyms (cell-sym) - ^(let ((,cell-sym (cdaaar ,cell))) - (macrolet ((,getter () ^(car ,',cell-sym)) - (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) - ,body)))) - (ssetter - ^(macrolet ((,ssetter (val) ^(sys:rplaca (cdaaar ,',cell) ,val))) - ,body)) - (deleter - ^(macrolet ((,deleter () - (with-gensyms (tmp) - (with-update-expander (cgetter csetter) '(cdaaar ,cell) nil - ^(let ((,tmp (,cgetter))) - (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) - ,body))) - -(defplace (cadaadr cell) body - (getter setter - (with-gensyms (cell-sym) - ^(let ((,cell-sym (cdaadr ,cell))) - (macrolet ((,getter () ^(car ,',cell-sym)) - (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) - ,body)))) - (ssetter - ^(macrolet ((,ssetter (val) ^(sys:rplaca (cdaadr ,',cell) ,val))) - ,body)) - (deleter - ^(macrolet ((,deleter () - (with-gensyms (tmp) - (with-update-expander (cgetter csetter) '(cdaadr ,cell) nil - ^(let ((,tmp (,cgetter))) - (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) - ,body))) - -(defplace (cadadar cell) body - (getter setter - (with-gensyms (cell-sym) - ^(let ((,cell-sym (cdadar ,cell))) - (macrolet ((,getter () ^(car ,',cell-sym)) - (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) - ,body)))) - (ssetter - ^(macrolet ((,ssetter (val) ^(sys:rplaca (cdadar ,',cell) ,val))) - ,body)) - (deleter - ^(macrolet ((,deleter () - (with-gensyms (tmp) - (with-update-expander (cgetter csetter) '(cdadar ,cell) nil - ^(let ((,tmp (,cgetter))) - (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) - ,body))) - -(defplace (cadaddr cell) body - (getter setter - (with-gensyms (cell-sym) - ^(let ((,cell-sym (cdaddr ,cell))) - (macrolet ((,getter () ^(car ,',cell-sym)) - (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) - ,body)))) - (ssetter - ^(macrolet ((,ssetter (val) ^(sys:rplaca (cdaddr ,',cell) ,val))) - ,body)) - (deleter - ^(macrolet ((,deleter () - (with-gensyms (tmp) - (with-update-expander (cgetter csetter) '(cdaddr ,cell) nil - ^(let ((,tmp (,cgetter))) - (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) - ,body))) - -(defplace (caddaar cell) body - (getter setter - (with-gensyms (cell-sym) - ^(let ((,cell-sym (cddaar ,cell))) - (macrolet ((,getter () ^(car ,',cell-sym)) - (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) - ,body)))) - (ssetter - ^(macrolet ((,ssetter (val) ^(sys:rplaca (cddaar ,',cell) ,val))) - ,body)) - (deleter - ^(macrolet ((,deleter () - (with-gensyms (tmp) - (with-update-expander (cgetter csetter) '(cddaar ,cell) nil - ^(let ((,tmp (,cgetter))) - (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) - ,body))) - -(defplace (caddadr cell) body - (getter setter - (with-gensyms (cell-sym) - ^(let ((,cell-sym (cddadr ,cell))) - (macrolet ((,getter () ^(car ,',cell-sym)) - (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) - ,body)))) - (ssetter - ^(macrolet ((,ssetter (val) ^(sys:rplaca (cddadr ,',cell) ,val))) - ,body)) - (deleter - ^(macrolet ((,deleter () - (with-gensyms (tmp) - (with-update-expander (cgetter csetter) '(cddadr ,cell) nil - ^(let ((,tmp (,cgetter))) - (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) - ,body))) - -(defplace (cadddar cell) body - (getter setter - (with-gensyms (cell-sym) - ^(let ((,cell-sym (cdddar ,cell))) - (macrolet ((,getter () ^(car ,',cell-sym)) - (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) - ,body)))) - (ssetter - ^(macrolet ((,ssetter (val) ^(sys:rplaca (cdddar ,',cell) ,val))) - ,body)) - (deleter - ^(macrolet ((,deleter () - (with-gensyms (tmp) - (with-update-expander (cgetter csetter) '(cdddar ,cell) nil - ^(let ((,tmp (,cgetter))) - (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) - ,body))) - -(defplace (caddddr cell) body - (getter setter - (with-gensyms (cell-sym) - ^(let ((,cell-sym (cddddr ,cell))) - (macrolet ((,getter () ^(car ,',cell-sym)) - (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) - ,body)))) - (ssetter - ^(macrolet ((,ssetter (val) ^(sys:rplaca (cddddr ,',cell) ,val))) - ,body)) - (deleter - ^(macrolet ((,deleter () - (with-gensyms (tmp) - (with-update-expander (cgetter csetter) '(cddddr ,cell) nil - ^(let ((,tmp (,cgetter))) - (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) - ,body))) - -(defplace (cdaaaar cell) body - (getter setter - (with-gensyms (cell-sym) - ^(let ((,cell-sym (caaaar ,cell))) - (macrolet ((,getter () ^(cdr ,',cell-sym)) - (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) - ,body)))) - (ssetter - ^(macrolet ((,ssetter (val) ^(sys:rplacd (caaaar ,',cell) ,val))) - ,body)) - (deleter - ^(macrolet ((,deleter () - (with-gensyms (tmp) - (with-update-expander (cgetter csetter) '(caaaar ,cell) nil - ^(let ((,tmp (,cgetter))) - (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) - ,body))) - -(defplace (cdaaadr cell) body - (getter setter - (with-gensyms (cell-sym) - ^(let ((,cell-sym (caaadr ,cell))) - (macrolet ((,getter () ^(cdr ,',cell-sym)) - (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) - ,body)))) - (ssetter - ^(macrolet ((,ssetter (val) ^(sys:rplacd (caaadr ,',cell) ,val))) - ,body)) - (deleter - ^(macrolet ((,deleter () - (with-gensyms (tmp) - (with-update-expander (cgetter csetter) '(caaadr ,cell) nil - ^(let ((,tmp (,cgetter))) - (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) - ,body))) - -(defplace (cdaadar cell) body - (getter setter - (with-gensyms (cell-sym) - ^(let ((,cell-sym (caadar ,cell))) - (macrolet ((,getter () ^(cdr ,',cell-sym)) - (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) - ,body)))) - (ssetter - ^(macrolet ((,ssetter (val) ^(sys:rplacd (caadar ,',cell) ,val))) - ,body)) - (deleter - ^(macrolet ((,deleter () - (with-gensyms (tmp) - (with-update-expander (cgetter csetter) '(caadar ,cell) nil - ^(let ((,tmp (,cgetter))) - (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) - ,body))) - -(defplace (cdaaddr cell) body - (getter setter - (with-gensyms (cell-sym) - ^(let ((,cell-sym (caaddr ,cell))) - (macrolet ((,getter () ^(cdr ,',cell-sym)) - (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) - ,body)))) - (ssetter - ^(macrolet ((,ssetter (val) ^(sys:rplacd (caaddr ,',cell) ,val))) - ,body)) - (deleter - ^(macrolet ((,deleter () - (with-gensyms (tmp) - (with-update-expander (cgetter csetter) '(caaddr ,cell) nil - ^(let ((,tmp (,cgetter))) - (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) - ,body))) - -(defplace (cdadaar cell) body - (getter setter - (with-gensyms (cell-sym) - ^(let ((,cell-sym (cadaar ,cell))) - (macrolet ((,getter () ^(cdr ,',cell-sym)) - (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) - ,body)))) - (ssetter - ^(macrolet ((,ssetter (val) ^(sys:rplacd (cadaar ,',cell) ,val))) - ,body)) - (deleter - ^(macrolet ((,deleter () - (with-gensyms (tmp) - (with-update-expander (cgetter csetter) '(cadaar ,cell) nil - ^(let ((,tmp (,cgetter))) - (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) - ,body))) - -(defplace (cdadadr cell) body - (getter setter - (with-gensyms (cell-sym) - ^(let ((,cell-sym (cadadr ,cell))) - (macrolet ((,getter () ^(cdr ,',cell-sym)) - (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) - ,body)))) - (ssetter - ^(macrolet ((,ssetter (val) ^(sys:rplacd (cadadr ,',cell) ,val))) - ,body)) - (deleter - ^(macrolet ((,deleter () - (with-gensyms (tmp) - (with-update-expander (cgetter csetter) '(cadadr ,cell) nil - ^(let ((,tmp (,cgetter))) - (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) - ,body))) - -(defplace (cdaddar cell) body - (getter setter - (with-gensyms (cell-sym) - ^(let ((,cell-sym (caddar ,cell))) - (macrolet ((,getter () ^(cdr ,',cell-sym)) - (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) - ,body)))) - (ssetter - ^(macrolet ((,ssetter (val) ^(sys:rplacd (caddar ,',cell) ,val))) - ,body)) - (deleter - ^(macrolet ((,deleter () - (with-gensyms (tmp) - (with-update-expander (cgetter csetter) '(caddar ,cell) nil - ^(let ((,tmp (,cgetter))) - (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) - ,body))) - -(defplace (cdadddr cell) body - (getter setter - (with-gensyms (cell-sym) - ^(let ((,cell-sym (cadddr ,cell))) - (macrolet ((,getter () ^(cdr ,',cell-sym)) - (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) - ,body)))) - (ssetter - ^(macrolet ((,ssetter (val) ^(sys:rplacd (cadddr ,',cell) ,val))) - ,body)) - (deleter - ^(macrolet ((,deleter () - (with-gensyms (tmp) - (with-update-expander (cgetter csetter) '(cadddr ,cell) nil - ^(let ((,tmp (,cgetter))) - (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) - ,body))) - -(defplace (cddaaar cell) body - (getter setter - (with-gensyms (cell-sym) - ^(let ((,cell-sym (cdaaar ,cell))) - (macrolet ((,getter () ^(cdr ,',cell-sym)) - (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) - ,body)))) - (ssetter - ^(macrolet ((,ssetter (val) ^(sys:rplacd (cdaaar ,',cell) ,val))) - ,body)) - (deleter - ^(macrolet ((,deleter () - (with-gensyms (tmp) - (with-update-expander (cgetter csetter) '(cdaaar ,cell) nil - ^(let ((,tmp (,cgetter))) - (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) - ,body))) - -(defplace (cddaadr cell) body - (getter setter - (with-gensyms (cell-sym) - ^(let ((,cell-sym (cdaadr ,cell))) - (macrolet ((,getter () ^(cdr ,',cell-sym)) - (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) - ,body)))) - (ssetter - ^(macrolet ((,ssetter (val) ^(sys:rplacd (cdaadr ,',cell) ,val))) - ,body)) - (deleter - ^(macrolet ((,deleter () - (with-gensyms (tmp) - (with-update-expander (cgetter csetter) '(cdaadr ,cell) nil - ^(let ((,tmp (,cgetter))) - (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) - ,body))) - -(defplace (cddadar cell) body - (getter setter - (with-gensyms (cell-sym) - ^(let ((,cell-sym (cdadar ,cell))) - (macrolet ((,getter () ^(cdr ,',cell-sym)) - (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) - ,body)))) - (ssetter - ^(macrolet ((,ssetter (val) ^(sys:rplacd (cdadar ,',cell) ,val))) - ,body)) - (deleter - ^(macrolet ((,deleter () - (with-gensyms (tmp) - (with-update-expander (cgetter csetter) '(cdadar ,cell) nil - ^(let ((,tmp (,cgetter))) - (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) - ,body))) - -(defplace (cddaddr cell) body - (getter setter - (with-gensyms (cell-sym) - ^(let ((,cell-sym (cdaddr ,cell))) - (macrolet ((,getter () ^(cdr ,',cell-sym)) - (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) - ,body)))) - (ssetter - ^(macrolet ((,ssetter (val) ^(sys:rplacd (cdaddr ,',cell) ,val))) - ,body)) - (deleter - ^(macrolet ((,deleter () - (with-gensyms (tmp) - (with-update-expander (cgetter csetter) '(cdaddr ,cell) nil - ^(let ((,tmp (,cgetter))) - (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) - ,body))) - -(defplace (cdddaar cell) body - (getter setter - (with-gensyms (cell-sym) - ^(let ((,cell-sym (cddaar ,cell))) - (macrolet ((,getter () ^(cdr ,',cell-sym)) - (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) - ,body)))) - (ssetter - ^(macrolet ((,ssetter (val) ^(sys:rplacd (cddaar ,',cell) ,val))) - ,body)) - (deleter - ^(macrolet ((,deleter () - (with-gensyms (tmp) - (with-update-expander (cgetter csetter) '(cddaar ,cell) nil - ^(let ((,tmp (,cgetter))) - (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) - ,body))) - -(defplace (cdddadr cell) body - (getter setter - (with-gensyms (cell-sym) - ^(let ((,cell-sym (cddadr ,cell))) - (macrolet ((,getter () ^(cdr ,',cell-sym)) - (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) - ,body)))) - (ssetter - ^(macrolet ((,ssetter (val) ^(sys:rplacd (cddadr ,',cell) ,val))) - ,body)) - (deleter - ^(macrolet ((,deleter () - (with-gensyms (tmp) - (with-update-expander (cgetter csetter) '(cddadr ,cell) nil - ^(let ((,tmp (,cgetter))) - (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) - ,body))) - -(defplace (cddddar cell) body - (getter setter - (with-gensyms (cell-sym) - ^(let ((,cell-sym (cdddar ,cell))) - (macrolet ((,getter () ^(cdr ,',cell-sym)) - (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) - ,body)))) - (ssetter - ^(macrolet ((,ssetter (val) ^(sys:rplacd (cdddar ,',cell) ,val))) - ,body)) - (deleter - ^(macrolet ((,deleter () - (with-gensyms (tmp) - (with-update-expander (cgetter csetter) '(cdddar ,cell) nil - ^(let ((,tmp (,cgetter))) - (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) - ,body))) - -(defplace (cdddddr cell) body - (getter setter - (with-gensyms (cell-sym) - ^(let ((,cell-sym (cddddr ,cell))) - (macrolet ((,getter () ^(cdr ,',cell-sym)) - (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) - ,body)))) - (ssetter - ^(macrolet ((,ssetter (val) ^(sys:rplacd (cddddr ,',cell) ,val))) - ,body)) - (deleter - ^(macrolet ((,deleter () - (with-gensyms (tmp) - (with-update-expander (cgetter csetter) '(cddddr ,cell) nil - ^(let ((,tmp (,cgetter))) - (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) - ,body))) diff --git a/share/txr/stdlib/compiler.tl b/share/txr/stdlib/compiler.tl deleted file mode 100644 index f510d892..00000000 --- a/share/txr/stdlib/compiler.tl +++ /dev/null @@ -1,1865 +0,0 @@ -;; Copyright 2018-2020 -;; Kaz Kylheku <kaz@kylheku.com> -;; Vancouver, Canada -;; All rights reserved. -;; -;; Redistribution and use in source and binary forms, with or without -;; modification, are permitted provided that the following conditions are met: -;; -;; 1. Redistributions of source code must retain the above copyright notice, this -;; list of conditions and the following disclaimer. -;; -;; 2. Redistributions in binary form must reproduce the above copyright notice, -;; this list of conditions and the following disclaimer in the documentation -;; and/or other materials provided with the distribution. -;; -;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -(load "vm-param") - -(compile-only - (load-for (struct sys:param-parser-base "param"))) - -(defstruct (frag oreg code : fvars ffuns) nil - oreg - code - fvars - ffuns) - -(defstruct binding nil - sym - loc - used - sys:env) - -(defstruct vbinding binding) - -(defstruct fbinding binding) - -(defstruct blockinfo nil - sym - used - sys:env) - -(defstruct sys:env nil - vb - fb - bb - up - co - lev - (v-cntr 0) - - (:postinit (me) - (unless me.lev - (set me.lev (succ (or me.up.?lev 0)))) - (unless (or me.co (null me.up)) - (set me.co me.up.co)) - me.co.(new-env me)) - - (:method lookup-var (me sym : mark-used) - (condlet - (((cell (assoc sym me.vb))) - (let ((bi (cdr cell))) - (if mark-used (set bi.used t)) - bi)) - (((up me.up)) up.(lookup-var sym mark-used)) - (t nil))) - - (:method lookup-fun (me sym : mark-used) - (condlet - (((cell (assoc sym me.fb))) - (let ((bi (cdr cell))) - (if mark-used (set bi.used t)) - bi)) - (((up me.up)) up.(lookup-fun sym mark-used)) - (t nil))) - - (:method lookup-lisp1 (me sym : mark-used) - (condlet - (((cell (or (assoc sym me.vb) - (assoc sym me.fb)))) - (let ((bi (cdr cell))) - (if mark-used (set bi.used t)) - bi)) - (((up me.up)) up.(lookup-lisp1 sym mark-used)) - (t nil))) - - (:method lookup-block (me sym : mark-used) - (condlet - (((cell (assoc sym me.bb))) - (let ((bi (cdr cell))) - (if mark-used (set bi.used t)) - bi)) - (((up me.up)) up.(lookup-block sym mark-used)) - (t nil))) - - (:method extend-var (me sym) - (when (assoc sym me.vb) - (compile-error me.co.last-form "duplicate variable: ~s" sym)) - (let* ((loc ^(v ,(ppred me.lev) ,(pinc me.v-cntr))) - (bn (new vbinding sym sym loc loc env me))) - (set me.vb (acons sym bn me.vb)))) - - (:method extend-var* (me sym) - (let* ((loc ^(v ,(ppred me.lev) ,(pinc me.v-cntr))) - (bn (new vbinding sym sym loc loc env me))) - (set me.vb (acons sym bn me.vb)))) - - (:method extend-fun (me sym) - (when (assoc sym me.fb) - (compile-error me.co.last-form "duplicate function ~s" sym)) - (let* ((loc ^(v ,(ppred me.lev) ,(pinc me.v-cntr))) - (bn (new fbinding sym sym loc loc env me))) - (set me.fb (acons sym bn me.fb)))) - - (:method rename-var (me from-sym to-sym) - (iflet ((cell (assoc from-sym me.vb))) - (rplaca cell to-sym) - (let ((bn (cdr cell))) - (set bn.sym to-sym)))) - - (:method out-of-scope (me reg) - (if (eq (car reg) 'v) - (let ((lev (ssucc (cadr reg)))) - (< me.lev lev)))) - - (:method extend-block (me sym) - (let* ((bn (new blockinfo sym sym env me))) - (set me.bb (acons sym bn me.bb))))) - -(compile-only - (defstruct compiler nil - (treg-cntr 2) - (dreg-cntr 0) - (sidx-cntr 0) - (nlev 2) - (tregs nil) - (dreg (hash :eql-based)) - (data (hash :eql-based)) - (sidx (hash :eql-based)) - (stab (hash :eql-based)) - lt-frags - last-form)) - -(eval-only - (defmacro compile-in-toplevel (comp . body) - (with-gensyms (comp-var saved-tregs saved-treg-cntr saved-nlev) - ^(let* ((,comp-var ,comp) - (,saved-tregs (qref ,comp-var tregs)) - (,saved-treg-cntr (qref ,comp-var treg-cntr)) - (,saved-nlev (qref ,comp-var nlev))) - (unwind-protect - (progn - (set (qref ,comp-var tregs) nil - (qref ,comp-var treg-cntr) 2 - (qref ,comp-var nlev) 2) - (prog1 - (progn ,*body) - (qref ,comp-var (check-treg-leak)))) - (set (qref ,comp-var tregs) ,saved-tregs - (qref ,comp-var treg-cntr) ,saved-treg-cntr - (qref ,comp-var nlev) ,saved-nlev)))))) - -(defvarl %gcall-op% (relate '(apply usr:apply call) '(gapply gapply gcall))) - -(defvarl %call-op% (relate '(apply usr:apply call) '(apply apply call))) - -(defvarl %test-funs-pos% '(eq eql)) - -(defvarl %test-funs-neg% '(neq neql)) - -(defvarl %test-funs-ops% '(ifq ifql)) - -(defvarl %test-funs% (append %test-funs-pos% %test-funs-neg%)) - -(defvarl %test-inv% (relate %test-funs-neg% %test-funs-pos%)) - -(defvarl %test-opcode% (relate %test-funs-pos% %test-funs-ops%)) - -(defvarl %block-using-funs% '(sys:capture-cont return* sys:abscond* match-fun - eval load compile compile-file compile-toplevel)) - -(defvarl %nary-ops% '(< > <= => = + - * /)) - -(defvarl %bin-ops% '(b< b> b<= b=> b= b+ b- b* b/)) - -(defvarl %bin-op% (relate %nary-ops% %bin-ops%)) - -(defvarl assumed-fun) - -(defvar *dedup*) - -(defun dedup (obj) - (cond - ((null obj) nil) - ((null *dedup*) obj) - ((or (stringp obj) (bignump obj)) - (or [*dedup* obj] (set [*dedup* obj] obj))) - (t obj))) - -(defun null-reg (reg) - (equal reg '(t 0))) - -(defmeth compiler get-dreg (me obj) - (let ((dobj (dedup obj))) - (condlet - ((((null dobj))) '(t 0)) - (((dreg [me.dreg dobj])) dreg) - ((((< me.dreg-cntr %lev-size%))) - (let ((dreg ^(d ,(pinc me.dreg-cntr)))) - (set [me.data (cadr dreg)] dobj) - (set [me.dreg dobj] dreg))) - (t (compile-error me.last-form "code too complex: too many literals"))))) - -(defmeth compiler alloc-dreg (me) - (if (< me.dreg-cntr %lev-size%) - (let ((dreg ^(d ,(pinc me.dreg-cntr)))) - (set [me.data (cadr dreg)] nil) - dreg) - (compile-error me.last-form "code too complex: too many literals"))) - -(defmeth compiler get-sidx (me atom) - (iflet ((sidx [me.sidx atom])) - sidx - (let* ((sidx (pinc me.sidx-cntr))) - (set [me.stab sidx] atom) - (set [me.sidx atom] sidx)))) - -(defmeth compiler get-datavec (me) - (vec-list [mapcar me.data (range* 0 me.dreg-cntr)])) - -(defmeth compiler get-symvec (me) - (vec-list [mapcar me.stab (range* 0 me.sidx-cntr)])) - -(defmeth compiler alloc-treg (me) - (cond - (me.tregs (pop me.tregs)) - ((< me.treg-cntr %lev-size%) ^(t ,(pinc me.treg-cntr))) - (t (compile-error me.last-form "code too complex: out of registers")))) - -(defmeth compiler free-treg (me treg) - (when (and (eq t (car treg)) (neq 0 (cadr treg))) - (push treg me.tregs))) - -(defmeth compiler free-tregs (me tregs) - (mapdo (meth me free-treg) tregs)) - -(defmeth compiler maybe-alloc-treg (me given) - (if (eq t (car given)) - given - me.(alloc-treg))) - -(defmeth compiler maybe-free-treg (me treg given) - (when (nequal treg given) - me.(free-treg treg))) - -(defmeth compiler check-treg-leak (me) - (let ((balance (- (ppred me.treg-cntr) (len me.tregs)))) - (unless (zerop balance) - (error "t-register leak in compiler: ~s outstanding" balance)))) - -(defmeth compiler new-env (me env) - (when (>= env.lev me.nlev) - (unless (<= env.lev %max-lev%) - (compile-error me.last-form - "code too complex: lexical nesting too deep")) - (set me.nlev (succ env.lev)))) - -(defmeth compiler compile (me oreg env form) - (set me.last-form form) - (cond - ((symbolp form) - (if (bindable form) - me.(comp-var oreg env form) - me.(comp-atom oreg form))) - ((atom form) me.(comp-atom oreg form)) - (t (let ((sym (car form))) - (cond - ((special-operator-p sym) - (caseq sym - (quote me.(comp-atom oreg (cadr form))) - (sys:setq me.(comp-setq oreg env form)) - (sys:lisp1-setq me.(comp-lisp1-setq oreg env form)) - (sys:setqf me.(comp-setqf oreg env form)) - (cond me.(comp-cond oreg env form)) - (if me.(comp-if oreg env form)) - (switch me.(comp-switch oreg env form)) - (unwind-protect me.(comp-unwind-protect oreg env form)) - ((block block*) me.(comp-block oreg env form)) - ((return-from sys:abscond-from) me.(comp-return-from oreg env form)) - (return me.(comp-return oreg env form)) - (handler-bind me.(comp-handler-bind oreg env form)) - (sys:catch me.(comp-catch oreg env form)) - ((let let*) me.(comp-let oreg env form)) - ((sys:fbind sys:lbind) me.(comp-fbind oreg env form)) - (lambda me.(comp-lambda oreg env form)) - (fun me.(comp-fun oreg env form)) - (sys:for-op me.(comp-for oreg env form)) - (sys:each-op me.(compile oreg env (expand-each form env))) - ((progn eval-only compile-only) me.(comp-progn oreg env (cdr form))) - (and me.(comp-and-or oreg env form)) - (or me.(comp-and-or oreg env form)) - (prog1 me.(comp-prog1 oreg env form)) - (sys:quasi me.(comp-quasi oreg env form)) - (dohash me.(compile oreg env (expand-dohash form))) - (tree-bind me.(comp-tree-bind oreg env form)) - (mac-param-bind me.(comp-mac-param-bind oreg env form)) - (tree-case me.(comp-tree-case oreg env form)) - (sys:lisp1-value me.(comp-lisp1-value oreg env form)) - (dwim me.(comp-dwim oreg env form)) - (prof me.(comp-prof oreg env form)) - (defvarl me.(compile oreg env (expand-defvarl form))) - (defun me.(compile oreg env (expand-defun form))) - (defmacro me.(compile oreg env (expand-defmacro form))) - (defsymacro me.(compile oreg env (expand-defsymacro form))) - (sys:upenv me.(compile oreg env.up (cadr form))) - (sys:dvbind me.(compile oreg env (caddr form))) - (sys:load-time-lit me.(comp-load-time-lit oreg env form)) - ((macrolet symacrolet macro-time) - (compile-error form "unexpanded ~s encountered" sym)) - ((sys:var sys:expr) - (compile-error form "meta with no meaning: ~s " form)) - ((usr:qquote usr:unquote usr:splice - sys:qquote sys:unquote sys:splice) - (compile-error form "unexpanded quasiquote encountered")) - (t - (compile-error form "unrecognized special operator ~s" sym)))) - ((bindable sym) me.(comp-fun-form oreg env form)) - ((and (consp sym) - (eq (car sym) 'lambda)) me.(compile oreg env ^(call ,*form))) - (t (compile-error form "invalid operator"))))))) - -(defmeth compiler comp-atom (me oreg form) - (cond - ((null form) (new (frag '(t 0) nil))) - ((or (and (fixnump form) - (<= (width form) (- %imm-width% 3))) - (chrp form)) - (new (frag oreg ^((movi ,oreg ,form))))) - (t (let ((dreg me.(get-dreg form))) - (new (frag dreg nil)))))) - -(defmeth compiler comp-var (me oreg env sym) - (let ((vbin env.(lookup-var sym))) - (cond - (vbin (new (frag vbin.loc nil (list sym)))) - ((special-var-p sym) - (let ((dreg me.(get-dreg sym))) - (new (frag oreg ^((getv ,oreg ,dreg)) (list sym))))) - (t (new (frag oreg ^((getlx ,oreg ,me.(get-sidx sym))) (list sym))))))) - -(defmeth compiler comp-setq (me oreg env form) - (mac-param-bind form (op sym value) form - (let* ((bind env.(lookup-var sym)) - (spec (special-var-p sym)) - (vloc (cond - (bind bind.loc) - (spec me.(get-dreg sym)) - (t me.(get-sidx sym)))) - (vfrag me.(compile (if bind vloc oreg) env value))) - (new (frag vfrag.oreg - ^(,*vfrag.code - ,*(if bind - (maybe-mov vloc vfrag.oreg) - (if spec - ^((setv ,vfrag.oreg ,vloc)) - ^((setlx ,vfrag.oreg ,me.(get-sidx sym)))))) - (uni (list sym) vfrag.fvars) - vfrag.ffuns))))) - -(defmeth compiler comp-lisp1-setq (me oreg env form) - (mac-param-bind form (op sym val) form - (let ((bind env.(lookup-lisp1 sym))) - (cond - ((typep bind 'fbinding) - (compile-error form "assignment to lexical function binding")) - ((null bind) - (let ((vfrag me.(compile oreg env val)) - (l1loc me.(get-dreg sym))) - (new (frag vfrag.oreg - ^(,*vfrag.code - (setl1 ,vfrag.oreg ,l1loc)) - (uni (list sym) vfrag.fvars) - vfrag.ffuns)))) - (t me.(compile oreg env ^(sys:setq ,sym ,val))))))) - -(defmeth compiler comp-setqf (me oreg env form) - (mac-param-bind form (op sym val) form - (if env.(lookup-fun sym) - (compile-error form "assignment to lexical function binding") - (let ((vfrag me.(compile oreg env val)) - (fname me.(get-dreg sym)) - (rplcd me.(get-sidx 'usr:rplacd)) - (treg me.(alloc-treg))) - me.(free-treg treg) - (new (frag vfrag.oreg - ^(,*vfrag.code - (getfb ,treg ,fname) - (gcall ,treg ,rplcd ,treg ,vfrag.oreg)) - (uni (list sym) vfrag.fvars) - vfrag.ffuns)))))) - -(defmeth compiler comp-cond (me oreg env form) - (tree-case form - ((op) me.(comp-atom oreg nil)) - ((op (test) . more) me.(compile oreg env ^(or ,test (cond ,*more)))) - ((op (test . forms) . more) me.(compile oreg env - ^(if ,test - (progn ,*forms) - (cond ,*more)))) - ((op atom . more) - (compile-error form "atom in cond syntax; pair expected")) - ((op . atom) - (compile-error form "trailing atom in cond syntax")))) - -(defmeth compiler comp-if (me oreg env form) - (tree-case form - ((op test then else) - (cond - ((null test) - me.(compile oreg env else)) - ((constantp test) - me.(compile oreg env then)) - ((and (consp test) (member (car test) %test-funs%)) - me.(compile oreg env ^(ift ,(car test) ,(cadr test) ,(caddr test) - ,then ,else))) - (t - (let* ((te-oreg me.(maybe-alloc-treg oreg)) - (lelse (gensym "l")) - (lskip (gensym "l")) - (te-frag me.(compile te-oreg env test)) - (th-frag me.(compile oreg env then)) - (el-frag me.(compile oreg env else))) - me.(maybe-free-treg te-oreg oreg) - (new (frag oreg - ^(,*te-frag.code - (if ,te-frag.oreg ,lelse) - ,*th-frag.code - ,*(maybe-mov oreg th-frag.oreg) - (jmp ,lskip) - ,lelse - ,*el-frag.code - ,*(maybe-mov oreg el-frag.oreg) - ,lskip) - (uni te-frag.fvars (uni th-frag.fvars el-frag.fvars)) - (uni te-frag.ffuns (uni th-frag.ffuns el-frag.ffuns)))))))) - ((op test then) - (cond - ((null test) me.(compile oreg env nil)) - ((constantp test) - me.(compile oreg env then)) - ((and (consp test) (member (car test) %test-funs%)) - me.(compile oreg env ^(ift ,(car test) ,(cadr test) ,(caddr test) - ,then))) - (t (let* ((lskip (gensym "l")) - (te-oreg me.(maybe-alloc-treg oreg)) - (te-frag me.(compile te-oreg env test)) - (th-frag me.(compile oreg env then))) - me.(maybe-free-treg te-oreg oreg) - (new (frag oreg - ^(,*te-frag.code - ,*(maybe-mov oreg te-frag.oreg) - (if ,oreg ,lskip) - ,*th-frag.code - ,*(maybe-mov oreg th-frag.oreg) - ,lskip) - (uni te-frag.fvars th-frag.fvars) - (uni te-frag.ffuns th-frag.ffuns))))))) - ((op test) - (cond - ((constantp test) me.(compile oreg env nil)) - ((and (consp test) (member (car test) %test-funs%)) - me.(compile oreg env ^(ift ,(car test) ,(cadr test) ,(caddr test)))) - (t (let ((te-frag me.(compile oreg env test))) - (new (frag oreg - ^(,*te-frag.code - (mov ,oreg nil)) - te-frag.fvars - te-frag.ffuns)))))) - ((op) me.(compile oreg env nil)) - (form (compile-error form "excess argument forms")))) - -(defmeth compiler comp-ift (me oreg env form) - (mac-param-bind form (op fun left right : then else) form - (when (member fun %test-funs-neg%) - (set fun [%test-inv% fun]) - (swap then else)) - (if (and (constantp left) (constantp right)) - me.(compile oreg env (if (call fun (eval left) (eval right)) then else)) - (let* ((opcode [%test-opcode% fun]) - (le-oreg me.(alloc-treg)) - (ri-oreg me.(alloc-treg)) - (lelse (gensym "l")) - (lskip (gensym "l")) - (le-frag me.(compile le-oreg env left)) - (ri-frag me.(compile ri-oreg env right)) - (th-frag me.(compile oreg env then)) - (el-frag me.(compile oreg env else))) - me.(free-treg le-oreg) - me.(free-treg ri-oreg) - (new (frag oreg - ^(,*le-frag.code - ,*ri-frag.code - (,opcode ,le-frag.oreg ,ri-frag.oreg ,lelse) - ,*th-frag.code - ,*(maybe-mov oreg th-frag.oreg) - (jmp ,lskip) - ,lelse - ,*el-frag.code - ,*(maybe-mov oreg el-frag.oreg) - ,lskip) - (uni (uni le-frag.fvars ri-frag.fvars) - (uni th-frag.fvars el-frag.fvars)) - (uni (uni le-frag.ffuns ri-frag.ffuns) - (uni th-frag.ffuns el-frag.ffuns)))))))) - -(defmeth compiler comp-switch (me oreg env form) - (mac-param-bind form (op idx-form cases-vec) form - (let* ((ncases (len cases-vec)) - (cs (and (plusp ncases) (conses [cases-vec 0]))) - (shared (and cs - (let ((c cs) - (d (cdr (list-vec cases-vec)))) - (whilet ((m (if d (memq (pop d) c)))) - (set c m)) - (null d)))) - (cases (if shared - (let ((cs-nil ^(,*cs nil))) - [mapcar ldiff cs-nil (cdr cs-nil)]) - cases-vec)) - (lend (gensym "l")) - (clabels (mapcar (ret (gensym "l")) cases)) - (treg me.(maybe-alloc-treg oreg)) - (ifrag me.(compile treg env idx-form)) - (seen (unless shared (hash :eql-based))) - last-cfrag - (cfrags (collect-each ((cs cases) - (lb clabels) - (i (range 1))) - (iflet ((seen-lb (and seen [seen cs]))) - (progn - (set [clabels (pred i)] seen-lb) - (new (frag oreg nil))) - (let ((cfrag me.(comp-progn oreg env cs))) - (when (eq i ncases) - (set last-cfrag cfrag)) - (unless shared - (set [seen cs] lb)) - (new (frag oreg - ^(,lb - ,*cfrag.code - ,*(unless shared - ^(,*(maybe-mov oreg cfrag.oreg) - ,*(unless (= i ncases) - ^((jmp ,lend)))))) - cfrag.fvars cfrag.ffuns))))))) - me.(maybe-free-treg treg oreg) - (new (frag oreg - ^(,*ifrag.code - (swtch ,ifrag.oreg ,*clabels) - ,*(mappend .code cfrags) - ,*(when (and shared last-cfrag) - (maybe-mov oreg last-cfrag.oreg)) - ,lend) - (uni ifrag.fvars [reduce-left uni cfrags nil .fvars]) - (uni ifrag.ffuns [reduce-left uni cfrags nil .ffuns])))))) - -(defmeth compiler comp-unwind-protect (me oreg env form) - (mac-param-bind form (op prot-form . cleanup-body) form - (let* ((treg me.(alloc-treg)) - (pfrag me.(compile oreg env prot-form)) - (cfrag me.(comp-progn treg env cleanup-body)) - (lclean (gensym "l"))) - me.(free-treg treg) - (cond - ((null pfrag.code) - (new (frag cfrag.oreg - cfrag.code - cfrag.fvars - cfrag.ffuns))) - ((null cfrag.code) pfrag) - (t (new (frag pfrag.oreg - ^((uwprot ,lclean) - ,*pfrag.code - (end nil) - ,lclean - ,*cfrag.code - (end nil)) - (uni pfrag.fvars pfrag.fvars) - (uni cfrag.fvars cfrag.fvars)))))))) - -(defmeth compiler comp-block (me oreg env form) - (mac-param-bind form (op name . body) form - (let* ((star (and name (eq op 'block*))) - (nenv (unless star - (new env up env lev env.lev co me))) - (binfo (unless star - (cdar nenv.(extend-block name)))) - (treg (if star me.(maybe-alloc-treg oreg))) - (nfrag (if star me.(compile treg env name))) - (nreg (if star nfrag.oreg me.(get-dreg name))) - (bfrag me.(comp-progn oreg (or nenv env) body)) - (lskip (gensym "l"))) - (when treg - me.(maybe-free-treg treg oreg)) - (if (and (not star) - (not binfo.used) - [all bfrag.ffuns system-symbol-p] - [none bfrag.ffuns (op member @1 %block-using-funs%)]) - bfrag - (new (frag oreg - ^(,*(if nfrag nfrag.code) - (block ,oreg ,nreg ,lskip) - ,*bfrag.code - ,*(maybe-mov oreg bfrag.oreg) - (end ,oreg) - ,lskip) - bfrag.fvars - bfrag.ffuns)))))) - -(defmeth compiler comp-return-from (me oreg env form) - (mac-param-bind form (op name : value) form - (let* ((nreg (if (null name) - nil - me.(get-dreg name))) - (opcode (if (eq op 'return-from) 'ret 'abscsr)) - (vfrag me.(compile oreg env value)) - (binfo env.(lookup-block name t))) - (new (frag oreg - ^(,*vfrag.code - (,opcode ,nreg ,vfrag.oreg)) - vfrag.fvars - vfrag.ffuns))))) - -(defmeth compiler comp-return (me oreg env form) - (mac-param-bind form (op : value) form - me.(comp-return-from oreg env ^(return-from nil ,value)))) - -(defmeth compiler comp-handler-bind (me oreg env form) - (mac-param-bind form (op func-form ex-syms . body) form - (let* ((freg me.(maybe-alloc-treg oreg)) - (ffrag me.(compile freg env func-form)) - (sreg me.(get-dreg ex-syms)) - (bfrag me.(comp-progn oreg env body))) - me.(maybe-free-treg freg oreg) - (new (frag bfrag.oreg - ^(,*ffrag.code - (handle ,ffrag.oreg ,sreg) - ,*bfrag.code - (end ,bfrag.oreg)) - (uni ffrag.fvars bfrag.fvars) - (uni ffrag.ffuns bfrag.ffuns)))))) - -(defmeth compiler comp-catch (me oreg env form) - (mac-param-bind form (op symbols try-expr desc-expr . clauses) form - (with-gensyms (ex-sym-var ex-args-var) - (let* ((nenv (new env up env co me)) - (esvb (cdar nenv.(extend-var ex-sym-var))) - (eavb (cdar nenv.(extend-var ex-args-var))) - (tfrag me.(compile oreg nenv try-expr)) - (dfrag me.(compile oreg nenv desc-expr)) - (lhand (gensym "l")) - (lhend (gensym "l")) - (treg me.(alloc-treg)) - (nclauses (len clauses)) - (cfrags (collect-each ((cl clauses) - (i (range 1))) - (mac-param-bind form (sym params . body) cl - (let* ((cl-src ^(apply (lambda ,params ,*body) - ,ex-sym-var ,ex-args-var)) - (cfrag me.(compile oreg nenv (expand cl-src))) - (lskip (gensym "l"))) - (new (frag oreg - ^((gcall ,treg - ,me.(get-sidx 'exception-subtype-p) - ,esvb.loc - ,me.(get-dreg sym)) - (if ,treg ,lskip) - ,*cfrag.code - ,*(maybe-mov tfrag.oreg cfrag.oreg) - ,*(unless (eql i nclauses) - ^((jmp ,lhend))) - ,lskip) - cfrag.fvars - cfrag.ffuns))))))) - me.(free-treg treg) - (new (frag tfrag.oreg - ^((frame ,nenv.lev ,nenv.v-cntr) - ,*dfrag.code - (catch ,esvb.loc ,eavb.loc - ,me.(get-dreg symbols) ,dfrag.oreg ,lhand) - ,*tfrag.code - (jmp ,lhend) - ,lhand - ,*(mappend .code cfrags) - ,lhend - (end ,tfrag.oreg) - (end ,tfrag.oreg)) - (uni tfrag.fvars [reduce-left uni cfrags nil .fvars]) - (uni tfrag.ffuns [reduce-left uni cfrags nil .ffuns]))))))) - -(defmeth compiler comp-let (me oreg env form) - (mac-param-bind form (sym raw-vis . body) form - (let* ((vis (mapcar [iffi atom list] raw-vis)) - (specials [keep-if special-var-p vis car]) - (lexsyms [remove-if special-var-p [mapcar car vis]]) - allsyms - (specials-occur [find-if special-var-p vis car]) - (treg (if specials-occur me.(alloc-treg))) - (frsize (len lexsyms)) - (seq (eq sym 'let*)) - (nenv (new env up env co me)) - (eenv (unless seq (new env up env co me))) - (fenv (if seq nenv eenv))) - (unless seq - (each ((lsym lexsyms)) - nenv.(extend-var lsym))) - (let* (ffuns fvars - (code (build - (add ^(,(if specials-occur 'dframe 'frame) - ,nenv.lev ,frsize)) - (each ((vi vis)) - (tree-bind (sym : form) vi - (push sym allsyms) - (cond - ((special-var-p sym) - (let ((frag me.(compile treg fenv form)) - (dreg me.(get-dreg sym))) - (pend frag.code) - (add ^(bindv ,frag.oreg ,dreg)) - (set ffuns (uni ffuns frag.ffuns) - fvars (uni fvars - (if seq - (diff frag.fvars - (cdr allsyms)) - frag.fvars))))) - (form - (let* ((tmp (if seq (gensym))) - (bind (if seq - (cdar nenv.(extend-var tmp)) - nenv.(lookup-var sym))) - (frag me.(compile bind.loc fenv form))) - (when seq - fenv.(rename-var tmp sym)) - (pend frag.code) - (unless (null-reg frag.oreg) - (pend (maybe-mov bind.loc frag.oreg))) - (set ffuns (uni ffuns frag.ffuns) - fvars (uni fvars - (if seq - (diff frag.fvars - (cdr allsyms)) - frag.fvars))))) - (t (if seq nenv.(extend-var* sym)))))))) - (bfrag me.(comp-progn oreg nenv body)) - (boreg (if env.(out-of-scope bfrag.oreg) oreg bfrag.oreg))) - (when treg - me.(free-treg treg)) - (new (frag boreg - (append code bfrag.code - (maybe-mov boreg bfrag.oreg) - ^((end ,boreg))) - (uni (diff bfrag.fvars allsyms) fvars) - (uni ffuns bfrag.ffuns))))))) - -(defmeth compiler comp-fbind (me oreg env form) - (mac-param-bind form (sym raw-fis . body) form - (let* ((fis (mapcar [iffi atom list] raw-fis)) - (lexfuns [mapcar car fis]) - (frsize (len lexfuns)) - (rec (eq sym 'sys:lbind)) - (eenv (unless rec (new env up env co me))) - (nenv (new env up env co me))) - (each ((lfun lexfuns)) - nenv.(extend-fun lfun)) - (let* (ffuns fvars - (ffrags (collect-each ((fi fis)) - (tree-bind (sym : form) fi - (let* ((bind nenv.(lookup-fun sym)) - (frag me.(compile bind.loc - (if rec nenv eenv) - form))) - (list bind - (new (frag frag.oreg - (append frag.code - (maybe-mov bind.loc frag.oreg)) - frag.fvars - frag.ffuns))))))) - (bfrag me.(comp-progn oreg nenv body)) - (boreg (if env.(out-of-scope bfrag.oreg) oreg bfrag.oreg))) - (set ffrags (append-each ((bf ffrags)) - (tree-bind (bind ff) bf - (when bind.used - (set ffuns (uni ffuns ff.ffuns) - fvars (uni fvars ff.fvars)) - (list ff))))) - (new (frag boreg - (append ^((frame ,nenv.lev ,frsize)) - (mappend .code ffrags) - bfrag.code - (maybe-mov boreg bfrag.oreg) - ^((end ,boreg))) - (uni fvars bfrag.fvars) - (uni (diff bfrag.ffuns lexfuns) - (if rec (diff ffuns lexfuns) ffuns)))))))) - -(defmeth compiler comp-lambda (me oreg env form) - (mac-param-bind form (op par-syntax . body) form - (let* ((pars (new (fun-param-parser par-syntax form))) - (need-frame (or (plusp pars.nfix) pars.rest)) - (nenv (if need-frame (new env up env co me) env)) - lexsyms fvars specials need-dframe) - (when (> pars.nfix %max-lambda-fixed-args%) - (compile-warning form "~s arguments in a lambda (max is ~s)" - pars.nfix %max-lambda-fixed-args%)) - (flet ((spec-sub (sym) - (cond - ((special-var-p sym) - (let ((sub (gensym))) - (push (cons sym sub) specials) - (set need-dframe t) - nenv.(extend-var sub) - sub)) - (t - (push sym lexsyms) - nenv.(extend-var sym) - sym)))) - (let* ((req-pars (collect-each ((rp pars.req)) - (spec-sub rp))) - (opt-pars (collect-each ((op pars.opt)) - (tree-bind (var-sym : init-form have-sym) op - (list (spec-sub var-sym) - init-form - (if have-sym (spec-sub have-sym)))))) - (rest-par (when pars.rest (spec-sub pars.rest))) - (allsyms req-pars)) - (upd specials nreverse) - (let* ((col-reg (if opt-pars me.(get-dreg :))) - (tee-reg (if opt-pars me.(get-dreg t))) - (ifrags (collect-each ((op opt-pars)) - (tree-bind (var-sym init-form have-sym) op - (let* ((vbind nenv.(lookup-var var-sym)) - (ifrag me.(compile vbind.loc nenv init-form))) - (set fvars (uni fvars - (diff ifrag.fvars allsyms))) - (push var-sym allsyms) - (push have-sym allsyms) - ifrag)))) - (opt-code (append-each ((op opt-pars) - (ifrg ifrags)) - (tree-bind (var-sym init-form have-sym) op - (let ((vbind nenv.(lookup-var var-sym)) - (have-bind nenv.(lookup-var have-sym)) - (lskip (gensym "l"))) - ^(,*(if have-sym - ^((mov ,have-bind.loc ,tee-reg))) - (ifq ,vbind.loc ,col-reg ,lskip) - ,*(if have-sym - ^((mov ,have-bind.loc nil))) - ,*ifrg.code - ,*(maybe-mov vbind.loc ifrg.oreg) - ,lskip - ,*(whenlet ((spec-sub [find var-sym specials : cdr])) - (set specials [remq var-sym specials cdr]) - ^((bindv ,vbind.loc ,me.(get-dreg (car spec-sub))))) - ,*(whenlet ((spec-sub [find have-sym specials : cdr])) - (set specials [remq have-sym specials cdr]) - ^((bindv ,have-bind.loc ,me.(get-dreg (car spec-sub)))))))))) - (benv (if need-dframe (new env up nenv co me) nenv)) - (btreg me.(alloc-treg)) - (bfrag me.(comp-progn btreg benv body)) - (boreg (if env.(out-of-scope bfrag.oreg) btreg bfrag.oreg)) - (lskip (gensym "l-")) - (frsize (if need-frame nenv.v-cntr 0))) - me.(free-treg btreg) - (new (frag oreg - ^((close ,oreg ,frsize ,lskip ,pars.nfix ,pars.nreq - ,(if rest-par t nil) - ,*(collect-each ((rp req-pars)) - nenv.(lookup-var rp).loc) - ,*(collect-each ((op opt-pars)) - nenv.(lookup-var (car op)).loc) - ,*(if rest-par - (list nenv.(lookup-var rest-par).loc))) - ,*(if need-dframe - ^((dframe ,benv.lev 0))) - ,*(if specials - (collect-each ((vs specials)) - (tree-bind (special . gensym) vs - (let ((sub-bind nenv.(lookup-var gensym)) - (dreg me.(get-dreg special))) - ^(bindv ,sub-bind.loc ,dreg))))) - ,*opt-code - ,*bfrag.code - ,*(if need-dframe - ^((end ,boreg))) - ,*(maybe-mov boreg bfrag.oreg) - (end ,boreg) - ,lskip) - (uni fvars (diff bfrag.fvars lexsyms)) - (uni [reduce-left uni ifrags nil .ffuns] - bfrag.ffuns))))))))) - -(defmeth compiler comp-fun (me oreg env form) - (mac-param-bind form (op arg) form - (let ((fbin env.(lookup-fun arg t))) - (cond - (fbin (new (frag fbin.loc nil nil (list arg)))) - ((and (consp arg) (eq (car arg) 'lambda)) - me.(compile oreg env arg)) - (t (new (frag oreg ^((getf ,oreg ,me.(get-sidx arg))) - nil (list arg)))))))) - -(defmeth compiler comp-progn (me oreg env args) - (let* (ffuns fvars - (lead-forms (butlastn 1 args)) - (last-form (nthlast 1 args)) - (eff-lead-forms (remove-if [orf constantp symbolp] lead-forms)) - (forms (append eff-lead-forms last-form)) - (nargs (len forms)) - lastfrag - (oreg-discard me.(alloc-treg)) - (code (build - (each ((form forms) - (n (range 1))) - (let ((islast (eql n nargs))) - (let ((frag me.(compile (if islast oreg oreg-discard) - env form))) - (when islast - (set lastfrag frag)) - (set fvars (uni fvars frag.fvars)) - (set ffuns (uni ffuns frag.ffuns)) - (pend frag.code))))))) - me.(free-treg oreg-discard) - (new (frag (if lastfrag lastfrag.oreg ^(t 0)) code fvars ffuns)))) - -(defmeth compiler comp-and-or (me oreg env form) - (tree-case form - ((op) me.(compile oreg env (if (eq op 'and) t))) - ((op arg) me.(compile oreg env arg)) - ((op . args) - (let* (ffuns fvars - (nargs (len args)) - lastfrag - (is-and (eq op 'and)) - (lout (gensym "l")) - (treg me.(maybe-alloc-treg oreg)) - (code (build - (each ((form args) - (n (range 1))) - (let ((islast (eql n nargs))) - (let ((frag me.(compile treg env form))) - (when islast - (set lastfrag frag)) - (pend frag.code - (maybe-mov treg frag.oreg)) - (unless islast - (add (if is-and - ^(if ,treg ,lout) - ^(ifq ,treg ,nil ,lout)))) - (set fvars (uni fvars frag.fvars)) - (set ffuns (uni ffuns frag.ffuns)))))))) - me.(maybe-free-treg treg oreg) - (new (frag oreg - (append code ^(,lout - ,*(maybe-mov oreg treg))) - fvars ffuns)))))) - -(defmeth compiler comp-prog1 (me oreg env form) - (tree-case form - ((prog1 fi . re) (let* ((igreg me.(alloc-treg)) - (fireg me.(maybe-alloc-treg oreg)) - (fi-frag me.(compile fireg env fi)) - (re-frag me.(comp-progn igreg env - (append re '(nil))))) - me.(maybe-free-treg fireg oreg) - me.(free-treg igreg) - (new (frag fireg - (append fi-frag.code - (maybe-mov fireg fi-frag.oreg) - re-frag.code) - (uni fi-frag.fvars re-frag.fvars) - (uni fi-frag.ffuns re-frag.ffuns))))) - ((prog1 fi) me.(compile oreg env fi)) - ((prog1) me.(compile oreg env nil)))) - -(defmeth compiler comp-quasi (me oreg env form) - (let ((qexp (expand-quasi form))) - me.(compile oreg env (expand qexp)))) - -(defmeth compiler comp-fun-form (me oreg env form) - (tree-bind (sym . args) form - (cond - ((= (len args) 2) - (iflet ((bin [%bin-op% sym])) - (set sym bin - form (cons sym args)))) - ((= (len args) 1) - (caseq sym - (- (set sym 'neg - form (cons sym args))) - ((identity + * min max) (return-from comp-fun-form - me.(compile oreg env (car args))))))) - (caseql sym - ((call apply usr:apply) - (let ((gopcode [%gcall-op% sym]) - (opcode [%call-op% sym])) - (tree-case (car args) - ((op arg . more) - (caseq op - (fun (cond - (more (compile-error form "excess args in fun form")) - ((bindable arg) - (let ((fbind env.(lookup-fun arg t))) - me.(comp-call-impl oreg env (if fbind opcode gopcode) - (if fbind fbind.loc me.(get-sidx arg)) - (cdr args)))) - ((and (consp arg) (eq (car arg) 'lambda)) - me.(comp-fun-form oreg env ^(,sym ,arg ,*(cdr args)))) - (t :))) - (lambda me.(comp-inline-lambda oreg env opcode - (car args) (cdr args))) - (t :))) - (arg me.(comp-call oreg env - (if (eq sym 'usr:apply) 'apply sym) args))))) - (ift me.(comp-ift oreg env form)) - (t (let* ((fbind env.(lookup-fun sym t)) - (cfrag me.(comp-call-impl oreg env (if fbind 'call 'gcall) - (if fbind fbind.loc me.(get-sidx sym)) - args))) - (pushnew sym cfrag.ffuns) - cfrag))))) - -(defmeth compiler comp-call (me oreg env opcode args) - (tree-bind (fform . fargs) args - (let* ((foreg me.(maybe-alloc-treg oreg)) - (ffrag me.(compile foreg env fform)) - (cfrag me.(comp-call-impl oreg env opcode ffrag.oreg fargs))) - me.(maybe-free-treg foreg oreg) - (new (frag cfrag.oreg - (append ffrag.code - cfrag.code) - (uni ffrag.fvars cfrag.fvars) - (uni ffrag.ffuns cfrag.ffuns)))))) - -(defmeth compiler comp-call-impl (me oreg env opcode freg args) - (let* ((aoregs nil) - (afrags (collect-each ((arg args)) - (let* ((aoreg me.(alloc-treg)) - (afrag me.(compile aoreg env arg))) - (if (nequal afrag.oreg aoreg) - me.(free-treg aoreg) - (push aoreg aoregs)) - afrag)))) - me.(free-tregs aoregs) - (new (frag oreg - ^(,*(mappend .code afrags) - (,opcode ,oreg ,freg ,*(mapcar .oreg afrags))) - [reduce-left uni afrags nil .fvars] - [reduce-left uni afrags nil .ffuns])))) - -(defmeth compiler comp-inline-lambda (me oreg env opcode lambda args) - (let ((reg-args args) apply-list-arg) - (when (eql opcode 'apply) - (unless args - (compile-error lambda "apply requires arguments")) - (set reg-args (butlast args) - apply-list-arg (car (last args)))) - me.(compile oreg env (expand (lambda-apply-transform lambda - reg-args - apply-list-arg - nil))))) - -(defmeth compiler comp-for (me oreg env form) - (mac-param-bind form (op inits (: (test nil test-p) . rets) incs . body) form - (let* ((treg me.(alloc-treg)) - (ifrag me.(comp-progn treg env inits)) - (tfrag (if test-p me.(compile oreg env test))) - (rfrag me.(comp-progn oreg env rets)) - (nfrag me.(comp-progn treg env incs)) - (bfrag me.(comp-progn treg env body)) - (lback (gensym "l")) - (lskip (gensym "l")) - (frags (build - (add ifrag) - (if test-p (add tfrag)) - (add rfrag nfrag bfrag)))) - me.(free-treg treg) - (new (frag rfrag.oreg - ^(,*ifrag.code - ,lback - ,*(if test-p - ^(,*tfrag.code - (if ,tfrag.oreg ,lskip))) - ,*bfrag.code - ,*nfrag.code - (jmp ,lback) - ,*(if test-p - ^(,lskip - ,*rfrag.code))) - [reduce-left uni frags nil .fvars] - [reduce-left uni frags nil .ffuns]))))) - -(defmeth compiler comp-tree-bind (me oreg env form) - (tree-bind (op params obj . body) form - (with-gensyms (obj-var) - (let ((expn (expand ^(let ((,obj-var ,obj)) - ,(expand-bind-mac-params ^',form - ^',(rlcp ^(,(car form)) - form) - params nil - obj-var t nil body))))) - me.(compile oreg env expn))))) - -(defmeth compiler comp-mac-param-bind (me oreg env form) - (mac-param-bind form (op context params obj . body) form - (with-gensyms (obj-var form-var) - (let ((expn (expand ^(let* ((,obj-var ,obj) - (,form-var ,context)) - ,(expand-bind-mac-params form-var - form-var - params nil - obj-var t nil body))))) - me.(compile oreg env expn))))) - -(defmeth compiler comp-tree-case (me oreg env form) - (mac-param-bind form (op obj . cases) form - (let* ((ncases (len cases)) - (nenv (new env up env co me)) - (obj-immut-var (cdar nenv.(extend-var (gensym)))) - (obj-var (cdar nenv.(extend-var (gensym)))) - (err-blk (gensym)) - (lout (gensym "l")) - (ctx-form ^',form) - (err-form ^',(rlcp ^(,(car form)) form)) - (treg me.(maybe-alloc-treg oreg)) - (objfrag me.(compile treg env obj)) - (cfrags (collect-each ((c cases) - (i (range 1))) - (mac-param-bind form (params . body) c - (let* ((src (expand ^(block ,err-blk - (set ,obj-var.sym - ,obj-immut-var.sym) - ,(expand-bind-mac-params - ctx-form err-form - params nil obj-var.sym : - err-blk - body)))) - (lerrtest (gensym "l")) - (lnext (gensym "l")) - (cfrag me.(compile treg nenv src))) - (new (frag treg - ^(,*cfrag.code - ,*(maybe-mov treg cfrag.oreg) - (ifq ,treg ,me.(get-dreg :) ,lout)) - cfrag.fvars - cfrag.ffuns)))))) - (allfrags (cons objfrag cfrags))) - me.(maybe-free-treg treg oreg) - (new (frag oreg - ^(,*objfrag.code - (frame ,nenv.lev ,nenv.v-cntr) - ,*(maybe-mov obj-immut-var.loc objfrag.oreg) - ,*(mappend .code cfrags) - (mov ,treg nil) - ,lout - ,*(maybe-mov oreg treg) - (end ,oreg)) - [reduce-left uni allfrags nil .fvars] - [reduce-left uni allfrags nil .ffuns]))))) - -(defmeth compiler comp-lisp1-value (me oreg env form) - (mac-param-bind form (op arg) form - (cond - ((bindable arg) - (let ((bind env.(lookup-lisp1 arg t))) - (cond - (bind - (new (frag bind.loc - nil - (if (typep bind 'vbinding) (list arg)) - (if (typep bind 'fbinding) (list arg))))) - ((not (boundp arg)) - (pushnew arg assumed-fun) - (new (frag oreg - ^((getf ,oreg ,me.(get-sidx arg))) - nil - (list arg)))) - ((special-var-p arg) - (new (frag oreg - ^((getv ,oreg ,me.(get-dreg arg))) - (list arg) - nil))) - (t (new (frag oreg - ^((getlx ,oreg ,me.(get-sidx arg))) - (list arg) - nil)))))) - (t me.(compile oreg env arg))))) - -(defmeth compiler comp-dwim (me oreg env form) - (mac-param-bind form (op obj . args) form - (let* ((l1-exprs (cdr form)) - (fun (car l1-exprs)) - (bind env.(lookup-lisp1 fun nil))) - me.(compile oreg env - (if (and (symbolp fun) - (not bind) - (not (boundp fun))) - (progn - (pushnew fun assumed-fun) - ^(,fun ,*(mapcar (op list 'sys:lisp1-value) (cdr l1-exprs)))) - ^(call ,*(mapcar (op list 'sys:lisp1-value) l1-exprs))))))) - -(defmeth compiler comp-prof (me oreg env form) - (mac-param-bind form (op . forms) form - (let ((bfrag me.(comp-progn oreg env forms))) - (new (frag oreg - ^((prof ,oreg) - ,*bfrag.code - (end ,bfrag.oreg)) - bfrag.fvars bfrag.ffuns))))) - -(defun misleading-ref-check (frag env form) - (each ((v frag.fvars)) - (when env.(lookup-var v) - (compile-warning form "cannot refer to lexical variable ~s" v))) - (each ((f frag.ffuns)) - (when env.(lookup-fun f) - (compile-warning form "cannot refer to lexical function ~s" f)))) - -(defmeth compiler comp-load-time-lit (me oreg env form) - (mac-param-bind form (op loaded-p exp) form - (if loaded-p - me.(compile oreg env ^(quote ,exp)) - (compile-in-toplevel me - (let* ((oreg me.(alloc-treg)) - (dreg me.(alloc-dreg)) - (exp me.(compile oreg (new env co me) exp)) - (lt-frag (new (frag dreg - ^(,*exp.code - (mov ,dreg ,exp.oreg)) - exp.fvars - exp.ffuns)))) - (misleading-ref-check exp env form) - me.(free-treg oreg) - (push lt-frag me.lt-frags) - (new (frag dreg nil))))))) - -(defun maybe-mov (to-reg from-reg) - (if (nequal to-reg from-reg) - ^((mov ,to-reg ,from-reg)))) - -(defun expand-quasi-mods (obj mods : form) - (let (plist num sep rng-ix scalar-ix-p flex gens) - (flet ((get-sym (exp) - (let ((gen (gensym))) - (push (list gen exp) gens) - gen))) - (for () (mods) ((pop mods)) - (let ((mel (car mods))) - (cond - ((keywordp mel) - (set plist mods) - (return)) - ((integerp mel) - (when num - (compile-error form "duplicate modifier (width/alignment): ~s" - num)) - (set num mel)) - ((stringp mel) - (when sep - (compile-error form "duplicate modifier (separator): ~s" - num)) - (set sep mel)) - ((atom mel) - (push (get-sym mel) flex)) - (t - (caseq (car mel) - (dwim - (when rng-ix - (compile-error form "duplicate modifier (range/index): ~s" - mel)) - (unless (consp (cdr mel)) - (compile-error form "missing argument in range/index: ~s" - mel)) - (unless (null (cddr mel)) - (compile-error form "excess args in range/index: ~s" - num)) - (let ((arg (cadr mel))) - (cond - ((and (consp arg) (eq (car arg) 'range)) - (set rng-ix (get-sym ^(rcons ,(cadr arg) ,(caddr arg))))) - (t - (set rng-ix (get-sym arg)) - (set scalar-ix-p t))))) - (sys:expr (push (get-sym flex) (cadr mel))) - (t (push (get-sym mel) flex))))))) - (let ((mcount (+ (if num 1 0) - (if sep 1 0) - (if rng-ix 1 0) - (len flex)))) - (when (> mcount 3) - (compile-error form "too many formatting modifiers")) - ^(alet ,(nreverse gens) - ,(if flex - ^(sys:fmt-flex ,obj ',plist - ,*(remq nil (list* num sep - (if scalar-ix-p - ^(rcons ,rng-ix nil) - rng-ix) - (nreverse flex)))) - (cond - (plist ^(sys:fmt-simple ,obj ,num ,sep, rng-ix ',plist)) - (rng-ix ^(sys:fmt-simple ,obj ,num ,sep, rng-ix)) - (sep ^(sys:fmt-simple ,obj ,num ,sep)) - (num ^(sys:fmt-simple ,obj ,num)) - (t ^(sys:fmt-simple ,obj ,num))))))))) - -(defun expand-quasi-args (form) - (append-each ((el (cdr form))) - (cond - ((consp el) - (caseq (car el) - (sys:var (mac-param-bind form (sym exp : mods) el - (list (expand-quasi-mods exp mods)))) - (sys:quasi (expand-quasi-mods el)) - (t (list ^(sys:fmt-simple ,el))))) - ((bindable el) - (list ^(sys:fmt-simple ,el))) - (t - (list el))))) - -(defun expand-quasi (form) - (let ((qa (expand-quasi-args form))) - ^(sys:fmt-join ,*qa))) - -(defun expand-dohash (form) - (mac-param-bind form (op (key-var val-var hash-form : res-form) . body) form - (with-gensyms (iter-var cell-var) - ^(let (,key-var ,val-var (,iter-var (hash-begin ,hash-form)) ,cell-var) - (sys:for-op ((sys:setq ,cell-var (hash-next ,iter-var))) - (,cell-var ,res-form) - ((sys:setq ,cell-var (hash-next ,iter-var))) - (sys:setq ,key-var (car ,cell-var)) - (sys:setq ,val-var (cdr ,cell-var)) - ,*body))))) - -(defun expand-each (form env) - (mac-param-bind form (op each-type vars . body) form - (unless vars - (set vars [mapcar car env.vb])) - (let* ((gens (mapcar (ret (gensym)) vars)) - (out (if (member each-type '(collect-each append-each)) - (gensym))) - (accum (if out (gensym)))) - ^(let* (,*(zip gens vars) ,*(if accum ^((,out (cons nil nil)) (,accum ,out)))) - (sys:for-op () - ((and ,*gens) ,*(if accum ^((cdr ,out)))) - (,*(mapcar (ret ^(sys:setq ,@1 (cdr ,@1))) gens)) - ,*(mapcar (ret ^(sys:setq ,@1 (car ,@2))) vars gens) - ,*(caseq each-type - (collect-each ^((rplacd ,accum (cons (progn ,*body) nil)) - (sys:setq ,accum (cdr ,accum)))) - (append-each ^((rplacd ,accum (append (cdr ,accum) (progn ,*body))) - (sys:setq ,accum (last ,accum)))) - (t body))))))) - -(defun expand-bind-mac-params (ctx-form err-form params menv-var - obj-var strict err-block body) - (let (gen-stk stmt vars) - (labels ((get-gen () - (or (pop gen-stk) (gensym))) - (put-gen (g) - (push g gen-stk)) - (expand-rec (par-syntax obj-var check-var) - (labels ((emit-stmt (form) - (when form - (if check-var - (push ^(when ,check-var ,form) stmt) - (push form stmt)))) - (emit-var (sym init-form) - (push (if stmt - (prog1 - ^(,sym (progn ,*(nreverse stmt) - ,(if check-var - ^(when ,check-var ,init-form) - init-form))) - (set stmt nil)) - ^(,sym ,(if check-var - ^(when ,check-var ,init-form) - init-form))) - vars))) - (let ((pars (new (mac-param-parser par-syntax ctx-form)))) - (progn - (cond - ((eq strict t) - (emit-stmt - ^(sys:bind-mac-check ,err-form ',par-syntax - ,obj-var ,pars.nreq - ,(unless pars.rest - pars.nfix)))) - ((null strict)) - ((symbolp strict) - (emit-stmt - (let ((len-expr ^(if (consp ,obj-var) - (len ,obj-var) 0))) - (if pars.rest - ^(unless (<= ,pars.nreq ,len-expr) - (return-from ,err-block ',strict)) - ^(unless (<= ,pars.nreq ,len-expr ,pars.nfix) - (return-from ,err-block ',strict))))))) - (each ((k pars.key)) - (tree-bind (key . sym) k - (caseq key - (:whole (emit-var sym obj-var)) - (:form (emit-var sym ctx-form)) - (:env (emit-var sym menv-var))))) - (each ((p pars.req)) - (cond - ((listp p) - (let ((curs (get-gen))) - (emit-stmt ^(set ,curs (car ,obj-var))) - (emit-stmt ^(set ,obj-var (cdr ,obj-var))) - (expand-rec p curs check-var) - (put-gen curs))) - (t - (emit-var p ^(car ,obj-var)) - (emit-stmt ^(set ,obj-var (cdr ,obj-var)))))) - (each ((o pars.opt)) - (tree-bind (p : init-form pres-p) o - (cond - ((listp p) - (let* ((curs (get-gen)) - (stmt ^(cond - (,obj-var - (set ,curs (car ,obj-var)) - (set ,obj-var (cdr ,obj-var)) - ,*(if pres-p '(t))) - (t - (set ,curs ,init-form) - ,*(if pres-p '(nil)))))) - (if pres-p - (emit-var pres-p stmt) - (emit-stmt stmt)) - (let ((cv (gensym))) - (emit-var cv curs) - (expand-rec p curs cv) - (put-gen curs)))) - (t - (cond - (pres-p - (emit-var p nil) - (emit-var pres-p - ^(cond - (,obj-var - (set ,p (car ,obj-var)) - (set ,obj-var (cdr ,obj-var)) - ,(if pres-p t)) - (t - ,(if init-form - ^(set ,p ,init-form)) - ,(if pres-p nil))))) - (t - (emit-var p ^(if ,obj-var - (prog1 - (car ,obj-var) - (set ,obj-var (cdr ,obj-var))) - (if ,init-form ,init-form))))))))) - (when pars.rest - (emit-var pars.rest obj-var))))))) - (expand-rec params obj-var nil) - (when stmt - (push ^(,(gensym) (progn ,*(nreverse stmt))) vars)) - ^(let* (,*gen-stk ,*(nreverse vars)) - ,*body)))) - -(defun expand-defvarl (form) - (mac-param-bind form (op sym : value) form - (with-gensyms (cell) - ^(let ((,cell (sys:rt-defvarl ',sym))) - (if ,cell - (usr:rplacd ,cell (cons ',sym ,value))) - ',sym)))) - -(defun expand-defun (form) - (mac-param-bind form (op name args . body) form - (flet ((mklambda (block-name) - ^(lambda ,args (block ,block-name ,*body)))) - (cond - ((bindable name) - ^(sys:rt-defun ',name ,(mklambda name))) - ((consp name) - (caseq (car name) - (meth - (mac-param-bind form (meth type slot) name - ^(sys:define-method ',type ',slot ,(mklambda slot)))) - (macro - (mac-param-bind form (macro sym) name - ^(sys:rt-defmacro ',sym ',name ,(mklambda sym)))) - (t (compile-error form "~s isn't a valid compound function name" - name)))) - (t (compile-error form "~s isn't a valid function name" name)))))) - -(defun expand-defmacro (form) - (mac-param-bind form (op name mac-args . body) form - (with-gensyms (form menv spine-iter) - (let ((exp-lam ^(lambda (,form ,menv) - (let ((,spine-iter (cdr ,form))) - ,(expand (expand-bind-mac-params form form mac-args - menv spine-iter - t nil - ^((sys:set-macro-ancestor - (block ,name ,*body) - ,form)))))))) - ^(progn - (sys:rt-defmacro ',name '(macro ,name) ,exp-lam) - ',name))))) - -(defun expand-defsymacro (form) - (mac-param-bind form (op name def) form - ^(sys:rt-defsymacro ',name ',def))) - -(defun lambda-apply-transform (lm-expr fix-arg-exprs apply-list-expr recursed) - (if (and (not recursed) - apply-list-expr - (constantp apply-list-expr)) - (let* ((apply-list-val (eval apply-list-expr)) - (apply-atom (nthlast 0 apply-list-val)) - (apply-fixed (butlastn 0 apply-list-val))) - (lambda-apply-transform lm-expr (append fix-arg-exprs - (mapcar (ret ^',@1) apply-fixed)) - ^',apply-atom t)) - (mac-param-bind lm-expr (lambda lm-args . lm-body) lm-expr - (let* ((pars (new (fun-param-parser lm-args lm-expr))) - (fix-vals (mapcar (ret (gensym)) fix-arg-exprs)) - (ign-sym (gensym)) - (al-val (gensym)) - (shadow-p (let ((all-vars (append pars.req pars.(opt-syms) - (if pars.rest (list pars.rest))))) - (or (isec all-vars fix-arg-exprs) - (member apply-list-expr all-vars))))) - ^(,(if shadow-p 'let 'alet) ,(zip fix-vals fix-arg-exprs) - (let* ,(build - (if apply-list-expr - (add ^(,al-val ,apply-list-expr))) - (while (and fix-vals pars.req) - (add ^(,(pop pars.req) ,(pop fix-vals)))) - (while (and fix-vals pars.opt) - (tree-bind (var-sym : init-form have-sym) (pop pars.opt) - (add ^(,var-sym ,(pop fix-vals))) - (if have-sym - (add ^(,have-sym t))))) - (cond - ((and (null pars.req) - (null pars.opt)) - (if fix-vals - (if pars.rest - (add ^(,pars.rest (list* ,*fix-arg-exprs ,apply-list-expr))) - (lambda-too-many-args lm-expr)) - (when (or pars.rest apply-list-expr) - (add ^(,(or pars.rest ign-sym) ,apply-list-expr))))) - ((and fix-vals apply-list-expr) - (lambda-too-many-args lm-expr)) - (apply-list-expr - (when pars.req - (add ^(,ign-sym (if (< (len ,al-val) ,(len pars.req)) - (lambda-short-apply-list))))) - (while pars.req - (add ^(,(pop pars.req) (pop ,al-val)))) - (while pars.opt - (tree-bind (var-sym : init-form have-sym) (pop pars.opt) - (cond - (have-sym - (add ^(,var-sym (if ,al-val - (car ,al-val) - ,init-form))) - (add ^(,have-sym (when ,al-val - (pop ,al-val) - t)))) - (t (add ^(,var-sym (if ,al-val - (pop ,al-val) - ,init-form))))))) - (when pars.rest - (add ^(,pars.rest ,al-val)))) - (pars.req - (lambda-too-few-args lm-expr)) - (pars.opt - (while pars.opt - (tree-bind (var-sym : init-form have-sym) (pop pars.opt) - (add ^(,var-sym ,init-form)) - (if have-sym - (add ^(,have-sym))))) - (when pars.rest - (add ^(,pars.rest)))))) - ,*lm-body)))))) - -(defun system-symbol-p (sym) - (member (symbol-package sym) - (load-time (list user-package system-package)))) - -(defun usr:compile-toplevel (exp : (expanded-p nil)) - (let ((co (new compiler)) - (as (new assembler)) - (*dedup* (or *dedup* (hash)))) - (let* ((oreg co.(alloc-treg)) - (xexp (if expanded-p - exp - (unwind-protect - (expand* exp) - (unless *load-recursive* - (release-deferred-warnings))))) - (frag co.(compile oreg (new env co co) xexp))) - co.(free-treg oreg) - co.(check-treg-leak) - as.(asm ^(,*(mappend .code (nreverse co.lt-frags)) ,*frag.code (end ,frag.oreg))) - (vm-make-desc co.nlev (succ as.max-treg) as.buf co.(get-datavec) co.(get-symvec))))) - -(defun compiler-emit-warnings () - (let ((warn-fun [keep-if boundp (zap assumed-fun)])) - (when warn-fun - (usr:catch - (throw 'warning - `uses of @{warn-fun ", "} compiled as functions,\ - \ then defined as vars`) - (continue ()))))) - -(defvarl %file-suff-rx% #/[.][^\\\/.]+/) - -(defvar *emit*) - -(defvar *eval*) - -(defvarl %big-endian% (equal (ffi-put 1 (ffi uint32)) #b'00000001')) - -(defvarl %tlo-ver% ^(5 0 ,%big-endian%)) - -(defvarl %package-manip% '(make-package delete-package - use-package unuse-package - set-package-fallback-list - intern unintern rehome-sym - use-sym unuse-sym)) - -(defun open-compile-streams (in-path out-path test-fn) - (let* ((parent (or *load-path* "")) - (sep [path-sep-chars 0]) - (in-path (if (pure-rel-path-p in-path) - `@(dir-name parent)@sep@{in-path}` - in-path)) - (rsuff (r$ %file-suff-rx% in-path)) - (suff (if rsuff [in-path rsuff])) - (ip-nosuff (if rsuff [in-path 0..(from rsuff)] in-path)) - in-stream out-stream) - (cond - ((ends-with ".txr" in-path) - (error "~s: cannot compile TXR files" 'compile-file)) - ((ends-with ".tl" in-path) - (set in-stream (ignerr (open-file in-path)) - out-path (or out-path `@{in-path [0..-3]}.tlo`))) - (t - (set in-stream (or (ignerr (open-file `@{in-path}.tl`)) - (ignerr (open-file in-path))) - out-path (or out-path `@{in-path}.tlo`)))) - - (unless in-stream - (error "~s: unable to open input file ~s" 'compile-file in-path)) - - (unless [test-fn in-stream out-path] - (close-stream in-stream) - (return-from open-compile-streams nil)) - - (set out-stream (ignerr (open-file out-path "w"))) - - (unless out-stream - (close-stream in-stream) - (error "~s: unable to open output file ~s" 'compile-file in-stream)) - - (list in-stream out-stream out-path))) - -(defun list-from-vm-desc (vd) - (list (sys:vm-desc-nlevels vd) - (sys:vm-desc-nregs vd) - (sys:vm-desc-bytecode vd) - (copy (sys:vm-desc-datavec vd)) - (sys:vm-desc-symvec vd))) - -(defmacro usr:with-compilation-unit (. body) - (with-gensyms (rec) - ^(let* ((,rec sys:*load-recursive*) - (sys:*load-recursive* t) - (*dedup* (or *dedup* (hash)))) - (unwind-protect - (progn ,*body) - (unless ,rec - (release-deferred-warnings) - (compiler-emit-warnings)))))) - -(defun dump-to-tlo (out-stream out) - (let* ((*print-circle* t) - (*package* (sys:make-anon-package)) - (out-forms (split* out.(get) (op where (op eq :fence))))) - (prinl %tlo-ver% out-stream) - [mapdo (op prinl @1 out-stream) out-forms] - (delete-package *package*))) - -(defun propagate-perms (in-stream out-stream) - (let ((sti (stat in-stream))) - (when (plusp (logand sti.mode s-ixusr)) - (let ((mode "+x") - (suid (if (plusp (logand sti.mode s-isuid)) ",u+s")) - (sgid (if (and (plusp (logand sti.mode s-isgid)) - (plusp (logand sti.mode s-ixgrp))) ",g+s"))) - (when (or suid sgid) - (let ((sto (stat out-stream))) - (set mode (append mode - (if (eql sti.uid sto.uid) suid) - (if (eql sti.gid sto.gid) sgid))))) - (chmod out-stream mode))))) - -(defun compile-file-conditionally (in-path out-path test-fn) - (whenlet ((success nil) - (perms nil) - (streams (open-compile-streams in-path out-path test-fn))) - (with-resources ((in-stream (car streams) (close-stream in-stream)) - (out-stream (cadr streams) (progn - (when perms - (propagate-perms in-stream - out-stream)) - (close-stream out-stream) - (unless success - (remove-path (caddr streams)))))) - (let* ((err-ret (gensym)) - (*package* *package*) - (*emit* t) - (*eval* t) - (*load-path* (stream-get-prop (car streams) :name)) - (*rec-source-loc* t) - (out (new list-builder))) - (with-compilation-unit - (iflet ((line (get-line in-stream)) - ((starts-with "#!" line))) - (progn - (set line `@line `) - (upd line (regsub #/--lisp[^\-]/ (ret `--compiled@[@1 -1]`))) - (put-line (butlast line) out-stream) - (set perms t)) - (seek-stream in-stream 0 :from-start)) - (labels ((compile-form (unex-form) - (let* ((form (macroexpand unex-form)) - (sym (if (consp form) (car form)))) - (caseq sym - (progn [mapdo compile-form (cdr form)]) - (compile-only (let ((*eval* nil)) - [mapdo compile-form (cdr form)])) - (eval-only (let ((*emit* nil)) - [mapdo compile-form (cdr form)])) - (sys:load-time-lit - (if (cadr form) - (compile-form ^(quote ,(caddr form))) - (compile-form (caddr form)))) - (t (when (and (or *eval* *emit*) - (not (constantp form))) - (let* ((vm-desc (compile-toplevel form)) - (flat-vd (list-from-vm-desc vm-desc)) - (fence (member sym %package-manip%))) - (when *eval* - (let ((pa *package-alist*)) - (sys:vm-execute-toplevel vm-desc) - (when (neq pa *package-alist*) - (set fence t)))) - (when (and *emit* (consp form)) - out.(add flat-vd) - (when fence - out.(add :fence)))))))))) - (unwind-protect - (whilet ((obj (read in-stream *stderr* err-ret)) - ((neq obj err-ret))) - (compile-form obj)) - (dump-to-tlo out-stream out)) - - (let ((parser (sys:get-parser in-stream))) - (when (> (sys:parser-errors parser) 0) - (error "~s: compilation of ~s failed" 'compile-file - (stream-get-prop in-stream :name))))) - (flush-stream out-stream) - (set success t)))))) - -(defun usr:compile-file (in-path : out-path) - [compile-file-conditionally in-path out-path tf]) - -(defun usr:compile-update-file (in-path : out-path) - [compile-file-conditionally in-path out-path [mapf path-newer fstat identity]]) - -(defun usr:dump-compiled-objects (out-stream . compiled-objs) - (symacrolet ((self 'dump-compiled-objects)) - (let ((out (new list-builder))) - (flet ((vm-from-fun (fun) - (unless (vm-fun-p fun) - (error "~s: not a vm function: ~s" self fun)) - (sys:vm-closure-desc (func-get-env fun)))) - (each ((obj compiled-objs)) - (let* ((vm-desc (typecase obj - (vm-desc obj) - (fun (vm-from-fun obj)) - (t (iflet ((fun (symbol-function obj))) - (vm-from-fun fun) - (error "~s: not a compiled object: ~s" - self obj))))) - (symvec (sys:vm-desc-symvec vm-desc))) - out.(add (list-from-vm-desc vm-desc)) - (when (isec symvec %package-manip%) - out.(add :fence))))) - (dump-to-tlo out-stream out)))) - -(defun sys:env-to-let (env form) - (when env - (let ((vb (env-vbindings env)) - (fb (env-fbindings env)) - (up (env-next env))) - (when vb - (set form ^(let ,(mapcar (tb ((a . d)) ^(,a ',d)) vb) ,form))) - (when fb - (let (lbind fbind) - (each ((pair fb)) - (tree-bind (a . d) pair - (let* ((fun-p (interp-fun-p d)) - (fe (if fun-p (func-get-env d))) - (lb-p (and fe (eq fe env))) - (fb-p (and fe (eq fe up)))) - (cond - (lb-p (push ^(,a ,(func-get-form d)) lbind)) - (fb-p (push ^(,a ,(func-get-form d)) fbind)) - (t (push ^(,a ',d) fbind)))))) - (when lbind - (set form ^(sys:lbind ,(nreverse lbind) ,form))) - (when fbind - (set form ^(sys:fbind ,(nreverse fbind) ,form))))) - (if up - (set form (sys:env-to-let up form))))) - form) - -(defun usr:compile (obj) - (typecase obj - (fun (tree-bind (indicator args . body) (func-get-form obj) - (let* ((form (sys:env-to-let (func-get-env obj) - ^(lambda ,args ,*body))) - (vm-desc (compile-toplevel form))) - (vm-execute-toplevel vm-desc)))) - (t (condlet - (((fun (symbol-function obj))) - (tree-bind (indicator args . body) (func-get-form fun) - (let* ((form (sys:env-to-let (func-get-env fun) - ^(lambda ,args ,*body))) - (vm-desc (compile-toplevel form)) - (comp-fun (vm-execute-toplevel vm-desc))) - (set (symbol-function obj) comp-fun)))) - (t (error "~s: cannot compile ~s" 'compile obj)))))) diff --git a/share/txr/stdlib/conv.tl b/share/txr/stdlib/conv.tl deleted file mode 100644 index 7a3551f9..00000000 --- a/share/txr/stdlib/conv.tl +++ /dev/null @@ -1,98 +0,0 @@ -;; Copyright 2016-2020 -;; Kaz Kylheku <kaz@kylheku.com> -;; Vancouver, Canada -;; All rights reserved. -;; -;; Redistribution and use in source and binary forms, with or without -;; modification, are permitted provided that the following conditions are met: -;; -;; 1. Redistributions of source code must retain the above copyright notice, this -;; list of conditions and the following disclaimer. -;; -;; 2. Redistributions in binary form must reproduce the above copyright notice, -;; this list of conditions and the following disclaimer in the documentation -;; and/or other materials provided with the distribution. -;; -;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -(defun sys:conv-let (. body) - ^(flet ((i (arg : radix) - (toint arg radix)) - (o (arg) - (toint arg 8)) - (x (arg) - (toint arg 16)) - (b (arg) - (toint arg 2)) - (c (arg) - (toint arg #\c)) - (r (arg) - (tofloat arg)) - (iz (arg : radix) - (tointz arg radix)) - (oz (arg) - (tointz arg 8)) - (xz (arg) - (tointz arg 16)) - (bz (arg) - (tointz arg 2)) - (cz (arg) - (tointz arg #\c)) - (rz (arg) - (tofloatz arg))) - ,*body)) - -(defun sys:do-conv (lfl mfl tfl nm list) - (while (and list lfl) - (set (car list) (call (car lfl) (car list))) - (set list (cdr list)) - (set lfl (cdr lfl))) - (dotimes (i nm) - (unless list - (return)) - (when mfl - (set (car list) (call (car mfl) (car list))) - (set mfl (cdr mfl))) - (set list (cdr list))) - (while (and list tfl) - (set (car list) (call (car tfl) (car list))) - (set list (cdr list)) - (set tfl (cdr tfl)))) - -(defun sys:conv-expand (form specs list-sym) - (mac-param-bind form (lead : mid trail) - (split* (mapcar [iff (op eq :) - identity - [iff (op eq '-) - (retf '(fun identity)) - (ret ^[identity ,@1])]] - specs) - (op where (op eq :))) - (let ((nl (length lead)) - (nt (length trail))) - (with-gensyms (i nm lfl mfl tfl) - (sys:conv-let - ^(let* ((,nm (- (length ,list-sym) ,(+ nl nt))) - (,lfl (list ,*lead)) - (,mfl (if (plusp ,nm) (repeat (list ,*mid)))) - (,tfl (list ,*trail))) - (sys:do-conv ,lfl ,mfl ,tfl ,nm ,list-sym))))))) - -(defmacro sys:conv (:form form (. specs) list-expr) - (cond - ((null specs) list-expr) - ((atom specs) - (throwf 'eval-error "~s: invalid conversion list: ~s" 'conv specs)) - (t (with-gensyms (list-sym) - ^(let ((,list-sym ,list-expr)) - ,(sys:conv-expand form specs list-sym) - ,list-sym))))) diff --git a/share/txr/stdlib/copy-file.tl b/share/txr/stdlib/copy-file.tl deleted file mode 100644 index 52125fd4..00000000 --- a/share/txr/stdlib/copy-file.tl +++ /dev/null @@ -1,216 +0,0 @@ -;; Copyright 2018-2020 -;; Kaz Kylheku <kaz@kylheku.com> -;; Vancouver, Canada -;; All rights reserved. -;; -;; Redistribution and use in source and binary forms, with or without -;; modification, are permitted provided that the following conditions are met: -;; -;; 1. Redistributions of source code must retain the above copyright notice, this -;; list of conditions and the following disclaimer. -;; -;; 2. Redistributions in binary form must reproduce the above copyright notice, -;; this list of conditions and the following disclaimer in the documentation -;; and/or other materials provided with the distribution. -;; -;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -(eval-only - (defsymacro copy-size 65536) - - (defpackage copy-file - (:fallback usr sys) - (:use-syms usr:perms usr:times usr:owner usr:symlinks)) - - (in-package copy-file)) - -(defstruct copy-path-opts () - perms times owner symlinks (euid (geteuid))) - -(defstruct copy-path-stack-node () - path stat new-p) - -(defun make-copy-path-opts (opt-list) - (if opt-list - (let (opts) - (each ((opt opt-list)) - (if (structp opt) - (set opts opt) - (progn - (unless opts - (set opts (new copy-path-opts))) - (caseql opt - (:perms (set opts.perms t)) - (:times (set opts.times t)) - (:owner (set opts.owner t)) - (:symlinks (set opts.symlinks t)) - (:all (set opts.perms t - opts.times t - opts.owner t - opts.symlinks t)) - (t (error "~s: unrecognized option ~s" 'copy-path opt)))))) - opts) - (load-time (new copy-path-opts)))) - -(defun copy-file (from-path to-path : preserve-perms preserve-times) - (with-resources ((buf (make-buf copy-size) - (buf-set-length buf 0) (buf-trim buf)) - (ist (open-file from-path "b") (close-stream ist)) - (ista (fstat ist)) - (ost (if (path-dir-p ista) - (throwf 'path-permission `~s: ~a is a directory` - 'copy-file from-path) - (open-file to-path "wb")) - (close-stream ost))) - (while (eql (len buf) copy-size) - (fill-buf-adjust buf 0 ist) - (put-buf buf 0 ost)) - (when preserve-perms - (chmod ost ista.mode)) - (when preserve-times - (flush-stream ost) - (utimes ost - ista.atime (or ista.atime-nsec 0) - ista.mtime (or ista.mtime-nsec 0))) - nil)) - -(defun copy-files (paths dest-dir : preserve-perms preserve-times) - (each ((path paths)) - (while t - (catch** - (return (copy-file path (path-cat dest-dir (base-name path)) - preserve-perms preserve-times)) - (skip `skip copying @path` (exc . args) (return)) - (retry `retry copying @path` (exc . args)))))) - -(defun do-tweak-obj (to-path st opts link-p) - (when (and opts.perms (not link-p)) - (chmod to-path st.mode)) - (when opts.times - (lutimes to-path - st.atime (or st.atime-nsec 0) - st.mtime (or st.mtime-nsec 0))) - (when (and opts.owner - (or (zerop opts.euid) - (and (path-mine-p st) - (path-my-group-p st)))) - (lchown to-path st.uid st.gid))) - -(defun do-copy-obj (from-path to-path st opts) - (let ((type (logand st.mode s-ifmt)) - (initial-perms (if opts.perms #o700 #o777)) - (tweak t)) - (caseql* type - (s-ifreg - (copy-file from-path to-path opts.perms opts.times)) - (s-ifsock - (mknod to-path (logior type initial-perms))) - (s-ififo - (mkfifo to-path initial-perms)) - (s-iflnk - (if opts.symlinks - (symlink (readlink from-path) to-path) - (progn - (do-copy-obj from-path to-path (stat from-path) opts) - (set tweak nil)))) - ((s-ifblk s-ifchr) - (mknod to-path (logior type initial-perms) st.rdev)) - (s-ifdir - (ensure-dir to-path))) - (when tweak - (do-tweak-obj to-path st opts (eq type s-iflnk))))) - -(defun copy-path-rec (from-dir to-dir . opt-list) - (let* ((opts (make-copy-path-opts opt-list)) - (dir-stack nil)) - (unwind-protect - (ftw from-dir - (lambda (path type stat . rest) - (while t - (catch** - (let* ((rel-path (let ((p [path (len from-dir)..:])) - (if (pure-rel-path-p p) p [p 1..:]))) - (tgt-path (path-cat to-dir rel-path))) - (unless (starts-with from-dir path) - (error "~s: problem with directory traversal" 'copy-path)) - (caseql* type - ((ftw-dnr ftw-ns) (error "~s: unable to access ~s" - 'copy-path path)) - (ftw-d (let ((new-p (ensure-dir tgt-path))) - (whilet ((top (car dir-stack)) - ((and top - (not (starts-with tgt-path - top.path))))) - (do-tweak-obj top.path top.stat opts nil) - (pop dir-stack)) - (push (new copy-path-stack-node - path tgt-path - stat stat - new-p new-p) - dir-stack))) - (t (iflet ((cur (car dir-stack))) - (unless cur.new-p - (remove-path tgt-path))) - (do-copy-obj path tgt-path stat opts))) - (return)) - (skip `skip copying @path` (exc . args) (return)) - (retry `retry copying @path` (exc . args))))) - ftw-phys) - (whilet ((top (pop dir-stack))) - (do-tweak-obj top.path top.stat opts nil))))) - -(defun remove-path-rec (path) - (ftw path - (lambda (path type stat . rest) - (while t - (catch** - (return - (caseql* type - ((ftw-dnr ftw-ns) (error "~s: unable to access ~s" - 'remove-rec path)) - (ftw-dp (rmdir path)) - (t (remove-path path)))) - (skip `skip removing @path` (exc . args) (return)) - (retry `retry copying @path` (exc . args))))) - (logior ftw-phys ftw-depth))) - -(defun chmod-rec (path perm) - (ftw path - (lambda (path type stat . rest) - (while t - (catch** - (return - (caseql* type - ((ftw-dnr ftw-ns) (error "~s: unable to access ~s" - 'remove-rec path)) - (ftw-sl) - (t (chmod path perm)))) - (skip `skip chmod @path` (exc . args) (return)) - (retry `retry chmod @path` (exc . args))))) - (logior ftw-phys))) - -(defun chown-rec (path uid gid) - (ftw path - (lambda (path type stat . rest) - (while t - (catch** - (return - (caseql* type - ((ftw-dnr ftw-ns) (error "~s: unable to access ~s" - 'remove-rec path)) - (t (lchown path uid gid)))) - (skip `skip chown @path` (exc . args) (return)) - (retry `retry chown @path` (exc . args))))) - (logior ftw-phys))) - -(eval-only - (merge-delete-package 'sys)) diff --git a/share/txr/stdlib/debugger.tl b/share/txr/stdlib/debugger.tl deleted file mode 100644 index 225d8207..00000000 --- a/share/txr/stdlib/debugger.tl +++ /dev/null @@ -1,102 +0,0 @@ -;; Copyright 2019-2020 -;; Kaz Kylheku <kaz@kylheku.com> -;; Vancouver, Canada -;; All rights reserved. -;; -;; Redistribution and use in source and binary forms, with or without -;; modification, are permitted provided that the following conditions are met: -;; -;; 1. Redistributions of source code must retain the above copyright notice, this -;; list of conditions and the following disclaimer. -;; -;; 2. Redistributions in binary form must reproduce the above copyright notice, -;; this list of conditions and the following disclaimer in the documentation -;; and/or other materials provided with the distribution. -;; -;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -(defmacro with-disabled-debugging (. forms) - (let ((state (gensym))) - ^(let ((,state (dbg-clear dbg-all))) - (unwind-protect - (progn ,*forms) - (dbg-restore ,state))))) - -(defun make-command-env (command-table) - (let ((env (make-env ))) - (mapdo (ado env-vbind env @1 ^(,@2)) command-table) - env)) - -(defparml %dbg-commands% '((usr:? debugger-help "list command summary") - (usr:bt print-backtrace "print backtrace"))) - -(defparml %dbg-command-env% (make-command-env %dbg-commands%)) - -(defun debugger-help () - (mapdo (ap pprinl `@{@1 15} @3`) %dbg-commands%)) - -(defmeth fcall-frame loc (fr)) - -(defmeth fcall-frame print-trace (fr pr-fr nx-fr prefix) - (let* ((fun fr.fun) - (args fr.args) - (name (if (functionp fun) - (func-get-name fun))) - (loc (if nx-fr nx-fr.(loc))) - (kind - (cond - ((interp-fun-p fun) "I") - ((vm-fun-p fun) "V") - ((functionp fun) "C") - (t "O")))) - (put-string `@prefix @kind:@(if loc `(@loc):`)`) - (prinl ^[,(or name fun) ,*args]))) - -(defmeth eval-frame loc (fr) - (source-loc-str fr.form)) - -(defmeth eval-frame print-trace (fr pr-fr nx-fr prefix) - (when (or (null nx-fr) - (and (typep pr-fr 'fcall-frame) - (not (interp-fun-p pr-fr.fun)) - (not (vm-fun-p pr-fr.fun)))) - (let* ((form fr.form) - (sym (if (consp form) (car form))) - (loc (source-loc-str form))) - (when sym - (put-string `@prefix E:@(if loc `(@loc):`)`) - (prinl (if (eq sym 'dwim) - ^[,(cadr form)] - ^(,sym))))))) - -(defmeth expand-frame print-trace (fr pr-fr nx-fr prefix) - (let* ((form fr.form) - (loc (source-loc-str form))) - (put-string `@prefix X:@(if loc `(@loc):`)`) - (prinl form))) - -(defmeth expand-frame loc (fr) - (source-loc-str fr.form)) - -(defun print-backtrace (: (*stdout* *stdout*) (prefix "")) - (with-resources ((imode (set-indent-mode *stdout* indent-foff) - (set-indent-mode *stdout* imode)) - (depth (set-max-depth *stdout* 2) - (set-max-depth *stdout* depth)) - (length (set-max-length *stdout* 10) - (set-max-length *stdout* length))) - (window-mapdo 1 nil (lambda (pr el nx) el.(print-trace pr nx prefix)) - (find-frames-by-mask (logior uw-fcall uw-eval uw-expand))))) - -(defun debugger () - (with-disabled-debugging - (sys:repl nil *stdin* *stdout* %dbg-command-env%))) diff --git a/share/txr/stdlib/defset.tl b/share/txr/stdlib/defset.tl deleted file mode 100644 index 009a9ef8..00000000 --- a/share/txr/stdlib/defset.tl +++ /dev/null @@ -1,130 +0,0 @@ -;; Copyright 2019-2020 -;; Kaz Kylheku <kaz@kylheku.com> -;; Vancouver, Canada -;; All rights reserved. -;; -;; Redistribution and use in source and binary forms, with or without -;; modification, are permitted provided that the following conditions are met: -;; -;; 1. Redistributions of source code must retain the above copyright notice, this -;; list of conditions and the following disclaimer. -;; -;; 2. Redistributions in binary form must reproduce the above copyright notice, -;; this list of conditions and the following disclaimer in the documentation -;; and/or other materials provided with the distribution. -;; -;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - -(compile-only - (load-for (struct sys:param-parser-base "param"))) - -(defun mac-env-flatten (env) - (when env - (let ((lexvars [mapcar car - [keep-if (op eq 'sys:special) - (env-vbindings env) cdr]])) - (append (mac-env-flatten (env-next env)) lexvars)))) - -(defun analyze-params (params) - (let* ((env (gensym)) - (lam ^(lambda ,params - (macrolet ((,env (:env e) - (set (symbol-value ',env) e))) - (,env)))) - (explam (expand lam)) - (syms (mac-env-flatten (symbol-value env)))) - (list (cadr explam) syms))) - -(defun defset-expander-simple (macform get-fun set-fun) - (with-gensyms (getter setter params) - ^(defplace (,get-fun . ,params) body - (,getter ,setter - (let ((pgens (mapcar (ret (gensym)) ,params))) - ^(alet ,(zip pgens (list ,*params)) - (macrolet ((,,getter () ^(,',',get-fun ,*',pgens)) - (,,setter (val) ^(,',',set-fun ,*',pgens ,val))) - ,body))))))) - -(defun defset-expander (env macform name params newval setform) - (with-gensyms (getter setter args gpf-pairs gpr-pairs ext-pairs - pgens rgens egens all-pairs agens nvsym) - (let* ((ap (analyze-params params)) - (exp-params (car ap)) - (total-syms (cadr ap)) - (fp (new fun-param-parser form macform syntax exp-params)) - (fixpars (append fp.req fp.(opt-syms))) - (restpar (if (symbol-package fp.rest) fp.rest)) - (extsyms [keep-if symbol-package - (diff total-syms (cons restpar fixpars))]) - (xsetform ^^(alet ((,',nvsym ,,newval)) - ,,(expand ^(symacrolet ((,newval ',nvsym)) - ,setform) - env)))) - ^(defplace (,name . ,args) body - (,getter ,setter - (tree-bind ,params ,args - (let* ((,gpf-pairs (mapcar (op (fun list) (gensym)) (list ,*fixpars))) - (,gpr-pairs (if ',restpar - (if (consp ,restpar) - (mapcar (op (fun list) (gensym)) ,restpar) - (list (list (gensym) ,restpar))))) - (,ext-pairs (mapcar (op (fun list) (gensym)) (list ,*extsyms))) - (,pgens (mapcar (fun car) ,gpf-pairs)) - (,rgens (mapcar (fun car) ,gpr-pairs)) - (,egens (mapcar (fun car) ,ext-pairs)) - (,all-pairs (append ,gpf-pairs ,gpr-pairs ,ext-pairs)) - (,agens (collect-each ((a ,args)) - (let ((p (pos a ,all-pairs (fun eq) (fun cadr)))) - (if p - (car (del [,all-pairs p])) - a))))) - ^(alet (,*,gpf-pairs ,*,gpr-pairs ,*,ext-pairs) - ,(expand ^(symacrolet (,*(zip ',fixpars - (mapcar (ret ^',@1) ,pgens)) - ,*(zip ',extsyms - (mapcar (ret ^',@1) ,egens)) - ,*(if ,gpr-pairs - (if (consp ,restpar) - ^((,',restpar ',,rgens)) - ^((,',restpar ',(car ,rgens)))))) - (macrolet ((,,getter () ^(,',',name ,',*,agens)) - (,,setter (,',newval) - ,',xsetform)) - ,body)) - ,env))))))))) - -(defmacro usr:defset (:env e :form mf . args) - (tree-case args - ((name (. params) newval setform) - (defset-expander e mf . args)) - ((get-fun set-fun) - (defset-expander-simple mf get-fun set-fun)) - (x (compile-error mf "invalid syntax")))) - -(defset sub-list (list : (from 0) (to t)) items - ^(progn (set ,list (replace-list ,list ,items ,from ,to)) ,items)) - -(defset sub-vec (vec : (from 0) (to t)) items - ^(progn (replace-vec ,vec ,items ,from ,to) ,items)) - -(defset sub-str (str : (from 0) (to t)) items - ^(progn (replace-str ,str ,items ,from ,to) ,items)) - -(defset left (node) nleft - ^(progn (set-left ,node ,nleft) ,nleft)) - -(defset right (node) nright - ^(progn (set-right ,node ,nright) ,nright)) - -(defset key (node) nkey - ^(progn (set-key ,node ,nkey) ,nkey)) diff --git a/share/txr/stdlib/doloop.tl b/share/txr/stdlib/doloop.tl deleted file mode 100644 index 5cccd861..00000000 --- a/share/txr/stdlib/doloop.tl +++ /dev/null @@ -1,54 +0,0 @@ -;; Copyright 2017-2020 -;; Kaz Kylheku <kaz@kylheku.com> -;; Vancouver, Canada -;; All rights reserved. -;; -;; Redistribution and use in source and binary forms, with or without -;; modification, are permitted provided that the following conditions are met: -;; -;; 1. Redistributions of source code must retain the above copyright notice, this -;; list of conditions and the following disclaimer. -;; -;; 2. Redistributions in binary form must reproduce the above copyright notice, -;; this list of conditions and the following disclaimer in the documentation -;; and/or other materials provided with the distribution. -;; -;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -(defun sys:expand-doloop (f vars cexp body) - (let ((xvars (mapcar (tc - (((:whole w v i s . r)) - (if r (compile-error f "excess elements in ~s" w) w)) - (((:whole w v i . r)) - (if r - (compile-error f "bad variable clause syntax ~s" w) - ^(,v ,i ,i))) - (((:whole w v . r)) - (if r - (compile-error f "bad variable clause syntax ~s" w) - ^(,v nil ,v))) - ((v) ^(,v nil ,v))) - vars)) - (pllel (eq (car f) 'doloop))) - ^(,(if pllel 'for 'for*) - ,(mapcar (aret ^(,@1 ,@2)) xvars) - ,cexp - ((,(if pllel 'pset 'set) ,*(mappend (ado unless (eq @1 @3) - ^(,@1 ,@3)) - xvars))) - (tagbody ,*body)))) - -(defmacro doloop (:form f vars cexp . body) - (sys:expand-doloop f vars cexp body)) - -(defmacro doloop* (:form f vars cexp . body) - (sys:expand-doloop f vars cexp body)) diff --git a/share/txr/stdlib/error.tl b/share/txr/stdlib/error.tl deleted file mode 100644 index 1e946732..00000000 --- a/share/txr/stdlib/error.tl +++ /dev/null @@ -1,82 +0,0 @@ -;; Copyright 2017-2020 -;; Kaz Kylheku <kaz@kylheku.com> -;; Vancouver, Canada -;; All rights reserved. -;; -;; Redistribution and use in source and binary forms, with or without -;; modification, are permitted provided that the following conditions are met: -;; -;; 1. Redistributions of source code must retain the above copyright notice, this -;; list of conditions and the following disclaimer. -;; -;; 2. Redistributions in binary form must reproduce the above copyright notice, -;; this list of conditions and the following disclaimer in the documentation -;; and/or other materials provided with the distribution. -;; -;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -(defun sys:loc (ctx) - (iflet ((loc (source-loc-str (sys:ctx-form ctx)))) - `(@loc) ` "")) - -(defun compile-error (ctx fmt . args) - (let ((loc (sys:loc ctx)) - (name (sys:ctx-name ctx))) - (dump-deferred-warnings *stderr*) - (throwf 'eval-error `@loc~s: @fmt` name . args))) - -(defun compile-warning (ctx fmt . args) - (let ((loc (sys:loc ctx)) - (name (sys:ctx-name ctx))) - (usr:catch - (throwf 'warning `@loc~s: @fmt` name . args) - (continue ())))) - -(defun compile-defr-warning (ctx tag fmt . args) - (let ((loc (sys:loc ctx)) - (name (sys:ctx-name ctx))) - (usr:catch - (throw 'defr-warning (fmt `@loc~s: @fmt` name . args) tag) - (continue ())))) - -(defun sys:bind-mac-error (ctx-form params obj too-few-p) - (cond - ((atom obj) - (compile-error ctx-form "extra element ~s not matched by params ~a" - obj params)) - ((null obj) - (compile-error ctx-form "params ~a require arguments" params)) - (t (compile-error ctx-form "too ~a elements in ~s for params ~a" - (if too-few-p "few" "many") - obj params)))) - -(defun sys:bind-mac-check (ctx-form params obj req fix) - (if (and obj (atom obj)) - (compile-error ctx-form "extra element ~s not matched by params ~a" - obj params) - (let ((l (len obj))) - (iflet ((problem (cond - ((< l req) "few") - ((and fix (> l fix)) "many")))) - (if (zerop l) - (compile-error ctx-form "params ~a require arguments" params) - (compile-error ctx-form "too ~a elements in ~s for params ~a" - problem obj params)))))) - -(defun lambda-too-many-args (form) - (compile-error form "excess arguments given")) - -(defun lambda-too-few-args (form) - (compile-error form "inufficient arguments given")) - -(defun lambda-short-apply-list () - (throwf 'eval-error "~s: applied argument list too short" 'lambda)) diff --git a/share/txr/stdlib/except.tl b/share/txr/stdlib/except.tl deleted file mode 100644 index aa2c214a..00000000 --- a/share/txr/stdlib/except.tl +++ /dev/null @@ -1,88 +0,0 @@ -;; Copyright 2015-2020 -;; Kaz Kylheku <kaz@kylheku.com> -;; Vancouver, Canada -;; All rights reserved. -;; -;; Redistribution and use in source and binary forms, with or without -;; modification, are permitted provided that the following conditions are met: -;; -;; 1. Redistributions of source code must retain the above copyright notice, this -;; list of conditions and the following disclaimer. -;; -;; 2. Redistributions in binary form must reproduce the above copyright notice, -;; this list of conditions and the following disclaimer in the documentation -;; and/or other materials provided with the distribution. -;; -;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -(defun sys:handle-bad-syntax (item) - (throwf 'eval-error "~s: bad clause syntax: ~s" 'handle item)) - -(defmacro usr:catch (:form form :env e try-form . catch-clauses) - (let ((catch-syms [mapcar car catch-clauses]) - (sys-catch-clauses (mapcar (do mac-param-bind @1 (type args . body) @1 - (tree-bind (args-ex . body-ex) - (sys:expand-params args body - e nil form) - ^(,type (,(gensym) ,*args-ex) ,*body-ex))) - catch-clauses))) - ^(sys:catch ,catch-syms ,try-form nil ,*sys-catch-clauses))) - -(defmacro catch* (try-form . catch-clauses) - (let ((catch-syms [mapcar car catch-clauses])) - ^(sys:catch ,catch-syms ,try-form nil ,*catch-clauses))) - -(defmacro catch** (:env menv try-form . catch-clauses) - (let ((catch-syms [mapcar car catch-clauses]) - sys-catch-clauses descs) - (each ((cl catch-clauses)) - (mac-param-bind cl (type desc args . body) cl - (push ^(,type ,args ,*body) sys-catch-clauses) - (push desc descs))) - (sys:setq sys-catch-clauses (nreverse sys-catch-clauses)) - (sys:setq descs (nreverse descs)) - (let ((desc-expr (if [all descs (op constantp @1 menv)] - ^'(,*[mapcar eval descs]) - ^(list ,*descs)))) - ^(sys:catch ,catch-syms ,try-form ,desc-expr ,*sys-catch-clauses)))) - -(defun sys:expand-handle (form try-form handle-clauses) - (let* ((oper (car form)) - (exc-sym (gensym)) - (exc-args (gensym)) - (syms-fragments (collect-each ((hc handle-clauses)) - (tree-case hc - ((name arglist . body) - (unless (symbolp name) - (sys:handle-bad-syntax hc)) - (list name ^(apply (lambda ,arglist ,*body) - ,*(if (or (eq oper 'handle*) - (and (plusp sys:compat) - (<= 161 sys:compat))) - ^(,exc-sym)) - ,exc-args))) - (else (sys:handle-bad-syntax hc)))))) - ^(handler-bind (lambda (,exc-sym . ,exc-args) - (cond - ,*(mapcar (aret ^((exception-subtype-p ,exc-sym ',@1) ,@2)) - syms-fragments))) - ,[mapcar car syms-fragments] - ,try-form))) - -(defmacro handle (:form form try-form . handle-clauses) - (sys:expand-handle form try-form handle-clauses)) - -(defmacro handle* (:form form try-form . handle-clauses) - (sys:expand-handle form try-form handle-clauses)) - -(defmacro ignwarn (. forms) - ^(handler-bind (lambda (exc-sym arg) (throw 'continue)) (warning) ,*forms)) diff --git a/share/txr/stdlib/ffi.tl b/share/txr/stdlib/ffi.tl deleted file mode 100644 index a5748f3f..00000000 --- a/share/txr/stdlib/ffi.tl +++ /dev/null @@ -1,167 +0,0 @@ -;; Copyright 2017-2020 -;; Kaz Kylheku <kaz@kylheku.com> -;; Vancouver, Canada -;; All rights reserved. -;; -;; Redistribution and use in source and binary forms, with or without -;; modification, are permitted provided that the following conditions are met: -;; -;; 1. Redistributions of source code must retain the above copyright notice, this -;; list of conditions and the following disclaimer. -;; -;; 2. Redistributions in binary form must reproduce the above copyright notice, -;; this list of conditions and the following disclaimer in the documentation -;; and/or other materials provided with the distribution. -;; -;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -(defmacro sys:dlib-expr (spec) - (typecase spec - (null ^(dlopen)) - (str ^(dlopen ,spec rtld-now)) - (t spec))) - -(defmacro with-dyn-lib (lib . body) - (let ((keep-var (gensym "lib-"))) - ^(prog1 - (defvarl ,keep-var (sys:dlib-expr ,lib)) - (symacrolet ((sys:ffi-lib ,keep-var)) - ,*body)))) - -(defun sys:with-dyn-lib-check (f e ref) - (when (eq (macroexpand 'sys:ffi-lib e) 'sys:ffi-lib) - (compile-warning f "simple ref ~s requires ~s" - ref 'with-dyn-lib))) - -(defun sys:expand-sym-ref (f e exp) - (cond - ((stringp exp) - (sys:with-dyn-lib-check f e exp) - ^(dlsym-checked sys:ffi-lib ,exp)) - ((and (consp exp) (stringp (car exp))) - (mac-param-bind f (sym ver) exp - (sys:with-dyn-lib-check f e exp) - ^(dlvsym-checked sys:ffi-lib ,sym ,ver))) - (t exp))) - -(defun sys:analyze-argtypes (form argtypes) - (let ((p (posq : argtypes))) - (when p - (if (zerop p) - (compile-error form "variadic with zero fixed arguments not allowed") - (del [argtypes p]))) - (list* (length argtypes) p argtypes))) - - -(defmacro deffi (:form f :env e name fun-expr rettype argtypes) - (let ((fun-ref (sys:expand-sym-ref f e fun-expr)) - (ret-type-sym (gensym "ret-type-")) - (arg-types-sym (gensym "arg-types-")) - (call-desc-sym (gensym "call-desc-")) - (fun-sym (gensym "ffi-fun-"))) - (tree-bind (nargs nvariadic . argtypes) (sys:analyze-argtypes f argtypes) - (let ((arg-syms (take nargs (gun (gensym))))) - ^(progn - (defvarl ,ret-type-sym (ffi-type-compile ',rettype)) - (defvarl ,arg-types-sym [mapcar ffi-type-compile ',argtypes]) - (defvarl ,call-desc-sym (ffi-make-call-desc ,nargs ,nvariadic - ,ret-type-sym - ,arg-types-sym)) - (defvarl ,fun-sym ,fun-ref) - (defun ,name ,arg-syms - (ffi-call ,fun-sym ,call-desc-sym ,*arg-syms))))))) - -(defmacro deffi-type (name type-expr) - ^(ffi-typedef ',name (ffi-type-compile ',type-expr))) - -(defmacro typedef (name type-expr) - ^(ffi-typedef ',name (ffi-type-compile ',type-expr))) - -(defun sys:deffi-cb-expander (f name rettype argtypes safe-p abort-retval) - (let ((ret-type-sym (gensym "ret-type-")) - (arg-types-sym (gensym "arg-types-")) - (call-desc-sym (gensym "call-desc-")) - (fun-sym (gensym "fun-"))) - (tree-bind (nargs nvariadic . argtypes) (sys:analyze-argtypes f argtypes) - ^(progn - (defvarl ,ret-type-sym (ffi-type-compile ',rettype)) - (defvarl ,arg-types-sym [mapcar ffi-type-compile ',argtypes]) - (defvarl ,call-desc-sym (ffi-make-call-desc ,nargs ,nvariadic - ,ret-type-sym - ,arg-types-sym)) - (defun ,name (,fun-sym) - [ffi-make-closure ,fun-sym ,call-desc-sym ,safe-p ,abort-retval]))))) - -(defmacro deffi-cb (:form f name rettype argtypes : abort-retval) - (sys:deffi-cb-expander f name rettype argtypes t abort-retval)) - -(defmacro deffi-cb-unsafe (:form f name rettype argtypes) - (sys:deffi-cb-expander f name rettype argtypes nil nil)) - -(defmacro deffi-sym (:form f :env e name var-expr : type-sym) - (let ((var-ref (sys:expand-sym-ref f e var-expr))) - ^(defparml ,name ,(if type-sym - ^(cptr-cast ',type-sym ,var-ref) - var-ref)))) - -(defmacro deffi-var (:form f :env e name var-expr type) - (let ((var-ref (sys:expand-sym-ref f e var-expr)) - (type-sym (gensym "type-")) - (var-sym (gensym "var-"))) - ^(progn - (defvarl ,type-sym (ffi ,type)) - (defvarl ,var-sym (carray-cptr ,var-ref ,type-sym 1)) - (defsymacro ,name (carray-ref ,var-sym 0))))) - -(defmacro sizeof (type : (obj nil obj-p) :env menv) - (if obj-p - (if (constantp obj menv) - (sys:dyn-size (ffi-type-compile type) obj) - ^(sys:dyn-size (load-time (ffi-type-compile ',type)) ,obj)) - (ffi-size (ffi-type-compile type)))) - -(defmacro alignof (type) - (ffi-alignof (ffi-type-compile type))) - -(defmacro offsetof (struct memb) - (ffi-offsetof (ffi-type-compile struct) memb)) - -(defmacro arraysize (arr) - (ffi-arraysize (ffi-type-compile arr))) - -(defmacro elemtype (type) - ^(ffi-elemtype (ffi-type-compile ',type))) - -(defmacro elemsize (type) - (ffi-elemsize (ffi-type-compile type))) - -(defmacro ffi (type) - ^(ffi-type-compile ',type)) - -(define-accessor carray-ref carray-refset) - -(defset carray-sub (carray : (from 0) (to t)) items - (with-gensyms (it) - ^(alet ((,it ,items)) - (progn (carray-replace ,carray ,it ,from ,to) ,it)))) - -(defset sub-buf (buf : (from 0) (to t)) items - (with-gensyms (it) - ^(alet ((,it ,items)) - (progn (replace-buf ,buf ,it ,from ,to) ,it)))) - -(defmacro znew (type . pairs) - (if (oddp (length pairs)) - (throwf 'eval-error "~s: slot initform arguments must occur pairwise" - 'znew)) - (let ((qpairs (mappend (aret ^(',@1 ,@2)) (tuples 2 pairs)))) - ^(make-zstruct (ffi ,type) ,*qpairs))) diff --git a/share/txr/stdlib/getopts.tl b/share/txr/stdlib/getopts.tl deleted file mode 100644 index b98a76dc..00000000 --- a/share/txr/stdlib/getopts.tl +++ /dev/null @@ -1,407 +0,0 @@ -;; Copyright 2016-2020 -;; Kaz Kylheku <kaz@kylheku.com> -;; Vancouver, Canada -;; All rights reserved. -;; -;; Redistribution and use in source and binary forms, with or without -;; modification, are permitted provided that the following conditions are met: -;; -;; 1. Redistributions of source code must retain the above copyright notice, this -;; list of conditions and the following disclaimer. -;; -;; 2. Redistributions in binary form must reproduce the above copyright notice, -;; this list of conditions and the following disclaimer in the documentation -;; and/or other materials provided with the distribution. -;; -;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -(defex opt-error error) - -(defstruct opt-desc nil - short - long - helptext - arg-p - (type :bool) - (:static valid-types '(:bool :dec :hex :oct :cint :float :str :text)) - (:postinit (me) - me.(check) - (set me.arg-p (neq me.type :bool)))) - -(defstruct (sys:opt-parsed name arg desc : eff-type) nil - name - arg ;; string, integer, real, ... - desc ;; opt-desc - eff-type - cumul - (:postinit (me) me.(convert-type))) - -(defstruct opts nil - (opt-hash (hash :equal-based)) ;; string to sys:opt-parsed - in-args - out-args) - -(defstruct sys:opt-processor nil - od-list - (od-hash (hash :equal-based)) ;; string to opt-desc - opts - (:postinit (me) - me.(build-hash))) - -(defun sys:opt-err (. args) - (throwf 'opt-error . args)) - -(defun getopts-error (msg . args) - (error `~s: @msg` 'getopts . args)) - -(defun sys:opt-dash (name) - `@(if (> (length name) 1) "-")-@name`) - -(defmeth opt-desc basic-type-p (me type) - (or (functionp type) (fboundp type) (member type me.valid-types))) - -(defmeth opt-desc list-type-p (me type) - (tree-case type - ((indicator btype) (and (eq indicator 'list) - me.(basic-type-p btype))) - (x nil))) - -(defmeth opt-desc cumul-type-p (me type) - (tree-case type - ((indicator btype) (and (eq indicator 'usr:cumul) - (or me.(basic-type-p btype) - me.(list-type-p btype)))) - (x nil))) - -(defmeth opt-desc check (me) - (unless (or me.(basic-type-p me.type) - me.(list-type-p me.type) - me.(cumul-type-p me.type)) - (getopts-error "invalid option type specifier ~s" - me.type)) - (when me.long - (when (< (length me.long) 2) - (getopts-error "long option ~a has a short name" me.long)) - (when (eql [me.long 0] #\-) - (getopts-error "long option ~a starts with - character" me.long))) - (when me.short - (when (neq (length me.short) 1) - (getopts-error "short option ~a not one character long" me.short)) - (when (eql [me.short 0] #\-) - (getopts-error "short option ~a starts with - character" me.short)))) - -(defmeth sys:opt-parsed convert-type (me) - (let ((name (sys:opt-dash me.name)) - (type (or me.eff-type me.desc.type))) - (when (and (neq type :bool) - (eq me.arg :explicit-no)) - (sys:opt-err "Non-Boolean option ~a explicitly specified as false" name)) - (caseql type - (:bool - (set me.arg (neq me.arg :explicit-no))) - (:dec (set me.arg - (or (and (r^$ #/[+\-]?\d+/ me.arg) (int-str me.arg)) - (sys:opt-err "option ~a needs decimal integer arg, not ~a" - name me.arg)))) - (:hex (set me.arg - (or (and (r^$ #/[+\-]?[\da-fA-F]+/ me.arg) (int-str me.arg 16)) - (sys:opt-err "option ~a needs hexadecimal integer arg, not ~a" - name me.arg)))) - (:oct (set me.arg - (or (and (r^$ #/[+\-]?[0-7]+/ me.arg) (int-str me.arg 8)) - (sys:opt-err "option ~a needs octal integer arg, not ~a" - name me.arg)))) - (:cint (set me.arg - (cond - ((r^$ #/[+\-]?0x[\da-fA-F]+/ me.arg) - (int-str (regsub #/0x/ "" me.arg) 16)) - ((r^$ #/[+\-]?0[0-7]+/ me.arg) - (int-str me.arg 8)) - ((r^$ #/[+\-]?0[\da-fA-F]+/ me.arg) - (sys:opt-err "option ~a argument ~a non octal, but leading 0" - name me.arg)) - ((r^$ #/[+\-]?\d+/ me.arg) - (int-str me.arg)) - (t (sys:opt-err "option ~a needs C style numeric arg, not ~a" - name me.arg))))) - (:float (set me.arg - (cond - ([[chand (orf (f^$ #/[+\-]?\d+[.]?([Ee][+\-]?\d+)?/) - (f^$ #/[+\-]?\d*[.]?\d+([Ee][+\-]?\d+)?/)) - flo-str] me.arg]) - (t (sys:opt-err "option ~a needs floating-point arg, not ~a" - name me.arg))))) - (:str (set me.arg - (or (ignerr (read `"@{me.arg}"`)) - (sys:opt-err "option ~a needs string lit syntax, ~a given" - name me.arg)))) - (:text) - (t (cond - ((and (consp type) (eq (car type) 'list)) - (let* ((rec-type (cadr type)) - (pieces (split-str me.arg #/,/)) - (sub-opts (mapcar (do new (sys:opt-parsed me.name @1 - me.desc - rec-type)) - pieces))) - (set me.arg (mapcar (usl arg) sub-opts)))) - ((and (consp type) (eq (car type) 'cumul)) - (let* ((rec-type (cadr type)) - (sub-opt (new (sys:opt-parsed me.name me.arg - me.desc rec-type)))) - (set me.arg sub-opt.arg - me.cumul t))) - ((or (symbolp type) (functionp type)) - (set me.arg (call type me.arg)))))))) - -(defmeth opts lambda (me key : dfl) - (iflet ((o [me.opt-hash key])) o.arg dfl)) - -(defmeth opts lambda-set (me key val) - (iflet ((o [me.opt-hash key])) - (set o.arg val) - (error "opts: cannot set option ~s to ~s: no such option" key val))) - -(defmeth opts add-opt (me opt) - (when opt.cumul - (let* ((old-opt [me.opt-hash (or opt.desc.long - opt.desc.short)]) - (old-arg (if old-opt old-opt.arg))) - (set opt.arg (cons opt.arg old-arg)))) - (whenlet ((n opt.desc.short)) - (set [me.opt-hash n] opt)) - (whenlet ((n opt.desc.long)) - (set [me.opt-hash n] opt))) - -(defmeth sys:opt-processor build-hash (me) - (each ((od me.od-list)) - (unless (or od.long od.short) - (error "opt-processor: no short or long name in option ~s" od)) - (each ((str (list od.long od.short))) - (when (and str [me.od-hash str]) - (error "opt-processor: duplicate option ~s" str)) - (set [me.od-hash str] od)))) - -(defmeth sys:opt-processor parse-long (me opt : arg) - (iflet ((ieq (unless (stringp arg) (break-str opt "=")))) - (let ((oname [opt 0..ieq]) - (arg [opt (succ ieq)..:])) - me.(parse-long oname arg)) - (let ((od [me.od-hash opt]) - (opts me.opts)) - (cond - ((null od) - (sys:opt-err "unrecognized option: --~a" opt)) - ((and arg od.arg-p) - opts.(add-opt (new (sys:opt-parsed opt arg od)))) - ((stringp arg) - (sys:opt-err "option --~a doesn't take an argument" opt)) - (od.arg-p - (iflet ((arg (pop opts.out-args))) - opts.(add-opt (new (sys:opt-parsed opt arg od))) - (sys:opt-err "option --~a requires an argument" opt))) - (t opts.(add-opt (new (sys:opt-parsed opt arg od)))))))) - -(defmeth sys:opt-processor parse-shorts (me oarg) - (each ((o (split-str oarg #//))) - (iflet ((opts me.opts) - (od [me.od-hash o])) - (let ((arg (when od.arg-p - (when (> (length oarg) 1) - (sys:opt-err "argument -~a includes -~a, which does not clump" - oarg o)) - (unless opts.out-args - (sys:opt-err "option -~a requires an argument" o)) - (pop opts.out-args)))) - opts.(add-opt (new (sys:opt-parsed o arg od)))) - (sys:opt-err "unrecognized option: -~a" o)))) - -(defmeth sys:opt-processor parse-opts (me args) - (let ((opts me.opts)) - (whilet ((arg (pop opts.out-args))) - (cond - ((equal "--" arg) (return)) - ((r^ #/--no-/ arg) me.(parse-long [arg 5..:] :explicit-no)) - ((r^ #/--/ arg) me.(parse-long [arg 2..:])) - ((r^ #/-.+/ arg) me.(parse-shorts [arg 1..:])) - (t (push arg opts.out-args) - (return)))) - opts)) - -(defun sys:wdwrap (string columns) - (let ((words (tok-str string #/\S+/)) - line) - (build - (whilet ((word (pop words)) - (wpart (cond - ((and word (r^$ #/\w+[\w\-]*\w[.,;:!?"]?/ word)) - (split-str word #/-/)) - (word (list word)))) - (wpart-orig wpart)) - (whilet ((wp0 (eq wpart wpart-orig)) - (wp (pop wpart)) - (w (if wp `@wp@(if wpart "-")`))) - (cond - ((not line) - (set line w)) - ((> (+ (length line) (length w) 1) columns) - (add line) - (set line w)) - (t (set line `@line@(if wp0 " ")@w`))))) - (if line - (add line))))) - -(defun opt (short long : (type :bool) helptext) - (new opt-desc short short long long helptext helptext type type)) - -(defun getopts (opt-desc-list args) - (let* ((opts (new opts in-args args out-args args)) - (opr (new sys:opt-processor od-list opt-desc-list opts opts))) - opr.(parse-opts args))) - -(defun opthelp (opt-desc-list : (stream *stdout*)) - (let ((sorted [sort (copy-list (remove-if (op null @1.helptext) - opt-desc-list)) : - (do if @1.long @1.long @1.short)]) - (undocumented (keep-if (op null @1.helptext) opt-desc-list))) - (put-line "\nOptions:\n") - (each ((od sorted)) - (let* ((type (if (and (consp od.type) (eq (car od.type) 'cumul)) - (cadr od.type) - od.type)) - (tstr (cond - ((keywordp type) (upcase-str (symbol-name type))) - ((and (consp type) (eq (car type) 'list)) - (let ((ts (upcase-str (symbol-name (cadr type))))) - `@ts[,@ts...]`)) - (t "ARG"))) - (long (if od.long - `--@{od.long}@(if od.arg-p `=@tstr`)`)) - (short (if od.short - `-@{od.short}@(if od.arg-p ` @tstr`)`)) - (ls (cond - ((and long short) `@{long 21} (@short)`) - (long long) - (short `@{"" 21} @short`))) - (lines (if od.helptext (sys:wdwrap od.helptext 43)))) - (put-line ` @{ls 34}@(pop lines)`) - (while lines - (put-line ` @{"" 34}@(pop lines)`)))) - (put-line) - (when undocumented - (put-line "Undocumented options:\n") - (let* ((undoc-str `@{[mapcar sys:opt-dash - (flatten (mappend (op list @1.short @1.long) - undocumented))] ", "}`)) - (each ((line (sys:wdwrap undoc-str 75))) - (put-line ` @line`))) - (put-line)) - (put-line "Notes:\n") - (let* ((have-short (some sorted (usl short))) - (have-long (some sorted (usl long))) - (have-arg-p (some sorted (usl arg-p))) - (have-bool (some sorted (op eq @1.type :bool))) - (texts (list (if have-short - "Short options can be invoked with long syntax: \ \ - for example, --a can be used when -a exists.\ \ - Short no-argument options can be clumped into\ \ - one argument as exemplified by -xyz.") - (if have-bool - (if have-arg-p - "Options that take no argument are Boolean:" - (if undocumented - "All documented options are Boolean:" - "All options are Boolean:"))) - (if have-bool - "they are true when present, false when absent.") - (if (and have-bool have-arg-p) - "The --no- prefix can explicitly specify \ \ - Boolean options as false: if a Boolean option\ \ - X exists,\ \ - --no-X specifies it as false. This is useful\ \ - for making false those options which default\ \ - to true. " - "The --no- prefix can explicitly specify \ \ - options as false: if an X option exists,\ \ - --no-X specifies it as false. This is useful\ \ - for making false those options which default\ \ - to true. ") - (if (not have-long) - "Note the double dash on --no.") - (if (and have-short have-long) - "The --no- prefix can be applied to a short\ \ - or long option name.") - (if have-arg-p - "The argument to a long option can be given in one\ \ - argument as --option=arg or as a separate\ \ - argument using --option arg.") - "The special argument -- can be used where an option\ \ - may appear. It means \"end of options\": the\ \ - arguments which follow are not treated as options\ \ - even if they look like options."))) - (mapdo (do put-line ` @1`) - (sys:wdwrap `@{(flatten texts)}` 77))) - (put-line) - (whenlet ((types (keep-if [andf keywordp (op neq :bool)] - (uniq (mapcar (usl type) sorted))))) - (put-line "Type legend:\n") - (each ((ty types)) - (iflet ((ln (caseql ty - (:dec " DEC - Decimal integer: -123, 0, 5, +73") - (:hex " HEX - Hexadecimal integer -EF, 2D0, +9A") - (:oct " OCT - Octal integer: -773, 5677, +326") - (:cint " CINT - C-style integer: leading 0 octal,\ - \ leading 0x hex, else decimal;\n\ - \ leading sign allowed: -0777, 0xFDC, +123") - (:float " FLOAT - Floating-point: -1.3e+03, +5, 3.3,\ - \ 3., .5, .12e9, 53.e-3, 3e-015") - (:str " STR - String with embedded escapes, valid\ - \ as TXR Lisp string literals\n\ - \ syntax: foo, foo\\tbar, abc\\nxyz") - (:text " TEXT - Unprocessed text")))) - (put-line ln))) - (put-line)))) - - -(defstruct sys:option-base nil - in-args - out-args - (:static slot-hash) - (:static opt-desc-list) - (:method add-opt (me opt) - (let* ((sl [me.slot-hash (or opt.desc.long opt.desc.short)]) - (arg (if opt.cumul - (cons opt.arg (slot me sl)) - opt.arg))) - (slotset me sl arg))) - (:method getopts (me args) - (set me.in-args args me.out-args args) - (let ((opr (new sys:opt-processor od-list me.opt-desc-list opts me))) - opr.(parse-opts args))) - (:method opthelp (me : (stream *stdout*)) - (opthelp me.opt-desc-list stream))) - -(defmacro define-option-struct (name super-spec . opts) - (let* ((slots (mapcar (tb ((short long . rest)) - (or long short)) - opts)) - (supers (if (and super-spec (atom super-spec)) - (list super-spec) - super-spec))) - ^(defstruct ,name (,*supers sys:option-base) - ,*slots - (:static slot-hash #H(() ,*(mapcar [juxt symbol-name identity] slots))) - (:static opt-desc-list ',(mapcar (tb ((short long . rest)) - (opt (if short (symbol-name short)) - (if long (symbol-name long)) - . rest)) - opts))))) diff --git a/share/txr/stdlib/getput.tl b/share/txr/stdlib/getput.tl deleted file mode 100644 index daf08b1e..00000000 --- a/share/txr/stdlib/getput.tl +++ /dev/null @@ -1,132 +0,0 @@ -;; Copyright 2016-2020 -;; Kaz Kylheku <kaz@kylheku.com> -;; Vancouver, Canada -;; All rights reserved. -;; -;; Redistribution and use in source and binary forms, with or without -;; modification, are permitted provided that the following conditions are met: -;; -;; 1. Redistributions of source code must retain the above copyright notice, this -;; list of conditions and the following disclaimer. -;; -;; 2. Redistributions in binary form must reproduce the above copyright notice, -;; this list of conditions and the following disclaimer in the documentation -;; and/or other materials provided with the distribution. -;; -;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -(defun sys:get-buf-common (s bytes seek) - (let ((b (make-buf 0 0 (min bytes 4096))) - (o 0)) - (when (plusp seek) - (unless (ignerr (seek-stream s seek :from-current)) - (let ((b (make-buf (min seek 4096))) - (c 0)) - (while (< c seek) - (let ((p (fill-buf b 0 s))) - (if (zerop p) - (return)) - (inc c p)))))) - (while (or (null bytes) (< (len b) bytes)) - (let ((p (fill-buf-adjust b o s))) - (when (= p o) - (return)) - (set o p) - (when (eql p (buf-alloc-size b)) - (buf-set-length b (min (+ p p) bytes))))) - b)) - -(defun file-get (name) - (with-stream (s (open-file name)) - (read s))) - -(defun file-put (name obj) - (with-stream (s (open-file name "w")) - (prinl obj s))) - -(defun file-append (name obj) - (with-stream (s (open-file name "a")) - (prinl obj s))) - -(defun file-get-string (name) - (with-stream (s (open-file name)) - (get-string s))) - -(defun file-put-string (name string) - (with-stream (s (open-file name "w")) - (put-string string s))) - -(defun file-append-string (name string) - (with-stream (s (open-file name "a")) - (put-string string s))) - -(defun file-get-lines (name) - (get-lines (open-file name))) - -(defun file-put-lines (name lines) - (with-stream (s (open-file name "w")) - (put-lines lines s))) - -(defun file-append-lines (name lines) - (with-stream (s (open-file name "a")) - (put-lines lines s))) - -(defun file-get-buf (name : bytes (seek 0)) - (with-stream (s (open-file name "rb")) - (sys:get-buf-common s bytes seek))) - -(defun file-put-buf (name buf : (seek 0)) - (with-stream (s (open-file name "wb")) - (unless (zerop seek) - (seek-stream s seek :from-current)) - (put-buf buf 0 s))) - -(defun file-place-buf (name buf : (seek 0)) - (with-stream (s (open-file name "mb")) - (unless (zerop seek) - (seek-stream s seek :from-current)) - (put-buf buf 0 s))) - -(defun file-append-buf (name buf) - (with-stream (s (open-file name "ab")) - (put-buf buf 0 s))) - -(defun command-get (cmd) - (with-stream (s (open-command cmd)) - (read s))) - -(defun command-put (cmd obj) - (with-stream (s (open-command cmd "w")) - (prinl obj s))) - -(defun command-get-string (cmd) - (with-stream (s (open-command cmd)) - (get-string s))) - -(defun command-put-string (cmd string) - (with-stream (s (open-command cmd "w")) - (put-string string s))) - -(defun command-get-lines (cmd) - (get-lines (open-command cmd))) - -(defun command-put-lines (cmd lines) - (with-stream (s (open-command cmd "w")) - (put-lines lines s))) - -(defun command-get-buf (cmd : bytes (skip 0)) - (with-stream (s (open-command cmd "rb")) - (sys:get-buf-common s bytes skip))) - -(defun command-put-buf (cmd buf) - (with-stream (s (open-command cmd "wb")) - (put-buf buf 0 s))) diff --git a/share/txr/stdlib/hash.tl b/share/txr/stdlib/hash.tl deleted file mode 100644 index 96d2e705..00000000 --- a/share/txr/stdlib/hash.tl +++ /dev/null @@ -1,42 +0,0 @@ -;; Copyright 2015-2020 -;; Kaz Kylheku <kaz@kylheku.com> -;; Vancouver, Canada -;; All rights reserved. -;; -;; Redistribution and use in source and binary forms, with or without -;; modification, are permitted provided that the following conditions are met: -;; -;; 1. Redistributions of source code must retain the above copyright notice, this -;; list of conditions and the following disclaimer. -;; -;; 2. Redistributions in binary form must reproduce the above copyright notice, -;; this list of conditions and the following disclaimer in the documentation -;; and/or other materials provided with the distribution. -;; -;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -(defmacro with-hash-iter ((name hash-form : key val) . body) - (let ((hash (gensym)) - (iter (gensym)) - (next (gensym))) - ^(let* ((,hash ,hash-form) - (,iter (hash-begin ,hash)) - ,*(if key ^((,key))) - ,*(if val ^((,val)))) - (flet ((,name () - ,(if (not (or key val)) - ^(hash-next ,iter) - ^(let ((,next (hash-next ,iter))) - ,*(if key ^((set ,key (car ,next)))) - ,*(if val ^((set ,val (cdr ,next)))) - ,next)))) - ,*body)))) diff --git a/share/txr/stdlib/ifa.tl b/share/txr/stdlib/ifa.tl deleted file mode 100644 index c1c32538..00000000 --- a/share/txr/stdlib/ifa.tl +++ /dev/null @@ -1,82 +0,0 @@ -;; Copyright 2015-2020 -;; Kaz Kylheku <kaz@kylheku.com> -;; Vancouver, Canada -;; All rights reserved. -;; -;; Redistribution and use in source and binary forms, with or without -;; modification, are permitted provided that the following conditions are met: -;; -;; 1. Redistributions of source code must retain the above copyright notice, this -;; list of conditions and the following disclaimer. -;; -;; 2. Redistributions in binary form must reproduce the above copyright notice, -;; this list of conditions and the following disclaimer in the documentation -;; and/or other materials provided with the distribution. -;; -;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -(defmacro ifa (:env e :form f test then : else) - (flet ((candidate-p (form) - (not (or (constantp form e) (symbolp form))))) - (cond - ((or (atom test) (null (cdr test))) ^(let ((it ,test)) - (if it ,then ,else))) - ((member (first test) '(not null false)) - (unless (eql (length test) 2) - (compile-error f "wrong number of arguments to ~s" (first test))) - ^(ifa ,(second test) ,else ,then)) - (t (let* ((sym (first test)) - (args (if (eq 'dwim sym) (cddr test) (cdr test))) - (n-candidate-args [count-if candidate-p args]) - (pos-candidate (or [pos-if candidate-p args] 0))) - (unless (or (lexical-fun-p e sym) - (and (or (functionp (symbol-function sym)) - (eq sym 'dwim) - (null (symbol-function sym))))) - (compile-error f "test expression must be \ - \ a simple function call")) - (when (> n-candidate-args 1) - (compile-error f "ambiguous situation: \ - \ not clear what can be \"it\"")) - (iflet ((it-form (macroexpand [args pos-candidate] e)) - (is-place (place-form-p it-form e))) - (let ((before-it [args 0..pos-candidate]) - (after-it [args (succ pos-candidate)..:])) - (let* ((btemps (mapcar (ret (gensym)) before-it)) - (atemps (mapcar (ret (gensym)) after-it))) - ^(let (,*(zip btemps before-it)) - (placelet ((it ,it-form)) - (let (,*(zip atemps after-it)) - (if (,sym ,*(if (eq 'dwim sym) ^(,(second test))) - ,*btemps it ,*atemps) - ,then ,else)))))) - (let* ((temps (mapcar (ret (gensym)) args)) - (it-temp [temps pos-candidate])) - ^(let* (,*(zip temps args) (it ,it-temp)) - (if (,sym ,*(if (eq 'dwim sym) ^(,(second test))) - ,*temps) ,then ,else))))))))) - -(defmacro whena (test . body) - ^(ifa ,test (progn ,*body))) - -(defun sys:if-to-cond (f if-oper cond-oper pairs) - (tree-case pairs - (((test . forms) . rest) ^(,if-oper ,test (progn ,*forms) - (,cond-oper ,*rest))) - (() ()) - (else (compile-error f "bad syntax: ~s" pairs)))) - -(defmacro conda (:form f . pairs) - (sys:if-to-cond f 'ifa 'conda pairs)) - -(defmacro condlet (:form f . pairs) - (sys:if-to-cond f 'iflet 'condlet pairs)) diff --git a/share/txr/stdlib/keyparams.tl b/share/txr/stdlib/keyparams.tl deleted file mode 100644 index 7dd38de2..00000000 --- a/share/txr/stdlib/keyparams.tl +++ /dev/null @@ -1,90 +0,0 @@ -;; Copyright 2017-2020 -;; Kaz Kylheku <kaz@kylheku.com> -;; Vancouver, Canada -;; All rights reserved. -;; -;; Redistribution and use in source and binary forms, with or without -;; modification, are permitted provided that the following conditions are met: -;; -;; 1. Redistributions of source code must retain the above copyright notice, this -;; list of conditions and the following disclaimer. -;; -;; 2. Redistributions in binary form must reproduce the above copyright notice, -;; this list of conditions and the following disclaimer in the documentation -;; and/or other materials provided with the distribution. -;; -;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -(defun sys:extract-keys (keys args) - (build - (each ((k keys)) - (iflet ((f (memp (car k) args))) - (add (cadr f)) - (add (cdr k)))))) - -(defun sys:extract-keys-p (keys args) - (build - (each ((k keys)) - (add (if (memp k args) t))))) - -(defun sys:build-key-list-expr (key-params menv) - (let ((exprs (collect-each ((kp key-params)) - (let ((kw (intern (symbol-name (first kp)) 'keyword)) - (ex (second kp))) - (if (constantp ex menv) - ^(quote (,kw . ,(second kp))) - ^(cons ,kw ,(second kp))))))) - (if [all exprs (op eq 'quote) car] - ^(quote ,[mapcar cadr exprs]) - ^(list ,*exprs)))) - -(define-param-expander :key (param body menv form) - (let* ((excluding-rest (butlastn 0 param)) - (key-start (memq '-- excluding-rest)) - (rest-param (or (nthlast 0 param) (gensym))) - (before-key (ldiff excluding-rest key-start)) - (key-params-raw (butlastn 0 (cdr key-start))) - (key-params [mapcar [iffi atom (op list @1)] key-params-raw]) - (eff-param (append before-key rest-param))) - (each ((key-spec key-params)) - (tree-case key-spec - ((sym init var-p . junk) - (when (consp junk) - (compile-error form "superfluous forms in ~s" key-spec)) - (when junk - (compile-error form "invalid dotted form ~s" key-spec)) - (unless (bindable var-p) - (compile-error form "~s isn't a bindable symbol" var-p)) - :) - ((sym init . more) - (unless (listp more) - (compile-error form "invalid dotted form ~s" key-spec)) - :) - ((sym . more) - (unless (listp more) - (compile-error form "invalid dotted form ~s" key-spec)) - (unless (bindable sym) - (compile-error form "~s isn't a bindable symbol" sym))))) - (let* ((key-params-p [keep-if third key-params]) - (key-vars [mapcar first key-params]) - (key-vars-p [mapcar third key-params-p]) - (keys (sys:build-key-list-expr key-params menv)) - (keys-p (mapcar (op intern (symbol-name (first @1)) 'keyword) - key-params-p))) - (list eff-param - ^(tree-bind ,key-vars - (sys:extract-keys ,keys ,rest-param) - ,*(if keys-p - ^((tree-bind ,key-vars-p - (sys:extract-keys-p ',keys-p ,rest-param) - ,*body)) - body)))))) diff --git a/share/txr/stdlib/op.tl b/share/txr/stdlib/op.tl deleted file mode 100644 index 9b3cf346..00000000 --- a/share/txr/stdlib/op.tl +++ /dev/null @@ -1,198 +0,0 @@ -;; Copyright 2017-2020 -;; Kaz Kylheku <kaz@kylheku.com> -;; Vancouver, Canada -;; All rights reserved. -;; -;; Redistribution and use in source and binary forms, with or without -;; modification, are permitted provided that the following conditions are met: -;; -;; 1. Redistributions of source code must retain the above copyright notice, this -;; list of conditions and the following disclaimer. -;; -;; 2. Redistributions in binary form must reproduce the above copyright notice, -;; this list of conditions and the following disclaimer in the documentation -;; and/or other materials provided with the distribution. -;; -;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -(defvar sys:*op-ctx*) - -(sys:make-struct-type - 'sys:op-ctx nil nil '(form gens up meta rec recvar) nil - (lambda (me) - (slotset me 'up sys:*op-ctx*) - (slotset me 'meta (gensym "meta-"))) - nil nil) - -(defun sys:ensure-op-arg (ctx n) - (let ((ag (slot ctx 'gens))) - (when (> n 1024) - ['compile-error (slot ctx 'form) - "@~a calls for function with too many arguments" n]) - (for ((i (len ag)) (l)) - ((<= i n) - (sys:setq ag (append ag (nreverse l))) - (slotset ctx 'gens ag) - [ag n]) - ((sys:setq i (succ i))) - (sys:setq l (cons (gensym `arg-@(if (plusp i) i "rest")-`) l))))) - -(defun sys:op-meta-p (expr) - (tree-case expr - ((x y . r) (and (null r) - (cond - ((eq x 'sys:expr) (sys:op-meta-p y)) - ((eq x 'sys:var) (or (integerp y) - (eq y 'rest)))))))) - -(defun sys:op-rec-p (expr) - (tree-case expr - ((x (y . r)) (and (eq x 'sys:expr) (eq y 'usr:rec))))) - -(defun sys:op-ensure-rec (ctx : recvar) - (when recvar - (slotset ctx 'recvar t)) - (or (slot ctx 'rec) (slotset ctx 'rec (gensym "rec-")))) - -(defun sys:op-alpha-rename (f e op-args do-nested-metas) - (let* ((ctx sys:*op-ctx*) - (code ^(macrolet ((sys:expr (:form f arg) - (let ((ctx ,ctx)) - (cond - ((and (slot ctx 'up) - (or (sys:op-meta-p arg) - (sys:op-rec-p arg) - (equal arg '(sys:var usr:rec)))) - ^(,(slot (slot ctx 'up) 'meta) (quote ,arg))) - ((sys:op-rec-p f) - ^(,(sys:op-ensure-rec ctx) ,*(rest arg))) - (t f)))) - (sys:var (:form f arg . mods) - (cond - ((sys:op-meta-p f) - (unless (integerp arg) - (sys:setq arg 0)) - (sys:ensure-op-arg ,ctx arg)) - ((equal f '(sys:var usr:rec)) - (sys:op-ensure-rec ,ctx t)) - (t f))) - ,*(if do-nested-metas - ^((,(slot ctx 'meta) ((quote arg)) arg)))) - ,op-args))) - (expand code e))) - -(eval-only - (defmacro op-ignerr (x) - ^(sys:catch (error) ,x () (error (. args))))) - -(defun sys:op-expand (f e args) - (unless args - ['compile-error f "arguments required"]) - (let* ((compat (and (plusp sys:compat) (<= sys:compat 225))) - (ctx (make-struct 'sys:op-ctx ^(form ,f))) - (do-gen) - (sys:*op-ctx* ctx) - (sym (car f)) - (syntax-0 (if (eq sym 'do) args ^[,*args])) - (syntax-1 (if (or (null syntax-0) (neq sym 'do) compat) - (sys:op-alpha-rename f e syntax-0 nil) - (or (op-ignerr (sys:op-alpha-rename f e syntax-0 nil)) - (let ((syn (sys:op-alpha-rename - f e (append syntax-0 - (list (sys:setq do-gen - (gensym)))) - nil))) - (when (slot ctx 'gens) - (sys:op-alpha-rename f e syntax-0 nil)) - syn)))) - (syntax-2 (sys:op-alpha-rename f e syntax-1 t)) - (metas (slot ctx 'gens)) - (rec (slot ctx 'rec)) - (recvar (slot ctx 'recvar)) - (rest-sym (sys:ensure-op-arg ctx 0)) - (lambda-interior (let ((fargs (cdr (cdr syntax-2)))) - (cond - ((and (eq sym 'lop) fargs) - (let ((fargs-l1 (mapcar (lambda (farg) - ^(sys:l1-val ,farg)) - fargs))) - ^[sys:apply ,(car (cdr syntax-2)) - (append ,rest-sym (list ,*fargs-l1))])) - (metas syntax-2) - ((eq sym 'do) - (cond - (compat syntax-2) - (do-gen - (let ((arg1 (sys:ensure-op-arg ctx 1))) - ^(symacrolet ((,do-gen ,arg1)) - ,syntax-2))) - (t (let ((arg1 (sys:ensure-op-arg ctx 1))) - (append syntax-2 (list arg1)))))) - (t (append syntax-2 rest-sym)))))) - (let ((metas (slot ctx 'gens))) - (cond - (recvar ^(sys:lbind ((,rec (lambda (,*(cdr metas) . ,rest-sym) - (let ((,rec (fun ,rec))) - ,lambda-interior)))) - (fun ,rec))) - (rec ^(sys:lbind ((,rec (lambda (,*(cdr metas) . ,rest-sym) - ,lambda-interior))) - (fun ,rec))) - (t ^(lambda (,*(cdr metas) . ,rest-sym) - ,lambda-interior)))))) - -(defmacro op (:form f :env e . args) - (sys:op-expand f e args)) - -(defmacro do (:form f :env e . args) - (sys:op-expand f e args)) - -(defmacro lop (:form f :env e . args) - (sys:op-expand f e args)) - -(defmacro ldo (op . args) - ^(do ,op @1 ,*args)) - -(defmacro ap (. args) - ^(apf (op ,*args))) - -(defmacro ip (. args) - ^(ipf (op ,*args))) - -(defmacro ado (. args) - ^(apf (do ,*args))) - -(defmacro ido (. args) - ^(ipf (do ,*args))) - -(defmacro ret (. args) - ^(op identity (progn @rest ,*args))) - -(defmacro aret (. args) - ^(ap identity (progn @rest ,*args))) - -(defun sys:opip-expand (e clauses) - (collect-each ((c clauses)) - (if (atom c) - c - (let ((sym (car c))) - (if (member sym '(dwim uref qref)) - c - (let ((opdo (if (or (special-operator-p (car c)) - (macro-form-p c e)) 'do 'op))) - ^(,opdo ,*c))))))) - -(defmacro opip (:env e . clauses) - ^[chain ,*(sys:opip-expand e clauses)]) - -(defmacro oand (:env e . clauses) - ^[chand ,*(sys:opip-expand e clauses)]) diff --git a/share/txr/stdlib/package.tl b/share/txr/stdlib/package.tl deleted file mode 100644 index d399dd81..00000000 --- a/share/txr/stdlib/package.tl +++ /dev/null @@ -1,91 +0,0 @@ -;; Copyright 2016-2020 -;; Kaz Kylheku <kaz@kylheku.com> -;; Vancouver, Canada -;; All rights reserved. -;; -;; Redistribution and use in source and binary forms, with or without -;; modification, are permitted provided that the following conditions are met: -;; -;; 1. Redistributions of source code must retain the above copyright notice, this -;; list of conditions and the following disclaimer. -;; -;; 2. Redistributions in binary form must reproduce the above copyright notice, -;; this list of conditions and the following disclaimer in the documentation -;; and/or other materials provided with the distribution. -;; -;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -(defun sys:name-str (kind sym-or-string) - (cond - ((symbolp sym-or-string) (symbol-name sym-or-string)) - ((stringp sym-or-string) sym-or-string) - (t (throw 'eval-error "~s: ~s isn't a valid ~a name" - 'defpackage sym-or-string kind)))) - -(defmacro defpackage (name . clauses) - (let* ((pkg (gensym "pkg-")) - (nstr (sys:name-str 'package name)) - (exp-clauses (append-each ((c clauses)) - (tree-case c - ((keyword package . rest) - (caseql keyword - (:use-from - ^((let ((p (find-package ',package))) - (unless p - (throwf 'eval-error - "~s: no such package: ~s" - 'defpackage ',package)) - (each ((n ',(mapcar (op sys:name-str 'symbol) - rest))) - (let ((s (intern n p))) - (unless (eq (symbol-package s) p) - (throwf 'eval-error - "~s: won't use non-local ~s from ~s" - 'defpackage s p)) - (use-sym s ,pkg)))))) - (t :))) - ((keyword . rest) - (caseql keyword - (:use - (if rest ^((use-package ',rest ,pkg)))) - (:use-syms - ^((each ((s ',rest)) - (use-sym s ,pkg)))) - (:local - ^((each ((n ',(mapcar (op sys:name-str 'symbol) - rest))) - (let ((s (intern n ,pkg))) - (unless (eq (symbol-package s) ,pkg) - (unuse-sym s ,pkg) - (intern n ,pkg)))))) - (:fallback - (if rest ^((set-package-fallback-list ,pkg - ',rest)))) - (:use-from - (throwf 'eval-error - "~s: :use-from clause needs package argument" - 'defpackage)) - (t :))) - (atom - (throwf 'eval-error "~s: invalid clause: ~s" - 'defpackage atom)))))) - ^(let ((,pkg (or (find-package ,nstr) - (make-package ,nstr)))) - ,*exp-clauses - ,pkg))) - -(defmacro in-package (pkg) - (unless (or (symbolp pkg) (stringp pkg)) - (throwf 'eval-error "~s: ~s isn't a package name" 'in-package pkg)) - ^(set *package* (or (find-package ',pkg) - (throwf 'eval-error "~s: no such package: ~s" - 'in-package ',pkg)))) diff --git a/share/txr/stdlib/param.tl b/share/txr/stdlib/param.tl deleted file mode 100644 index e656eadc..00000000 --- a/share/txr/stdlib/param.tl +++ /dev/null @@ -1,70 +0,0 @@ -;; Copyright 2019-2020 -;; Kaz Kylheku <kaz@kylheku.com> -;; Vancouver, Canada -;; All rights reserved. -;; -;; Redistribution and use in source and binary forms, with or without -;; modification, are permitted provided that the following conditions are met: -;; -;; 1. Redistributions of source code must retain the above copyright notice, this -;; list of conditions and the following disclaimer. -;; -;; 2. Redistributions in binary form must reproduce the above copyright notice, -;; this list of conditions and the following disclaimer in the documentation -;; and/or other materials provided with the distribution. -;; -;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -(compile-only - (defstruct param-parser-base nil - syntax form - rest req opt key - nreq nopt nfix - - (:postinit (me) - (let* ((rest (nthlast 0 me.syntax)) - (fixed (ldiff me.syntax rest)) - nonkey key) - (cond - (me.mac-param-p - (while fixed - (let ((pp (pop fixed))) - (caseq pp - ((:env :whole :form) - (unless fixed - (compile-error me.form "~s requires argument" pp)) - (push (cons pp (pop fixed)) key)) - (t (push pp nonkey))))) - (set nonkey (nreverse nonkey) - key (nreverse key))) - (t (set nonkey fixed))) - (tree-bind (: rp opt) (split* nonkey (op where (op eq :))) - (set me.rest rest - me.req rp - me.opt (mapcar [iffi atom list] opt) - me.key key - me.nreq (len rp) - me.nopt (len opt) - me.nfix (+ me.nreq me.nopt))))) - - (:method opt-syms (me) - (build - (each ((o me.opt)) - (caseql (len o) - ((1 2) (add (car o))) - (3 (add (car o) (caddr o)))))))) - - (defstruct (fun-param-parser syntax form) param-parser-base - (mac-param-p nil)) - - (defstruct (mac-param-parser syntax form) param-parser-base - (mac-param-p t))) diff --git a/share/txr/stdlib/path-test.tl b/share/txr/stdlib/path-test.tl deleted file mode 100644 index d550352b..00000000 --- a/share/txr/stdlib/path-test.tl +++ /dev/null @@ -1,185 +0,0 @@ -;; Copyright 2015-2020 -;; Kaz Kylheku <kaz@kylheku.com> -;; Vancouver, Canada -;; All rights reserved. -;; -;; Redistribution and use in source and binary forms, with or without -;; modification, are permitted provided that the following conditions are met: -;; -;; 1. Redistributions of source code must retain the above copyright notice, this -;; list of conditions and the following disclaimer. -;; -;; 2. Redistributions in binary form must reproduce the above copyright notice, -;; this list of conditions and the following disclaimer in the documentation -;; and/or other materials provided with the distribution. -;; -;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -(defun sys:do-path-test (statfun path testfun) - [testfun (if (stringp path) (ignerr [statfun path]) path)]) - -(eval-only - (defmacro sys:path-test ((sym statfun path) . body) - ^[sys:do-path-test ,statfun ,path - (lambda (,sym) (when ,sym ,*body))])) - -(defun sys:path-test-type (statfun path code) - (sys:path-test (s statfun path) - (eql (logand s.mode s-ifmt) code))) - -(defun sys:path-test-mode (statfun path mask) - (sys:path-test (s statfun path) - (plusp (logand s.mode mask)))) - -(defun path-exists-p (path) - (sys:path-test (s stat path) t)) - -(defun path-file-p (path) - [sys:path-test-type stat path s-ifreg]) - -(defun path-dir-p (path) - [sys:path-test-type stat path s-ifdir]) - -(defun path-symlink-p (path) - [sys:path-test-type lstat path s-iflnk]) - -(defun path-blkdev-p (path) - [sys:path-test-type stat path s-ifblk]) - -(defun path-chrdev-p (path) - [sys:path-test-type stat path s-ifchr]) - -(defun path-sock-p (path) - [sys:path-test-type stat path s-ifsock]) - -(defun path-pipe-p (path) - [sys:path-test-type stat path s-ififo]) - -(defun path-setgid-p (path) - [sys:path-test-mode stat path s-isgid]) - -(defun path-setuid-p (path) - [sys:path-test-mode stat path s-isuid]) - -(defun path-sticky-p (path) - [sys:path-test-mode stat path s-isvtx]) - -(defun path-mine-p (path) - (sys:path-test (s stat path) - (= s.uid (geteuid)))) - -(defun path-my-group-p (path) - (sys:path-test (s stat path) - (let ((g s.gid)) - (or (= g (getegid)) - (find g (getgroups)))))) - -;; umask, gmask and omask must test identical permissions -;; multiple permissions may be tested, but not a combination -;; of x with any other permission. -(defun sys:path-access (path umask gmask omask) - (sys:path-test (s stat path) - (let ((m s.mode) - (euid (geteuid))) - (cond - ((zerop euid) (or (zerop (logand umask s-ixusr)) - (plusp (logand m (logior umask gmask omask))))) - ((= euid s.uid) (= umask (logand m umask))) - ((let ((g s.gid)) - (or (= g (getegid)) - (find g (getgroups)))) - (= gmask (logand m gmask))) - (t (= omask (logand m omask))))))) - -(defun path-executable-to-me-p (path) - (sys:path-access path s-ixusr s-ixgrp s-ixoth)) - -(defun path-writable-to-me-p (path) - (sys:path-access path s-iwusr s-iwgrp s-iwoth)) - -(defun path-readable-to-me-p (path) - (sys:path-access path s-irusr s-irgrp s-iroth)) - -(defun path-read-writable-to-me-p (path) - (sys:path-access path - (logior s-irusr s-iwusr) - (logior s-irgrp s-iwgrp) - (logior s-iroth s-iwoth))) - -(defun path-private-to-me-p (path) - (sys:path-test (s stat path) - (let ((m s.mode) - (euid (geteuid))) - (mlet ((g (getgrgid s.gid)) - (name (let ((pw (getpwuid euid))) - (if pw pw.name))) - (suname (let ((pw (getpwuid 0))) - (if pw pw.name)))) - (and (or (zerop s.uid) - (eql euid s.uid)) - (zerop (logand m s-iwoth)) - (or (zerop (logand m s-iwgrp)) - (null g.mem) - (and (all g.mem (orf (op equal name) - (op equal suname)))))))))) - -(defun path-strictly-private-to-me-p (path) - (sys:path-test (s stat path) - (let ((m s.mode) - (euid (geteuid))) - (mlet ((g (getgrgid s.gid)) - (name (let ((pw (getpwuid euid))) - (if pw pw.name))) - (suname (let ((pw (getpwuid 0))) - (if pw pw.name)))) - (and (or (zerop s.uid) - (eql euid s.uid)) - (zerop (logand m (logior s-iroth s-iwoth))) - (or (zerop (logand m (logior s-irgrp s-iwgrp))) - (null g.mem) - (and (all g.mem (orf (op equal name) - (op equal suname)))))))))) - - -(defmacro sys:path-examine ((sym statfun path) . body) - ^[sys:do-path-test ,statfun ,path - (lambda (,sym) ,*body)]) - -(defun path-newer (path-0 path-1) - (sys:path-examine (s0 stat path-0) - (sys:path-examine (s1 stat path-1) - (if s0 - (or (null s1) - (let ((mt0 s0.mtime) - (mt1 s1.mtime)) - (or (> mt0 mt1) - (and (= mt0 mt1) - (> s0.mtime-nsec s1.mtime-nsec))))))))) - -(defun path-older (path-0 path-1) - (path-newer path-1 path-0)) - -(defun path-same-object (path-0 path-1) - (sys:path-examine (s0 stat path-0) - (sys:path-examine (s1 stat path-1) - (and s0 s1 - (eql s0.dev s1.dev) - (eql s0.ino s1.ino))))) - -(defun path-dir-empty (path) - (when (path-dir-p path) - (let ((name (if (stringp path) path path.path))) - (with-stream (ds (open-directory name)) - (for (ent) ((set ent (get-line ds)) t) () - (casequal ent - (("." "..")) - (t (return nil)))))))) diff --git a/share/txr/stdlib/place.tl b/share/txr/stdlib/place.tl deleted file mode 100644 index 4e2c7904..00000000 --- a/share/txr/stdlib/place.tl +++ /dev/null @@ -1,970 +0,0 @@ -;; Copyright 2015-2020 -;; Kaz Kylheku <kaz@kylheku.com> -;; Vancouver, Canada -;; All rights reserved. -;; -;; Redistribution and use in source and binary forms, with or without -;; modification, are permitted provided that the following conditions are met: -;; -;; 1. Redistributions of source code must retain the above copyright notice, this -;; list of conditions and the following disclaimer. -;; -;; 2. Redistributions in binary form must reproduce the above copyright notice, -;; this list of conditions and the following disclaimer in the documentation -;; and/or other materials provided with the distribution. -;; -;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -(defvar *place-clobber-expander* (hash)) -(defvar *place-update-expander* (hash)) -(defvar *place-delete-expander* (hash)) -(defvar *place-macro* (hash)) -(defvar sys:*pl-env* nil) -(defvar sys:*pl-form* nil) - -(defun sys:eval-err (. params) - (throwf 'eval-error . params)) - -(defun sys:sym-update-expander (getter-name setter-name - place-expr op-body) - ^(macrolet ((,getter-name () ',place-expr) - (,setter-name (val-expr) ^(sys:setq ,',place-expr - ,val-expr))) - ,op-body)) - -(defun sys:sym-clobber-expander (simple-setter-name - place-expr op-body) - ^(macrolet ((,simple-setter-name (val-expr) - ^(sys:setq ,',place-expr ,val-expr))) - ,op-body)) - -(defun sys:sym-delete-expander (deleter-name - place-expr . op-body) - ^(macrolet ((,deleter-name (:env env) - (when (lexical-var-p env ',place-expr) - (sys:eval-err "~s is a lexical variable, thus not deletable" - ',place-expr)) - ^(prog1 - (symbol-value ',',place-expr) - (makunbound ',',place-expr)))) - ,*op-body)) - -(defun sys:get-place-macro (sym) - (or [*place-macro* sym] - (progn (sys:try-load sym) [*place-macro* sym]))) - -(defun sys:pl-expand (unex-place env) - (while t - (let ((place unex-place) - pm-expander) - (while (and (consp place) - (sys:setq pm-expander (sys:get-place-macro (car place))) - (sys:setq place (sys:set-macro-ancestor [pm-expander place] place)) - (neq place unex-place)) - (sys:setq unex-place place)) - (sys:setq place (macroexpand-1 place env)) - (when (or (eq place unex-place) - (null place) - (and (atom place) (not (symbolp place)))) - (return-from sys:pl-expand place)) - (sys:setq unex-place place)))) - -(defun place-form-p (unex-place env) - (let ((place (sys:pl-expand unex-place env))) - (or (bindable place) - (and (consp place) [*place-update-expander* (car place)] t)))) - -(defun get-update-expander (place) - (cond - ((symbolp place) (fun sys:sym-update-expander)) - ((consp place) (or [*place-update-expander* (car place)] - (sys:eval-err "~s is not an assignable place" place))) - (t (sys:eval-err "form ~s is not syntax denoting an assignable place" place)))) - -(defun get-clobber-expander (place) - (cond - ((symbolp place) (fun sys:sym-clobber-expander)) - ((consp place) (or [*place-clobber-expander* (car place)] - (iflet ((fun [*place-update-expander* (car place)])) - (op apply fun (gensym) @1 @2 @rest)) - (sys:eval-err "~s is not an assignable place" place))) - (t (sys:eval-err "form ~s is not syntax denoting an assignable place" place)))) - -(defun get-delete-expander (place) - (cond - ((symbolp place) (fun sys:sym-delete-expander)) - ((consp place) (or [*place-delete-expander* (car place)] - (sys:eval-err "~s is not a deletable place" place))) - (t (sys:eval-err "form ~s is not syntax denoting a deletable place" place)))) - -(defun sys:r-s-let-expander (bindings body e letsym pred) - (let ((exp-bindings (mapcar (aret ^(,@1 ,(macroexpand @2 e))) bindings))) - (let ((renames [keep-if pred exp-bindings second]) - (regular [remove-if pred exp-bindings second])) - (cond ((and renames regular) - ^(symacrolet ,renames - (,letsym ,regular ,*body))) - (renames ^(symacrolet ,renames ,*body)) - (regular ^(,letsym ,regular ,*body)) - (t ^(progn ,*body)))))) - -(defmacro rlet (bindings :env e . body) - [sys:r-s-let-expander bindings body e 'let constantp]) - -(defmacro slet (bindings :env e . body) - (sys:r-s-let-expander bindings body e 'let [orf constantp bindable])) - -(defmacro alet (bindings :env e . body) - (let ((exp-bindings (mapcar (aret ^(,@1 ,(macroexpand @2 e))) bindings))) - (if [some exp-bindings constantp second] - [sys:r-s-let-expander exp-bindings body e 'alet constantp] - ^(,(if [all exp-bindings bindable second] - 'symacrolet 'let) - ,exp-bindings ,*body)))) - -(defmacro with-gensyms (syms . body) - ^(let ,(zip syms (repeat '((gensym)))) ,*body)) - -(defun sys:propagate-ancestor (to-tree from-form . syms) - (tree-case to-tree - ((a . d) - (when (memq a syms) - (sys:set-macro-ancestor to-tree from-form)) - (sys:propagate-ancestor a from-form . syms) - (sys:propagate-ancestor d from-form . syms))) - to-tree) - -(defun call-update-expander (getter setter unex-place env body) - (sys:propagate-ancestor body unex-place getter setter) - (let* ((place (sys:pl-expand unex-place env)) - (expander (get-update-expander place)) - (sys:*pl-env* env) - (sys:*pl-form* unex-place) - (expansion [expander getter setter place body]) - (expansion-ex (expand expansion env))) - (sys:propagate-ancestor expansion-ex place getter setter))) - -(defun call-clobber-expander (ssetter unex-place env body) - (sys:propagate-ancestor body unex-place ssetter) - (let* ((place (sys:pl-expand unex-place env)) - (expander (get-clobber-expander place)) - (sys:*pl-env* env) - (sys:*pl-form* unex-place) - (expansion [expander ssetter place body]) - (expansion-ex (expand expansion env))) - (sys:propagate-ancestor expansion-ex place ssetter))) - -(defun call-delete-expander (deleter unex-place env body) - (sys:propagate-ancestor body unex-place deleter) - (let* ((place (sys:pl-expand unex-place env)) - (expander (get-delete-expander place)) - (sys:*pl-env* env) - (sys:*pl-form* unex-place) - (expansion [expander deleter place body]) - (expansion-ex (expand expansion env))) - (sys:propagate-ancestor expansion-ex place deleter))) - -(defmacro with-update-expander ((getter setter) unex-place env body) - ^(with-gensyms (,getter ,setter) - (call-update-expander ,getter ,setter ,unex-place ,env ,body))) - -(defmacro with-clobber-expander ((ssetter) unex-place env body) - ^(with-gensyms (,ssetter) - (call-clobber-expander ,ssetter ,unex-place ,env ,body))) - -(defmacro with-delete-expander ((deleter) unex-place env body) - ^(with-gensyms (,deleter) - (call-delete-expander ,deleter ,unex-place ,env ,body))) - -(defmacro set (:env env . place-value-pairs) - (let ((assign-forms (mapcar (tb ((place : (value nil value-present-p))) - (unless value-present-p - (sys:eval-err "set: arguments must be pairs")) - (with-clobber-expander (ssetter) place env - ^(,ssetter ,value))) - (tuples 2 place-value-pairs)))) - (if (cdr assign-forms) - ^(progn ,*assign-forms) - (car assign-forms)))) - -(defmacro pset (:env env . place-value-pairs) - (let ((len (length place-value-pairs))) - (cond - ((oddp len) (sys:eval-err "pset: arguments must be pairs")) - ((<= len 2) ^(set ,*place-value-pairs)) - (t (let* ((pvtgs (mapcar (tb ((a b)) - (list a b (gensym) (gensym) (gensym))) - (tuples 2 place-value-pairs))) - (ls (reduce-left (tb ((lets stores) (place value temp getter setter)) - (list ^((,temp ,value) ,*lets) - ^((,setter ,temp) ,*stores))) - pvtgs '(nil nil))) - (lets (first ls)) - (stores (second ls)) - (body-form ^(rlet (,*lets) ,*stores))) - (reduce-left (tb (accum-form (place value temp getter setter)) - (call-update-expander getter setter - place env accum-form)) - pvtgs body-form)))))) - -(defmacro zap (place : (new-val nil) :env env) - (with-update-expander (getter setter) place env - ^(prog1 (,getter) (,setter ,new-val)))) - -(defmacro flip (place :env env) - (with-update-expander (getter setter) place env - ^(,setter (not (,getter))))) - -(defmacro inc (place : (delta 1) :env env) - (with-update-expander (getter setter) place env - (caseql delta - (0 place) - (1 ^(,setter (succ (,getter)))) - (2 ^(,setter (ssucc (,getter)))) - (3 ^(,setter (sssucc (,getter)))) - (t ^(,setter (+ (,getter) ,delta)))))) - -(defmacro dec (place : (delta 1) :env env) - (with-update-expander (getter setter) place env - (caseql delta - (0 place) - (1 ^(,setter (pred (,getter)))) - (2 ^(,setter (ppred (,getter)))) - (3 ^(,setter (pppred (,getter)))) - (t ^(,setter (- (,getter) ,delta)))))) - -(defmacro pinc (place : (delta 1) :env env) - (with-gensyms (oldval) - (with-update-expander (getter setter) place env - (caseql delta - (0 place) - (1 ^(let ((,oldval (,getter))) (,setter (succ ,oldval)) ,oldval)) - (2 ^(let ((,oldval (,getter))) (,setter (ssucc ,oldval)) ,oldval)) - (3 ^(let ((,oldval (,getter))) (,setter (sssucc ,oldval)) ,oldval)) - (t ^(let ((,oldval (,getter))) (,setter (+ ,oldval, delta)) ,oldval)))))) - -(defmacro pdec (place : (delta 1) :env env) - (with-gensyms (oldval) - (with-update-expander (getter setter) place env - (caseql delta - (0 place) - (1 ^(let ((,oldval (,getter))) (,setter (pred ,oldval)) ,oldval)) - (2 ^(let ((,oldval (,getter))) (,setter (ppred ,oldval)) ,oldval)) - (3 ^(let ((,oldval (,getter))) (,setter (pppred ,oldval)) ,oldval)) - (t ^(let ((,oldval (,getter))) (,setter (- ,oldval, delta)) ,oldval)))))) - -(defmacro swap (place-0 place-1 :env env) - (with-gensyms (tmp) - (with-update-expander (getter-0 setter-0) place-0 env - (with-update-expander (getter-1 setter-1) place-1 env - ^(let ((,tmp (,getter-0))) - (,setter-0 (,getter-1)) - (,setter-1 ,tmp)))))) - -(defmacro push (new-item place :env env) - (with-gensyms (new-sym) - ^(alet ((,new-sym ,new-item)) - ,(with-update-expander (getter setter) place env - ^(,setter (cons ,new-sym (,getter))))))) - -(defmacro pop (place :env env) - (with-gensyms (tmp) - (with-update-expander (getter setter) place env - ^(alet ((,tmp (,getter))) - (prog1 (car ,tmp) (,setter (cdr ,tmp))))))) - -(defmacro pushnew (new-item place :env env : - (testfun :) - (keyfun :)) - (with-update-expander (getter setter) place env - (with-gensyms (new-item-sym old-list-sym) - ^(rlet ((,new-item-sym ,new-item)) - ,(with-update-expander (getter setter) place env - ^(let ((,old-list-sym (,getter))) - (if (member ,new-item-sym ,old-list-sym ,testfun ,keyfun) - ,old-list-sym - (,setter (cons ,new-item-sym ,old-list-sym))))))))) - -(defmacro shift (:form f :env env . places) - (tree-case places - (() (compile-error f "need at least two arguments")) - ((place) (compile-error f "need at least two arguments")) - ((place newvalue) - (with-update-expander (getter setter) place env - ^(prog1 (,getter) (,setter ,newvalue)))) - ((place . others) - (with-update-expander (getter setter) place env - ^(prog1 (,getter) (,setter (shift ,*others))))))) - -(defmacro rotate (:env env . places) - (tree-case places - (() ()) - ((fplace) fplace) - ((fplace . rplaces) - (with-gensyms (tmp) - (with-update-expander (getter-f setter-f) fplace env - ^(let ((,tmp (,getter-f))) - (,setter-f (shift ,*rplaces ,tmp)) - ,tmp)))))) - -(defmacro test-set (:env env place) - (with-update-expander (getter setter) place env - ^(unless (,getter) - (,setter t)))) - -(defmacro test-clear (:env env place) - (with-update-expander (getter setter) place env - ^(when (,getter) - (,setter nil) - t))) - -(defmacro compare-swap (:env env comp-fun place comp-val store-val) - (with-update-expander (getter setter) place env - ^(when (,comp-fun (,getter) ,comp-val) - (,setter ,store-val) - t))) - -(defmacro test-inc (place : (delta 1) (upfrom-val 0)) - ^(eql (pinc ,place ,delta) ,upfrom-val)) - -(defmacro test-dec (place : (delta 1) (downto-val 0)) - ^(eql (dec ,place ,delta) ,downto-val)) - -(defmacro del (place :env env) - (with-delete-expander (deleter) place env - ^(,deleter))) - -(defmacro lset (:form f . places-source) - (let ((places (butlast places-source)) - (source (last places-source)) - (orig (gensym)) - (iter (gensym))) - (unless places - (compile-error f "require one or more places followed by expression")) - ^(let* ((,orig ,(car source)) - (,iter ,orig)) - ,*(butlast (mappend (ret ^((set ,@1 (car ,iter)) (set ,iter (cdr ,iter)))) - places)) - ,orig))) - -(defmacro upd (place . opip-args) - (with-gensyms (pl) - ^(placelet ((,pl ,place)) - (set ,pl (call (opip ,*opip-args) ,pl))))) - -(defmacro defplace (place-destructuring-args body-sym - (getter-sym setter-sym update-body) : - ((ssetter-sym clobber-body)) - ((deleter-sym delete-body))) - (let ((name (car place-destructuring-args)) - (args (cdr place-destructuring-args))) - (unless (and name - (symbolp name) - (not (keywordp name)) - (not (eq t name))) - (compile-error sys:*pl-form* "~s cannot be used as a place name" name)) - (with-gensyms (place) - ^(progn - (sethash *place-update-expander* ',name - (lambda (,getter-sym ,setter-sym ,place ,body-sym) - (tree-bind ,args (cdr ,place) - ,update-body))) - ,*(if ssetter-sym - ^((sethash *place-clobber-expander* ',name - (lambda (,ssetter-sym ,place ,body-sym) - (tree-bind ,args (cdr ,place) - ,clobber-body))))) - ,*(if deleter-sym - ^((sethash *place-delete-expander* ',name - (lambda (,deleter-sym ,place ,body-sym) - (tree-bind ,args (cdr ,place) - ,delete-body))))) - ',name)))) - -(defmacro define-place-macro (name place-destructuring-args . body) - (with-gensyms (name-dummy args) - ^(progn - (sethash *place-macro* ',name - (lambda (,args) - (mac-param-bind ,args - (,name-dummy ,*place-destructuring-args) - ,args ,*body))) - ',name))) - -(defplace (sys:var arg) body - (getter setter - ^(macrolet ((,getter () ^(sys:var ,',arg)) - (,setter (val) ^(sys:setq ,'(sys:var ,arg) ,val))) - ,body))) - -(defplace (sys:l1-val arg) body - (getter setter - ^(macrolet ((,getter () ^(sys:l1-val ,',arg)) - (,setter (val) ^(sys:l1-setq ,',arg ,val))) - ,body)) - (ssetter - ^(macrolet ((,ssetter (val) ^(sys:l1-setq ,',arg ,val))) - ,body))) - -(defplace (sys:lisp1-value arg) body - (getter setter - ^(macrolet ((,getter () ^(sys:lisp1-value ,',arg)) - (,setter (val) ^(sys:lisp1-setq ,',arg ,val))) - ,body)) - (ssetter - ^(macrolet ((,ssetter (val) ^(sys:lisp1-setq ,',arg ,val))) - ,body))) - -(defplace (car cell) body - (getter setter - (with-gensyms (cell-sym) - ^(slet ((,cell-sym ,cell)) - (macrolet ((,getter () ^(car ,',cell-sym)) - (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) - ,body)))) - (ssetter - ^(macrolet ((,ssetter (val) ^(sys:rplaca ,',cell ,val))) - ,body)) - (deleter - ^(macrolet ((,deleter () ^(pop ,',cell))) - ,body))) - -(defplace (cdr cell) body - (getter setter - (with-gensyms (cell-sym) - ^(slet ((,cell-sym ,cell)) - (macrolet ((,getter () ^(cdr ,',cell-sym)) - (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) - ,body)))) - (ssetter - ^(macrolet ((,ssetter (val) ^(sys:rplacd ,',cell ,val))) - ,body)) - (deleter - ^(macrolet ((,deleter () - (with-gensyms (tmp) - (with-update-expander (cgetter csetter) ',cell nil - ^(let ((,tmp (,cgetter))) - (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) - ,body))) - -(defplace (nthcdr index list) body - (getter setter - (with-gensyms (index-sym list-sym sentinel-head-sym parent-cell-sym) - (if (place-form-p list sys:*pl-env*) - (with-update-expander (lgetter lsetter) list sys:*pl-env* - ^(alet ((,index-sym ,index) - (,list-sym (,lgetter))) - (let* ((,sentinel-head-sym (cons nil ,list-sym)) - (,parent-cell-sym (nthcdr ,index-sym ,sentinel-head-sym))) - (macrolet ((,getter () ^(cdr ,',parent-cell-sym)) - (,setter (val) - ^(prog1 (sys:rplacd ,',parent-cell-sym ,val) - (,',lsetter (cdr ,',sentinel-head-sym))))) - ,body)))) - ^(alet ((,index-sym ,index) - (,list-sym ,list)) - (let ((,parent-cell-sym (nthcdr (pred ,index-sym) ,list-sym))) - (macrolet ((,getter () ^(cdr ,',parent-cell-sym)) - (,setter (val) - ^(sys:rplacd ,',parent-cell-sym ,val))) - ,body))))))) - -(defplace (nthlast index list) body - (getter setter - (with-gensyms (index-sym list-sym sentinel-head-sym parent-cell-sym) - (if (place-form-p list sys:*pl-env*) - (with-update-expander (lgetter lsetter) list sys:*pl-env* - ^(alet ((,index-sym ,index) - (,list-sym (,lgetter))) - (let* ((,sentinel-head-sym (cons nil ,list-sym)) - (,parent-cell-sym (nthlast (succ ,index-sym) - ,sentinel-head-sym))) - (macrolet ((,getter () ^(cdr ,',parent-cell-sym)) - (,setter (val) - ^(prog1 (sys:rplacd ,',parent-cell-sym ,val) - (,',lsetter (cdr ,',sentinel-head-sym))))) - ,body)))) - ^(alet ((,index-sym index) - (,list-sym ,list)) - (let ((,parent-cell-sym (nthlast (succ ,index-sym) ,list-sym))) - (macrolet ((,getter () ^(cdr ,',parent-cell-sym)) - (,setter (val) - ^(sys:rplacd ,',parent-cell-sym ,val))) - ,body))))))) - -(defplace (butlastn num list) body - (getter setter - (with-gensyms (num-sym list-sym head-sym tail-sym val-sym) - (with-update-expander (lgetter lsetter) list sys:*pl-env* - ^(alet ((,num-sym ,num) - (,list-sym (,lgetter))) - (let* ((,tail-sym (nthlast ,num-sym ,list-sym)) - (,head-sym (ldiff ,list-sym ,tail-sym))) - (macrolet ((,getter () ,head-sym) - (,setter (val) - ^(alet ((,',val-sym ,val)) - (progn (,',lsetter (append ,',val-sym - ,',tail-sym)) - ,',val-sym)))) - ,body))))))) - -(defplace (vecref vector index :whole args) body - (getter setter - (with-gensyms (vec-sym ind-sym) - ^(alet ((,vec-sym ,vector) - (,ind-sym ,index)) - (macrolet ((,getter () ^(vecref ,',vec-sym ,',ind-sym)) - (,setter (val) ^(refset ,',vec-sym ,',ind-sym ,val))) - ,body)))) - (ssetter - ^(macrolet ((,ssetter (val) ^(refset ,*',args ,val))) - ,body)) - (deleter - (with-gensyms (vec-sym ind-sym) - ^(alet ((,vec-sym ,vector) - (,ind-sym ,index)) - (macrolet ((,deleter () - ^(prog1 (vecref ,',vec-sym ,',ind-sym) - (replace-vec ,',vec-sym nil - ,',ind-sym (succ ,',ind-sym))))) - ,body))))) - -(defplace (chr-str string index :whole args) body - (getter setter - (with-gensyms (str-sym ind-sym) - ^(alet ((,str-sym ,string) - (,ind-sym ,index)) - (macrolet ((,getter () ^(chr-str ,',str-sym ,',ind-sym)) - (,setter (val) ^(chr-str-set ,',str-sym ,',ind-sym ,val))) - ,body)))) - (ssetter - ^(macrolet ((,ssetter (val) ^(chr-str-set ,*',args ,val))) - ,body)) - (deleter - (with-gensyms (str-sym ind-sym) - ^(alet ((,str-sym ,string) - (,ind-sym ,index)) - (macrolet ((,deleter () - ^(prog1 (chr-str ,',str-sym ,',ind-sym) - (replace-str ,',str-sym nil - ,',ind-sym (succ ,',ind-sym))))) - ,body))))) - -(defplace (ref seq index :whole args) body - (getter setter - (with-gensyms (seq-sym ind-sym) - ^(alet ((,seq-sym ,seq) - (,ind-sym ,index)) - (macrolet ((,getter () ^(ref ,',seq-sym ,',ind-sym)) - (,setter (val) ^(refset ,',seq-sym ,',ind-sym ,val))) - ,body)))) - (ssetter - ^(macrolet ((,ssetter (val) ^(refset ,*',args ,val))) - ,body)) - (deleter - (with-gensyms (seq-sym ind-sym) - ^(alet ((,seq-sym ,seq) - (,ind-sym ,index)) - (macrolet ((,deleter () - ^(prog1 (ref ,',seq-sym ,',ind-sym) - (replace ,',seq-sym nil - ,',ind-sym (succ ,',ind-sym))))) - ,body))))) - -(defplace (sub seq :whole args : (from 0) (to t)) body - (getter setter - (with-gensyms (seq-sym from-sym to-sym v-sym) - (with-update-expander (seq-getter seq-setter) seq sys:*pl-env* - ^(alet ((,seq-sym (,seq-getter)) - (,from-sym ,from) - (,to-sym ,to)) - (macrolet ((,getter () ^(sub ,',seq-sym ,',from-sym ,',to-sym)) - (,setter (val) - ^(alet ((,',v-sym ,val)) - (,',seq-setter (replace ,',seq-sym ,',v-sym - ,',from-sym ,',to-sym)) - ,',v-sym))) - ,body))))) - (ssetter - (with-gensyms (seq-sym from-sym to-sym v-sym) - (with-update-expander (seq-getter seq-setter) seq sys:*pl-env* - ^(macrolet ((,ssetter (val) - ^(alet ((,',seq-sym (,',seq-getter)) - (,',from-sym ,',from) - (,',to-sym ,',to) - (,',v-sym ,val)) - (,',seq-setter (replace ,',seq-sym ,',v-sym - ,',from-sym ,',to-sym)) - ,',v-sym))) - ,body)))) - (deleter - (with-gensyms (seq-sym from-sym to-sym) - (with-update-expander (seq-getter seq-setter) seq sys:*pl-env* - ^(alet ((,seq-sym (,seq-getter)) - (,from-sym ,from) - (,to-sym ,to)) - (macrolet ((,deleter () - ^(prog1 - (sub ,',seq-sym ,',from-sym ,',to-sym) - (,',seq-setter (replace ,',seq-sym nil - ,',from-sym ,',to-sym))))) - ,body)))))) - -(defplace (gethash hash key : (default nil have-default-p)) body - (getter setter - (with-gensyms (entry-sym) - ^(let ((,entry-sym (inhash ,hash ,key ,default))) - (macrolet ((,getter () ^(cdr ,',entry-sym)) - (,setter (val) ^(sys:rplacd ,',entry-sym ,val))) - ,body)))) - nil - (deleter - ^(macrolet ((,deleter () - (if ,have-default-p - (with-gensyms (entry-sym - dfl-sym) - ^(alet ((,entry-sym (inhash ,',hash ,',key)) - (,dfl-sym ,',default)) - (if ,entry-sym - (remhash ,',hash ,',key) - ,dfl-sym))) - ^(remhash ,',hash ,',key)))) - ,body))) - -(defplace (hash-userdata hash) body - (getter setter - (with-gensyms (hash-sym) - ^(slet ((,hash-sym ,hash)) - (macrolet ((,getter () ^(hash-userdata ,',hash-sym)) - (,setter (val) ^(set-hash-userdata ,',hash-sym ,val))) - ,body)))) - (ssetter - ^(macrolet ((,ssetter (val) - ^(set-hash-userdata ,',hash ,val))) - ,body))) - -(defplace (dwim obj-place :env env . args) body - (getter setter - (with-gensyms (ogetter-sym osetter-sym obj-sym newval-sym) - (let ((arg-syms (mapcar (ret (gensym)) args))) - (if (place-form-p obj-place sys:*pl-env*) - (with-update-expander (ogetter-sym osetter-sym) - ^(sys:l1-val ,obj-place) sys:*pl-env* - ^(rlet ((,obj-sym (,ogetter-sym)) - ,*(mapcar (ret ^(,@1 (sys:l1-val ,@2))) arg-syms args)) - (macrolet ((,getter () - '[,obj-sym ,*arg-syms]) - (,setter (val) - ^(rlet ((,',newval-sym ,val)) - (,',osetter-sym - (sys:dwim-set t ,',obj-sym - ,*',arg-syms ,',newval-sym)) - ,',newval-sym))) - ,body))) - ^(rlet ((,obj-sym ,obj-place) - ,*(mapcar (ret ^(,@1 (sys:l1-val ,@2))) arg-syms args)) - (macrolet ((,getter () - '[,obj-sym ,*arg-syms]) - (,setter (val) - ^(rlet ((,',newval-sym ,val)) - (sys:dwim-set nil ,',obj-sym - ,*',arg-syms ,',newval-sym) - ,',newval-sym))) - ,body)))))) - (ssetter - (with-gensyms (osetter-sym ogetter-sym obj-sym newval-sym) - (let ((arg-syms (mapcar (ret (gensym)) args))) - (if (place-form-p obj-place sys:*pl-env*) - (with-update-expander (ogetter-sym osetter-sym) - ^(sys:l1-val ,obj-place) sys:*pl-env* - ^(macrolet ((,ssetter (val) - ^(rlet ((,',obj-sym (,',ogetter-sym)) - ,*(mapcar (ret ^(,@1 (sys:l1-val ,@2))) - ',arg-syms ',args) - (,',newval-sym ,val)) - (,',osetter-sym - (sys:dwim-set t ,',obj-sym - ,*',arg-syms - ,',newval-sym)) - ,',newval-sym))) - ,body)) - ^(macrolet ((,ssetter (val) - ^(rlet ((,',obj-sym ,',obj-place) - ,*(mapcar (ret ^(,@1 (sys:l1-val ,@2))) - ',arg-syms ',args) - (,',newval-sym ,val)) - (sys:dwim-set nil ,',obj-sym - ,*',arg-syms - ,',newval-sym) - ,',newval-sym))) - ,body))))) - - (deleter - (with-gensyms (osetter-sym ogetter-sym obj-sym oldval-sym) - (let ((arg-syms (mapcar (ret (gensym)) args))) - (if (place-form-p obj-place sys:*pl-env*) - (with-update-expander (ogetter-sym osetter-sym) - ^(sys:l1-val ,obj-place) sys:*pl-env* - ^(macrolet ((,deleter () - ^(rlet ((,',obj-sym (,',ogetter-sym)) - ,*(mapcar (ret ^(,@1 (sys:l1-val ,@2))) - ',arg-syms ',args)) - (let ((,',oldval-sym [,',obj-sym ,*',arg-syms])) - (progn - (,',osetter-sym - (sys:dwim-del t ,',obj-sym ,*',arg-syms)) - ,',oldval-sym))))) - ,body)) - ^(macrolet ((,deleter () - ^(rlet ((,',obj-sym ,',obj-place) - ,*(mapcar (ret ^(,@1 (sys:l1-val ,@2))) - ',arg-syms ',args)) - (let ((,',oldval-sym [,',obj-sym ,*',arg-syms])) - (progn - (sys:dwim-del nil ,',obj-sym ,*',arg-syms) - ,',oldval-sym))))) - ,body)))))) - -(defplace (force promise) body - (getter setter - (with-gensyms (promise-sym) - ^(rlet ((,promise-sym ,promise)) - (macrolet ((,getter () - ^(force ,',promise-sym)) - (,setter (val) - ^(set (car (cdr ,',promise-sym)) ,val))) - ,body)))) - (ssetter - (with-gensyms (promise-sym) - ^(rlet ((,promise-sym ,promise)) - (macrolet ((,ssetter (val) - ^(prog1 - (set (car (cdr ,',promise-sym)) ,val) - (set (car ,',promise-sym) 'sys:promise-forced)))) - ,body))))) - -(defplace (errno) body - (getter setter - ^(macrolet ((,getter () '(errno)) - (,setter (val-expr) - (with-gensyms (val-sym) - ^(slet ((,val-sym ,val-expr)) - (progn (errno ,val-sym) ,val-sym))))) - ,body))) - -(defplace (fun sym) body - (getter setter - ^(macrolet ((,getter () ^(fun ,',sym)) - (,setter (val) ^(sys:setqf ,',sym ,val))) - ,body)) - nil - (deleter - ^(macrolet ((,deleter (:env env) - (when (lexical-fun-p env ',sym) - (compile-error ',sys:*pl-form* - "~s is a lexical function, \ - \ thus not deletable")) - ^(fmakunbound ',',sym))) - ,body))) - -(defun sys:get-fun-getter-setter (sym : f) - (tree-case sym - ((type struct slot) - (if (eq type 'meth) - (caseql slot - (:init (cons (op struct-get-initfun struct) - (op struct-set-initfun struct))) - (:postinit (cons (op struct-get-postinitfun struct) - (op struct-set-postinitfun struct))) - (t (cons (op static-slot struct slot) - (op static-slot-ensure struct slot)))) - :)) - ((type sym) - (if (eq type 'macro) - (let ((cell (or (gethash sys:top-mb sym) - (sethash sys:top-mb sym (cons sym nil))))) - (cons (op cdr) - (op sys:rplacd cell))) - :)) - ((op . rest) - (if (eq op 'lambda) - (compile-error f "cannot assign to lambda") - (compile-error f "invalid function syntax ~s" sym))) - (else - (let ((cell (or (gethash sys:top-fb sym) - (sethash sys:top-fb sym (cons sym nil))))) - (cons (op cdr) - (op sys:rplacd cell)))))) - -(defplace (symbol-function sym-expr) body - (getter setter - (with-gensyms (gs-sym) - ^(let ((,gs-sym (sys:get-fun-getter-setter ,sym-expr ',sys:*pl-form*))) - (macrolet ((,getter () ^(call (car ,',gs-sym))) - (,setter (val) ^(call (cdr ,',gs-sym) ,val))) - ,body)))) - nil - (deleter - ^(macrolet ((,deleter () ^(fmakunbound ,',sym-expr))) - ,body))) - -(defun sys:get-mb (f sym) - (or (gethash sys:top-mb sym) - (compile-error f "unbound macro ~s" sym))) - -(defplace (symbol-macro sym-expr) body - (getter setter - (with-gensyms (binding-sym) - ^(let ((,binding-sym (sys:get-mb ',sys:*pl-form* ,sym-expr))) - (macrolet ((,getter () ^(cdr ,',binding-sym)) - (,setter (val) ^(sys:rplacd ,',binding-sym ,val))) - ,body)))) - nil - (deleter - ^(macrolet ((,deleter () ^(mmakunbound ,',sym-expr))) - ,body))) - -(defun sys:get-vb (sym) - (or (gethash sys:top-vb sym) - (sethash sys:top-vb sym (cons sym nil)))) - -(defplace (symbol-value sym-expr) body - (getter setter - (with-gensyms (binding-sym) - ^(let ((,binding-sym (sys:get-vb ,sym-expr))) - (macrolet ((,getter () ^(cdr ,',binding-sym)) - (,setter (val) ^(sys:rplacd ,',binding-sym ,val))) - ,body)))) - nil - (deleter - ^(macrolet ((,deleter () ^(makunbound ,',sym-expr))) - ,body))) - -(defplace (slot struct sym) body - (getter setter - (with-gensyms (struct-sym slot-sym) - ^(alet ((,struct-sym ,struct) - (,slot-sym ,sym)) - (macrolet ((,getter () ^(slot ,',struct-sym ,',slot-sym)) - (,setter (val) ^(slotset ,',struct-sym ,',slot-sym ,val))) - ,body)))) - (ssetter - ^(macrolet ((,ssetter (val) ^(slotset ,',struct ,',sym ,val))) - ,body))) - -(defmacro define-modify-macro (name lambda-list function) - (let ((cleaned-lambda-list (mapcar [iffi consp car] - (remql : lambda-list)))) - (with-gensyms (place-sym args-sym) - ^(defmacro ,name (:env env ,place-sym ,*lambda-list) - (with-update-expander (getter setter) ,place-sym env - ^(,setter (,',function (,getter) ,,*cleaned-lambda-list))))))) - -(defmacro sys:placelet-1 (((sym place)) :env env . body) - (with-gensyms (tmp-place pl-getter pl-setter) - (unwind-protect - (progn - ;; This temporary proxy place installed into the - ;; *place-update-expander* hash, and the forced expansion - ;; of the symacrolet form are necessary for correctness. - ;; If we don't perform that expand, then the temporary proxy - ;; place is not used, and sym ends up being an alias - ;; for the getter form (,',pl-getter) of the original place. - ;; Then, placelet will only work for places whose getter forms - ;; themselves places. This is not required in general. A (foo ...) - ;; place can, for instance, use (get-foo ...) and (set-foo ...) - ;; getters and setters, where (get-foo ...) is not a place. - ;; If sym turns into a symbol macro for a (get-foo ...) form, - ;; uses of sym as a place will fail due to get-foo not being a place. - (sethash *place-update-expander* tmp-place - (lambda (tmp-getter tmp-setter tmp-place tmp-body) - ^(macrolet ((,tmp-getter () ^(,',pl-getter)) - (,tmp-setter (val) ^(,',pl-setter ,val))) - ,tmp-body))) - (call-update-expander pl-getter pl-setter place env - ^(macrolet ((,tmp-place () ^(,',pl-getter))) - ,(expand ^(symacrolet ((,sym (,tmp-place))) - ,*body) env)))) - (remhash *place-update-expander* tmp-place)))) - -(defmacro placelet* (:form f sym-place-pairs . body) - (tree-case sym-place-pairs - (() ^(progn ,*body)) - (((sym place)) ^(sys:placelet-1 ((,sym ,place)) ,*body)) - (((sym place) . rest-pairs) ^(sys:placelet-1 ((,sym ,place)) - (placelet* (,*rest-pairs) ,*body))) - (obj (compile-error f "bad syntax: ~s" obj)))) - -(defmacro placelet (:form f sym-place-pairs . body) - (unless (all sym-place-pairs - [andf consp (opip length (= 2)) (oand first bindable)]) - (compile-error f "bad syntax: ~s" sym-place-pairs)) - (tree-bind (: syms places) (transpose sym-place-pairs) - (let ((temps (mapcar (ret (gensym)) syms))) - ^(placelet* (,*(zip temps places)) - (symacrolet (,*(zip syms temps)) - ,*body))))) - -(defun sys:register-simple-accessor (get-fun set-fun) - (sethash *place-update-expander* get-fun - (lambda (getter setter place body) - (let* ((args (cdr place)) - (temps (mapcar (ret (gensym)) args))) - ^(let (,(zip temps args)) - (macrolet ((,getter () ^(,',get-fun ,*',temps)) - (,setter (val) - ^(,',set-fun ,*',temps ,val))) - ,body))))) - (sethash *place-clobber-expander* get-fun - (lambda (ssetter place body) - ^(macrolet ((,ssetter (val) - ^(,',set-fun ,*(cdr ',place) ,val))) - ,body))) - get-fun) - -(defmacro define-accessor (get-fun set-fun) - ^(sys:register-simple-accessor ',get-fun ',set-fun)) - -(define-place-macro first (obj) ^(car ,obj)) -(define-place-macro rest (obj) ^(cdr ,obj)) -(define-place-macro second (obj) ^(ref ,obj 1)) -(define-place-macro third (obj) ^(ref ,obj 2)) -(define-place-macro fourth (obj) ^(ref ,obj 3)) -(define-place-macro fifth (obj) ^(ref ,obj 4)) -(define-place-macro sixth (obj) ^(ref ,obj 5)) -(define-place-macro seventh (obj) ^(ref ,obj 6)) -(define-place-macro eighth (obj) ^(ref ,obj 7)) -(define-place-macro ninth (obj) ^(ref ,obj 8)) -(define-place-macro tenth (obj) ^(ref ,obj 9)) - -(define-place-macro last (:env e obj : (n nil have-n)) - (cond - ((and have-n (constantp n e) (not (plusp n))) - ^(sub ,obj t t)) - ((and have-n (constantp n e)) - ^(sub ,obj ,(- n) t)) - (have-n - ^(sub ,obj (- (max ,n 0)) t)) - (t ^(sub ,obj -1 t)))) - -(define-place-macro butlast (:env e obj : (n nil have-n)) - (cond - ((and have-n (constantp n e) (not (plusp n))) - obj) - ((and have-n (constantp n e)) - ^(sub ,obj 0 ,(- n))) - (have-n - ^(sub ,obj 0 (- (max ,n 0)))) - (t ^(sub ,obj 0 -1)))) - -(define-place-macro nth (index obj) - ^(car (nthcdr ,index ,obj))) diff --git a/share/txr/stdlib/pmac.tl b/share/txr/stdlib/pmac.tl deleted file mode 100644 index 48bb3386..00000000 --- a/share/txr/stdlib/pmac.tl +++ /dev/null @@ -1,34 +0,0 @@ -;; Copyright 2017-2020 -;; Kaz Kylheku <kaz@kylheku.com> -;; Vancouver, Canada -;; All rights reserved. -;; -;; Redistribution and use in source and binary forms, with or without -;; modification, are permitted provided that the following conditions are met: -;; -;; 1. Redistributions of source code must retain the above copyright notice, this -;; list of conditions and the following disclaimer. -;; -;; 2. Redistributions in binary form must reproduce the above copyright notice, -;; this list of conditions and the following disclaimer in the documentation -;; and/or other materials provided with the distribution. -;; -;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -(defmacro define-param-expander (keyword - (parms body : (env (gensym)) (form (gensym))) - . forms) - ^(progn - (set [*param-macro* ,keyword] - (lambda (,parms ,body ,env ,form) - ,*forms)) - ,keyword)) diff --git a/share/txr/stdlib/save-exe.tl b/share/txr/stdlib/save-exe.tl deleted file mode 100644 index 4823cd4e..00000000 --- a/share/txr/stdlib/save-exe.tl +++ /dev/null @@ -1,38 +0,0 @@ -;; Copyright 2019-2020 -;; Kaz Kylheku <kaz@kylheku.com> -;; Vancouver, Canada -;; All rights reserved. -;; -;; Redistribution and use in source and binary forms, with or without -;; modification, are permitted provided that the following conditions are met: -;; -;; 1. Redistributions of source code must retain the above copyright notice, this -;; list of conditions and the following disclaimer. -;; -;; 2. Redistributions in binary form must reproduce the above copyright notice, -;; this list of conditions and the following disclaimer in the documentation -;; and/or other materials provided with the distribution. -;; -;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -(defun save-exe (path string) - (let* ((fbuf (file-get-buf txr-exe-path)) - (bs (make-buf-stream fbuf)) - (pre (progn - (stream-set-prop bs :byte-oriented t) - (scan-until-match #/@\(txr\)/ bs))) - (sbuf (ffi-put string (ffi (zarray 128 char))))) - (unless pre - (throwf 'error "~s: ~a isn't a TXR executable" 'save-txr-exe path)) - (put-buf sbuf 0 bs) - (file-put-buf path fbuf) - (chmod path #o766))) diff --git a/share/txr/stdlib/socket.tl b/share/txr/stdlib/socket.tl deleted file mode 100644 index 5f9d3d7c..00000000 --- a/share/txr/stdlib/socket.tl +++ /dev/null @@ -1,158 +0,0 @@ -;; Copyright 2016-2020 -;; Kaz Kylheku <kaz@kylheku.com> -;; Vancouver, Canada -;; All rights reserved. -;; -;; Redistribution and use in source and binary forms, with or without -;; modification, are permitted provided that the following conditions are met: -;; -;; 1. Redistributions of source code must retain the above copyright notice, this -;; list of conditions and the following disclaimer. -;; -;; 2. Redistributions in binary form must reproduce the above copyright notice, -;; this list of conditions and the following disclaimer in the documentation -;; and/or other materials provided with the distribution. -;; -;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -(defstruct sockaddr nil - (:static family nil)) - -(defstruct sockaddr-in sockaddr - (addr 0) (port 0) - (:static family af-inet)) - -(defstruct sockaddr-in6 sockaddr - (addr 0) (port 0) (flow-info 0) (scope-id 0) - (:static family af-inet6)) - -(defstruct sockaddr-un sockaddr - path - (:static family af-unix)) - -(defstruct addrinfo nil - (flags 0) - (family 0) - (socktype 0) - (protocol 0) - (canonname 0)) - -(defvarl shut-rd 0) -(defvarl shut-wr 1) -(defvarl shut-rdwr 2) - -(defun str-inaddr (addr : port) - (let ((d (logand addr #xFF)) - (c (logand (ash addr -8) #xFF)) - (b (logand (ash addr -16) #xFF)) - (a (ash addr -24)) - (p (if port `:@port` ""))) - (if (or (> a 255) (minusp a)) - (throwf 'eval-error "~s: ~a out of range for IPv4 address" - 'str-inaddr addr) - `@a.@b.@c.@d@p`))) - -(defun sys:in6addr-condensed-text (numeric-pieces) - (let* ((notyet t) - (texts (window-mappend - 1 nil - (lambda (pre chunk post) - (cond - ((and notyet (zerop (car chunk)) (cdr chunk)) - (zap notyet) - (if (and post pre) '("") '(":"))) - (t (mapcar (op format nil "~x") chunk)))) - [partition-by zerop numeric-pieces]))) - `@{texts ":"}`)) - -(defun str-in6addr (addr : port) - (let ((str (if (and (<= (width addr) 48) - (= (ash addr -32) #xFFFF)) - `::ffff:@(str-inaddr (logtrunc addr 32))` - (let* ((pieces (let ((count 8)) - (nexpand-left (lambda (val) - (if (minusp (dec count)) - (unless (zerop val) - (throwf 'eval-error - "~s: \ - \ ~a out of range \ - \ for IPv6 address" - 'str-in6addr - addr)) - (cons (logand val #xFFFF) - (ash val -16)))) - addr)))) - (sys:in6addr-condensed-text pieces))))) - (if port - `[@str]:@port` - str))) - -(defun sys:str-inaddr-net-impl (addr wextra : weff) - (let ((mask addr)) - (set mask (logior mask (ash mask 1))) - (set mask (logior mask (ash mask 2))) - (set mask (logior mask (ash mask 4))) - (set mask (logior mask (ash mask 8))) - (set mask (logior mask (ash mask 16))) - (let* ((w (- 32 (width (lognot mask 32)))) - (d (logand addr #xFF)) - (c (logand (ash addr -8) #xFF)) - (b (logand (ash addr -16) #xFF)) - (a (ash addr -24)) - (we (or weff (+ w wextra)))) - (cond - ((or (> a 255) (minusp a)) - (throwf 'eval-error "~s: ~a out of range for IPv4 address" - 'str-inaddr-net addr)) - ((> w 24) `@a.@b.@c.@d/@we`) - ((> w 16) `@a.@b.@c/@we`) - ((> w 8) `@a.@b/@we`) - (t `@a/@we`))))) - -(defun str-inaddr-net (addr : width) - (sys:str-inaddr-net-impl addr 0 width)) - -(defun str-in6addr-net (addr : width) - (if (and (<= (width addr) 48) - (= (ash addr -32) #xFFFF)) - `::ffff:@(sys:str-inaddr-net-impl (logtrunc addr 32) 96 width)` - (let ((mask addr)) - (set mask (logior mask (ash mask 1))) - (set mask (logior mask (ash mask 2))) - (set mask (logior mask (ash mask 4))) - (set mask (logior mask (ash mask 8))) - (set mask (logior mask (ash mask 16))) - (set mask (logior mask (ash mask 32))) - (set mask (logior mask (ash mask 64))) - (let* ((w (- 128 (width (lognot mask 128)))) - (pieces (let ((count 8)) - (nexpand-left (lambda (val) - (if (minusp (dec count)) - (unless (zerop val) - (throwf 'eval-error - "~s: \ - \ ~a out of range \ - \ for IPv6 address" - 'str-in6addr-net - addr)) - (cons (logand val #xFFFF) - (ash val -16)))) - addr))) - (cand-prefix [pieces 0..(trunc (+ w 15) 16)]) - (prefix (if (search cand-prefix '(0 0)) pieces cand-prefix))) - `@(sys:in6addr-condensed-text prefix)/@(or width w)`)))) - -(defplace (sock-peer sock) body - (getter setter - ^(macrolet ((,getter () ^(sock-peer ',',sock)) - (,setter (val) ^(sock-set-peer ,',sock ,val))) - ,body))) diff --git a/share/txr/stdlib/stream-wrap.tl b/share/txr/stdlib/stream-wrap.tl deleted file mode 100644 index ba5a5cb2..00000000 --- a/share/txr/stdlib/stream-wrap.tl +++ /dev/null @@ -1,68 +0,0 @@ -;; Copyright 2017-2020 -;; Kaz Kylheku <kaz@kylheku.com> -;; Vancouver, Canada -;; All rights reserved. -;; -;; Redistribution and use in source and binary forms, with or without -;; modification, are permitted provided that the following conditions are met: -;; -;; 1. Redistributions of source code must retain the above copyright notice, this -;; list of conditions and the following disclaimer. -;; -;; 2. Redistributions in binary form must reproduce the above copyright notice, -;; this list of conditions and the following disclaimer in the documentation -;; and/or other materials provided with the distribution. -;; -;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -(defstruct stream-wrap nil - stream - (:method put-string (me str) - (put-string str me.stream)) - (:method put-char (me chr) - (put-char chr me.stream)) - (:method put-byte (me byte) - (put-byte byte me.stream)) - (:method get-line (me) - (get-line me.stream)) - (:method get-char (me) - (get-char me.stream)) - (:method get-byte (me) - (get-byte me.stream)) - (:method unget-char (me chr) - (unget-char chr me.stream)) - (:method unget-byte (me byte) - (unget-byte byte me.stream)) - (:method put-buf (me buf pos) - (put-buf buf pos me.stream)) - (:method fill-buf (me buf pos) - (fill-buf buf pos me.stream)) - (:method close (me) - (close-stream me.stream)) - (:method flush (me) - (flush-stream me.stream)) - (:method seek (me offs whence) - (seek-stream me.stream offs whence)) - (:method truncate (me len) - (truncate-stream me.stream len)) - (:method get-prop (me sym) - (stream-get-prop me.stream sym)) - (:method set-prop (me sym nval) - (stream-set-prop me.stream sym nval)) - (:method get-error (me) - (get-error me.stream)) - (:method get-error-str (me) - (get-error-str me.stream)) - (:method clear-error (me) - (clear-error me.stream)) - (:method get-fd (me) - (fileno me.stream))) diff --git a/share/txr/stdlib/struct.tl b/share/txr/stdlib/struct.tl deleted file mode 100644 index aa518444..00000000 --- a/share/txr/stdlib/struct.tl +++ /dev/null @@ -1,367 +0,0 @@ -;; Copyright 2015-2020 -;; Kaz Kylheku <kaz@kylheku.com> -;; Vancouver, Canada -;; All rights reserved. -;; -;; Redistribution and use in source and binary forms, with or without -;; modification, are permitted provided that the following conditions are met: -;; -;; 1. Redistributions of source code must retain the above copyright notice, this -;; list of conditions and the following disclaimer. -;; -;; 2. Redistributions in binary form must reproduce the above copyright notice, -;; this list of conditions and the following disclaimer in the documentation -;; and/or other materials provided with the distribution. -;; -;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -(defun sys:bad-slot-syntax (form arg) - (compile-error form "bad slot syntax ~s" arg)) - -(defun sys:prune-missing-inits (slot-init-forms) - (remove-if (tb ((kind name : (init-form nil init-form-present))) - (and (member kind '(:static :instance :function)) - (not init-form-present))) - slot-init-forms)) - -(defmacro defstruct (:form form name-spec super-spec . slot-specs) - (tree-bind (name args) (tree-case name-spec - ((atom . args) (list atom args)) - (atom (list atom nil))) - (unless (bindable name) - (compile-error form "~s isn't a bindable symbol" name)) - (unless (proper-listp slot-specs) - (compile-error form "bad syntax: dotted form")) - (let* ((instance-init-form nil) - (instance-postinit-form nil) - (instance-fini-form nil) - (slot-init-forms (collect-each ((slot slot-specs)) - (tree-case slot - ((word name args . body) - (caseq word - (:method - (when (not args) - (compile-error form - "method ~s needs \ - \ at least one parameter" - name)) - ^(:function ,name - (lambda ,args - (block ,name ,*body)))) - (:function ^(,word ,name - (lambda ,args - (block ,name - ,*body)))) - ((:static :instance) - (when body - (sys:bad-slot-syntax form slot)) - ^(,word ,name ,args)) - (t :))) - ((word (arg) . body) - (caseq word - (:init - (unless (bindable arg) - (sys:bad-slot-syntax form slot)) - (when instance-init-form - (compile-error form - "duplicate :init")) - (set instance-init-form - (cons arg body)) - ^(,word nil nil)) - (:postinit - (unless (bindable arg) - (sys:bad-slot-syntax form slot)) - (when instance-postinit-form - (compile-error form - "duplicate :postinit")) - (set instance-postinit-form - (cons arg body)) - ^(,word nil nil)) - (:fini - (unless (bindable arg) - (sys:bad-slot-syntax form slot)) - (when instance-fini-form - (compile-error form - "duplicate :fini")) - (set instance-fini-form - (cons arg body)) - ^(,word nil nil)) - (t (when body - (sys:bad-slot-syntax form slot)) - :))) - ((word name) - (caseq word - ((:static) - ^(,word ,name)) - ((:instance) - ^(,word ,name nil)) - ((:method :function) - (sys:bad-slot-syntax form slot)) - (t ^(:instance ,word ,name)))) - ((name) - ^(:instance ,name nil)) - (name - ^(:instance ,name nil))))) - (supers (if (and super-spec (atom super-spec)) - (list super-spec) - super-spec)) - (stat-si-forms [keep-if (op member @1 '(:static :function)) - slot-init-forms car]) - (pruned-si-forms (sys:prune-missing-inits stat-si-forms)) - (func-si-forms [keep-if (op eq :function) pruned-si-forms car]) - (val-si-forms [keep-if (op eq :static) pruned-si-forms car]) - (inst-si-forms [keep-if (op eq :instance) slot-init-forms car]) - (stat-slots [mapcar second stat-si-forms]) - (inst-slots [mapcar second inst-si-forms])) - (whenlet ((bad [find-if [notf bindable] - (append stat-slots inst-slots)])) - (compile-error form - (if (symbolp bad) - "slot name ~s isn't a bindable symbol" - "invalid slot specifier syntax: ~s") - bad)) - (each ((s supers)) - (or (find-struct-type s) - (compile-defr-warning form ^(struct-type . ,s) - "inheritance base ~s \ - \ does not name a struct type" - s))) - (let ((arg-sym (gensym)) - (type-sym (gensym))) - (register-tentative-def ^(struct-type . ,name)) - (each ((s stat-slots)) - (register-tentative-def ^(slot . ,s))) - (each ((s inst-slots)) - (register-tentative-def ^(slot . ,s))) - ^(sys:make-struct-type - ',name ',supers ',stat-slots ',inst-slots - ,(if (or func-si-forms val-si-forms) - ^(lambda (,arg-sym) - ,*(mapcar (aret ^(when (static-slot-p ,arg-sym ',@2) - (static-slot-set ,arg-sym ',@2 ,@3))) - (append func-si-forms val-si-forms)))) - ,(if (or inst-si-forms instance-init-form instance-fini-form) - ^(lambda (,arg-sym) - ,*(if (cdr instance-fini-form) - ^((finalize ,arg-sym (lambda (,(car instance-fini-form)) - ,*(cdr instance-fini-form)) - t))) - ,*(if inst-si-forms - ^((let ((,type-sym (struct-type ,arg-sym))) - ,*(mapcar (aret ^(unless (static-slot-p ,type-sym ',@2) - (slotset ,arg-sym ',@2 ,@3))) - inst-si-forms)))) - ,*(if (cdr instance-init-form) - ^((let ((,(car instance-init-form) ,arg-sym)) - ,*(cdr instance-init-form)))))) - ,(when args - (when (> (countql : args) 1) - (compile-error form - "multiple colons in boa syntax")) - (let ((col-pos (posq : args))) - (let ((req-args [args 0..col-pos]) - (opt-args (if col-pos [args (succ col-pos)..:]))) - (let ((r-gens (mapcar (ret (gensym)) req-args)) - (o-gens (mapcar (ret (gensym)) opt-args)) - (p-gens (mapcar (ret (gensym)) opt-args))) - ^(lambda (,arg-sym ,*r-gens - ,*(if opt-args '(:)) - ,*(if opt-args - (mapcar (ret ^(,@1 nil ,@2)) - o-gens p-gens))) - ,*(mapcar (ret ^(slotset ,arg-sym ',@1 ,@2)) - req-args r-gens) - ,*(mapcar (ret ^(if ,@3 - (slotset ,arg-sym ',@1 ,@2))) - opt-args o-gens p-gens)))))) - ,(if instance-postinit-form - ^(lambda (,arg-sym) - ,*(if (cdr instance-postinit-form) - ^((let ((,(car instance-postinit-form) ,arg-sym)) - ,*(cdr instance-postinit-form))))))))))) - -(defmacro sys:struct-lit (name . plist) - ^(sys:make-struct-lit ',name ',plist)) - -(defun sys:check-slot (form slot) - (unless (or (sys:slot-types slot) - (sys:static-slot-types slot)) - (compile-defr-warning form ^(slot . ,slot) - "symbol ~s isn't the name of a struct slot" - slot)) - slot) - -(defun sys:check-struct (form stype) - (unless (find-struct-type stype) - (compile-defr-warning form ^(struct-type . ,stype) - "~s does not name a struct type" - stype))) - -(defmacro qref (:form form obj . refs) - (when (null refs) - (throwf 'eval-error "~s: bad syntax" 'qref)) - (tree-case obj - ((a b) (if (eq a 't) - ^(if ,b (qref ,b ,*refs)) - :)) - (x (tree-case refs - (() ()) - (((pref sym) . more) - (if (eq pref t) - (let ((s (gensym))) - ^(let ((,s (slot ,obj ',sym))) - (if ,s (qref ,s ,*more)))) - :)) - (((dw sym . args)) - (if (eq dw 'dwim) - ^[(slot ,obj ',(sys:check-slot form sym)) ,*args] - :)) - (((dw sym . args) . more) - (if (eq dw 'dwim) - ^(qref [(slot ,obj ',(sys:check-slot form sym)) ,*args] ,*more) - :)) - (((sym . args)) - (let ((osym (gensym))) - (sys:check-slot form sym) - ^(slet ((,osym ,obj)) - (call (slot ,osym ',sym) ,osym ,*args)))) - (((sym . args) . more) - (let ((osym (gensym))) - (sys:check-slot form sym) - ^(qref (slet ((,osym ,obj)) - (call (slot ,osym ',sym) ,osym ,*args)) ,*more))) - ((sym) - (sys:check-slot form sym) - ^(slot ,obj ',sym)) - ((sym . more) - (sys:check-slot form sym) - ^(qref (slot ,obj ',sym) ,*more)) - (obj (throwf 'eval-error "~s: bad syntax: ~s" 'qref refs)))))) - -(defmacro uref (. args) - (cond - ((null args) (throwf 'eval-error "~s: bad syntax" 'uref)) - ((null (cdr args)) - (if (consp (car args)) - ^(umeth ,*(car args)) - ^(usl ,(car args)))) - ((eq t (car args)) - (with-gensyms (ovar) - ^(lambda (,ovar) (qref (t ,ovar) ,*(cdr args))))) - (t (with-gensyms (ovar) - ^(lambda (,ovar) (qref ,ovar ,*args)))))) - -(defun sys:new-type (op form type) - (caseq op - ((new lnew) (sys:check-struct form type) ^',type) - (t type))) - -(defun sys:new-expander (op form spec pairs) - (when (oddp (length pairs)) - (compile-error form - "~s: slot initform arguments must occur pairwise" op)) - (let ((qpairs (mappend (aret ^(',@1 ,@2)) (tuples 2 pairs)))) - (tree-case spec - ((texpr . args) - (let ((type (sys:new-type op form texpr))) - (caseq op - ((new new*) (if qpairs - ^(make-struct ,type (list ,*qpairs) ,*args) - ^(struct-from-args ,type ,*args))) - ((lnew lnew*) ^(make-lazy-struct ,type - (lambda () - (cons (list ,*qpairs) - (list ,*args)))))))) - (texpr - (let ((type (sys:new-type op form texpr))) - (caseq op - ((new new*) ^(struct-from-plist ,type ,*qpairs)) - ((lnew lnew*) ^(make-lazy-struct ,type - (lambda () - (list (list ,*qpairs))))))))))) - -(defmacro new (:form form spec . pairs) - (sys:new-expander (car form) form spec pairs)) - -(defmacro new* (:form form spec . pairs) - (sys:new-expander (car form) form spec pairs)) - -(defmacro lnew (:form form spec . pairs) - (sys:new-expander (car form) form spec pairs)) - -(defmacro lnew* (:form form spec . pairs) - (sys:new-expander (car form) form spec pairs)) - -(defmacro meth (obj slot . bound-args) - ^[(fun method) ,obj ',slot ,*bound-args]) - -(defmacro usl (:form form slot) - (sys:check-slot form slot) - ^(uslot ',slot)) - -(defmacro umeth (:form form slot . bound-args) - (sys:check-slot form slot) - ^[(fun umethod) ',slot ,*bound-args]) - -(defun sys:define-method (type-sym name fun) - (caseq name - (:init (struct-set-initfun type-sym fun)) - (:postinit (struct-set-postinitfun type-sym fun)) - (t (static-slot-ensure type-sym name fun))) - ^(meth ,type-sym ,name)) - -(defmacro defmeth (:form form type-sym name arglist . body) - (cond - ((not (bindable type-sym)) - (compile-error form "~s isn't a valid struct name" type-sym)) - ((not (find-struct-type type-sym)) - (compile-defr-warning form ^(struct-type . ,type-sym) - "definition of struct ~s not seen here" type-sym))) - (register-tentative-def ^(slot . ,name)) - ^(sys:define-method ',type-sym ',name (lambda ,arglist - (block ,name ,*body)))) - -(defmacro with-slots ((. slot-specs) obj-expr . body) - (with-gensyms (obj-sym) - ^(let ((,obj-sym ,obj-expr)) - (symacrolet (,*(mapcar [iff consp - (aret ^(,@1 (slot ,obj-sym ',@2))) - (ret ^(,@1 (slot ,obj-sym ',@1)))] - slot-specs)) - ,*body)))) - -(defun sys:rslotset (struct sym meth-sym val) - (prog1 - (slotset struct sym val) - (call (umethod meth-sym) struct))) - -(defmacro usr:rslot (struct sym meth-sym) - ^(slot ,struct ,sym)) - -(define-place-macro usr:rslot (struct sym meth-sym) - ^(sys:rslot ,struct ,sym ,meth-sym)) - -(defplace (sys:rslot struct sym meth-sym) body - (getter setter - (with-gensyms (struct-sym slot-sym meth-slot-sym) - ^(slet ((,struct-sym ,struct) - (,slot-sym ,sym) - (,meth-slot-sym ,meth-sym)) - (macrolet ((,getter () ^(slot ,',struct-sym ,',slot-sym)) - (,setter (val) ^(sys:rslotset ,',struct-sym ,',slot-sym - ,',meth-slot-sym ,val))) - ,body)))) - (ssetter - ^(macrolet ((,ssetter (val) ^(progn - (sys:rslotset ,',struct ,',sym - ,',meth-sym ,val)))) - ,body))) diff --git a/share/txr/stdlib/tagbody.tl b/share/txr/stdlib/tagbody.tl deleted file mode 100644 index de2a8829..00000000 --- a/share/txr/stdlib/tagbody.tl +++ /dev/null @@ -1,72 +0,0 @@ -;; Copyright 2016-2020 -;; Kaz Kylheku <kaz@kylheku.com> -;; Vancouver, Canada -;; All rights reserved. -;; -;; Redistribution and use in source and binary forms, with or without -;; modification, are permitted provided that the following conditions are met: -;; -;; 1. Redistributions of source code must retain the above copyright notice, this -;; list of conditions and the following disclaimer. -;; -;; 2. Redistributions in binary form must reproduce the above copyright notice, -;; this list of conditions and the following disclaimer in the documentation -;; and/or other materials provided with the distribution. -;; -;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -(defmacro tagbody (:env env . forms) - (when forms - (let* ((tb-id (gensym "tb-id-")) - (next-var (gensym "next-")) - (bblocks (partition forms (op where [orf symbolp integerp chrp]))) - (start-lbl (if bblocks [[orf symbolp integerp chrp] (caar bblocks)]))) - (unless start-lbl - (push (gensym "entry-") (car bblocks))) - (if (and (not start-lbl) (not (cdr bblocks))) - ^(progn nil ,*forms nil) - (let* ((lbls [mapcar car bblocks]) - (forms [mapcar cdr bblocks]) - ;; This trickery transform the individually labeled form - ;; blocks into branches, such that each branch falls through - ;; to the next one thanks to substructure sharing. - (threaded-1 (mapcar (op member-if true) (conses forms))) - (threaded-2 [apply nconc forms]) ;; important side effect - (codes [mapcar car threaded-1])) - (unless (eql (length (uniq lbls)) (length lbls)) - (throwf 'eval-error "~s: duplicate labels occur" 'tagbody)) - (let* ((basic-code ^(let ((,tb-id (gensym "tb-dyn-id-")) - (,next-var 0)) - (sys:for-op () - (,next-var) - ((set ,next-var - (block* ,tb-id - (sys:switch ,next-var #(,*codes)) - nil))))))) - ^(macrolet ((go (:form form label) - (let ((index (posql label ',lbls))) - (if index ^(return* ,',tb-id ,index) form)))) - ,basic-code))))))) - -(defmacro go (label) - (if [[orf symbolp integerp chrp] label] - (throwf 'eval-error "~s: no ~s label visible" 'go label) - (throwf 'eval-error "~s: ~s isn't a symbol, integer or character" 'go label))) - - -(defmacro prog (vars . body) - ^(block nil - (let ,vars (tagbody ,*body)))) - -(defmacro prog* (vars . body) - ^(block nil - (let* ,vars (tagbody ,*body)))) diff --git a/share/txr/stdlib/termios.tl b/share/txr/stdlib/termios.tl deleted file mode 100644 index d8936633..00000000 --- a/share/txr/stdlib/termios.tl +++ /dev/null @@ -1,79 +0,0 @@ -;; Copyright 2016-2020 -;; Kaz Kylheku <kaz@kylheku.com> -;; Vancouver, Canada -;; All rights reserved. -;; -;; Redistribution and use in source and binary forms, with or without -;; modification, are permitted provided that the following conditions are met: -;; -;; 1. Redistributions of source code must retain the above copyright notice, this -;; list of conditions and the following disclaimer. -;; -;; 2. Redistributions in binary form must reproduce the above copyright notice, -;; this list of conditions and the following disclaimer in the documentation -;; and/or other materials provided with the distribution. -;; -;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -(defmeth termios set-iflags (tio . values) - (set tio.iflag (logior tio.iflag . values))) - -(defmeth termios set-oflags (tio . values) - (set tio.oflag (logior tio.oflag . values))) - -(defmeth termios set-cflags (tio . values) - (set tio.cflag (logior tio.cflag . values))) - -(defmeth termios set-lflags (tio . values) - (set tio.lflag (logior tio.lflag . values))) - -(defmeth termios clear-iflags (tio . values) - (set tio.iflag (logand tio.iflag (lognot (logior . values))))) - -(defmeth termios clear-oflags (tio . values) - (set tio.oflag (logand tio.oflag (lognot (logior . values))))) - -(defmeth termios clear-cflags (tio . values) - (set tio.cflag (logand tio.cflag (lognot (logior . values))))) - -(defmeth termios clear-lflags (tio . values) - (set tio.lflag (logand tio.lflag (lognot (logior . values))))) - -(defmeth termios go-raw (tio) - tio.(clear-iflags ignbrk brkint parmrk istrip inlcr igncr icrnl ixon) - tio.(clear-oflags opost) - tio.(clear-cflags csize parenb) - tio.(clear-lflags echo echonl icanon isig) - (if (boundp 'iexten) - tio.(clear-lflags iexten)) - tio.(set-cflags cs8) - (set tio.[cc vmin] 1) - (set tio.[cc vtime] 0)) - -(defmeth termios go-cbreak (tio) - tio.(clear-iflags icrnl) - tio.(clear-lflags icanon) - tio.(set-lflags isig) - (set tio.[cc vmin] 1) - (set tio.[cc vtime] 0)) - -(defmeth termios string-encode (tio) - (let ((*print-base* 16)) - tio.(sys:encode-speeds) - (downcase-str `@{tio.iflag}:@{tio.oflag}:@{tio.cflag}:@{tio.lflag}:\ - @{(list-vec tio.cc) ":"}`))) - -(defmeth termios string-decode (tio string) - (let ((vals (mapcar (op int-str @1 16) (split-str string ":")))) - (lset tio.iflag tio.oflag tio.cflag tio.lflag vals) - (set tio.cc (vec-list (cddddr vals))) - tio.(sys:decode-speeds))) diff --git a/share/txr/stdlib/trace.tl b/share/txr/stdlib/trace.tl deleted file mode 100644 index a9afcd1d..00000000 --- a/share/txr/stdlib/trace.tl +++ /dev/null @@ -1,123 +0,0 @@ -;; Copyright 2016-2020 -;; Kaz Kylheku <kaz@kylheku.com> -;; Vancouver, Canada -;; All rights reserved. -;; -;; Redistribution and use in source and binary forms, with or without -;; modification, are permitted provided that the following conditions are met: -;; -;; 1. Redistributions of source code must retain the above copyright notice, this -;; list of conditions and the following disclaimer. -;; -;; 2. Redistributions in binary form must reproduce the above copyright notice, -;; this list of conditions and the following disclaimer in the documentation -;; and/or other materials provided with the distribution. -;; -;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -(defvar *trace-output* *stdout*) - -(defvar sys:*trace-hash* (hash :equal-based)) -(defvar sys:*trace-level* -1) - -(defvarl sys:tr* (fun *)) -(defvarl sys:trfm (fun format)) - -(defun sys:trace-enter (name args) - [sys:trfm *trace-output* "~*a(~s ~s\n" [sys:tr* sys:*trace-level* 2] "" name args]) - -(defun sys:trace-leave (name val) - [sys:trfm *trace-output* "~*a ~s)\n" [sys:tr* sys:*trace-level* 2] "" val]) - -(defun sys:trace-canonicalize-name (name) - (if (and (consp name) - (eq (car name) 'meth)) - (let* ((req-type-sym (cadr name)) - (slot-sym (caddr name)) - (req-type (find-struct-type req-type-sym)) - (s-s-p (if req-type - (static-slot-p req-type slot-sym))) - (actual-type-sym (if s-s-p - (static-slot-home req-type-sym slot-sym)))) - (if (and s-s-p (neq req-type-sym actual-type-sym)) - ^(meth ,actual-type-sym ,slot-sym) - name)) - name)) - -(defun sys:trace (names) - (cond - ((null names) (hash-keys sys:*trace-hash*)) - (t - (each ((orig-n names) - (n [mapcar sys:trace-canonicalize-name names])) - (unless [sys:*trace-hash* n] - (when (neq n orig-n) - (usr:catch - (throwf 'warning "~s: ~s is actually ~s: tracing that instead" - 'trace orig-n n) - (continue ()))) - (let* ((prev (or (symbol-function n) - (throwf 'eval-error - "~s: ~s does not name a function" 'trace n))) - (lex-n n) - (hook (lambda (. args) - (let ((abandoned t) - (sys:*trace-level* (succ sys:*trace-level*))) - (unwind-protect - (progn - (sys:trace-enter lex-n args) - (let ((val (apply prev args))) - (sys:trace-leave lex-n val) - (set abandoned nil) - val)) - (if abandoned - (sys:trace-leave lex-n :abandoned))))))) - (set (symbol-function n) hook - [sys:*trace-hash* n] prev))))))) - -(defun sys:untrace (names) - (flet ((disable (name-orig name) - (let ((prev (del [sys:*trace-hash* name]))) - (when prev - (when (neq name-orig name) - (usr:catch - (throwf 'warning "~s: ~s is actually ~s: untracing that instead" - 'trace name-orig name) - (continue ()))) - (set (symbol-function name) prev))))) - (if names - (each ((n-orig names) - (n [mapcar sys:trace-canonicalize-name names])) - (disable n-orig n)) - (dohash (n v sys:*trace-hash*) - (disable n n))))) - -(defun sys:trace-redefine-check (orig-name) - (let ((name (sys:trace-canonicalize-name orig-name))) - (when [sys:*trace-hash* name] - (usr:catch - (cond - ((neq name orig-name) - (throwf 'warning "~!~s won't be traced, though it overrides\n\ - ~s which is currently traced" - name orig-name)) - (t (sys:untrace (list name)) - (throwf 'warning "previously traced ~s is redefined and no\ \ - longer traced" - name))) - (continue ()))))) - -(defmacro usr:trace (. names) - ^(sys:trace ',names)) - -(defmacro usr:untrace (. names) - ^(sys:untrace ',names)) diff --git a/share/txr/stdlib/txr-case.tl b/share/txr/stdlib/txr-case.tl deleted file mode 100644 index 5a507fb1..00000000 --- a/share/txr/stdlib/txr-case.tl +++ /dev/null @@ -1,68 +0,0 @@ -;; Copyright 2015-2020 -;; Kaz Kylheku <kaz@kylheku.com> -;; Vancouver, Canada -;; All rights reserved. -;; -;; Redistribution and use in source and binary forms, with or without -;; modification, are permitted provided that the following conditions are met: -;; -;; 1. Redistributions of source code must retain the above copyright notice, this -;; list of conditions and the following disclaimer. -;; -;; 2. Redistributions in binary form must reproduce the above copyright notice, -;; this list of conditions and the following disclaimer in the documentation -;; and/or other materials provided with the distribution. -;; -;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -(defmacro txr-if (name args input : then else) - (let ((syms (keep-if [andf true symbolp [notf keywordp] [notf (op eq t)]] - args)) - (arg-exprs [mapcar [iffi symbolp (ret ^',@1)] args]) - (result (gensym "res-")) - (bindings (gensym "bindings-")) - (insym (gensym "input-"))) - ^(let* ((,insym ,input) - (,result (match-fun ',name (list ,*arg-exprs) - (if (stringp ,insym) (list ,insym) ,insym) - nil))) - (if ,result - (let ((,bindings (car ,result))) - (let (,*[mapcar (ret ^(,@1 (cdr (assoc ',@1 ,bindings)))) - syms]) - ,then)) - ,else)))) - -(defmacro txr-when (name args input . body) - ^(txr-if ,name ,args ,input (progn ,*body))) - -(defmacro txr-case-impl (:form f sym . clauses) - (tree-case clauses - (((name args . body) . other-clauses) - (if (eq name t) : - ^(txr-if ,name ,args ,sym - (progn ,*body) - (txr-case-impl ,sym ,*other-clauses)))) - (((sym . rest) . other-clauses) - (if (eq sym t) - (if other-clauses - (compile-error f "clauses after (t ...) clause ignored") - ^(progn ,*rest)) - (compile-error f "bad syntax: ~s" (car clauses)))) - (() ()) - (atom - (compile-error f "unexpected atom in syntax: ~s" atom)))) - -(defmacro txr-case (input-expr . clauses) - (let ((input (gensym "input-"))) - ^(let ((,input ,input-expr)) - (txr-case-impl ,input ,*clauses)))) diff --git a/share/txr/stdlib/txr-case.txr b/share/txr/stdlib/txr-case.txr deleted file mode 100644 index 9b65d1bc..00000000 --- a/share/txr/stdlib/txr-case.txr +++ /dev/null @@ -1 +0,0 @@ -@(load "txr-case.tl") diff --git a/share/txr/stdlib/type.tl b/share/txr/stdlib/type.tl deleted file mode 100644 index d784b893..00000000 --- a/share/txr/stdlib/type.tl +++ /dev/null @@ -1,39 +0,0 @@ -;; Copyright 2015-2020 -;; Kaz Kylheku <kaz@kylheku.com> -;; Vancouver, Canada -;; All rights reserved. -;; -;; Redistribution and use in source and binary forms, with or without -;; modification, are permitted provided that the following conditions are met: -;; -;; 1. Redistributions of source code must retain the above copyright notice, this -;; list of conditions and the following disclaimer. -;; -;; 2. Redistributions in binary form must reproduce the above copyright notice, -;; this list of conditions and the following disclaimer in the documentation -;; and/or other materials provided with the distribution. -;; -;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -(defmacro typecase (form . clauses) - (let* ((val (gensym)) - (cond-pairs (collect-each ((cl clauses)) - (tree-case cl - ((type . body) - (if (symbolp type) - ^((typep ,val ',type) ,*body) - :)) - (else (throwf 'eval-error - "~s: bad clause syntax: ~s" - 'typecase cl)))))) - ^(let ((,val ,form)) - (cond ,*cond-pairs)))) diff --git a/share/txr/stdlib/ver.tl b/share/txr/stdlib/ver.tl deleted file mode 100644 index bf26de46..00000000 --- a/share/txr/stdlib/ver.tl +++ /dev/null @@ -1,2 +0,0 @@ -(defvarl lib-version 233) -(defvarl *lib-version* lib-version) diff --git a/share/txr/stdlib/ver.txr b/share/txr/stdlib/ver.txr deleted file mode 100644 index 2339bda7..00000000 --- a/share/txr/stdlib/ver.txr +++ /dev/null @@ -1 +0,0 @@ -@(load "ver.tl") diff --git a/share/txr/stdlib/vm-param.tl b/share/txr/stdlib/vm-param.tl deleted file mode 100644 index 1198831b..00000000 --- a/share/txr/stdlib/vm-param.tl +++ /dev/null @@ -1,37 +0,0 @@ -;; Copyright 2018-2020 -;; Kaz Kylheku <kaz@kylheku.com> -;; Vancouver, Canada -;; All rights reserved. -;; -;; Redistribution and use in source and binary forms, with or without -;; modification, are permitted provided that the following conditions are met: -;; -;; 1. Redistributions of source code must retain the above copyright notice, this -;; list of conditions and the following disclaimer. -;; -;; 2. Redistributions in binary form must reproduce the above copyright notice, -;; this list of conditions and the following disclaimer in the documentation -;; and/or other materials provided with the distribution. -;; -;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -(defsymacro %lev-size% 1024) -(defsymacro %max-lev-idx% (macro-time (pred %lev-size%))) -(defsymacro %lev-bits% 10) -(defsymacro %max-lev% 63) -(defsymacro %max-v-lev% (macro-time (ppred %max-lev%))) -(defsymacro %imm-width% 32) -(defsymacro %sm-lev-size% 64) -(defsymacro %max-sm-lev-idx% (macro-time (pred %sm-lev-size%))) -(defsymacro %max-sm-lev% 15) -(defsymacro %sm-lev-bits% 6) -(defsymacro %max-lambda-fixed-args% 127) diff --git a/share/txr/stdlib/with-resources.tl b/share/txr/stdlib/with-resources.tl deleted file mode 100644 index 5c1b8130..00000000 --- a/share/txr/stdlib/with-resources.tl +++ /dev/null @@ -1,51 +0,0 @@ -;; Copyright 2015-2020 -;; Kaz Kylheku <kaz@kylheku.com> -;; Vancouver, Canada -;; All rights reserved. -;; -;; Redistribution and use in source and binary forms, with or without -;; modification, are permitted provided that the following conditions are met: -;; -;; 1. Redistributions of source code must retain the above copyright notice, this -;; list of conditions and the following disclaimer. -;; -;; 2. Redistributions in binary form must reproduce the above copyright notice, -;; this list of conditions and the following disclaimer in the documentation -;; and/or other materials provided with the distribution. -;; -;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -(defmacro with-resources (:form f res-bindings . body) - (tree-case res-bindings - (((sym init) . rest) - ^(let ((,sym ,init)) - (with-resources ,rest ,*body))) - (((sym init . cleanup) . rest) - ^(let ((,sym ,init)) - (when ,sym - (unwind-protect - (with-resources ,rest ,*body) - ,*cleanup)))) - ((sym . rest) - ^(let (,sym) - (with-resources ,rest ,*body))) - (nil - ^(progn ,*body)) - (other (compile-error f "bad syntax")))) - -(defmacro with-objects (var-init-forms . body) - (let ((gens (mapcar (ret (gensym)) var-init-forms))) - ^(let ,gens - (unwind-protect - (let* ,(mapcar (aret ^(,@2 (set ,@1 ,@3))) gens var-init-forms) - ,*body) - ,*(reverse (mapcar (ret ^(call-finalizers ,@1)) gens)))))) diff --git a/share/txr/stdlib/with-stream.tl b/share/txr/stdlib/with-stream.tl deleted file mode 100644 index d79ff5da..00000000 --- a/share/txr/stdlib/with-stream.tl +++ /dev/null @@ -1,58 +0,0 @@ -;; Copyright 2015-2020 -;; Kaz Kylheku <kaz@kylheku.com> -;; Vancouver, Canada -;; All rights reserved. -;; -;; Redistribution and use in source and binary forms, with or without -;; modification, are permitted provided that the following conditions are met: -;; -;; 1. Redistributions of source code must retain the above copyright notice, this -;; list of conditions and the following disclaimer. -;; -;; 2. Redistributions in binary form must reproduce the above copyright notice, -;; this list of conditions and the following disclaimer in the documentation -;; and/or other materials provided with the distribution. -;; -;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -(defmacro with-out-string-stream ((stream) . body) - ^(let ((,stream (make-string-output-stream))) - ,*body - (get-string-from-stream ,stream))) - -(defmacro with-out-strlist-stream ((stream) . body) - ^(let ((,stream (make-strlist-output-stream))) - ,*body - (get-list-from-stream ,stream))) - -(defmacro with-out-buf-stream ((stream : buf) . body) - ^(let ((,stream (make-buf-stream ,*[[iff have list] buf]))) - ,*body - (get-buf-from-stream ,stream))) - -(defmacro with-in-string-stream ((stream string) . body) - ^(let ((,stream (make-string-input-stream ,string))) - ,*body)) - -(defmacro with-in-string-byte-stream ((stream string) . body) - ^(let ((,stream (make-string-byte-input-stream ,string))) - ,*body)) - -(defmacro with-in-buf-stream ((stream buf) . body) - ^(let ((,stream (make-buf-stream ,buf))) - ,*body)) - -(defmacro with-stream ((sym stream) . body) - ^(let ((,sym ,stream)) - (unwind-protect - (progn ,*body) - (close-stream ,sym)))) diff --git a/share/txr/stdlib/yield.tl b/share/txr/stdlib/yield.tl deleted file mode 100644 index 947c3a1d..00000000 --- a/share/txr/stdlib/yield.tl +++ /dev/null @@ -1,118 +0,0 @@ -;; Copyright 2015-2020 -;; Kaz Kylheku <kaz@kylheku.com> -;; Vancouver, Canada -;; All rights reserved. -;; -;; Redistribution and use in source and binary forms, with or without -;; modification, are permitted provided that the following conditions are met: -;; -;; 1. Redistributions of source code must retain the above copyright notice, this -;; list of conditions and the following disclaimer. -;; -;; 2. Redistributions in binary form must reproduce the above copyright notice, -;; this list of conditions and the following disclaimer in the documentation -;; and/or other materials provided with the distribution. -;; -;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -(defstruct (sys:yld-item val cont) nil val cont) - -(defstruct (sys:rcv-item val cont) nil val cont) - -(defun sys:obtain-impl (fun) - (finalize - (lambda (: resume-val) - (let ((yi (call fun resume-val))) - (while t - (cond - ((eq (typeof yi) 'sys:yld-item) - (call fun 'sys:cont-free) - (set fun yi.cont) - (return yi.val)) - ((eq (typeof yi) 'sys:rcv-item) - (call fun 'sys:cont-free) - (set fun yi.cont) - (set yi (call fun resume-val))) - (t (return yi)))))) - (lambda (cont) - (call cont 'sys:cont-poison)))) - -(defmacro obtain (. body) - (let ((arg (gensym "arg"))) - ^(sys:obtain-impl (lambda (,arg) - (unless (eq ,arg 'sys:cont-free) - ,*body))))) - -(defmacro obtain-block (name . body) - ^(obtain (block ,name ,*body))) - -(defmacro obtain* (. body) - (let ((arg (gensym "arg")) - (fun (gensym "fun"))) - ^(let ((,fun (sys:obtain-impl (lambda (,arg) - (unless (eq ,arg 'sys:cont-free) - ,*body))))) - (call ,fun nil) - ,fun))) - -(defmacro obtain*-block (name . body) - ^(obtain* (block ,name ,*body))) - -(defmacro yield-from (:form ctx-form name : (form nil have-form-p)) - (let ((cont-sym (gensym))) - ^(sys:capture-cont ',name - (lambda (,cont-sym) - (sys:abscond-from ,name - ,(if have-form-p - ^(new (sys:yld-item - ,form ,cont-sym)) - ^(new (sys:rcv-item - nil ,cont-sym))))) - ',ctx-form))) - -(defmacro yield (: (form nil have-form-p)) - (if have-form-p - ^(yield-from nil ,form) - ^(yield-from nil))) - -(defmacro suspend (:form form name sym . body) - ^(sys:capture-cont ',name (lambda (,sym) - (sys:abscond-from ,name (progn ,*body))) - ',form)) - -(defun hlet-expand (op raw-vis body) - (let* ((vis (mapcar [iffi atom list] raw-vis)) - (nvars (len vis)) - (syms [mapcar car vis]) - (inits [mapcar cadr vis]) - (letop (if (eq op 'hlet*) 'let* 'let)) - (gens (mapcar (ret (gensym)) vis)) - (vec (gensym)) - (macs (mapcar (ret ^(,@1 (vecref ,vec ,@2))) - syms (range 0))) - (inits (mapcar (ret ^(set (vecref ,vec ,@1) ,@2)) - (range 0) inits))) - (if (eq op 'hlet*) - ^(let* ((,vec (vector ,nvars))) - (symacrolet ,macs - ,*inits - ,*body)) - ^(let* ((,vec (vector ,nvars))) - ,*inits - (symacrolet ,macs - ,*body))))) - -(defmacro hlet (var-inits . body) - (hlet-expand 'hlet var-inits body)) - -(defmacro hlet* (var-inits . body) - (hlet-expand 'hlet* var-inits body)) |