present for /prog/

; A prototype based object system
(define (resolve-slot object name)
  (let loop ((queue (list object)))
    (cond
      ((null? queue) #f)
      (((car queue) '_get-slot name) => (lambda (slot) slot))
      (else (loop (append (cdr queue)
                          ((car queue) '_protos)))))))
(define (meta-object)
  (let ((protos '()) (slots (make-hash-table)))
    (define (self message . args)
      (let-syntax ((meta-method
                    (syntax-rules ()
                      ((_ (method-args ...) body ...)
                       (apply (lambda (method-args ...) body ...) args)))))
        (case message
          ((_protos) protos)
          ((_slots) slots)
          ((_get-slot)
           (meta-method (name)
                        (hash-table-get slots name #f)))
          ((_set-slot!)
           (meta-method (name value)
                        (hash-table-put! slots name value)))
          ((_append-proto!)
           (meta-method (proto)
                        (set! protos (cons proto protos))))
          (else (cond
                  ((not (symbol? message))
                   (error "message must be a symbol -- META-OBJECT"
                          message args))
                  ((resolve-slot self message)
                   => (lambda (slot) (apply slot (cons self args))))
                  ; If an object doesn't respond to a message, invoke the "forward"
                  ; method if it has one.
                  ((resolve-slot self 'forward)
                   => (lambda (forward) (apply forward
                                               (append (list self message) args))))
                  (else
                   (error "don't know how to respond -- META-OBJECT"
                          message args)))))))
    self))
(define object
  (let ((self (meta-object)))
    (let-syntax ((define-slot
                   (syntax-rules ()
                     ((_ (name args ...) body ...)
                      (self '_set-slot! 'name (lambda (args ...) body ...))))))
      (define-slot (get-slot self name)
        (resolve-slot self name))
      (define-slot (set-slot! self name value)
        (self '_set-slot! name value))
      (define-slot (append-proto! self proto)
        (self '_append-proto proto))
      (define-slot (protos self)
        (self '_protos))
      (define-slot (slot-names self)
        (hash-table-map (self '_slots) (lambda (key value) key)))
      (define-slot (clone self)
        (let ((new (meta-object)))
          (new '_append-proto! self)
          (when (new 'get-slot 'init)
            (new 'init))
          new)))
    self))
(define-syntax define-method
  (syntax-rules ()
    ((_ class (name args ...) body ...)
     (class 'set-slot! 'name (lambda (args ...) body ...)))))
(define-method object (set-value! self name value)
  (self 'set-slot! name (lambda (self) value)))

(define (test-account)
  (define account (object 'clone))
  (define-method account (init self)
    (self 'set-value! 'balance 0))
  (define-method account (deposit! self amount)
    (self 'set-value! 'balance (+ (self 'balance) amount)))
  (define-method account (withdraw! self amount)
    (self 'set-value! 'balance (- (self 'balance) amount)))
 
  (let ((x (account 'clone)))
    (printf "(deposit 200)~n")
    (x 'deposit! 200)
    (printf "balance = ~a~n" (x 'balance))
    (printf "(withdraw 150)~n")
    (x 'withdraw! 150)
    (printf "balance = ~a~n" (x 'balance))))

Fucking hell, I hate LISP.

>>3
Get off of my /prog/.

I REALLY enjoyed reading your source codes.

Am I to assume this is licensed under the GPL license?

>>6
_{GPL license
GPL license
GPL license
GPL Public License licenseLicense license}

>>7
I lulid

>>7
Thanks for pointing that out honey. I'm off to the ATM machine so I can get some cash to purchase a new LCD display for my PC computer.

>>9
Does it run Windows with new NT technology?

>>10
No, it runs the millenium ME edition.

Did you build this inside of Emacs?

>>12
M-x configure-mode M-x make-mode

ATM Teller Machine

LCD Crystal Display
PC Computer

>>14
More like ATM To Mouth, amirite?

>>16
More like ATM Transfer Mode, amirite?

>>12
>>13
i used vim actually.
:!mzscheme -f %

VIMMER !!!

>>18
gfhyytrjhafhrtdfh tedheruylo7kr6e576454

>>20
Valid VIM command

seems like you're missing a close parenthesis....

>>21
gf open file under cursor
h move cursor left
yy yank (copy) current line
tr move cursor till r
j move cursor down
a start insert mode
fhrtdfh tedheruylo7kr6e576454 insert self

>>23
a start insert mode

YOU'RE WRONG. YOU'RE FUCKING WRONG AND YOU ^LIE.

a append

Good job!  But it still needs to be optimized with vectors.

>>26
-O3 -funroll-vectors

What is that?
Any example of what you can do with this code?

>>28
I wish.  It's machine code.

>>29
back to /b/, please

>>28
http://en.wikipedia.org/wiki/Prototype-based_programming
To send a message to an object: (object 'message-name . args). For example, (object 'set-value! 'life 42) (printf "~a~n" (object 'life)) prints out "42"; send the set-value! message to define a slot that has a value. You can use the set-slot! message to define a more complex slot, such as a method, or you can use the macro define-method.

>>30
I wish.  It's BBCode.