ヤドカリ自習室(第二倉庫)

2009-12-16

[]問題5.15&問題5.16 08:03

;; レジスタ
(define (make-register name)
  (let ((contents '*unassigned*))
    (define (dispatch message)
      (cond ((eq? message 'get) contents)
            ((eq? message 'set) (lambda (value) (set! contents value)))
            (else (error "Unknown request -- REGISTER" message))))
    dispatch))

(define (get-contents register)
  (register 'get))

(define (set-contents! register value)
  ((register 'set) value))

;; スタック
(define (make-stack)
  (let ((s '())
        (number-pushes 0)
        (max-depth 0)
        (current-depth 0))
    (define (push x)
      (set! s (cons x s))
      (set! number-pushes (+ 1 number-pushes))
      (set! current-depth (+ 1 current-depth))
      (set! max-depth (max current-depth max-depth)))

    (define (pop)
      (if (null? s)
          (error "Empty stack -- POP")
          (let ((top (car s)))
            (set! s (cdr s))
            (set! current-depth (- current-depth 1))
            top)))

    (define (initialize)
      (set! s '())
      (set! number-pushes 0)
      (set! max-depth 0)
      (set! current-depth 0)
      'done)
 
    (define (print-statistics)
      (newline)
      (display (list 'total-pushes  '= number-pushes
                     'maximum-depth '= max-depth)))

    (define (dispatch message)
      (cond ((eq? message 'push)       push)
            ((eq? message 'pop)        (pop))
            ((eq? message 'initialize) (initialize))
            ((eq? message 'print-statistics)
             (print-statistics))
            (else
             (error "Unknown request -- STACK" message))))
    dispatch))

(define (pop stack)
  (stack 'pop))

(define (push stack value)
  ((stack 'push) value))

;; 基本計算機
(define (start machine)
  (machine 'start))

(define (get-register-contents machine register-name)
  (get-contents (get-register machine register-name)))

(define (set-register-contents! machine register-name value)
  (set-contents! (get-register machine register-name) value)
  'done)

(define (get-register machine register-name)
  ((machine 'get-register) register-name))


;; 5.2.2 アセンブラ
(define (make-new-machine)
  (let ((pc (make-register 'pc))
	(flag (make-register 'flag))
	(stack (make-stack))
	(the-instruction-sequence '())
	(information '())
        (insts-count 0)
        (trace-on? #f))
    (let ((the-ops
	   (list (list 'initialize-stack
		       (lambda () (stack 'initialize)))
                 (list 'print-stack-statistics
                       (lambda () (stack 'print-statistics)))))
	  (register-table
	   (list (list 'pc pc) (list 'flag flag))))
 
      (define (allocate-register name)
	(if (assoc name register-table)
	    (error "Multiply defined register: " name)
	    (set! register-table
		  (cons (list name (make-register name))
			register-table)))
	'register-allocated)
      (define (lookup-register name)
	(let ((val (assoc name register-table)))
	  (if val
	      (cadr val)
	      (error "Unknown register: " name))))
      (define (execute)
	(let ((insts (get-contents pc)))
	  (if (null? insts)
	      'done
              (let ((inst (car insts)))
                ((instruction-execution-proc inst))
                (set! insts-count (+ insts-count 1))
                (if trace-on?
                    (begin (display (instruction-text inst))
                           (newline)))
                (execute)))))
      (define (get-goto-reg information)
        (define (iter info result)
          (if (null? info) result
              (if (and (eq? (caar info) 'goto)
                       (eq? (car (cadr (car info))) 'reg))
                  (iter (cdr info) (cons (cadr (cadr (car info))) result))
                  (iter (cdr info) result))))
        (iter information '()))
      (define (get-save-restore-reg information)
        (define (iter info result)
          (if (null? info) result
              (if (or (eq? (caar info) 'save)
                      (eq? (caar info) 'restore))
                  (iter (cdr info) (cons (cadr (car info)) result))
                  (iter (cdr info) result))))
        (remove-duplicates (iter information '())))
      (define (get-assign-source information)
        (define (iter info result)
          (if (null? info) result
              (if (eq? (caar info) 'assign)
                  (iter (cdr info)
                        (cons
                         (if (null? (cdddr (car info)))
                             (cdr (car info))
                             (list (cadr (car info)) (cddr (car info))))
                         result))
                  (iter (cdr info) result))))
        (iter information '()))
      (define (aggregate source)
        (map (lambda (r)
               (cons r
                     (map cadr
                          (filter (lambda (p) (eq? (car p) r)) source))))
             (remove-duplicates (map car source))))
      (define (dispatch message)
	(cond ((eq? message 'start)
	       (set-contents! pc the-instruction-sequence)
	       (execute))
	      ((eq? message 'install-instruction-sequence)
	       (lambda (seq) (set! the-instruction-sequence seq)))
	      ((eq? message 'allocate-register) allocate-register)
	      ((eq? message 'get-register) lookup-register)
	      ((eq? message 'install-operations)
	       (lambda (ops) (set! the-ops (append the-ops ops))))
	      ((eq? message 'stack) stack)
	      ((eq? message 'operations) the-ops)
	      ((eq? message 'install-information)
	       (lambda (info) (set! information (append information info))))
	      ((eq? message 'get-insts-info)
	       information)
              ((eq? message 'get-goto-reg-info)
               (get-goto-reg information))
              ((eq? message 'get-save-restore-reg-info)
               (get-save-restore-reg information))
              ((eq? message 'get-assign-source-info)
               (aggregate (get-assign-source information)))
              ((eq? message 'print-insts-count)
               (begin (display "instruction counting: ")
                      (display insts-count)
                      (set! insts-count 0)
                      (newline)
                      'cleared))
              ((eq? message 'trace-on)
               (set! trace-on? #t))
              ((eq? message 'trace-off)
               (set! trace-on? #f))
              (else (error "Unknown request -- MACHINE" message))))
      dispatch)))

(define (assemble controller-text machine)
  (extract-labels controller-text
    (lambda (insts labels)
      (update-insts! insts labels machine)
      (cons insts (make-information insts)))))

(define (make-machine register-names ops controller-text)
  (let ((machine (make-new-machine)))
    (for-each (lambda (register-name)
		((machine 'allocate-register) register-name))
	      register-names)
    ((machine 'install-operations) ops)
    (let ((assembled (assemble controller-text machine)))
      ((machine 'install-instruction-sequence)
       (car assembled))
      ((machine 'install-information)
       (cdr assembled)))
    machine))

(define (extract-labels text receive)
  (if (null? text)
      (receive '() '())
      (extract-labels
       (cdr text)
       (lambda (insts labels)
         (let ((next-inst (car text)))
           (if (symbol? next-inst)
               (receive insts
                        (cons (make-label-entry next-inst insts)
                              labels))
               (receive (cons (make-instruction next-inst)
                              insts)
                        labels)))))))

(define (update-insts! insts labels machine)
  (let ((pc    (get-register machine 'pc))
        (flag  (get-register machine 'flag))
        (stack (machine 'stack))
        (ops   (machine 'operations)))
    (for-each
     (lambda (inst)
       (set-instruction-execution-proc!
        inst
        (make-execution-procedure
         (instruction-text inst) labels machine
         pc flag stack ops)))
     insts)))

;; constructor for an instruction
(define (make-instruction text)
  (cons text '()))

;; selector(getter) for an instruction
(define (instruction-text inst)
  (car inst))

;; selector(getter) for an instruction
(define (instruction-execution-proc inst)
  (cdr inst))

;; setter for an instruction
(define (set-instruction-execution-proc! inst proc)
  (set-cdr! inst proc))

(define (make-label-entry label-name insts)
  (cons label-name insts))

(define (lookup-label labels label-name)
  (let ((val (assoc label-name labels)))
    (if val
        (cdr val)
        (error "Undefined label -- ASSEMBLE" label-name))))

;; 5.2.3 命令の実行手続きの生成

(define (make-execution-procedure inst labels machine pc flag stack ops)
  (cond ((eq? (car inst) 'assign)
         (make-assign inst machine labels ops pc))

        ((eq? (car inst) 'test)
         (make-test inst machine labels ops flag pc))

        ((eq? (car inst) 'branch)
         (make-branch inst machine labels flag pc))

        ((eq? (car inst) 'goto)
         (make-goto inst machine labels pc))

        ((eq? (car inst) 'save)
         (make-save inst machine stack pc))

        ((eq? (car inst) 'restore)
         (make-restore inst machine stack pc))

        ((eq? (car inst) 'perform)
         (make-perform inst machine labels ops pc))

        (else
         (error "Unknown instruction type -- ASSEMBLE" inst))))


;; assign命令
(define (make-assign inst machine labels operations pc)
  (let ((target (get-register machine (assign-reg-name inst)))
        (value-exp (assign-value-exp inst)))
    (let ((value-proc
           (if (operation-exp? value-exp)
               (make-operation-exp value-exp machine labels operations)
               (make-primitive-exp (car value-exp) machine labels))))
      (lambda ()
        (set-contents! target (value-proc))
        (advance-pc pc)))))

(define (assign-reg-name assign-instruction)
  (cadr assign-instruction))

(define (assign-value-exp assign-instruction)
  (cddr assign-instruction))

(define (advance-pc pc)
  (set-contents! pc (cdr (get-contents pc)))) ; pc には命令列
                                              ; (the-instruction-sequence)
                                              ; が入ってる

;; test, branch および goto命令

(define (make-test inst machine labels operations flag pc)
  (let ((condition (test-condition inst)))
    (if (operation-exp? condition)
        (let ((condition-proc
               (make-operation-exp condition machine labels operations)))
          (lambda ()
            (set-contents! flag (condition-proc))
            (advance-pc pc)))
        (error "Bad TEST instruction -- ASSEMBLE" inst))))

(define (test-condition test-instruction)
  (cdr test-instruction))


(define (make-branch inst machine labels flag pc)
  (let ((dest (branch-dest inst)))
    (if (label-exp? dest)
        (let ((insts
               (lookup-label labels (label-exp-label dest))))
          (lambda ()
            (if (get-contents flag)
                (set-contents! pc insts)
                (advance-pc pc))))
        (error "Bad BRANCH instruction -- ASSEMBLE" inst))))

(define (branch-dest branch-instruction)
  (cadr branch-instruction))


(define (make-goto inst machine labels pc)
  (let ((dest (goto-dest inst)))
    (cond ((label-exp? dest)
           (let ((insts
                  (lookup-label labels (label-exp-label dest))))
             (lambda ()
               (set-contents! pc insts))))
          ((register-exp? dest)
           (let ((reg
                  (get-register machine (register-exp-reg dest))))
             (lambda ()
               (set-contents! pc (get-contents reg)))))
          (else
           (error "Bad GOTO instruction -- ASSEMBLE" inst)))))

(define (goto-dest goto-instruction)
  (cadr goto-instruction))


;; その他の命令
(define (make-save inst machine stack pc)
  (let ((reg (get-register machine (stack-inst-reg-name inst))))
    (lambda ()
      (push stack (get-contents reg))
      (advance-pc pc))))

(define (make-restore inst machine stack pc)
  (let ((reg (get-register machine (stack-inst-reg-name inst))))
    (lambda ()
      (set-contents! reg (pop stack))
      (advance-pc pc))))

(define (stack-inst-reg-name stack-instruction)
  (cadr stack-instruction))


(define (make-perform inst machine labels operations pc)
  (let ((action (perform-action inst)))
    (if (operation-exp? action)
        (let ((action-proc
               (make-operation-exp action machine labels operations)))
          (lambda ()
            (action-proc)
            (advance-pc pc)))
        (error "Bad PERFORM instruction -- ASSEMBLE" inst))))

(define (perform-action inst)
  (cdr inst))


;; 部分式の実行手続き
(define (make-primitive-exp exp machine labels)
  (cond ((constant-exp? exp)
         (let ((c (constant-exp-value exp)))
           (lambda () c)))

        ((label-exp? exp)
         (let ((insts
                (lookup-label labels
                              (label-exp-label exp))))
           (lambda () insts)))
        
        ((register-exp? exp)
         (let ((r
                (get-register machine
                              (register-exp-reg exp))))
           (lambda () (get-contents r))))

        (else (error "Unknown expression type -- ASSEMBLE" exp))))

(define (tagged-list? exp tag)
  (and (pair? exp)
       (eq? (car exp) tag)))

(define (register-exp? exp) (tagged-list? exp 'reg))
(define (register-exp-reg exp) (cadr exp))

(define (constant-exp? exp) (tagged-list? exp 'const))
(define (constant-exp-value exp) (cadr exp))

(define (label-exp? exp) (tagged-list? exp 'label))
(define (label-exp-label exp) (cadr exp))

(define (make-operation-exp exp machine labels operations)
  (let ((op (lookup-prim (operation-exp-op exp) operations))
        (aprocs
         (map (lambda (e)
                (make-primitive-exp e machine labels))
              (operation-exp-operands exp))))
    (lambda ()
      (apply op (map (lambda (p) (p)) aprocs)))))

(define (operation-exp? exp)
  (and (pair? exp) (tagged-list? (car exp) 'op)))
(define (operation-exp-op exp)
  (cadr (car exp)))
(define (operation-exp-operands exp)
  (cdr exp))

(define (lookup-prim symbol operations)
  (let ((val (assoc symbol operations)))
    (if val
        (cadr val)
        (error "Unknown operation -- ASSEMBLE" symbol))))

(define (filter pred lst)
  (cond ((null? lst) '())
        ((pred (car lst))
         (cons (car lst)
               (filter pred (cdr lst))))
        (else (filter pred (cdr lst)))))

(define (remove-duplicates lst)
  (define (iter lst result)
    (if (null? lst) result
        (if (member (car lst) (cdr lst))
            (iter (cdr lst) result)
            (iter (cdr lst) (cons (car lst) result)))))
  (iter lst '()))

(define (make-information insts)
  (let ((insts-text (map instruction-text insts)))
    (apply append
           (map
            (lambda (name)
              (remove-duplicates
               (filter
                (lambda (i) (eq? (car i) name))
                insts-text)))
            '(assign test branch goto save restore perform)))))

(define (get-insts-info machine)
  (machine 'get-insts-info))
(define (get-goto-reg-info machine)
  (machine 'get-goto-reg-info))
(define (get-save-restore-reg-info machine)
  (machine 'get-save-restore-reg-info))
(define (get-assign-source-info machine)
  (machine 'get-assign-source-info))
(define (print-insts-count machine)
  (machine 'print-insts-count))
(define (trace-on machine)
  (machine 'trace-on))
(define (trace-off machine)
  (machine 'trace-off))

(define fib-machine
  (make-machine
   '(n val continue)
   (list (list '< <) (list '- -) (list '+ +))
   '(
       (assign continue (label fib-done))
     fib-loop
       (test (op <) (reg n) (const 2))
       (branch (label immediate-answer))
       ;; set up to compute Fib(n - 1)
       (save continue)
       (assign continue (label afterfib-n-1))
       (save n)                           ; save old value of n
       (assign n (op -) (reg n) (const 1)); clobber n to n - 1
       (goto (label fib-loop))            ; perform recursive call
     afterfib-n-1                         ; upon return, val contains Fib(n - 1)
       (restore n)
       (restore continue)
       ;; set up to compute Fib(n - 2)
       (assign n (op -) (reg n) (const 2))
       (save continue)
       (assign continue (label afterfib-n-2))
       (save val)                         ; save Fib(n - 1)
       (goto (label fib-loop))
     afterfib-n-2                         ; upon return, val contains Fib(n - 2)
       (assign n (reg val))               ; n now contains Fib(n - 2)
       (restore val)                      ; val now contains Fib(n - 1)
       (restore continue)
       (assign val                        ;  Fib(n - 1) +  Fib(n - 2)
               (op +) (reg val) (reg n)) 
     (goto (reg continue))              ; return to caller, answer is in val
     immediate-answer
       (assign val (reg n))               ; base case:  Fib(n) = n
       (goto (reg continue))
     fib-done)))

(define (test-fib-machine)
  (set-register-contents! fib-machine 'n 5)
  (start fib-machine)
  (display (get-register-contents fib-machine 'val))
  (newline)
  (print-insts-count fib-machine))

(define (info-fib-machine)
  (display "instructions: ")
  (display (get-insts-info fib-machine))
  (newline) (newline)
  (display "label registers: ")
  (display (get-goto-reg-info fib-machine))
  (newline)  (newline)
  (display "stacked registers: ")
  (display (get-save-restore-reg-info fib-machine))
  (newline)  (newline)
  (display "assign sources: ")
  (display (get-assign-source-info fib-machine))
  (newline)
  'done)

;;(trace-on fib-machine)
;;(test-fib-machine)

bucbaiswlnbucbaiswln2014/06/02 20:03ibiwutjdq, <a href="http://www.jjmhoxwkbl.com/">yxkvgqsxix</a> , [url=http://www.uabyktuvph.com/]hvxifqveek[/url], http://www.kedrioqvum.com/ yxkvgqsxix

ChasPriodsChasPriods2017/05/10 05:49Levitra Costo In Farmacia Cialis 20 <a href=http://byuvaigranonile.com>viagra</a> Overdose Amoxicillin 3000 Mg Day Cialis 5 Mg Filmtabl 28 St

ShanlekShanlek2017/11/05 21:39Viagra 100mg 12 Preis <a href=http://costofcial.com>buy cialis</a> Priligy Viagra Together

MauNAVAMauNAVA2018/01/28 09:49Finasteride Website 40 For $99 <a href=http://cheapciali.com>online pharmacy</a> Need Plavix From The Uk

GerbedaGerbeda2018/02/08 18:23Viagra Sale Online Buy Viagra Cialis On Line <a href=http://tadalaffbuy.com>viagra cialis</a> Viagra Acidez Estomacal

GerbedaGerbeda2018/02/11 20:02Cialis Once Day Amoxicillin Yogurt Effect <a href=http://brandciali.com>cialis</a> Dramamine Buy Australia

GerbedaGerbeda2018/02/12 05:23Online Canadian Pharmacies <a href=http://brandciali.com>cialis price</a> Hoa To Buy Alli Pills

GerbedaGerbeda2018/02/13 16:46Buy Cheap Propecia Levitra Online Erfahrungen Sore Throat Amoxicillin <a href=http://cialviag.com>online pharmacy</a> Generic V Real Cialis

GerbedaGerbeda2018/02/14 12:48Cialis Precios Farmacia Achat Levitra Au Usa <a href=http://cialviag.com>viagra cialis</a> Prix Viagra Pas Cher

GerbedaGerbeda2018/02/14 22:23Levitra Alkohol Lasix Overnight Shipping Best National Pharmacy <a href=http://buyciali.com>cialis price</a> Clomid 50mg Posologie A Acheter Kamagra Petite Quantite Coreg Fpr Cheap With No Prescription

JacExtildJacExtild2018/02/15 02:28Generic Hydrochlorothiazide Tablet Without Perscription Zithromax Z Pak For Sale <a href=http://buyciali.com>cialis</a> Need Fluoxetine Mastercard Accepted Medication Free Shipping Cialis Internet Canada

GerbedaGerbeda2018/02/15 10:38Proscar Ogame Propecia Cialis Tablets 20mg <a href=http://cialibuy.com>online pharmacy</a> Amoxicillin And Std'S Amoxicillin A Clavulante Potassium Tablets

GerbedaGerbeda2018/02/16 05:46On Line Meds Propecia For Sale Online Pharmacy Finasteride Generique <a href=http://cial20mg.com>cialis</a> Forum Meilleur Site Achat Cialis

GerbedaGerbeda2018/02/17 07:10Association Amoxicillin Cephalosporin <a href=http://cialibuy.com>cialis online</a> Discount Fedex Isotretinoin With Overnight Delivery Medication Overseas Cheap Sex Pills Priligy 30mg Side Effects

GerbedaGerbeda2018/02/18 03:45Levitra Venta Libre <a href=http://ciali5mg.com>cialis buy online</a> Macrobid Buying Overseas

GerbedaGerbeda2018/02/18 16:26Effets Secondaires Viagra 100 Propecia Side Effects Women Cheap Effective Cialis <a href=http://cialiorder.com>cialis buy online</a> Efecto De Kamagra En Jovenes Precio Cialis Espana

GerbedaGerbeda2018/02/19 05:37Expiration Keflex Propecia Folcres Generico Clomid Date Regles <a href=http://cheapciali.com>cialis</a> Viagra Pріт‘ Nett I Sverige

GerbedaGerbeda2018/02/19 14:15Duracion Levitra Where Can I Buy Elavil Cialis Online Ricetta <a href=http://cialiviag.com>cialis</a> Non Prescripion Compazine Viagra Nombre Generico Quiero Comprar Viagra Sin Receta

GerbedaGerbeda2018/02/20 08:05Levitra Senza Ricetta In Farmacia Kamagra Ajanta Pharmaceuticals Cialis 10 Mg Online <a href=http://brandciali.com>cialis</a> Lactating Amoxicillin Nizagara Online Canadian

KelgomiKelgomi2018/04/08 00:50Cialis 20mg Gratis Uk Buy Propecia Keflex A Sulpha Drug <a href=http://cialibuy.com>overnight cialis delivery</a> Kamagra PiРів„– Economico Mono And Amoxicillin

KelgomiKelgomi2018/04/13 20:28Fluoxetine Need Legally Low Price With Free Shipping Levitra Ordering <a href=http://cheapciali.com>cialis ohne rezept</a> Viagra Online Comprar

ShaPrepleShaPreple2018/04/15 18:05Cialis E Psicofarmaci Cialis Ohne Rezept Schweiz <a href=http://cheapciali.com>cialis from canada</a> Online Pharmacies India

MarkEnuctMarkEnuct2018/04/17 05:34erectile enhancement supplements
<a href=http://edpils-gg.com/>solutions to erectile dysfunction</a>
erectile pill as shown on shark tank
<a href="http://edpils-gg.com/">erectile dysfunction pills</a>

HilhaugHilhaug2018/04/17 06:00Cephalexin Clamydia Fedex Viagra Generic <a href=http://cialviag.com>cialis from canada</a> Como Conseguir Viagra Gratis Antabuse Without Prescription

LdrgeGawLdrgeGaw2018/04/17 11:32erectile dementia <a href=http://dc-shuttle.com/>top erectile dysfunction pills</a>
erectile improvement <a href="http://dc-shuttle.com/">buy erectile dysfunction pills</a> http://dc-shuttle.com/

eddrugsgeneric.comeddrugsgeneric.com2018/04/17 18:01low cost erectile treatment
<a href=http://eddrugsgeneric.com/#>herbs for erectile dysfunction</a>
which erectile dysfunction drug is best
<a href="http://eddrugsgeneric.com/#">erection pills</a>

BrcebutBrcebut2018/04/17 22:48generic cialis in vietnam cialis professional from usa
<a href="http://kaivanrosendaal.com/#Cheap-Cialis">Buy Cheap Cialis</a> opinioni cialis generico prix de cialis

EarnestelirmEarnestelirm2018/04/18 07:47men with erectile dysfunction
<a href="http://erectiledysfunctionlq.com/">best erectile dysfunction drug</a>
erectile creams walmart
<a href="http://erectiledysfunctionlq.com/">best erectile dysfunction pills</a>

KoldrBoXyKoldrBoXy2018/04/18 10:02erectile hopeless
<a href=http://edpilsmystery.com/>buy erectile dysfunction pills</a>
is erectile dysfunction covered by insurance
<a href="http://edpilsmystery.com/">ed drugs list</a>

BrcebutBrcebut2018/04/18 17:11venta de cialis canada we use it cialis online store
<a href="http://kaivanrosendaal.com/#Cialis-Cheap-Buy-Online">Buy Cheap Cialis usa</a> buy cialis online cheapest buy cialis uk no prescription

MarkEnuctMarkEnuct2018/04/19 06:45opzioni binarie yahoo answers
<a href="http://platform-binary-best-try-options.pw/option-trading-earnings-announcements-5976.php#">60 second binary options strategy training</a>
binary signals coach review
<a href=http://best-platform-try-binary-options.pw/energy-trading-and-risk-management-jobs-9430.php>different types of binary codes</a>

HrafdcebutHrafdcebut2018/04/19 08:25generic cialis soft tab 50mg overdosering af cialis buy real cialis online usa <a href=http://jvrimages.com/#cialis+canada>doses</a> colour cialis tablets reviews on cialis 50mg cialis occh
<a href=http://jvrimages.com/#tadalafil+generic>cialis cost</a> cheap cialis 150mg on line extenze used with cialis is generic cialis ok
http://jvrimages.com/#callus 50mg cialis paypal uk kamagra cialis jelly uk cialis cialis panorama

MarkEnuctMarkEnuct2018/04/19 20:14levitra headache
<a href="http://levitra-gg.com">levitra 10 mg prezzo</a>
pengalaman levitra vs cialis
<a href=http://myvardenafilok.com#levitra+20mg>buy levitra</a>

2009-11-24

[]問題5.12 02:13

;; 補助関数
(define (filter pred lst)
  (cond ((null? lst) '())
        ((pred (car lst))
         (cons (car lst)
               (filter pred (cdr lst))))
        (else (filter pred (cdr lst)))))

(define (remove-duplicates lst)
  (define (iter lst result)
    (if (null? lst) result
        (if (member (car lst) (cdr lst))
            (iter (cdr lst) result)
            (iter (cdr lst) (cons (car lst) result)))))
  (iter lst '()))

;; 命令列情報の生成関数
(define (make-information insts)
  (let ((insts-text (map instruction-text insts)))
    (apply append
           (map
            (lambda (name)
              (remove-duplicates
               (filter
                (lambda (i) (eq? (car i) name))
                insts-text)))
            '(assign test branch goto save restore perform)))))

;; 処理系の書き換え分
(define (assemble controller-text machine)
  (extract-labels controller-text
    (lambda (insts labels)
      (update-insts! insts labels machine)
      (cons insts (make-information insts)))))

(define (make-machine register-names ops controller-text)
  (let ((machine (make-new-machine)))
    (for-each (lambda (register-name)
                ((machine 'allocate-register) register-name))
              register-names)
    ((machine 'install-operations) ops)
    (let ((assembled (assemble controller-text machine)))
      ((machine 'install-instruction-sequence)
       (car assembled))
      ((machine 'install-information)
       (cdr assembled)))
    machine))

(define (make-new-machine)
  (let ((pc (make-register 'pc))
        (flag (make-register 'flag))
        (stack (make-stack))
        (the-instruction-sequence '())
        (information '()))
    (let ((the-ops
           (list (list 'initialize-stack
                       (lambda () (stack 'initialize)))))
          (register-table
           (list (list 'pc pc) (list 'flag flag)))) 
      (define (allocate-register name)
        (if (assoc name register-table)
            (error "Multiply defined register: " name)
            (set! register-table
                  (cons (list name (make-register name))
                        register-table)))
        'register-allocated)
      (define (lookup-register name)
        (let ((val (assoc name register-table)))
          (if val
              (cadr val)
              (error "Unknown register: " name))))
      (define (execute)
        (let ((insts (get-contents pc)))
          (if (null? insts)
              'done
              (begin
                ((instruction-execution-proc (car insts)))
                (execute)))))
      (define (get-goto-reg information)
        (define (iter info result)
          (if (null? info) result
              (if (and (eq? (caar info) 'goto)
                       (eq? (car (cadr (car info))) 'reg))
                  (iter (cdr info) (cons (cadr (cadr (car info))) result))
                  (iter (cdr info) result))))
        (iter information '()))
      (define (get-save-restore-reg information)
        (define (iter info result)
          (if (null? info) result
              (if (or (eq? (caar info) 'save)
                      (eq? (caar info) 'restore))
                  (iter (cdr info) (cons (cadr (car info)) result))
                  (iter (cdr info) result))))
        (remove-duplicates (iter information '())))
      (define (get-assign-source information)
        (define (iter info result)
          (if (null? info) result
              (if (eq? (caar info) 'assign)
                  (iter (cdr info)
                        (cons
                         (if (null? (cdddr (car info)))
                             (cdr (car info))
                             (list (cadr (car info)) (cddr (car info))))
                         result))
                  (iter (cdr info) result))))
        (iter information '()))
      (define (aggregate source)
        (map (lambda (r)
               (cons r
                     (map cadr
                          (filter (lambda (p) (eq? (car p) r)) source))))
             (remove-duplicates (map car source))))
      (define (dispatch message)
        (cond ((eq? message 'start)
               (set-contents! pc the-instruction-sequence)
               (execute))
              ((eq? message 'install-instruction-sequence)
               (lambda (seq) (set! the-instruction-sequence seq)))
              ((eq? message 'allocate-register) allocate-register)
              ((eq? message 'get-register) lookup-register)
              ((eq? message 'install-operations)
               (lambda (ops) (set! the-ops (append the-ops ops))))
              ((eq? message 'stack) stack)
              ((eq? message 'operations) the-ops)
              ((eq? message 'install-information)
               (lambda (info) (set! information (append information info))))
              ((eq? message 'get-insts-info)
               information)
              ((eq? message 'get-goto-reg-info)
               (get-goto-reg information))
              ((eq? message 'get-save-restore-reg-info)
               (get-save-restore-reg information))
              ((eq? message 'get-assign-source-info)
               (aggregate (get-assign-source information)))
              (else (error "Unknown request -- MACHINE" message))))
      dispatch)))

;; 大域環境用の関数インタフェース
(define (get-insts-info machine)
  (machine 'get-insts-info))
(define (get-goto-reg-info machine)
  (machine 'get-goto-reg-info))
(define (get-save-restore-reg-info machine)
  (machine 'get-save-restore-reg-info))
(define (get-assign-source-info machine)
  (machine 'get-assign-source-info))

;; fib計算機
(define fib-machine
  (make-machine
   '(n val continue)
   (list (list '< <) (list '- -) (list '+ +))
   '(
       (assign continue (label fib-done))
     fib-loop
       (test (op <) (reg n) (const 2))
       (branch (label immediate-answer))
       ;; set up to compute Fib(n - 1)
       (save continue)
       (assign continue (label afterfib-n-1))
       (save n)                           ; save old value of n
       (assign n (op -) (reg n) (const 1)); clobber n to n - 1
       (goto (label fib-loop))            ; perform recursive call
     afterfib-n-1                         ; upon return, val contains Fib(n - 1)
       (restore n)
       (restore continue)
       ;; set up to compute Fib(n - 2)
       (assign n (op -) (reg n) (const 2))
       (save continue)
       (assign continue (label afterfib-n-2))
       (save val)                         ; save Fib(n - 1)
       (goto (label fib-loop))
     afterfib-n-2                         ; upon return, val contains Fib(n - 2)
       (assign n (reg val))               ; n now contains Fib(n - 2)
       (restore val)                      ; val now contains Fib(n - 1)
       (restore continue)
       (assign val                        ;  Fib(n - 1) +  Fib(n - 2)
               (op +) (reg val) (reg n)) 
     (goto (reg continue))              ; return to caller, answer is in val
     immediate-answer
       (assign val (reg n))               ; base case:  Fib(n) = n
       (goto (reg continue))
     fib-done)))

;; fib計算機の情報を表示
(define (info-fib-machine)
  (display "instructions: ")
  (display (get-insts-info fib-machine))
  (newline) (newline)
  (display "label registers: ")
  (display (get-goto-reg-info fib-machine))
  (newline)  (newline)
  (display "stacked registers: ")
  (display (get-save-restore-reg-info fib-machine))
  (newline)  (newline)
  (display "assign sources: ")
  (display (get-assign-source-info fib-machine))
  (newline)
  'done)

FoutleweefbofikFoutleweefbofik2014/01/19 08:08<a href="http://freecialiscialissaleyce.com/#nuan">cialis prescription</a> .,You can <a href="http://freecialiscialissalestrh.com/#wugk">cialis reviews</a> at large discounts with great service,Excellent health benefits are attainable when you <a href="http://cialisukcialissoftarry.com/#rhyw">buy cialis online</a>

jydnasgpsljydnasgpsl2014/12/03 22:33vxfqgtjdq, <a href="http://www.nwodugbkxi.com/">ctbkxbogyv</a> , [url=http://www.ebfdacihvr.com/]tblosnothx[/url], http://www.yqzlddjudk.com/ ctbkxbogyv

2009-11-17

コンビネータメモ 16:01

http://practical-scheme.net/chaton/haskell-ja/a/2009/11/17#entry-4b023df0-32385 より

pfc> (define (m x) (x x))
m
pfc> (define (c f x y) (f y x))
c
pfc> (define (b f g x) (f (g x)))
b
pfc> (define (s f g x) (f x (g x)))
s
pfc> (define l (c b m))
l
pfc> (define y (s l l))
y
pfc> (define fib (y (lambda (f n) (if (< n 2) n (+ (f (- n 1)) (f (- n 2)))))))        
fib
pfc> (fib 10)
55

2009-09-03

こないだのデモメモ 08:22

(load "trace.blk")

読み込み

(trace n)

(define (fact n) (if (= n 0) 1 (* n (fact (- n 1)))))

fact

(fact 3)

(exit 'bye)

eval-application

(define (fact n) (if (= n 0) 1 (* n (fact (- n 1)))))

(fact3)

(old-cont 'hello)

(fact 3)

DahrannDahrann2016/05/11 01:48Articles like these put the consumer in the driver seat-very imttnoarp.

2009-08-17

Blackメモ 16:23

(exec-at-metalevel
 (let ((old-eval base-eval))
   (set! base-eval (lambda (exp env cont)
                     (if (and (number? exp)
                              (= exp 1))
                         (set! exp 100))
                     (old-eval exp env cont)))))

AmeliaAmelia2016/05/11 01:31Yup, that'll do it. You have my aprteciapion.

JacalynJacalyn2016/05/14 09:44I can’t front….Craig smashed it!I wasn’t too keen on his MOBO performance if I’m to be honest…but this freestyle is hot….Props to Craig for going in over that <a href="http://xeafubcmhuh.com">be2at#8a30;especi&lly</a> after Giggs killed it.